frustration/frustration.rs

use std::io;
use std::io::Read;
use std::io::Write;
use std::convert::TryInto;
const ADDRESS_SPACE: usize = 65535;

#[derive(Debug)]
struct Stack<const N: usize> {
    mem: [u16; N],
    tos: usize
}

impl<const N: usize> Stack<N> {
    fn push(&mut self, val: u16) {
        self.tos = (self.tos.wrapping_add(1)) & (N - 1);
        self.mem[self.tos] = val;
    }

    fn pop(&mut self) -> u16 {
        let val = self.mem[self.tos];
        self.mem[self.tos] = 0;
        self.tos = (self.tos.wrapping_sub(1)) & (N - 1);
        return val;
    }
}

struct Core {
    ram: [u8; ADDRESS_SPACE],
    ip: u16,
    dstack: Stack<16>,
    rstack: Stack<32>
}

fn new_core() -> Core {
    let c = Core {
        ram: [0; ADDRESS_SPACE],
        ip: 0,
        dstack: Stack {tos: 15, mem: [0; 16]},
        rstack: Stack {tos: 31, mem: [0; 32]}};
    return c;
}

impl Core {
    fn load(&self, addr: u16) -> u16 {
        let a = addr as usize;
        return u16::from_le_bytes(self.ram[a..=a+1].try_into().unwrap());
    }

    fn store(&mut self, addr: u16, val: u16) {
        let a = addr as usize;
        self.ram[a..=a+1].copy_from_slice(&val.to_le_bytes());
    }

    fn step(&mut self) {
        let opcode = self.load(self.ip);
        self.ip = self.ip.wrapping_add(2);
        if (opcode >= 0xffe0) && (opcode & 1 == 0) {
            PRIMITIVES[((opcode - 0xffe0) >> 1) as usize](self);
        }
        else if (opcode & 1) == 1 {
            // Literal
            self.dstack.push(opcode >> 1);
        }
        else {
            // Call
            self.rstack.push(self.ip);
            self.ip = opcode;
        }
    }
}

type Primitive = fn(&mut Core);

enum Op {
    RET = 0xffe0, TOR = 0xffe2, RTO = 0xffe4, LD  = 0xffe6,
    ST  = 0xffe8, DUP = 0xffea, SWP = 0xffec, DRP = 0xffee,
    Q   = 0xfff0, ADD = 0xfff2, SFT = 0xfff4, OR  = 0xfff6,
    AND = 0xfff8, INV = 0xfffa, GEQ = 0xfffc, IO  = 0xfffe,
}

const PRIMITIVES: [Primitive; 16] = [
    | x | { /* ret */ x.ip = x.rstack.pop() },
    | x | { /* >r  */ x.rstack.push(x.dstack.pop()) },
    | x | { /* r>  */ x.dstack.push(x.rstack.pop()) },
    | x | { // ld
        let a = x.dstack.pop();
        x.dstack.push(x.load(a));
    },
    | x | { // st
        let a = x.dstack.pop();
        let v = x.dstack.pop();
        x.store(a, v);
    },
    | x | { // dup
        let v = x.dstack.pop();
        x.dstack.push(v);
        x.dstack.push(v);
    },
    | x | { // swp
        let v1 = x.dstack.pop();
        let v2 = x.dstack.pop();
        x.dstack.push(v1);
        x.dstack.push(v2);
    },
    | x | { /* drp */ let _ = x.dstack.pop(); },
    | x | { // ?
        let f = x.dstack.pop();
        if f == 0 {
            x.ip = x.ip.wrapping_add(2)
        };
    },
    | x | { // add
        let v1 = x.dstack.pop();
        let v2 = x.dstack.pop();
        x.dstack.push(v1.wrapping_add(v2));
    },
    | x | { // sft
        let amt = x.dstack.pop();
        let val = x.dstack.pop();
        x.dstack.push(
            if amt <= 0xf {
                val << amt
            } else if amt >= 0xfff0 {
                val >> (0xffff - amt + 1)
            } else {
                0
            }
        );
    },
    | x | { // or
        let v1 = x.dstack.pop();
        let v2 = x.dstack.pop();
        x.dstack.push(v1 | v2);
    },
    | x | { // and
        let v1 = x.dstack.pop();
        let v2 = x.dstack.pop();
        x.dstack.push(v1 & v2);
    },
    | x | { // inv
        let v1 = x.dstack.pop();
        x.dstack.push(!v1);
    },
    | x | { // geq (unsigned)
        let v2 = x.dstack.pop();
        let v1 = x.dstack.pop();
        x.dstack.push(if v1 >= v2 { 0xffff } else { 0 });
    },
    | x | { // io
        let port = x.dstack.pop();
        match port {
            0 => {
                let mut buf: [u8; 1] = [0];
                let _ = io::stdin().read(&mut buf);
                x.dstack.push(buf[0] as u16);
            }
            1 => {
                let val  = x.dstack.pop();
                print!("{}", ((val & 0xff) as u8) as char);
                let _ = io::stdout().flush();
            }
            2 => {
                println!("{:?} {:?}", x.dstack, x.rstack);
                let _ = io::stdout().flush();
            }
            _ => {}
        }
    }
];

struct Dict<'a> {
    dp: u16,
    here: u16,
    c: &'a mut Core
}

enum Item {
    Literal(u16),
    Call(u16),
    Opcode(Op)
}
impl From<u16> for Item { fn from(a: u16) -> Self { Item::Call(a) } }
impl From<Op>  for Item { fn from(o: Op)  -> Self { Item::Opcode(o) } }

impl Dict<'_> {
    fn allot(&mut self, n: u16) {
        self.here = self.here.wrapping_add(n);
    }

    fn comma(&mut self, val: u16) {
        self.c.store(self.here, val);
        self.allot(2);
    }

    fn emit<T: Into<Item>>(&mut self, val: T) {
        match val.into() {
            Item::Call(val)    => { self.comma(val) }
            Item::Opcode(val)  => { self.comma(val as u16) }
            Item::Literal(val) => { assert!(val <= 0x7fff);
                                    self.comma((val << 1) | 1) }
        }
    }

    fn name(&mut self, n: u8, val: [u8; 3]) {
        self.comma(n as u16 | ((val[0] as u16) << 8));
        self.comma(val[1] as u16 | ((val[2] as u16) << 8));
    }

    fn entry(&mut self) {
        let here = self.here;
        self.comma(self.dp);
        self.dp = here;
    }
}

fn build_dictionary(c: &mut Core) {
    use Op::*;
    use Item::*;

    let mut d = Dict {dp: 0, here: 2, c: c};

    macro_rules! forth {
        ($x:expr) => (d.emit($x));
        ($x:expr, $($y:expr),+) => (d.emit($x); forth!($($y),+))
    }

    // key ( -- n )
    d.entry(); d.name(3, *b"key");  let key = d.here;
    forth!(Literal(0), IO, RET);

    // emit ( n -- )
    d.entry(); d.name(4, *b"emi");  let emit = d.here;
    forth!(Literal(1), IO, RET);

    // - ( a b -- a-b )
    d.entry(); d.name(1, *b"-  ");  let sub = d.here;
    forth!(INV, Literal(1), ADD, ADD, RET);

    let zero = d.here;
    forth!(Literal(0), RTO, DRP, RET);

    // 0= ( n -- f )
    d.entry(); d.name(2, *b"0= ");  let zero_eq = d.here;
    forth!(Q, zero, Literal(0), INV, RET);

    // = ( a b -- a=b )
    d.entry(); d.name(1, *b"=  ");  let eq = d.here;
    forth!(sub, zero_eq, RET);

    // Advance past whitespace
    let skip_helper = d.here;
    forth!(RTO, DRP, key, DUP, Literal(33), GEQ, Q, RET, DRP, skip_helper);

    d.entry(); d.name(6, *b"ski");  let skipws = d.here;
    forth!(skip_helper);

    // over ( a b -- a b a )
    d.entry(); d.name(4, *b"ove");  let over = d.here;
    forth!(TOR, DUP, RTO, SWP, RET);

    // 2dup ( a b -- a b a b )
    d.entry(); d.name(4, *b"2du");  let twodup = d.here;
    forth!(over, over, RET);

    // Buffer for parsing an input word, formatted as Nabcde.
    let word_buf = d.here;
    d.allot(6);

    // min ( a b -- n )
    d.entry(); d.name(3, *b"min");  let min = d.here;
    forth!(twodup, GEQ, Q, SWP, DRP, RET);

    // c@ ( a -- n )
    d.entry(); d.name(2, *b"c@ ");  let cld = d.here;
    forth!(LD, Literal(0xff), AND, RET);

    // c! ( n a -- )
    d.entry(); d.name(2, *b"c! ");  let cst = d.here;
    forth!(DUP, LD, Literal(0xff), INV, AND, SWP, TOR, OR, RTO, ST, RET);

    // Load 1 letter into buffer.
    let stchar = d.here;
    forth!(Literal(word_buf), cld, Literal(1), ADD, DUP, Literal(word_buf), cst,
           Literal(5), min, Literal(word_buf), ADD, cst, RET);

    // Load letters into buffer until whitespace is hit again.
    // Return the whitespace character that was seen.
    let getcs_helper = d.here;
    forth!(RTO, DRP, stchar, key, DUP, Literal(32), SWP, GEQ, Q, RET, getcs_helper);

    d.entry(); d.name(5, *b"get");  let getcs = d.here;
    forth!(getcs_helper, RET);

    // word ( -- )
    // Not quite standard.
    d.entry(); d.name(4, *b"wor");  let word = d.here;
    forth!(Literal(word_buf), DUP, Literal(2), ADD,
           Literal(0x2020), SWP, ST, Literal(0x2000), SWP, ST,
           skipws, getcs, DRP, RET);

    // latest ( -- a )
    // Address of "latest" variable.  This variable stores the address of
    // the latest word in the dictionary.
    let latest_ptr = d.here; d.allot(2);
    d.entry(); d.name(6, *b"lat");  let latest = d.here;
    forth!(Literal(latest_ptr), RET);

    let matches = d.here;
    forth!(Literal(2), ADD, TOR,
           Literal(word_buf), DUP, Literal(2), ADD, LD, SWP, LD,
           RTO, DUP, TOR,
           LD, Literal(0x0080), INV, AND, eq,
           SWP, RTO, Literal(2), ADD, LD, eq, AND, RET);

    let matched = d.here;
    forth!(Literal(6), ADD, RTO, DRP, RET);

    let find_helper = d.here;
    forth!(RTO, DRP,
           DUP, Literal(0), eq, Q, RET,
           DUP, matches, Q, matched,
           LD, find_helper);

    // find ( -- xt|0 )
    d.entry(); d.name(4, *b"fin");  let find = d.here;
    forth!(latest, LD, find_helper);

    // ' ( -- xt|0 )
    d.entry(); d.name(1, *b"'  ");
    forth!(word, find, RET);

    /* --- The outer interpreter --- */

    // x10 ( n -- n*10 )
    d.entry(); d.name(3, *b"x10");  let x10 = d.here;
    forth!(DUP, DUP, Literal(3), SFT, ADD, ADD, RET);

    // here ( -- a )
    // Address of "here" variable.  This variable stores the address of
    // the first free space in the dictionary
    let here_ptr = d.here; d.allot(2);
    d.entry(); d.name(4, *b"her");  let here = d.here;
    forth!(Literal(here_ptr), RET);

    // state ( -- a )
    // Address of "state" variable.  This variable stores -1 if
    // interpreting or 0 if compiling.
    let state_ptr = d.here; d.allot(2);
    d.entry(); d.name(5, *b"sta");  let state = d.here;
    forth!(Literal(state_ptr), RET);

    let word_addr = d.here;
    forth!(Literal(latest_ptr), LD, Literal(2), ADD, RET);

    // immediate ( -- )
    d.entry(); d.name(9 | 0x80, *b"imm");
    forth!(word_addr, DUP, LD, Literal(0x0080), OR, SWP, ST, RET);

    // smudge ( -- )
    d.entry(); d.name(6 | 0x80, *b"smu");  let smudge = d.here;
    forth!(word_addr, DUP, LD, Literal(0x0040), OR, SWP, ST, RET);

    // unsmudge ( -- )
    d.entry(); d.name(8 | 0x80, *b"uns");  let unsmudge = d.here;
    forth!(word_addr, DUP, LD, Literal(0x0040), INV, AND, SWP, ST, RET);

    // [ ( -- )
    d.entry(); d.name(1 | 0x80, *b"[  ");  let lbracket = d.here;
    forth!(Literal(0), INV, state, ST, RET);

    // ] ( -- )
    d.entry(); d.name(1 | 0x80, *b"]  ");  let rbracket = d.here;
    forth!(Literal(0), state, ST, RET);

    // , ( n -- )
    d.entry(); d.name(1, *b",  "); let comma = d.here;
    forth!(here, LD, ST,
           here, LD, Literal(2), ADD, here, ST, RET);

    let compile_call = d.here;
    forth!(DUP, Literal(4), sub, LD, Literal(0x0080), AND, state, LD, OR, Q, RET,
           comma, RTO, DRP, RET);

    let compile_lit = d.here;
    forth!(state, LD, Q, RET,
           DUP, ADD, Literal(1), ADD, comma, RTO, DRP, RET);

    let end_num = d.here;
    forth!(DRP, RTO, DRP, RET);

    let bad_num = d.here;
    forth!(DRP, DRP, DRP, Literal(0), INV, RTO, DRP, RET);

    let number_helper = d.here;
    forth!(RTO, DRP, DUP, Literal(word_buf), ADD, cld,
           Literal(48), sub, DUP, Literal(10), GEQ, Q, bad_num,
           SWP, TOR, SWP, x10, ADD, RTO,
           DUP, Literal(word_buf), cld, GEQ, Q, end_num,
           Literal(1), ADD, number_helper);

    // number ( -- n|-1 )
    d.entry(); d.name(6, *b"num");  let number = d.here;
    forth!(Literal(0), Literal(1), number_helper);

    // execute ( xt -- )
    d.entry(); d.name(7, *b"exe");  let execute = d.here;
    forth!(TOR, RET);

    let doit = d.here;
    forth!(RTO, DRP, compile_call, execute, RET);

    let bad = d.here;
    forth!(DRP, Literal(63), emit, RTO, DRP, RET);

    // dispatch ( xt -- )
    d.entry(); d.name(9, *b"int");  let dispatch = d.here;
    forth!(DUP, Q, doit,
           DRP, number, DUP, Literal(1), ADD, zero_eq, Q, bad,
           compile_lit, RET);

    // quit ( -- )
    d.entry(); d.name(4, *b"qui");  let quit = d.here;
    forth!(word, find, dispatch, quit);

    // create ( -- )
    d.entry(); d.name(6, *b"cre");  let create = d.here;
    forth!(word,
           here, LD, latest, LD, comma, latest, ST,
           Literal(word_buf), DUP, LD, comma, Literal(2), ADD, LD, comma, RET);

    // : ( -- )
    d.entry(); d.name(1, *b":  ");
    forth!(create, smudge, rbracket, RET);

    // ; ( -- )
    d.entry(); d.name(1 | 0x80, *b";  ");
    forth!(Literal(!(RET as u16)), INV, comma, lbracket, unsmudge, RET);

    // Finally put the primitives in the dictionary so they can be called directly.
    d.entry(); d.name(3, *b"ret"); forth!(RTO, DRP, RET);
    d.entry(); d.name(2, *b">r "); forth!(RTO, SWP, TOR, TOR, RET);
    d.entry(); d.name(2, *b"r> "); forth!(RTO, RTO, SWP, TOR, RET);
    d.entry(); d.name(1, *b"@  "); forth!(LD, RET);
    d.entry(); d.name(1, *b"!  "); forth!(ST, RET);
    d.entry(); d.name(3, *b"dup"); forth!(DUP, RET);
    d.entry(); d.name(4, *b"swa"); forth!(SWP, RET);
    d.entry(); d.name(4, *b"dro"); forth!(DRP, RET);

    d.entry(); d.name(1 | 0x80, *b"?  "); // This one only works in-line.
    forth!(Literal(!(Q as u16)), INV, comma, RET);

    d.entry(); d.name(1, *b"+  "); forth!(ADD, RET);
    d.entry(); d.name(5, *b"shi"); forth!(SFT, RET);
    d.entry(); d.name(2, *b"or "); forth!(OR, RET);
    d.entry(); d.name(3, *b"and"); forth!(AND, RET);
    d.entry(); d.name(3, *b"inv"); forth!(INV, RET);
    d.entry(); d.name(3, *b"u>="); forth!(GEQ, RET);
    d.entry(); d.name(2, *b"io "); let io = d.here; forth!(IO, RET);

    d.c.store(latest_ptr, io-6);
    d.c.store(here_ptr, d.here);
    d.c.store(state_ptr, 0xffff);
    d.c.store(0, quit);
}

fn main() {
    let mut c = new_core();
    build_dictionary(&mut c);
    c.ip = 0;
    loop {
        c.step();
    }
}