Make DEFINE more like Scheme

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();

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