Experiment with friendlier branch

Makefile

@@ -1,5 +1,4 @@
-CFLAGS  = -w -Os
-LDFLAGS = -s
+CFLAGS = -w -g
 
 CLEANFILES =				\
 	lisp				\

lisp.c

@@ -28,121 +28,78 @@
 #include <setjmp.h>
 #endif
 
-/*───────────────────────────────────────────────────────────────────────────│─╗
-│ The LISP Challenge § LISP Machine                                        ─╬─│┼
-╚────────────────────────────────────────────────────────────────────────────│*/
-
-#define kT          4
-#define kQuote      6
-#define kCond       12
-#define kAtom       17
-#define kCar        22
-#define kCdr        26
-#define kCons       30
-#define kEq         35
-
-#define M (RAM + sizeof(RAM) / sizeof(RAM[0]) / 2)
-#define S "NIL\0T\0QUOTE\0COND\0ATOM\0CAR\0CDR\0CONS\0EQ"
-
-int cx; /* stores negative memory use */
-int dx; /* stores lookahead character */
-int RAM[0100000]; /* your own ibm7090 */
 jmp_buf undefined;
+int cx, dx, M[0100000];
+int Null = sizeof(M) / sizeof(M[0]) / 2;
+char *line = "NIL T CAR CDR ATOM COND CONS QUOTE EQ ";
+int kT, kEq, kNil, kCar, kCdr, kCond, kAtom, kCons, kQuote;
 
-Intern() {
-  int i, j, x;
-  for (i = 0; (x = M[i++]);) {
-    for (j = 0;; ++j) {
-      if (x != RAM[j]) break;
-      if (!x) return i - j - 1;
-      x = M[i++];
-    }
-    while (x)
-      x = M[i++];
-  }
-  j = 0;
-  x = --i;
-  while ((M[i++] = RAM[j++]));
-  return x;
+Get(i) {
+  return M[Null + i];
 }
 
-GetChar() {
-  int c, t;
-  static char *l, *p;
-  if (l || (l = p = bestlineWithHistory("* ", "sectorlisp"))) {
-    if (*p) {
-      c = *p++ & 255;
-    } else {
-      free(l);
-      l = p = 0;
-      c = '\n';
-    }
-    t = dx;
-    dx = c;
-    return t;
-  } else {
-    PrintChar('\n');
-    exit(0);
-  }
+Set(i, x) {
+  M[Null + i] = x;
 }
 
-PrintChar(b) {
-  fputwc(b, stdout);
+Read() {
+  return ReadObject(ReadAtom(0));
 }
 
-GetToken() {
-  int c, i = 0;
-  do if ((c = GetChar()) > ' ') RAM[i++] = c;
-  while (c <= ' ' || (c > ')' && dx > ')'));
-  RAM[i] = 0;
-  return c;
+Intern(x, y, i) {
+  if (x == Get(i) && y == Get(i + 1)) return i;
+  if (Get(i)) return Intern(x, y, i + 2);
+  Set(i, x);
+  Set(i + 1, y);
+  return i;
 }
 
-AddList(x) {
-  return Cons(x, GetList());
+ReadAtom(i) {
+  int c = ReadChar();
+  if (c <= ' ') return ReadAtom(i);
+  return Intern(c, c > ')' && dx > ')' ? ReadAtom(0) : 0, i + c * 2);
 }
 
-GetList() {
-  int c = GetToken();
-  if (c == ')') return 0;
-  return AddList(GetObject(c));
+AddList(x) {
+  return Cons(x, ReadList());
 }
 
-GetObject(c) {
-  if (c == '(') return GetList();
-  return Intern();
+ReadList() {
+  int t = ReadAtom(0);
+  if (Get(t) == ')') return kNil;
+  return AddList(ReadObject(t));
 }
 
-Read() {
-  return GetObject(GetToken());
+ReadObject(t) {
+  if (Get(t) != '(') return t;
+  return ReadList();
 }
 
 PrintAtom(x) {
-  int c;
-  for (;;) {
-    if (!(c = M[x++])) break;
-    PrintChar(c);
-  }
+  do PrintChar(Get(x));
+  while ((x = Get(x + 1)));
 }
 
 PrintList(x) {
   PrintChar('(');
-  PrintObject(Car(x));
-  while ((x = Cdr(x))) {
-    if (x < 0) {
-      PrintChar(' ');
-      PrintObject(Car(x));
-    } else {
-      PrintChar(L'∙');
-      PrintObject(x);
-      break;
+  if (x < 0) {
+    PrintObject(Car(x));
+    while ((x = Cdr(x)) != kNil) {
+      if (x < 0) {
+        PrintChar(' ');
+        PrintObject(Car(x));
+      } else {
+        PrintChar(L'∙');
+        PrintObject(x);
+        break;
+      }
     }
   }
   PrintChar(')');
 }
 
 PrintObject(x) {
-  if (x < 0) {
+  if (1./x < 0) {
     PrintList(x);
   } else {
     PrintAtom(x);
@@ -154,39 +111,49 @@ Print(e) {
   PrintChar('\n');
 }
 
-/*───────────────────────────────────────────────────────────────────────────│─╗
-│ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator    ─╬─│┼
-╚────────────────────────────────────────────────────────────────────────────│*/
-
 Car(x) {
-  if (x >= 0) longjmp(undefined, x);
-  return M[x];
+  if (x < 0) {
+    return Get(x);
+  } else {
+    longjmp(undefined, x);
+  }
 }
 
 Cdr(x) {
-  if (x >= 0) longjmp(undefined, x);
-  return M[x + 1];
+  if (x < 0) {
+    return Get(x + 1);
+  } else {
+    longjmp(undefined, x);
+  }
 }
 
 Cons(car, cdr) {
-  M[--cx] = cdr;
-  M[--cx] = car;
+  Set(--cx, cdr);
+  Set(--cx, car);
   return cx;
 }
 
-Gc(x, m, k) {
-  return x < m ? Cons(Gc(Car(x), m, k), 
-                      Gc(Cdr(x), m, k)) + k : x;
+Gc(A, x) {
+  int C, B = cx;
+  x = Copy(x, A, A - B), C = cx;
+  while (C < B) Set(--A, Get(--B));
+  cx = A;
+  return x;
+}
+
+Copy(x, m, k) {
+  return x < m ? Cons(Copy(Car(x), m, k), 
+                      Copy(Cdr(x), m, k)) + k : x;
 }
 
 Evlis(m, a) {
-  return m ? Cons(Eval(Car(m), a),
-                  Evlis(Cdr(m), a)) : 0;
+  return m != kNil ? Cons(Eval(Car(m), a),
+                          Evlis(Cdr(m), a)) : kNil;
 }
 
 Pairlis(x, y, a) {
-  return x ? Cons(Cons(Car(x), Car(y)),
-                  Pairlis(Cdr(x), Cdr(y), a)) : a;
+  return x != kNil ? Cons(Cons(Car(x), Car(y)),
+                          Pairlis(Cdr(x), Cdr(y), a)) : a;
 }
 
 Assoc(x, y) {
@@ -196,63 +163,93 @@ Assoc(x, y) {
 }
 
 Evcon(c, a) {
-  if (Eval(Car(Car(c)), a)) {
+  if (Eval(Car(Car(c)), a) != kNil) {
     return Eval(Car(Cdr(Car(c))), a);
-  } else {
+  } else if (Cdr(c) != kNil) {
     return Evcon(Cdr(c), a);
+  } else {
+    longjmp(undefined, c);
   }
 }
 
 Apply(f, x, a) {
   if (f < 0)      return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(f)), x, a));
-  if (f > kEq)    return Apply(Eval(f, a), x, a);
-  if (f == kEq)   return Car(x) == Car(Cdr(x)) ? kT : 0;
+  if (f == kEq)   return Car(x) == Car(Cdr(x)) ? kT : kNil;
   if (f == kCons) return Cons(Car(x), Car(Cdr(x)));
-  if (f == kAtom) return Car(x) < 0 ? 0 : kT;
+  if (f == kAtom) return Car(x) < 0 ? kNil : kT;
   if (f == kCar)  return Car(Car(x));
   if (f == kCdr)  return Cdr(Car(x));
-  longjmp(undefined, f);
+  return Apply(Assoc(f, a), x, a);
 }
 
 Eval(e, a) {
-  int A, B, C;
-  if (!e) return 0;
-  if (e > 0) return Assoc(e, a);
+  int A = cx;
+  if (e == kNil) return kNil;
+  if (e >= 0) return Assoc(e, a);
   if (Car(e) == kQuote) return Car(Cdr(e));
-  A = cx;
   if (Car(e) == kCond) {
     e = Evcon(Cdr(e), a);
   } else {
     e = Apply(Car(e), Evlis(Cdr(e), a), a);
   }
-  B = cx;
-  e = Gc(e, A, A - B);
-  C = cx;
-  while (C < B)
-    M[--A] = M[--B];
-  cx = A;
-  return e;
+  return Gc(A, e);
 }
 
-/*───────────────────────────────────────────────────────────────────────────│─╗
-│ The LISP Challenge § User Interface                                      ─╬─│┼
-╚────────────────────────────────────────────────────────────────────────────│*/
-
 main() {
-  int x, a = 0;
+  int x, a;
   setlocale(LC_ALL, "");
   bestlineSetXlatCallback(bestlineUppercase);
-  for(x = 0; x < sizeof(S); ++x) M[x] = S[x];
-  for (;;) {
+  kNil = ReadAtom(0);
+  kT = ReadAtom(0);
+  kCar = ReadAtom(0);
+  kCdr = ReadAtom(0);
+  kAtom = ReadAtom(0);
+  kCond = ReadAtom(0);
+  kCons = ReadAtom(0);
+  kQuote = ReadAtom(0);
+  kEq = ReadAtom(0);
+  for (a = kNil;;) {
     if (!(x = setjmp(undefined))) {
-      x = Eval(Read(), a);
+      x = Read();
+      x = Eval(x, a);
       if (x < 0) {
         a = Cons(x, a);
       }
     } else {
-      if (x == 1) x = 0;
       PrintChar('?');
     }
     Print(x);
   }
 }
+
+PrintChar(b) {
+  fputwc(b, stdout);
+}
+
+ReadChar() {
+  int b, c, t;
+  static char *freeme;
+  if (line || (line = freeme = bestlineWithHistory("* ", "sectorlisp"))) {
+    if (*line) {
+      c = *line++ & 0377;
+      if (c >= 0300) {
+        for (b = 0200; c & b; b >>= 1) c ^= b;
+        while ((*line & 0300) == 0200) {
+          c <<= 6;
+          c |= *line++ & 0177;
+        }
+      }
+    } else {
+      free(freeme);
+      freeme = 0;
+      line = 0;
+      c = '\n';
+    }
+    t = dx;
+    dx = c;
+    return t;
+  } else {
+    PrintChar('\n');
+    exit(0);
+  }
+}

sectorlisp.S

@@ -23,12 +23,13 @@
 // Compatible with the original hardware
 
 	.code16
-	.set	save,-10
-	.set	look,start+2
+	.set	save,-2-2
+	.set	look,start+5-2
 	.globl	_start
 _start:	.asciz	"NIL"				# dec %si ; dec %cx ; dec %sp
 kT:	.asciz	"T"				# add %dl,(%si) boot A:\ DL=0
-start:	ljmp	$0x7c00>>4,$begin		# cs = 0x7c00 is boot address
+start:	mov	$0x8000,%sp			# this should be safe we hope
+	ljmp	$0x7c00>>4,$begin		# cs = 0x7c00 is boot address
 	.asciz	""
 kQuote:	.asciz	"QUOTE"
 kCond:	.asciz	"COND"
@@ -38,20 +39,17 @@ kCdr:	.asciz	"CDR"				# ordering matters
 kCons:	.asciz	"CONS"				# ordering matters
 kEq:	.asciz	"EQ"				# needs to be last
 
-begin:	mov	$2,%bx
-	mov	$0x8000,%cx
-main:	cli
-	push	%cs				# that means ss = ds = es = cs
+begin:	push	%cs				# that means ss = ds = es = cs
 	pop	%ds				# noting ljmp set cs to 0x7c00
 	push	%cs				# that's the bios load address
 	pop	%es				# therefore NULL points to NUL
 	push	%cs				# terminated NIL string above!
 	pop	%ss				# errata exists but don't care
-	xor	%sp,%sp				# use highest address as stack
-	sti
-	call	GetToken
+	mov	$2,%bx
+	mov	%sp,%cx
+main:	call	GetToken
 	call	GetObject
-	mov	%dx,save
+	mov	%dx,save(%bx)
 	call	Eval
 	test	%ax,%ax
 	jns	Print
@@ -69,7 +67,7 @@ Print:	xchg	%ax,%si
 
 GetToken:					# GetToken():al
 	mov	%cx,%di
-1:	mov	look,%al
+1:	mov	look(%bx),%al
 	cmp	$' ',%al
 	jbe	2f
 	stosb
@@ -79,12 +77,12 @@ GetToken:					# GetToken():al
 	jne	4f
 	dec	%di
 	jmp	2b
-4:	xchg	%ax,look
+4:	xchg	%ax,look(%bx)
 	cmp	$' ',%al
 	jbe	1b
 	cmp	$')',%al
 	jbe	3f
-	cmpb	$')',look
+	cmpb	$')',look(%bx)
 	ja	1b
 3:	mov	%bh,(%di)			# bh is zero
 	xchg	%si,%ax
@@ -147,7 +145,7 @@ Undef:	push	%ax
 	mov	$'?',%al
 	call	PutChar
 	pop	%ax
-	mov	save,%dx
+	mov	save(%bx),%dx
 	jmp	Print
 
 GetChar:xor	%ax,%ax				# GetChar→al:dl