Create reform branch (429 bytes)

lisp.c

@@ -33,15 +33,14 @@
 
 #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 kAtom       12
+#define kCar        17
+#define kCdr        21
+#define kCons       25
+#define kEq         30
 
 #define M (RAM + sizeof(RAM) / sizeof(RAM[0]) / 2)
-#define S "NIL\0T\0QUOTE\0COND\0ATOM\0CAR\0CDR\0CONS\0EQ"
+#define S "NIL\0T\0QUOTE\0ATOM\0CAR\0CDR\0CONS\0EQ"
 
 int cx; /* stores negative memory use */
 int dx; /* stores lookahead character */
@@ -125,22 +124,24 @@ PrintAtom(x) {
 
 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) {
+    PrintObject(Car(x));
+    while ((x = Cdr(x))) {
+      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);
@@ -186,7 +187,6 @@ Pairlis(x, y, a) {
 }
 
 Assoc(x, y) {
-  if (!y) return 0;
   if (x == Car(Car(y))) return Cdr(Car(y));
   return Assoc(x, Cdr(y));
 }
@@ -200,7 +200,7 @@ Evcon(c, a) {
 }
 
 Apply(f, x, a) {
-  if (f < 0)      return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(f)), x, a));
+  if (f < 0)      return Evcon(Cdr(f), Pairlis(Car(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 == kCons) return Cons(Car(x), Car(Cdr(x)));
@@ -211,21 +211,13 @@ Apply(f, x, a) {
 
 Eval(e, a) {
   int A, B, C;
-  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);
+  if (!e) return 0;
+  if (e > 0) return Assoc(e, a);
+  if (Car(e) == kQuote) return Car(Cdr(e));
+  A = cx, 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];
+  while (C < B) M[--A] = M[--B];
   cx = A;
   return e;
 }

lisp.lisp

@@ -61,62 +61,53 @@ NIL
 ;; FIND FIRST ATOM IN TREE
 ;; CORRECT RESULT OF EXPRESSION IS `A`
 ;; RECURSIVE CONDITIONAL FUNCTION BINDING
-((LAMBDA (FF X) (FF X))
- (QUOTE (LAMBDA (X)
-          (COND ((ATOM X) X)
-                ((QUOTE T) (FF (CAR X))))))
+(((FF X)
+  ((QUOTE T) (FF X)))
+ (QUOTE ((X)
+         ((ATOM X) X)
+         ((QUOTE T) (FF (CAR X)))))
  (QUOTE ((A) B C)))
 
-;; LISP IMPLEMENTED IN LISP
-;; WITHOUT ANY SUBJECTIVE SYNTACTIC SUGAR
-;; RUNS "FIND FIRST ATOM IN TREE" PROGRAM
-;; CORRECT RESULT OF EXPRESSION IS STILL `A`
-;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND
-;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER
-;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP
-;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE
-((LAMBDA (ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
-   (EVAL (QUOTE ((LAMBDA (FF X) (FF X))
-                 (QUOTE (LAMBDA (X)
-                          (COND ((ATOM X) X)
-                                ((QUOTE T) (FF (CAR X))))))
+;; LISP IN LISP
+;; WITH LANGUAGE REFORMS
+(((ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
+  ((QUOTE T)
+   (EVAL (QUOTE (((FF X)
+                  ((QUOTE T) (FF X)))
+                 (QUOTE ((X)
+                         ((ATOM X) X)
+                         ((QUOTE T) (FF (CAR X)))))
                  (QUOTE ((A) B C))))
-         ()))
- (QUOTE (LAMBDA (X Y)
-          (COND ((EQ Y ()) ())
-                ((EQ X (CAR (CAR Y)))
-                       (CDR (CAR Y)))
-                ((QUOTE T)
-                 (ASSOC X (CDR Y))))))
- (QUOTE (LAMBDA (C A)
-          (COND ((EVAL (CAR (CAR C)) A)
-                 (EVAL (CAR (CDR (CAR C))) A))
-                ((QUOTE T) (EVCON (CDR C) A)))))
- (QUOTE (LAMBDA (X Y A)
-          (COND ((EQ X ()) A)
-                ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
-                                 (PAIRLIS (CDR X) (CDR Y) A))))))
- (QUOTE (LAMBDA (M A)
-          (COND ((EQ M ()) ())
-                ((QUOTE T) (CONS (EVAL (CAR M) A)
-                                 (EVLIS (CDR M) A))))))
- (QUOTE (LAMBDA (FN X A)
-          (COND
-            ((ATOM FN)
-             (COND ((EQ FN (QUOTE CAR))  (CAR  (CAR X)))
-                   ((EQ FN (QUOTE CDR))  (CDR  (CAR X)))
-                   ((EQ FN (QUOTE ATOM)) (ATOM (CAR X)))
-                   ((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X))))
-                   ((EQ FN (QUOTE EQ))   (EQ   (CAR X) (CAR (CDR X))))
-                   ((QUOTE T)            (APPLY (EVAL FN A) X A))))
-            ((EQ (CAR FN) (QUOTE LAMBDA))
-             (EVAL (CAR (CDR (CDR FN)))
-                   (PAIRLIS (CAR (CDR FN)) X A))))))
- (QUOTE (LAMBDA (E A)
-          (COND
-            ((ATOM E) (ASSOC E A))
-            ((ATOM (CAR E))
-             (COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
-                   ((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))))))
+         ())))
+ (QUOTE ((X Y)
+         ((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
+         ((QUOTE T) (ASSOC X (CDR Y)))))
+ (QUOTE ((C A)
+         ((EVAL (CAR (CAR C)) A)
+          (EVAL (CAR (CDR (CAR C))) A))
+         ((QUOTE T) (EVCON (CDR C) A))))
+ (QUOTE ((X Y A)
+         ((EQ X ()) A)
+         ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
+                          (PAIRLIS (CDR X) (CDR Y) A)))))
+ (QUOTE ((M A)
+         ((EQ M ()) ())
+         ((QUOTE T) (CONS (EVAL (CAR M) A)
+                          (EVLIS (CDR M) A)))))
+ (QUOTE ((FN X A)
+         ((ATOM FN)
+          ((() ((EQ FN (QUOTE CAR))  (CAR  (CAR X)))
+               ((EQ FN (QUOTE CDR))  (CDR  (CAR X)))
+               ((EQ FN (QUOTE ATOM)) (ATOM (CAR X)))
+               ((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X))))
+               ((EQ FN (QUOTE EQ))   (EQ   (CAR X) (CAR (CDR X))))
+               ((QUOTE T)            (APPLY (EVAL FN A) X A)))))
+         ((QUOTE T)
+          (EVCON (CDR FN) (PAIRLIS (CAR FN) X A)))))
+ (QUOTE ((E A)
+         ((EQ E ()) ())
+         ((ATOM E) (ASSOC E A))
+         ((ATOM (CAR E))
+          ((() ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
+               ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A)))))
+         ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A)))))

sectorlisp.S

@@ -29,7 +29,6 @@ kT:	.asciz	"T"				# add %dl,(%si) boot A:\ DL=0
 start:	ljmp	$0x7c00>>4,$begin		# cs = 0x7c00 is boot address
 	.asciz	""
 kQuote:	.asciz	"QUOTE"
-kCond:	.asciz	"COND"
 kAtom:	.asciz	"ATOM"				# ordering matters
 kCar:	.asciz	"CAR"				# ordering matters
 kCdr:	.asciz	"CDR"				# ordering matters
@@ -205,13 +204,12 @@ GetList:call	GetToken
 Apply:	test	%ax,%ax				# Apply(fn:ax,x:si:a:dx):ax
 	jns	.switch				# jump if atom
 	xchg	%ax,%di				# di = fn
-.lambda:mov	(%bx,%di),%di			# di = Cdr(fn)
-	push	%di				# save 1
+.lambda:push	(%bx,%di)			# save 1
 	mov	(%di),%di			# di = Cadr(fn)
 	call	Pairlis
 	xchg	%ax,%dx
 	pop	%di				# restore 1
-	jmp	.EvCadr
+	jmp	Evcon
 .switch:cmp	$kEq,%ax			# eq is last builtin atom
 	ja	.dflt1				# ah is zero if not above
 	mov	(%si),%di			# di = Car(x)
@@ -255,7 +253,7 @@ Evcon:	push	%di				# save c
 	test	%ax,%ax				# nil test
 	jz	1b
 	mov	(%di),%di			# di = Car(c)
-.EvCadr:call	Cadr				# ax = Cadar(c)
+	call	Cadr				# ax = Cadar(c)
 #	jmp	Eval
 
 Eval:	test	%ax,%ax				# Eval(e:ax,a:dx):ax
@@ -266,8 +264,6 @@ Eval:	test	%ax,%ax				# Eval(e:ax,a:dx):ax
 	cmp	$kQuote,%ax			# maybe CONS
 	mov	(%si),%di			# di = Cdr(e)
 	je	Car
-	cmp	$kCond,%ax
-	je	Evcon				# ABC Garbage Collector
 	push	%dx				# save a
 	push	%cx				# save A
 	push	%ax
@@ -291,7 +287,6 @@ Eval:	test	%ax,%ax				# Eval(e:ax,a:dx):ax
 	.word	0xAA55
 2:	.type	.sig,@object
 	.type	kQuote,@object
-	.type	kCond,@object
 	.type	kAtom,@object
 	.type	kCar,@object
 	.type	kCdr,@object