Eval based on LISP 1.5 manual, 509 bytes

Makefile

@@ -36,8 +36,6 @@ CLEANFILES =				\
 	lisp.bin.dbg			\
 	sectorlisp.bin.dbg
 
-lisp:	lisp.o
-
 .PHONY:	all
 all:	lisp				\
 	lisp.bin			\
@@ -49,12 +47,18 @@ all:	lisp				\
 clean:;	$(RM) $(CLEANFILES)
 
 lisp.bin.dbg: start.o lisp.real.o lisp.lds
-sectorlisp.bin.dbg: start.o sectorlisp.o lisp.lds
+lisp:	lisp.o
 
 start.o: start.S Makefile
 lisp.o: lisp.c lisp.h Makefile
 lisp.real.o: lisp.c lisp.h Makefile
-sectorlisp.o: sectorlisp.S Makefile
+
+sectorlisp.o: sectorlisp.S
+	$(AS)  -g -mtune=i386 -o $@ $<
+sectorlisp.bin.dbg: sectorlisp.o
+	$(LD) -oformat:binary -Ttext=0x7600 -o $@ $<
+sectorlisp.bin: sectorlisp.bin.dbg
+	objcopy -SO binary sectorlisp.bin.dbg sectorlisp.bin
 
 %.real.o: %.c
 	$(CC) $(CPPFLAGS) $(CFLAGS) $(REALFLAGS) -c -o $@ $<

lisp.c

@@ -18,7 +18,6 @@
 ╚─────────────────────────────────────────────────────────────────────────────*/
 #include "lisp.h"
 
-#define TRACE  0  // print eval input output
 #define RETRO  1  // auto capitalize input
 #define DELETE 1  // allow backspace to rub out symbol
 #define QUOTES 1  // allow 'X shorthand (QUOTE X)
@@ -30,24 +29,22 @@
 │ The LISP Challenge § LISP Machine                                        ─╬─│┼
 ╚────────────────────────────────────────────────────────────────────────────│*/
 
-#define ATOM 0
+#define ATOM 1
-#define CONS 1
+#define CONS 0
 
-#define NIL         0
+#define NIL         (ATOM | 0)
-#define UNDEFINED   8
+#define UNDEFINED   (ATOM | 8)
-#define ATOM_T      30
+#define ATOM_T      (ATOM | 30)
-#define ATOM_QUOTE  34
+#define ATOM_QUOTE  (ATOM | 34)
-#define ATOM_ATOM   46
+#define ATOM_COND   (ATOM | 46)
-#define ATOM_EQ     56
+#define ATOM_ATOM   (ATOM | 56)
-#define ATOM_COND   62
+#define ATOM_CAR    (ATOM | 66)
-#define ATOM_CAR    72
+#define ATOM_CDR    (ATOM | 74)
-#define ATOM_CDR    80
+#define ATOM_CONS   (ATOM | 82)
-#define ATOM_CONS   88
+#define ATOM_EQ     (ATOM | 92)
-#define ATOM_LAMBDA 98
+#define ATOM_LAMBDA (ATOM | 98)
 
-#define BOOL(x)  ((x) ? ATOM_T : NIL)
 #define VALUE(x) ((x) >> 1)
-#define PTR(i)   ((i) << 1 | CONS)
 
 struct Lisp {
   WORD mem[WORDS];
@@ -66,12 +63,12 @@ _Alignas(char) const char kSymbols[] = "NIL\0"
                                        "*UNDEFINED\0"
                                        "T\0"
                                        "QUOTE\0"
-                                       "ATOM\0"
-                                       "EQ\0"
                                        "COND\0"
+                                       "ATOM\0"
                                        "CAR\0"
                                        "CDR\0"
                                        "CONS\0"
+                                       "EQ\0"
                                        "LAMBDA";
 
 #ifdef __REAL_MODE__
@@ -84,7 +81,7 @@ static void Print(long);
 static WORD GetList(void);
 static WORD GetObject(void);
 static void PrintObject(long);
-static WORD Eval(long, long);
+static WORD Eval(WORD, WORD);
 
 static void SetupSyntax(void) {
   unsigned char *syntax = q->syntax;
@@ -327,14 +324,6 @@ static void Print(long i) {
 │ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator    ─╬─│┼
 ╚────────────────────────────────────────────────────────────────────────────│*/
 
-static WORD Atom(long x) {
-  return BOOL(ISATOM(x));
-}
-
-static WORD Eq(long x, long y) {
-  return BOOL(x == y);
-}
-
 static WORD Caar(long x) {
   return Car(Car(x));  // ((A B C D) (E F G) H I) → A
 }
@@ -355,75 +344,75 @@ static WORD Caddar(long x) {
   return Caddr(Car(x));  // ((A B C D) (E F G) H I) → C
 }
 
-static WORD Arg1(long e, long a) {
-  return Eval(Cadr(e), a);
-}
-
-static WORD Arg2(long e, long a) {
-  return Eval(Caddr(e), a);
-}
-
-static WORD Append(long x, long y) {
-  return x ? Cons(Car(x), Append(Cdr(x), y)) : y;
-}
-
 static WORD Evcon(long c, long a) {
-  return Eval(Caar(c), a) ? Eval(Cadar(c), a) : Evcon(Cdr(c), a);
+  return Eval(Caar(c), a) != NIL ? Eval(Cadar(c), a) : Evcon(Cdr(c), a);
 }
 
-static WORD Bind(long v, long a, long e) { // evlis + pair w/ dot notation
+static WORD Assoc(long x, long a) {
-  return v ? Cons(Cons(Car(v), Eval(Car(a), e)), Bind(Cdr(v), Cdr(a), e)) : e;
+  return a != NIL ? Caar(a) == x ? Cdar(a) : Assoc(x, Cdr(a)) : NIL;
 }
 
-static WORD Assoc(long x, long y) {
+static WORD Pairlis(WORD x, WORD y, WORD a) {
-  return y ? Eq(Caar(y), x) ? Cdar(y) : Assoc(x, Cdr(y)) : NIL;
+  if (x == NIL)
+    return a;
+  WORD di = Cons(Car(x), Car(y));
+  WORD si = Pairlis(Cdr(x), Cdr(y), a);
+  return Cons(di, si); // Tail-Modulo-Cons
 }
 
-static WORD Evaluate(long e, long a) {
+static WORD Evlis(WORD m, WORD a) {
-  if (Atom(e)) {
+  if (m == NIL)
-    return Assoc(e, a);
+    return NIL;
-  } else if (Atom(Car(e))) {
+  WORD di = Eval(Car(m), a);
-    switch (Car(e)) {
+  WORD si = Evlis(Cdr(m), a);
-      case NIL:
+  return Cons(di, si);
-        return UNDEFINED;
+}
-      case ATOM_QUOTE:
+
-        return Cadr(e);
+static WORD Apply(WORD fn, WORD x, WORD a) {
-      case ATOM_ATOM:
+  if (ISATOM(fn)) {
-        return Atom(Arg1(e, a));
+    switch (fn) {
-      case ATOM_EQ:
+    case NIL:
-        return Eq(Arg1(e, a), Arg2(e, a));
+      return UNDEFINED;
-      case ATOM_COND:
+    case ATOM_CAR:
-        return Evcon(Cdr(e), a);
+      return Caar(x);
-      case ATOM_CAR:
+    case ATOM_CDR:
-        return Car(Arg1(e, a));
+      return Cdar(x);
-      case ATOM_CDR:
+    case ATOM_ATOM:
-        return Cdr(Arg1(e, a));
+      return ISATOM(Car(x)) ? ATOM_T : NIL;
-      case ATOM_CONS:
+    case ATOM_CONS:
-        return Cons(Arg1(e, a), Arg2(e, a));
+      return Cons(Car(x), Cadr(x));
-      default:
+    case ATOM_EQ:
-        return Eval(Cons(Assoc(Car(e), a), Cdr(e)), a);
+      return Car(x) == Cadr(x) ? ATOM_T : NIL;
+    default:
+      return Apply(Eval(fn, a), x, a);
     }
-  } else if (Eq(Caar(e), ATOM_LAMBDA)) {
-    return Eval(Caddar(e), Bind(Cadar(e), Cdr(e), a));
-  } else {
-    return UNDEFINED;
   }
+
+  if (Car(fn) == ATOM_LAMBDA) {
+    WORD t1 = Cdr(fn);
+    WORD si = Pairlis(Car(t1), x, a);
+    WORD ax = Cadr(t1);
+    return Eval(ax, si);
+  }
+
+  return UNDEFINED;
 }
 
-static WORD Eval(long e, long a) {
+static WORD Eval(WORD e, WORD a) {
-  WORD r;
+  if (ISATOM(e))
-#if TRACE
+    return Assoc(e, a);
-  PrintString("->");
+
-  Print(e);
+  WORD ax = Car(e);
-  PrintString("  ");
+  if (ISATOM(ax)) {
-  Print(a);
+    if (ax == ATOM_QUOTE)
-#endif
+      return Cadr(e);
-  e = Evaluate(e, a);
+    if (ax == ATOM_COND)
-#if TRACE
+      return Evcon(Cdr(e), a);
-  PrintString("<-");
+    if (ax == ATOM_LAMBDA)
-  Print(e);
+      return e;
-#endif
+  }
-  return e;
+
+  return Apply(ax, Evlis(Cdr(e), a), a);
 }
 
 /*───────────────────────────────────────────────────────────────────────────│─╗

lisp.h

@@ -13,7 +13,7 @@
 #define ISATOM(x) /* a.k.a. !(x&1) */                        \
   ({                                                         \
     _Bool IsAtom;                                            \
-    asm("test%z1\t$1,%1" : "=@ccz"(IsAtom) : "Qm"((char)x)); \
+    asm("test%z1\t$1,%1" : "=@ccnz"(IsAtom) : "Qm"((char)x)); \
     IsAtom;                                                  \
   })
 

sectorlisp.S

@@ -2,6 +2,7 @@
 │vi: set et ft=asm ts=8 tw=8 fenc=utf-8                                     :vi│
 ╞══════════════════════════════════════════════════════════════════════════════╡
 │ Copyright 2020 Justine Alexandra Roberts Tunney                              │
+│ Copyright 2021 Alain Greppin                                                 │
 │                                                                              │
 │ Permission to use, copy, modify, and/or distribute this software for         │
 │ any purpose with or without fee is hereby granted, provided that the         │
@@ -17,423 +18,305 @@
 │ PERFORMANCE OF THIS SOFTWARE.                                                │
 ╚─────────────────────────────────────────────────────────────────────────────*/
 
-//	@fileoverview lisp.c built for real mode with manual tuning
+// LISP meta-circular evaluator in a MBR
-//	binary footprint is approximately 824 bytes, about 40 bytes
-//	of it is overhead needed to load the second 512-byte sector
-//	so if we can find a way to reduce the code size another 300
-//	bytes we can bootstrap the metacircular evaluator in an mbr
 
-#define NIL		0
+.set NIL,		1
-#define UNDEFINED	8
+.set ATOM_T,		9
-#define ATOM_T		30
+.set ATOM_QUOTE,	13
-#define ATOM_QUOTE	34
+.set ATOM_COND,		25
-#define ATOM_ATOM	46
+.set ATOM_ATOM,		35
-#define ATOM_EQ		56
+.set ATOM_CAR,		45
-#define ATOM_COND	62
+.set ATOM_CDR,		53
-#define ATOM_CAR	72
+.set ATOM_CONS,		61
-#define ATOM_CDR	80
+.set ATOM_EQ,		71
-#define ATOM_CONS	88
-#define ATOM_LAMBDA	98
 
-#define STR 0x4186
+.set q.token,	0x4000
+.set q.str,	0x4080
+.set boot,	0x7c00
 
 ////////////////////////////////////////////////////////////////////////////////
-.section .start,"ax",@progbits
+.section .text,"ax",@progbits
-.globl	main
+.globl	_start
 .code16
 
-main:	mov	$q.syntax,%bx
+_start:	jmp	.init				# some bios scan for short jump
-	mov	$32,%al
+.type kSymbols,@object;
-	mov	%al,32(%bx)
+kSymbols:
-	mov	%al,13(%bx)
+	.ascii "NIL\0T\0QUOTE\0COND\0ATOM\0CAR\0CDR\0CONS\0EQ"
-	mov	%al,10(%bx)
+
-	movw	$10536,40(%bx)
+.type .init,@function
-	movb	$46,46(%bx)
+.init:	ljmp	$0x600>>4,$_begin		# end of bios data roundup page
-	mov	$STR,%di
+_begin:	push	%cs				# memory model cs=ds=es = 0x600
+	push	%cs
+	push	%cs
+	pop	%ds
+	pop	%es
+	pop	%ss
+	mov	$0x7c00-0x600,%cx
+	mov	%cx,%sp
+	cld
+	xor	%ax,%ax
+	mov	%ax,%fs				# fs = &q.mem
+	xor	%di,%di
+	rep stosb				# clears our bss memory
+main:	mov	$q.str,%di
 	mov	$kSymbols,%si
-	mov	$56,%cx
+	mov	$37,%cx
 	rep movsb
-0:	call	GetChar
+0:	mov	$'\n',%dl
-	mov	%ax,q.look
 	call	GetToken
 	call	GetObject
-	xchg	%ax,%di
+	mov	$NIL,%dx
-	mov	q.globals,%si
 	call	Eval
-	xchg	%ax,%di
 	call	PrintObject
-	mov	$kCrlf,%si
+	mov	$'\r',%al
-	call	PrintString
-	jmp	0b
-
-GetChar:xor	%ax,%ax				# get keystroke
-	int	$0x16				# keyboard service
-	xor	%ah,%ah				# ah is bios scancode
-	push	%ax				# al is ascii character
-	call	PutChar				# ax will have result
-	cmp	$'\r',%al			# don't clobber stuff
-	jne	1f
-	mov	$'\n',%al
 	call	PutChar
-1:	pop	%ax
-	ret
-
-Cadr:	and	$-2,%di				# (object >> 1) * sizeof(word)
-	mov	2(%di),%di			# contents of decrement register
-	and	$-2,%di				# contents of address register
-	mov	(%di),%ax
-	ret
-
-GetToken:
-	xor	%bx,%bx
-	mov	$q.syntax,%si
-	mov	q.look,%ax
-	mov	$q.token,%di
-0:	mov	%al,%bl
-	mov	(%bx,%si),%dl
-	mov	%dl,%bl
-	cmp	$0x20,%dl
-	jne	1f
-	call	GetChar
 	jmp	0b
-1:	test	%dl,%dl
-	je	3f
-	stosb
-	call	GetChar
-	jmp	4f
-2:	test	%bl,%bl
-	jne	4f
-	stosb
-	call	GetChar
-	mov	%ax,%bx
-	mov	(%bx,%si),%bl
-3:	test	%al,%al
-	jne	2b
-4:	movb	$0,(%di)
-	mov	%al,q.look
-	ret
 
-Assoc:	xchg	%si,%bx
+GetToken:					# GetToken():al, dl is q.look
-0:	test	%bx,%bx
-	je	2f
-	and	$-2,%bx
-	mov	(%bx),%si
-	and	$-2,%si
-	mov	(%si),%ax
-	cmp	%di,%ax
-	jne	1f
-	mov	(%bx),%si
-	and	$-2,%si
-	mov	2(%si),%ax
-	ret
-1:	mov	2(%bx),%bx
-	jmp	0b
-2:	xor	%ax,%ax
-	ret
-
-GetObject:
-	cmpb	$40,q.token
-	je	GetList
 	mov	$q.token,%di
-//	𝑠𝑙𝑖𝑑𝑒
+1:	mov	%dl,%al
-
+	cmp	$' ',%al
-Intern:	mov	%di,%bx
+	jbe	2f
-	mov	$STR,%si
-0:	mov	%bx,%di
-	push	%si
-	lodsb
-	test	%al,%al
-	jne	2f
-	pop	%di
-	push	%di
-	mov	%bx,%si
-4:	lodsb
 	stosb
-	test	%al,%al
+	xchg	%ax,%cx
-	jnz	4b
+2:	call	GetChar				# bh = 0 after PutChar
-6:	pop	%ax
+	xchg	%ax,%dx				# dl = q.look
-	sub	$STR,%ax
+	cmp	$' ',%al
-	shl	%ax
+	jbe	1b
-	ret
-1:	lodsb
-2:	scasb
-	jne	5f
-	test	%al,%al
-	jne	1b
-	jmp	6b
-5:	pop	%di
-3:	test	%al,%al
-	jz	0b
-	lodsb
-	jmp	3b
-
-GetList:call	GetToken
-	mov	q.token,%al
 	cmp	$')',%al
-	je	2f
+	jbe	3f
-	cmp	$'.',%al
+	cmp	$')',%dl
-	je	1f
+	ja	1b
-	call	GetObject
+3:	movb	%bh,(%di)
-	push	%ax				# save
+	xchg	%cx,%ax
-	call	GetList
-	xchg	%ax,%si
-	pop	%di				# restore
-	jmp	Cons
-1:	call	GetToken
-	jmp	GetObject
-2:	xor	%ax,%ax
 	ret
 
-EvalCons:
+GetObject:					# called just after GetToken
-	push	%dx				# save
+	cmpb	$'(',%al
-	mov	2(%bx),%bx
+	je	GetList
-	mov	%bx,%di
+	mov	$q.token,%si
-	call	Cadr
+.Intern:
-	xchg	%ax,%di
+	mov	%si,%bx				# save s
-	mov	%bp,%si
+	mov	$q.str,%di
-	call	Eval
+	xor	%al,%al
-	mov	%bp,%si
+0:	mov	$-1,%cl
-	pop	%di				# restore
+	push	%di				# save 1
-	push	%ax				# save
+1:	cmpsb
-	call	Arg1
+	jne	2f
-	pop	%si				# restore
+	cmp	-1(%di),%al
-	xchg	%ax,%di
+	jne	1b
-	pop	%bp
+	jmp	4f
-//	jmp	Cons
+2:	pop	%si				# drop 1
-//	𝑠𝑙𝑖𝑑𝑒
+	mov	%bx,%si				# restore s
-
+	repne scasb
-Cons:	mov	$q.index,%bx
+	cmp	(%di),%al
-	mov	(%bx),%ax
+	jne	0b
-	addw	$2,(%bx)
+	push	%di				# StpCpy
-	shl	%ax
+3:	lodsb
-	mov	%ax,%bx
+	stosb
-	mov	%di,(%bx)
-	mov	%si,2(%bx)
-	or	$1,%ax
-	ret
-
-Bind:	test	%di,%di
-	je	1f
-	push	%bp
-	and	$-2,%si
-	and	$-2,%di
-	mov	%di,%bp
-	push	%dx				# save no. 1
-	push	%si				# save no. 2
-	mov	2(%si),%si
-	mov	2(%di),%di
-	call	Bind
-	pop	%si				# rest no. 2
-	mov	(%si),%di
-	pop	%si				# rest no. 1
-	push	%ax				# save no. 3
-	call	Eval
-	mov	%ds:(%bp),%di
-	xchg	%ax,%si
-	call	Cons
-	pop	%si				# rest no. 3
-	xchg	%ax,%di
-	pop	%bp
-	jmp	Cons
-1:	xchg	%dx,%ax
-	ret
-
-PrintString:					# nul-terminated in si
-0:	lodsb					# don't clobber bp, bx
 	test	%al,%al
-	je	1f
+	jnz	3b
-	call	PutChar
+4:	pop	%ax				# restore 1
-	jmp	0b
+	add	$-q.str,%ax			# stc
-1:	ret
+	adc	%ax,%ax				# ax = 2 * ax + carry
+.ret:	ret
 
-PutChar:push	%bx				# don't clobber bp,bx,di,si,cx
+PrintObject:					# PrintObject(x:ax)
-	push	%bp				# original ibm pc scroll up bug
+	test	$1,%al
+	xchg	%ax,%di
+	jz	.PrintList
+.PrintAtom:
+	shr	%di
+	lea	q.str(%di),%si
+.PrintString:					# nul-terminated in si
+	lodsb
+	test	%al,%al
+	jz	.ret				# -> ret
+	call	PutChar
+	jmp	.PrintString
+.PrintList:
+	mov	$'(',%al
+2:	push	2(%di)				# save 1 Cdr(x)
+	mov	(%di),%di			# di = Car(x)
+	call	.PutObject
+	pop	%ax				# restore 1
+	cmp	$NIL,%ax
+	je	4f
+	test	$1,%al
+	xchg	%ax,%di
+	mov	$' ',%al
+	jz	2b
+	mov	$249,%al			# bullet (A∙B)
+	call	.PutObject
+4:	mov	$')',%al
+	jmp	PutChar
+.PutObject:					# .PutObject(c:al,x:di)
+	call	PutChar				# preserves di
+	xchg	%di,%ax
+	jmp	PrintObject
+
+GetChar:
+	xor	%ax,%ax				# get keystroke
+	int	$0x16				# keyboard service
+						# ah is bios scancode
+						# al is ascii character
+PutChar:
+#	push	%bx				# don't clobber di,si,cx,dx
+#	push	%bp				# original ibm pc scroll up bug
 	mov	$7,%bx				# normal mda/cga style page zero
 	mov	$0x0e,%ah			# teletype output al cp437
 	int	$0x10				# vidya service
-	pop	%bp				# preserves al
+#	pop	%bp				# preserves al
-	pop	%bx
+#	pop	%bx
-	ret
+	cmp	$'\r',%al			# don't clobber stuff
+	jne	.ret
+	mov	$'\n',%al
+	jmp	PutChar				# bx volatile, bp never used
+
+GetList:call	GetToken
+	cmpb	$')',%al
+	je	.retF
+	call	GetObject
+	push	%ax				# save 1
+	call	GetList
+	xchg	%ax,%si
+	pop	%di				# restore 1
+	jmp	Cons
 
 ////////////////////////////////////////////////////////////////////////////////
-.text
 
-PrintObject:
+Evlis:	cmp	$NIL,%di			# Evlis(m:di,a:dx):ax
-	test	$1,%di
-	jnz	1f
-	shr	%di
-	lea	STR(%di),%si
-	jmp	PrintString
-1:	push	%bx
-	mov	%di,%bx
-	mov	$40,%al
-	call	PutChar
-2:	and	$-2,%bx
-	mov	(%bx),%di
-	call	PrintObject
-	mov	2(%bx),%bx
-	test	%bx,%bx
-	jz	4f
-	test	$1,%bl
-	jz	3f
-	mov	$0x20,%al
-	call	PutChar
-	jmp	2b
-3:	mov	$kDot,%si
-	call	PrintString
-	mov	%bx,%di
-	call	PrintObject
-4:	pop	%bx
-	mov	$41,%al
-//	jmp	PutChar
-//	𝑠𝑙𝑖𝑑𝑒
-
-Arg1ds:	mov	%dx,%di
-	mov	%bp,%si
-//	𝑠𝑙𝑖𝑑𝑒
-Arg1:	call	Cadr
-	xchg	%ax,%di
-//	jmp	Eval
-//	𝑠𝑙𝑖𝑑𝑒
-
-Eval:	push	%bp
-	mov	%di,%dx
-	mov	%si,%bp
-0:	test	$1,%dl
-	jne	1f
-	xchg	%bp,%si
-	xchg	%dx,%di
-	pop	%bp
-	jmp	Assoc
-1:	mov	%dx,%bx
-	and	$-2,%bx
-	mov	(%bx),%ax
-	test	$1,%al
 	je	1f
-	mov	(%bx),%di
+	push	2(%di)				# save 1 Cdr(m)
-	and	$-2,%di
+	mov	(%di),%ax
-	cmpw	$ATOM_LAMBDA,(%di)
+	push	%dx				# save a
-	jne	EvalUndefined
-	mov	2(%bx),%si
-	mov	(%bx),%di
-	push	%bx
-	call	Cadr
-	xchg	%ax,%di
-	mov	%bp,%dx
-	call	Bind
-	xchg	%ax,%bp
-	pop	%bx
-	mov	(%bx),%bx
-	mov	%bx,%di
-	and	$-2,%di
-	mov	2(%di),%di
-	jmp	EvalCadrLoop
-1:	mov	(%bx),%ax
-	cmp	$ATOM_COND,%ax
-	je	EvalCond
-	jg	2f
-	cmp	$ATOM_ATOM,%ax
-	je	EvalAtom
-	jg	1f
-	test	%ax,%ax
-	je	EvalUndefined
-	cmp	$ATOM_QUOTE,%ax
-	jne	EvalCall
-//	𝑠𝑙𝑖𝑑𝑒
-EvalQuote:
-	xchg	%dx,%di
-	pop	%bp
-	jmp	Cadr
-1:	cmp	$ATOM_EQ,%ax
-	jne	EvalCall
-//	𝑠𝑙𝑖𝑑𝑒
-EvalEq:	push	%dx
-	mov	2(%bx),%bx
-	mov	%bx,%di
-	call	Cadr
-	xchg	%ax,%di
-	mov	%bp,%si
 	call	Eval
-	mov	%bp,%si
+	pop	%dx				# restore a
-	pop	%di				# restore
+	pop	%di				# restore 1
-	push	%ax				# save
+	push	%ax				# save 2
-	call	Arg1
+	call	Evlis
-	pop	%dx				# restore
+	xchg	%ax,%si
-	cmp	%dx,%ax
+	pop	%di				# restore 2
-	jmp	3f
+#	jmp	Cons
-EvalCdr:
+Cons:	xchg	%di,%ax
-	push	$2
+	mov	%fs,%di
-	jmp	EvalCarCdr
+	push	%di
-EvalUndefined:
+	stosw
-	mov	$UNDEFINED,%ax
+	xchg	%si,%ax
-9:	pop	%bp
+	stosw
+	mov	%di,%fs
+	pop	%ax
 	ret
-EvalCond:
+1:	xchg	%di,%ax
-	mov	2(%bx),%bx
+	ret
-	and	$-2,%bx
+
-	mov	(%bx),%di
+Pairlis:cmp	$NIL,%di			# Pairlis(x:di,y:si,a:dx):ax
-	and	$-2,%di
+	je	1f
+	push	2(%di)				# save 1 Cdr(x)
+	push	2(%si)				# save 2 Cdr(y)
 	mov	(%di),%di
-	mov	%bp,%si
+	mov	(%si),%si
-	push	%bx				# save
+	call	Cons				# preserves dx
+	pop	%si				# restore 2
+	pop	%di				# restore 1
+	push	%ax				# save 3
+	call	Pairlis
+	xchg	%ax,%si
+	pop	%di				# restore 3
+	jmp	Cons				# can be inlined here
+1:	xchg	%dx,%ax
+	ret
+
+Apply:	test	$1,%al				# Apply(fn:ax,x:si:a:dx):ax
+	jnz	.switch
+	xchg	%ax,%di				# di = fn
+.lambda:mov	2(%di),%di			# di = Cdr(fn)
+	push	%di				# save 1
+	mov	(%di),%di			# di = Cadr(fn)
+	call	Pairlis
+	xchg	%ax,%dx
+	pop	%di				# restore 1
+	jmp	.EvCadr
+.switch:cmp	$ATOM_EQ,%ax
+	ja	.dflt1
+	mov	(%si),%di			# di = Car(x)
+.ifCar:	cmp	$ATOM_CAR,%al
+	jne	.ifCdr
+	mov	(%di),%ax
+	ret
+.ifCdr:	cmp	$ATOM_CDR,%al
+	jne	.ifAtom
+	mov	2(%di),%ax
+	ret
+.ifAtom:cmp	$ATOM_ATOM,%al
+	jne	.ifCons
+	test	$1,%di
+	jnz	.retT
+.retF:	mov	$NIL,%ax			# ax = NIL
+	ret
+.ifCons:mov	2(%si),%si			# si = Cdr(x)
+	mov	(%si),%si			# si = Cadr(x)
+	cmp	$ATOM_CONS,%al
+	je	Cons
+.isEq:	cmp	%di,%si
+	jne	.retF
+.retT:	mov	$ATOM_T,%al			# ax = ATOM_T
+	ret
+.dflt1:	push	%si				# save x
+	push	%dx				# save a
 	call	Eval
-	pop	%bx				# restore
+	pop	%dx				# restore a
-	test	%ax,%ax
+	pop	%si				# restore x
-	je	EvalCond
+	jmp	Apply
-	mov	(%bx),%di
-	jmp	EvalCadrLoop
-2:	cmp	$ATOM_CDR,%ax
-	je	EvalCdr
-	cmp	$ATOM_CONS,%ax
-	je	EvalCons
-	cmp	$ATOM_CAR,%ax
-	jne	EvalCall
-//	𝑠𝑙𝑖𝑑𝑒
-EvalCar:
-	push	$0
-//	𝑠𝑙𝑖𝑑𝑒
-EvalCarCdr:
-	call	Arg1ds
-	and	$-2,%ax
-	xchg	%ax,%di
-	pop	%bx
-	mov	(%bx,%di),%ax
-	jmp	9b
-EvalCall:
-	push	2(%bx)
-	mov	(%bx),%di
-	mov	%bp,%si
-	call	Assoc
-	xchg	%ax,%di
-	pop	%si
-	call	Cons
-	jmp	1f
-EvalAtom:
-	call	Arg1ds
-	test	$1,%al
-3:	mov	$ATOM_T,%ax
-	je	9b
-	xor	%ax,%ax
-	jmp	9b
-EvalCadrLoop:
-	call	Cadr
-1:	xchg	%ax,%dx
-	jmp	0b
 
-////////////////////////////////////////////////////////////////////////////////
+Eval:	test	$1,%al				# Eval(e:ax,a:dx):ax
-.section .rodata,"a",@progbits
+	jnz	Assoc
+	xchg	%ax,%di				# di = e
+	mov	(%di),%ax			# ax = Car(e)
+	cmp	$ATOM_QUOTE,%ax			# maybe CONS
+	je	Cadr
+	mov	2(%di),%di			# di = Cdr(e)
+	cmp	$ATOM_COND,%ax
+	je	Evcon
+.Ldflt2:push	%ax				# save 2
+	call	Evlis				# preserves dx
+	xchg	%ax,%si
+	pop	%ax				# restore 2
+	jmp	Apply
 
-kDot:	.string	" . "
+Cadr:	mov	2(%di),%di			# contents of decrement register
-kCrlf:	.string	"\r\n"
+	mov	(%di),%ax			# contents of address register
-kSymbols:
+	ret
-	.string	"NIL"
+
-	.string	"*UNDEFINED"
+Evcon:	push	%di				# save c
-	.string	"T"
+	mov	(%di),%di			# di = Car(c)
-	.string	"QUOTE"
+	mov	(%di),%ax			# ax = Caar(c)
-	.string	"ATOM"
+	push	%dx				# save a
-	.string	"EQ"
+	call	Eval
-	.string	"COND"
+	pop	%dx				# restore a
-	.string	"CAR"
+	pop	%di				# restore c
-	.string	"CDR"
+	cmp	$NIL,%ax
-	.string	"CONS"
+	jne	2f
-	.string	"LAMBDA"
+	mov	2(%di),%di			# di = Cdr(c)
+	jmp	Evcon
+2:	mov	(%di),%di			# di = Car(c)
+.EvCadr:call	Cadr				# ax = Cadar(c)
+	jmp	Eval
+
+Assoc:	cmp	$NIL,%dx			# Assoc(x:ax,y:dx):ax
+	mov	%dx,%si
+	je	.retF
+	mov	(%si),%bx			# bx = Car(y)
+	mov	(%bx),%cx			# cx = Caar(y)
+	cmp	%cx,%ax
+	jne	1f
+	mov	2(%bx),%ax			# ax = Cdar(y)
+	ret
+1:	mov	2(%si),%dx			# dx = Cdr(y)
+	jmp	Assoc
+
+.type .sig,@object;
+.sig:
+.fill 510 - (. - _start), 1, 0xce
+.word 0xAA55