diff --git a/lisp.js b/lisp.js index 22654b1..f5cd9c0 100755 --- a/lisp.js +++ b/lisp.js @@ -26,19 +26,24 @@ exit #define function #define Null 16384 var M[Null * 2]; +var (*funcall)(); jmp_buf undefined; //` -var cx, dx, lo, kT, kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote, kDefine; - -function Set(i, x) { - M[Null + i] = x; -} +var cx, dx, depth, panic; +var cHeap, cGets, cSets, cPrints; +var kT, kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote, kDefine; function Get(i) { + ++cGets; return M[Null + i]; } +function Set(i, x) { + ++cSets; + M[Null + i] = x; +} + function Car(x) { if (x > 0) Throw(List(kCar, x)); return x ? Get(x) : +0; @@ -52,7 +57,7 @@ function Cdr(x) { function Cons(car, cdr) { Set(--cx, cdr); Set(--cx, car); - if (cx < lo) lo = cx; + if (cx < cHeap) cHeap = cx; return cx; } @@ -77,11 +82,6 @@ function ReadAtom(h) { Hash(h, c) - Hash(0, Ord('N'))); } -function PrintAtom(x) { - do PrintChar(Get(x)); - while ((x = Get(x + 1))); -} - function ReadList() { var x; if ((x = Read()) > 0) { @@ -100,17 +100,33 @@ function ReadObject(t) { return ReadList(); } +function Read() { + return ReadObject(ReadAtom(0)); +} + +function PrintAtom(x) { + do PrintChar(Get(x)); + while ((x = Get(x + 1))); +} + function PrintList(x) { PrintChar(Ord('(')); if (x < 0) { - PrintObject(Car(x)); + Print(Car(x)); while ((x = Cdr(x))) { + if (panic && cPrints > panic) { + PrintChar(Ord(' ')); + PrintChar(0x2026); + break; + } if (x < 0) { PrintChar(Ord(' ')); - PrintObject(Car(x)); + Print(Car(x)); } else { - PrintChar(0x2219); - PrintObject(x); + PrintChar(Ord(' ')); + PrintChar(Ord('.')); + PrintChar(Ord(' ')); + Print(x); break; } } @@ -118,7 +134,8 @@ function PrintList(x) { PrintChar(Ord(')')); } -function PrintObject(x) { +function Print(x) { + ++cPrints; if (1./x < 0) { PrintList(x); } else { @@ -126,13 +143,12 @@ function PrintObject(x) { } } -function Print(e) { - PrintObject(e); - PrintChar(Ord('\n')); +function List(x, y) { + return Cons(x, Cons(y, 0)); } -function Read() { - return ReadObject(ReadAtom(0)); +function Define(A, x, a) { + return Gc(A, Cons(x, Remove(Car(x), a))); } function Remove(x, y) { @@ -141,14 +157,6 @@ function Remove(x, y) { return Cons(Car(y), Remove(x, Cdr(y))); } -function List(x, y) { - return Cons(x, Cons(y, 0)); -} - -function Define(x, y) { - return Cons(Cons(x, Read()), Remove(x, y)); -} - function Gc(A, x) { var C, B = cx; x = Copy(x, A, A - B), C = cx; @@ -167,7 +175,6 @@ function Evlis(m, a) { } function Pairlis(x, y, a) { - if (!!x ^ !!y) Throw(List(x, y)); return x ? Cons(Cons(Car(x), Car(y)), Pairlis(Cdr(x), Cdr(y), a)) : a; } @@ -184,7 +191,7 @@ function Evcon(c, a) { } else if (Cdr(c)) { return Evcon(Cdr(c), a); } else { - Throw(c); + Throw(Cons(kCond, c)); } } @@ -195,16 +202,61 @@ function Apply(f, x, a) { if (f == kAtom) return Car(x) < 0 ? 0 : kT; if (f == kCar) return Car(Car(x)); if (f == kCdr) return Cdr(Car(x)); - return Apply(Assoc(f, a), x, a); + return funcall(f, Assoc(f, a), x, a); } function Eval(e, a) { - var A = cx; if (!e) return e; if (e > 0) return Assoc(e, a); if (Car(e) == kQuote) return Car(Cdr(e)); - if (Car(e) == kCond) return Gc(A, Evcon(Cdr(e), a)); - return Gc(A, Apply(Car(e), Evlis(Cdr(e), a), a)); + if (Car(e) == kCond) return Evcon(Cdr(e), a); + return Apply(Car(e), Evlis(Cdr(e), a), a); +} + +function Funcall(f, l, x, a) { + var A = cx; + return Gc(A, Apply(l, x, a)); +} + +function Funtrace(f, l, x, a) { + var y, i, A = cx; + Indent(depth); + Print(f); + Print(x); + PrintChar(Ord('\n')); + depth += 2; + y = Funcall(f, l, x, a); + depth -= 2; + Indent(depth); + Print(f); + Print(x); + PrintChar(Ord(' ')); + PrintChar(0x2192); + PrintChar(Ord(' ')); + Print(y); + PrintChar(Ord('\n')); + return y; +} + +function Indent(i) { + if (!i) return; + PrintChar(Ord(' ')); + Indent(i - 1); +} + +function Dump(a) { + if (!a) return; + Dump(Cdr(a)); + PrintChar(Ord('(')); + Print(kDefine); + PrintChar(Ord(' ')); + Print(Car(Car(a))); + PrintChar(Ord(' ')); + PrintChar(Ord('.')); + PrintChar(Ord(' ')); + Print(Cdr(Car(a))); + PrintChar(Ord(')')); + PrintChar(Ord('\n')); } function LoadBuiltins() { @@ -267,17 +319,24 @@ ReadChar() { } } -main() { +main(argc, argv) + char *argv[]; +{ var x, a, A; setlocale(LC_ALL, ""); bestlineSetXlatCallback(bestlineUppercase); + if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 't') { + funcall = Funtrace; + } else { + funcall = Funcall; + } LoadBuiltins(); for (a = 0;;) { A = cx; if (!(x = setjmp(undefined))) { x = Read(); - if (x == kDefine) { - a = Gc(0, Define(Read(), a)); + if (x < 0 && Car(x) == kDefine) { + a = Define(0, Cdr(x), a); SaveMachine(a); continue; } @@ -287,6 +346,7 @@ main() { PrintChar('?'); } Print(x); + PrintChar('\n'); Gc(A, 0); } } @@ -296,8 +356,8 @@ main() { //////////////////////////////////////////////////////////////////////////////// // JavaScript Specific Code for https://justine.lol/ -var a, code, index, output, M, Null; -var eInput, eOutput, eSubmit, eReset, eLoad, ePrograms; +var a, code, index, output, funcall, M, Null; +var eInput, eOutput, eEval, eReset, eLoad, eTrace, ePrograms; function Throw(x) { throw x; @@ -311,7 +371,10 @@ function Reset() { var i; a = 0; cx = 0; - lo = 0; + cHeap = 0; + cGets = 0; + cSets = 0; + cPrints = 0; Null = 16384; M = new Array(Null * 2); for (i = 0; i < M.length; ++i) { @@ -343,8 +406,11 @@ function ReadChar() { function Lisp() { var x, A; - lo = cx; - output = ''; + cGets = 0; + cSets = 0; + cHeap = cx; + cPrints = 0; + output = ""; while (dx) { if (dx <= Ord(' ')) { ReadChar(); @@ -352,8 +418,8 @@ function Lisp() { A = cx; try { x = Read(); - if (x == kDefine) { - a = Gc(0, Define(Read(), a)); + if (x < 0 && Car(x) == kDefine) { + a = Define(0, Cdr(x), a); continue; } x = Eval(x, a); @@ -362,6 +428,7 @@ function Lisp() { x = z; } Print(x); + PrintChar(Ord('\n')); Gc(A, 0); } } @@ -377,21 +444,11 @@ function Load(s) { index = 1; } -function OnSubmit() { +function OnEval() { Load(eInput.value.toUpperCase()); Lisp(); } -function Dump(a) { - if (!a) return; - Dump(Cdr(a)); - output += "DEFINE "; - PrintObject(Car(Car(a))); - output += " "; - PrintObject(Cdr(Car(a))); - output += "\n"; -} - function OnReset() { output = ""; try { @@ -406,6 +463,18 @@ function OnReset() { ReportUsage(); } +function OnTrace() { + var t; + Load(eInput.value); + t = panic; + depth = 0; + panic = 10000; + funcall = Funtrace; + Lisp(); + funcall = Funcall; + panic = t; +} + function OnLoad() { ePrograms.classList.toggle("show"); } @@ -431,7 +500,7 @@ function RestoreMachine() { M = machine[0]; a = machine[1]; cx = machine[2]; - lo = cx; + cHeap = cx; } } @@ -449,25 +518,48 @@ function Number(i) { function ReportUsage() { var i, c; for (c = i = 0; i < Null; i += 2) { - if (Get(i)) ++c; + if (M[Null + i]) ++c; } - document.getElementById("usage").innerText = + document.getElementById("ops").innerText = + Number(cGets) + " gets / " + + Number(cSets) + " sets"; + document.getElementById("mem").innerText = Number((-cx >> 1) + c) + " / " + - Number((-lo >> 1) + c) + " / " + + Number((-cHeap >> 1) + c) + " / " + Number(Null) + " doublewords"; } +function Discount(f) { + return function() { + var x, g, h, s; + g = cGets; + s = cSets; + h = cHeap; + x = f.apply(this, arguments); + cHeap = h; + cSets = s; + cGets = g; + return x; + }; +} + function SetUp() { + funcall = Funcall; + Read = Discount(Read); + Print = Discount(Print); + Define = Discount(Define); eLoad = document.getElementById("load"); eInput = document.getElementById("input"); eReset = document.getElementById("reset"); + eTrace = document.getElementById("trace"); eOutput = document.getElementById("output"); - eSubmit = document.getElementById("submit"); + eEval = document.getElementById("eval"); ePrograms = document.getElementById("programs"); window.onclick = OnWindowClick; - eSubmit.onclick = OnSubmit; - eReset.onclick = OnReset; eLoad.onclick = OnLoad; + eReset.onclick = OnReset; + eTrace.onclick = OnTrace; + eEval.onclick = OnEval; Reset(); RestoreMachine(); ReportUsage(); diff --git a/sectorlisp.S b/sectorlisp.S index e24b798..8a264e9 100644 --- a/sectorlisp.S +++ b/sectorlisp.S @@ -34,8 +34,8 @@ kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0 start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address .asciz "" kDefine:.asciz "DEFINE" -kQuote: .asciz "QUOTE" kCond: .asciz "COND" +kQuote: .asciz "QUOTE" kCar: .asciz "CAR" # ordering matters kCdr: .asciz "CDR" # ordering matters kCons: .asciz "CONS" # ordering matters @@ -123,16 +123,14 @@ PutChar:mov $0x0e,%ah # prints CP-437 int $0x10 # vidya service pop %bp # scroll up bug cmp $'\r',%al # don't clobber - jne .RetDx # look xchg ret + jne .retDx # look xchg ret mov $'\n',%al jmp PutChar -.RetDx: xchg %dx,%ax - ret //////////////////////////////////////////////////////////////////////////////// Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax - jb .RetDi # we assume immutable cells + jb .retDi # we assume immutable cells push (%bx,%di) # mark prevents negative gc mov (%di),%di call Gc @@ -146,7 +144,7 @@ Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax ret Evlis: test %di,%di # Evlis(m:di,a:dx):ax - jz .RetDi # jump if nil + jz .retDi # jump if nil push (%bx,%di) # save 1 Cdr(m) mov (%di),%ax call Eval @@ -160,7 +158,7 @@ Cons: xchg %di,%cx # Cons(m:di,a:ax):ax mov %cx,(%di) # must preserve si mov %ax,(%bx,%di) lea 4(%di),%cx -.RetDi: xchg %di,%ax +.retDi: xchg %di,%ax ret GetList:call GetToken @@ -178,6 +176,9 @@ GetList:call GetToken pop %ax ret +.retDx: xchg %dx,%ax + ret + .resolv:push %si call Eval # do (fn si) → ((λ ...) si) pop %si @@ -189,11 +190,16 @@ Apply: test %ax,%ax # Apply(fn:ax,x:si:a:dx):ax mov (%di),%di # di = Cadr(fn) Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):dx jz .EvCadr # return if x is nil + xor %ax,%ax # FRIENDLY FEATURE + test %si,%si # DEFAULT NIL ARGS + jz 1f lodsw # ax = Car(y) - push (%bx,%di) # push Cdr(x) +1: push (%bx,%di) # push Cdr(x) mov (%di),%di # di = Car(x) + test %si,%si + jz 1f mov (%si),%si # si = Cdr(y) - call Cons # Cons(Car(x),Car(y)) +1: call Cons # Cons(Car(x),Car(y)) xchg %ax,%di xchg %dx,%ax call Cons # Cons(Cons(Car(x),Car(y)),a) @@ -223,6 +229,10 @@ Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):dx .retF: xor %ax,%ax # ax = nil ret +Define: xchg %dx,%ax + call Cons + jmp .retDx + Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax 1: test %si,%si # FRIENDLY FEATURE jns Undef # PRINT ?X IF X∉DX @@ -260,6 +270,7 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax je Car cmp $kCond,%ax je Evcon # ABC Garbage Collector + jb Define push %dx # save a push %cx # save A push %ax @@ -288,17 +299,6 @@ Read: call GetToken call GetObject ret -Define: call Read # FRIENDLY FEATURE - push %ax # DEFINE NAME SEXP - call Read - pop %di - call Cons - xchg %ax,%di - xchg %bp,%ax - call Cons - xchg %ax,%bp - jmp main - begin: mov $0x8000,%sp push %cs pop %ds @@ -311,10 +311,11 @@ begin: mov $0x8000,%sp xor %bp,%bp main: xor %dx,%dx call Read - cmp $kDefine,%ax - je Define mov %bp,%dx call Eval + mov %dx,%bp + cmp $kDefine,%ax + je main Catch: xchg %ax,%si call PrintObject mov $'\r',%al