mirror of
https://gitlab.cs.washington.edu/fidelp/frustration.git
synced 2024-12-25 21:58:11 +01:00
495 lines
14 KiB
Rust
495 lines
14 KiB
Rust
/* --- The virtual CPU ---
|
|
*/
|
|
|
|
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<32>,
|
|
rstack: Stack<32>
|
|
}
|
|
|
|
fn new_core() -> Core {
|
|
let c = Core {
|
|
ram: [0; ADDRESS_SPACE],
|
|
ip: 0,
|
|
dstack: Stack {tos: 0, mem: [0; 32]},
|
|
rstack: Stack {tos: 0, 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 v1 = x.dstack.pop();
|
|
let v2 = 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.ip, x.dstack, x.rstack);
|
|
let _ = io::stdout().flush();
|
|
}
|
|
_ => {}
|
|
}
|
|
}
|
|
];
|
|
|
|
/* --- The memory map ---
|
|
*/
|
|
|
|
/* --- The dictionary format ---
|
|
*/
|
|
|
|
/* --- The threading kind ---
|
|
*/
|
|
|
|
/* --- Create the dictionary ---
|
|
*/
|
|
|
|
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 ) // note: signed comparison
|
|
d.entry(); d.name(2, *b">= "); let geq = d.here;
|
|
forth!(sub, Literal(0x4000), DUP, ADD, AND, zero_eq, 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, Literal(16383), and, // "unsigned comparison"
|
|
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"geq"); 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();
|
|
}
|
|
}
|
|
|