Create friendly version

lisp.c

@@ -25,6 +25,7 @@
 #include <string.h>
 #include <locale.h>
 #include <limits.h>
+#include <setjmp.h>
 #endif
 
 /*───────────────────────────────────────────────────────────────────────────│─╗
@@ -46,6 +47,7 @@
 int cx; /* stores negative memory use */
 int dx; /* stores lookahead character */
 int RAM[0100000]; /* your own ibm7090 */
+jmp_buf undefined;
 
 Intern() {
   int i, j, x;
@@ -157,10 +159,12 @@ Print(e) {
 ╚────────────────────────────────────────────────────────────────────────────│*/
 
 Car(x) {
+  if (x >= 0) longjmp(undefined, x);
   return M[x];
 }
 
 Cdr(x) {
+  if (x >= 0) longjmp(undefined, x);
   return M[x + 1];
 }
 
@@ -186,7 +190,7 @@ Pairlis(x, y, a) {
 }
 
 Assoc(x, y) {
-  if (!y) return 0;
+  if (y >= 0) longjmp(undefined, x);
   if (x == Car(Car(y))) return Cdr(Car(y));
   return Assoc(x, Cdr(y));
 }
@@ -207,14 +211,14 @@ 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));
+  longjmp(undefined, f);
 }
 
 Eval(e, a) {
   int A, B, C;
-  if (e >= 0)
+  if (!e) return 0;
-    return Assoc(e, a);
+  if (e > 0) return Assoc(e, a);
-  if (Car(e) == kQuote)
+  if (Car(e) == kQuote) return Car(Cdr(e));
-    return Car(Cdr(e));
   A = cx;
   if (Car(e) == kCond) {
     e = Evcon(Cdr(e), a);
@@ -235,12 +239,20 @@ Eval(e, a) {
 ╚────────────────────────────────────────────────────────────────────────────│*/
 
 main() {
-  int i;
+  int x, a = 0;
   setlocale(LC_ALL, "");
   bestlineSetXlatCallback(bestlineUppercase);
-  for(i = 0; i < sizeof(S); ++i) M[i] = S[i];
+  for(x = 0; x < sizeof(S); ++x) M[x] = S[x];
   for (;;) {
-    cx = 0;
+    if (!(x = setjmp(undefined))) {
-    Print(Eval(Read(), 0));
+      x = Eval(Read(), a);
+      if (x < 0) {
+        a = Cons(x, a);
+      }
+    } else {
+      if (x == 1) x = 0;
+      PrintChar('?');
+    }
+    Print(x);
   }
 }

lisp.lisp

@@ -120,3 +120,15 @@ NIL
                    ((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
                    ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
             ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))))
+
+(CONS (QUOTE NOT)
+      (QUOTE (LAMBDA (X)
+               (COND (X (QUOTE F))
+                     ((QUOTE T) (QUOTE T))))))
+
+((LAMBDA (X E C)
+   (CONS (QUOTE LAMBDA) (CONS NIL (CONS (CAR (CDR C)) NIL))))
+ (QUOTE T)
+ (QUOTE (LAMBDA (F) (F)))
+ (QUOTE (COND (X (QUOTE F))
+              ((QUOTE T) (QUOTE T)))))

sectorlisp.S

@@ -23,6 +23,8 @@
 // Compatible with the original hardware
 
 	.code16
+	.set	save,-10
+	.set	look,start+2
 	.globl	_start
 _start:	.asciz	"NIL"				# dec %si ; dec %cx ; dec %sp
 kT:	.asciz	"T"				# add %dl,(%si) boot A:\ DL=0
@@ -36,37 +38,53 @@ kCdr:	.asciz	"CDR"				# ordering matters
 kCons:	.asciz	"CONS"				# ordering matters
 kEq:	.asciz	"EQ"				# needs to be last
 
-begin:	push	%cs				# that means ss = ds = es = cs
+begin:	mov	$2,%bx
+	mov	$0x8000,%cx
+main:	cli
+	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
-	mov	$2,%bx
+	sti
-main:	mov	$0x8000,%cx			# dl (g_look) is zero or cr
 	call	GetToken
 	call	GetObject
+	mov	%dx,save
 	call	Eval
-	xchg	%ax,%si
+	test	%ax,%ax
+	jns	Print
+	push	%ax
+	xchg	%ax,%di
+	xchg	%dx,%ax
+	call	Cons
+	xchg	%ax,%dx
+	pop	%ax
+Print:	xchg	%ax,%si
 	call	PrintObject
 	mov	$'\r',%al
 	call	PutChar
 	jmp	main
 
-GetToken:					# GetToken():al, dl is g_look
+GetToken:					# GetToken():al
 	mov	%cx,%di
-1:	mov	%dl,%al
+1:	mov	look,%al
 	cmp	$' ',%al
 	jbe	2f
 	stosb
 	xchg	%ax,%si
 2:	call	GetChar				# exchanges dx and ax
+	cmp	$'\b',%al
+	jne	4f
+	dec	%di
+	jmp	2b
+4:	xchg	%ax,look
 	cmp	$' ',%al
 	jbe	1b
 	cmp	$')',%al
 	jbe	3f
-	cmp	$')',%dl			# dl = g_look
+	cmpb	$')',look
 	ja	1b
 3:	mov	%bh,(%di)			# bh is zero
 	xchg	%si,%ax
@@ -123,14 +141,21 @@ Intern:	push	%cx				# Intern(cx,di): ax
 	jmp	1b
 2:	rep movsb				# memcpy(di,si,cx)
 9:	pop	%cx
-	ret
+3:	ret
+
+Undef:	push	%ax
+	mov	$'?',%al
+	call	PutChar
+	pop	%ax
+	mov	save,%dx
+	jmp	Print
 
 GetChar:xor	%ax,%ax				# GetChar→al:dl
 	int	$0x16				# get keystroke
 PutChar:mov	$0x0e,%ah			# prints CP-437
 	int	$0x10				# vidya service
 	cmp	$'\r',%al			# don't clobber
-	jne	1f				# look xchg ret
+	jne	3b				# look xchg ret
 	mov	$'\n',%al
 	jmp	PutChar
 
@@ -183,6 +208,15 @@ Gc:	cmp	%dx,%di				# Gc(x:di,A:dx,B:si):ax
 	add	%dx,%ax
 	ret
 
+Assoc:	mov	%dx,%si				# Assoc(x:ax,y:dx):ax
+1:	test	%si,%si
+	jns	Undef
+	mov	(%si),%di
+	mov	(%bx,%si),%si
+	scasw
+	jne	1b
+	jmp	Car
+
 GetList:call	GetToken
 	cmp	$')',%al
 	je	.retF
@@ -234,13 +268,6 @@ Cdr:	scasw					# increments our data index by 2
 Car:	mov	(%di),%ax			# contents of address register!!
 2:	ret
 
-Assoc:	mov	%dx,%si				# Assoc(x:ax,y:dx):ax
-1:	mov	(%si),%di
-	mov	(%bx,%si),%si
-	scasw
-	jne	1b
-	jmp	Car
-
 1:	mov	(%bx,%di),%di			# di = Cdr(c)
 Evcon:	push	%di				# save c
 	mov	(%di),%si			# di = Car(c)