Update code

Makefile

@@ -17,7 +17,7 @@ all:	lisp				\
 clean:;	$(RM) lisp lisp.o bestline.o sectorlisp.o sectorlisp.bin sectorlisp.bin.dbg
 
 lisp: lisp.o bestline.o
-lisp.o: lisp.c bestline.h
+lisp.o: lisp.js bestline.h
 bestline.o: bestline.c bestline.h
 
 sectorlisp.o: sectorlisp.S
@@ -28,3 +28,6 @@ sectorlisp.bin.dbg: sectorlisp.o
 
 sectorlisp.bin: sectorlisp.bin.dbg
 	objcopy -S -O binary sectorlisp.bin.dbg sectorlisp.bin
+
+%.o: %.js
+	$(COMPILE.c) -xc $(OUTPUT_OPTION) $<

lisp.c

@@ -1,274 +0,0 @@
-/*-*- mode:c;indent-tabs-mode:nil;c-basic-offset:2;tab-width:8;coding:utf-8 -*-│
-│vi: set net ft=c ts=2 sts=2 sw=2 fenc=utf-8                                :vi│
-╞══════════════════════════════════════════════════════════════════════════════╡
-│ Copyright 2020 Justine Alexandra Roberts Tunney                              │
-│                                                                              │
-│ Permission to use, copy, modify, and/or distribute this software for         │
-│ any purpose with or without fee is hereby granted, provided that the         │
-│ above copyright notice and this permission notice appear in all copies.      │
-│                                                                              │
-│ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL                │
-│ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED                │
-│ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE             │
-│ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL         │
-│ DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR        │
-│ PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER               │
-│ TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR             │
-│ PERFORMANCE OF THIS SOFTWARE.                                                │
-╚─────────────────────────────────────────────────────────────────────────────*/
-#include "bestline.h"
-
-#ifndef __COSMOPOLITAN__
-#include <stdio.h>
-#include <locale.h>
-#include <setjmp.h>
-#endif
-
-#define var int
-#define function
-#define Null 0100000
-
-var M[Null * 2];
-jmp_buf undefined;
-
-var cx, dx, kT, kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote;
-
-function Set(i, x) {
-  M[Null + i] = x;
-}
-
-function Get(i) {
-  return M[Null + i];
-}
-
-function Hash(h, c) {
-  return h + c * 2;
-}
-
-function Intern(x, y, i) {
-  i &= Null - 1;
-  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;
-}
-
-function ReadAtom(h) {
-  var c = ReadChar();
-  if (c <= Ord(' ')) return ReadAtom(h);
-  return Intern(c, c > Ord(')') && dx > Ord(')') ?
-                ReadAtom(Hash(h, c)) : 0,
-                Hash(h, c) - Hash(0, Ord('N')));
-}
-
-function PrintAtom(x) {
-  do PrintChar(Get(x));
-  while ((x = Get(x + 1)));
-}
-
-function AddList(x) {
-  return Cons(x, ReadList());
-}
-
-function ReadList() {
-  var t = ReadAtom(0);
-  if (Get(t) == Ord(')')) return -0;
-  return AddList(ReadObject(t));
-}
-
-function ReadObject(t) {
-  if (Get(t) != Ord('(')) return t;
-  return ReadList();
-}
-
-function PrintList(x) {
-  PrintChar(Ord('('));
-  if (x < 0) {
-    PrintObject(Car(x));
-    while ((x = Cdr(x))) {
-      if (x < 0) {
-        PrintChar(Ord(' '));
-        PrintObject(Car(x));
-      } else {
-        PrintChar(0x2219);
-        PrintObject(x);
-        break;
-      }
-    }
-  }
-  PrintChar(Ord(')'));
-}
-
-function PrintObject(x) {
-  if (1./x < 0) {
-    PrintList(x);
-  } else {
-    PrintAtom(x);
-  }
-}
-
-function Print(e) {
-  PrintObject(e);
-  PrintChar(Ord('\n'));
-}
-
-function Read() {
-  return ReadObject(ReadAtom(0));
-}
-
-function Car(x) {
-  if (x < 0) {
-    return Get(x);
-  } else {
-    Throw(x);
-  }
-}
-
-function Cdr(x) {
-  if (x < 0) {
-    return Get(x + 1);
-  } else {
-    Throw(x);
-  }
-}
-
-function Cons(car, cdr) {
-  Set(--cx, cdr);
-  Set(--cx, car);
-  return cx;
-}
-
-function Gc(A, x) {
-  var C, B = cx;
-  x = Copy(x, A, A - B), C = cx;
-  while (C < B) Set(--A, Get(--B));
-  cx = A;
-  return x;
-}
-
-function Copy(x, m, k) {
-  return x < m ? Cons(Copy(Car(x), m, k),
-                      Copy(Cdr(x), m, k)) + k : x;
-}
-
-function Evlis(m, a) {
-  return m ? Cons(Eval(Car(m), a),
-                  Evlis(Cdr(m), a)) : m;
-}
-
-function Pairlis(x, y, a) {
-  return x ? Cons(Cons(Car(x), Car(y)),
-                  Pairlis(Cdr(x), Cdr(y), a)) : a;
-}
-
-function Assoc(x, y) {
-  if (y >= 0) Throw(x);
-  if (x == Car(Car(y))) return Cdr(Car(y));
-  return Assoc(x, Cdr(y));
-}
-
-function Evcon(c, a) {
-  if (Eval(Car(Car(c)), a)) {
-    return Eval(Car(Cdr(Car(c))), a);
-  } else if (Cdr(c)) {
-    return Evcon(Cdr(c), a);
-  } else {
-    Throw(c);
-  }
-}
-
-function Apply(f, x, a) {
-  if (f < 0)      return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(f)), x, a));
-  if (f == kEq)   return Car(x) == Car(Cdr(x)) ? kT : 0;
-  if (f == kCons) return Cons(Car(x), Car(Cdr(x)));
-  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);
-}
-
-function Eval(e, a) {
-  var A = cx;
-  if (!e) return 0;
-  if (e > 0) return Assoc(e, a);
-  if (Car(e) == kQuote) return Car(Cdr(e));
-  if (Car(e) == kCond) {
-    e = Evcon(Cdr(e), a);
-  } else {
-    e = Apply(Car(e), Evlis(Cdr(e), a), a);
-  }
-  return Gc(A, e);
-}
-
-function Lisp() {
-  var x, a;
-  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 = 0;;) {
-    if (!(x = setjmp(undefined))) {
-      x = Read();
-      x = Eval(x, a);
-      if (x < 0) {
-        a = Cons(x, a);
-      }
-    } else {
-      PrintChar(63);
-    }
-    Print(x);
-  }
-}
-
-Ord(c) {
-  return c;
-}
-
-Throw(x) {
-  longjmp(undefined, x);
-}
-
-PrintChar(b) {
-  fputwc(b, stdout);
-}
-
-ReadChar() {
-  int b, c, t;
-  static char *freeme;
-  static char *line = "NIL T CAR CDR ATOM COND CONS QUOTE EQ ";
-  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 = Ord('\n');
-    }
-    t = dx;
-    dx = c;
-    return t;
-  } else {
-    PrintChar(Ord('\n'));
-    exit(0);
-  }
-}
-
-main() {
-  setlocale(LC_ALL, "");
-  bestlineSetXlatCallback(bestlineUppercase);
-  Lisp();
-}

lisp.lisp

@@ -69,70 +69,69 @@ NIL
  (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))
-                 (LAMBDA (X)
-                   (COND ((ATOM X) X)
-                         (T (FF (CAR X)))))
-                 (QUOTE ((A) B C))))
-         NIL))
- (QUOTE (LAMBDA (X Y)
-          (COND ((EQ Y NIL) (QUOTE *UNDEFINED))
-                ((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 NIL) A)
-                ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
-                                 (PAIRLIS (CDR X) (CDR Y) A))))))
- (QUOTE (LAMBDA (M A)
-          (COND ((EQ M NIL) 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)
-             (COND ((EQ E NIL) E)
-                   ((EQ E (QUOTE T)) (QUOTE T))
-                   ((QUOTE T) (ASSOC E A))))
-            ((ATOM (CAR E))
-             (COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
-                   ((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
-                   ((EQ (CAR E) (QUOTE LAMBDA)) E)
-                   ((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))))))
+DEFINE ASSOC
+(LAMBDA (X Y)
+  (COND ((EQ Y NIL) (QUOTE *UNDEFINED))
+        ((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
+        ((QUOTE T) (ASSOC X (CDR Y)))))
 
-((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)))))
+DEFINE EVCON
+(LAMBDA (C A)
+  (COND ((EVAL (CAR (CAR C)) A)
+         (EVAL (CAR (CDR (CAR C))) A))
+        ((QUOTE T) (EVCON (CDR C) A))))
+
+DEFINE PAIRLIS
+(LAMBDA (X Y A)
+  (COND ((EQ X NIL) A)
+        ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
+                         (PAIRLIS (CDR X) (CDR Y) A)))))
+
+DEFINE EVLIS
+(LAMBDA (M A)
+  (COND ((EQ M NIL) M)
+        ((QUOTE T) (CONS (EVAL (CAR M) A)
+                         (EVLIS (CDR M) A)))))
+
+DEFINE APPLY
+(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)))))
+
+DEFINE EVAL
+(LAMBDA (E A)
+  (COND
+    ((ATOM E)
+     (COND ((EQ E NIL) E)
+           ((EQ E (QUOTE T)) (QUOTE T))
+           ((QUOTE T) (ASSOC E A))))
+    ((ATOM (CAR E))
+     (COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
+           ((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
+           ((EQ (CAR E) (QUOTE LAMBDA)) E)
+           ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
+    ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
+
+(EVAL (QUOTE ((LAMBDA (FF X)
+                (FF X))
+              (LAMBDA (X)
+                (COND ((ATOM X) X)
+                      (T (FF (CAR X)))))
+              (QUOTE ((A) B C))))
+      NIL)

sectorlisp.S

@@ -23,14 +23,13 @@
 // Compatible with the original hardware
 
 	.code16
-	.set	save,-2-2
-	.set	look,start+5-2
-	.globl	_start
+	.set	a,-2-2
+	.globl	_start				# LISP: VERITAS NUMQUAM PERIT
 _start:	.asciz	"NIL"				# dec %si ; dec %cx ; dec %sp
 kT:	.asciz	"T"				# add %dl,(%si) boot A:\ DL=0
-start:	mov	$0x8000,%sp			# this should be safe we hope
-	ljmp	$0x7c00>>4,$begin		# cs = 0x7c00 is boot address
+start:	ljmp	$0x7c00>>4,$begin		# cs = 0x7c00 is boot address
 	.asciz	""
+kDefine:.asciz	"DEFINE"
 kQuote:	.asciz	"QUOTE"
 kCond:	.asciz	"COND"
 kAtom:	.asciz	"ATOM"				# ordering matters
@@ -39,27 +38,38 @@ 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
-	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
-	mov	$2,%bx
-	mov	%sp,%cx
-main:	call	GetToken
+Read:	call	GetToken
 	call	GetObject
-	mov	%dx,save(%bx)
-	call	Eval
-	test	%ax,%ax
-	jns	Print
+	ret
+
+Define:	call	Read
 	push	%ax
+	call	Read
+	pop	%di
+	call	Cons
 	xchg	%ax,%di
-	xchg	%dx,%ax
+	xchg	%bp,%ax
 	call	Cons
-	xchg	%ax,%dx
-	pop	%ax
-Print:	xchg	%ax,%si
+	xchg	%ax,%bp
+	jmp	main
+
+begin:	mov	$0x8000,%sp
+	push	%cs
+	pop	%ds
+	push	%cs
+	pop	%es
+	push	%cs
+	pop	%ss
+	mov	$2,%bx
+	mov	%sp,%cx
+	xor	%bp,%bp
+main:	xor	%dx,%dx
+	call	Read
+	cmp	$kDefine,%ax
+	je	Define
+	mov	%bp,%dx
+	call	Eval
+Catch:	xchg	%ax,%si
 	call	PrintObject
 	mov	$'\r',%al
 	call	PutChar
@@ -67,26 +77,25 @@ Print:	xchg	%ax,%si
 
 GetToken:					# GetToken():al
 	mov	%cx,%di
-1:	mov	look(%bx),%al
+1:	mov	%dl,%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(%bx)
+	je	4f
 	cmp	$' ',%al
 	jbe	1b
 	cmp	$')',%al
 	jbe	3f
-	cmpb	$')',look(%bx)
+	cmp	$')',%dl
 	ja	1b
 3:	mov	%bh,(%di)			# bh is zero
 	xchg	%si,%ax
 	ret
+4:	dec	%di
+	jmp	2b
 
 .PrintList:
 	mov	$'(',%al
@@ -106,7 +115,7 @@ GetToken:					# GetToken():al
 .PutObject:					# .PutObject(c:al,x:si)
 .PrintString:					# nul-terminated in si
 	call	PutChar				# preserves si
-PrintObject:					# PrintObject(x:si)
+PrintObject:					# PrintObject(x:si,a:di)
 	test	%si,%si				# set sf=1 if cons
 	js	.PrintList			# jump if not cons
 .PrintAtom:
@@ -121,39 +130,42 @@ GetObject:					# called just after GetToken
 #	jmp	Intern
 
 Intern:	push	%cx				# Intern(cx,di): ax
-	mov	%di,%bp
-	sub	%cx,%bp
-	inc	%bp
+	sub	%cx,%di
+	inc	%di
+	push	%di
 	xor	%di,%di
-1:	pop	%si
+1:	pop	%cx
+	pop	%si
 	push	%si
-	mov	%bp,%cx
+	push	%cx
 	mov	%di,%ax
 	cmp	%bh,(%di)
-	je	2f
+	je	8f
 	rep cmpsb				# memcmp(di,si,cx)
 	je	9f
-	not	%cx
 	xor	%ax,%ax
-	repne scasb				# memchr(di,al,cx)
+2:	scasb
+	jne	2b
 	jmp	1b
-2:	rep movsb				# memcpy(di,si,cx)
+8:	rep movsb				# memcpy(di,si,cx)
 9:	pop	%cx
-3:	ret
+	pop	%cx
+	ret
 
 Undef:	push	%ax
 	mov	$'?',%al
 	call	PutChar
 	pop	%ax
-	mov	save(%bx),%dx
-	jmp	Print
+	jmp	Catch
 
 GetChar:xor	%ax,%ax				# GetChar→al:dl
 	int	$0x16				# get keystroke
 PutChar:mov	$0x0e,%ah			# prints CP-437
+	push	%bp				# scroll up bug
 	int	$0x10				# vidya service
+	pop	%bp				# scroll up bug
 	cmp	$'\r',%al			# don't clobber
-	jne	3b				# look xchg ret
+	jne	1f				# look xchg ret
 	mov	$'\n',%al
 	jmp	PutChar
 
@@ -213,7 +225,12 @@ Assoc:	mov	%dx,%si				# Assoc(x:ax,y:dx):ax
 	mov	(%bx,%si),%si
 	scasw
 	jne	1b
-	jmp	Car
+	.byte	0xf6
+Cadr:	mov	(%bx,%di),%di			# contents of decrement register
+	.byte	0x3C				# cmp §scasw,%al (nop next byte)
+Cdr:	scasw					# increments our data index by 2
+Car:	mov	(%di),%ax			# contents of address register!!
+2:	ret
 
 GetList:call	GetToken
 	cmp	$')',%al
@@ -255,17 +272,11 @@ Apply:	test	%ax,%ax				# Apply(fn:ax,x:si:a:dx):ax
 	mov	(%bx,%si),%si			# si = Cdr(x)
 	lodsw					# si = Cadr(x)
 	je	Cons
-.isEq:	cmp	%di,%ax				# we know for certain it's eq
+.isEq:	xor	%di,%ax				# we know for certain it's eq
 	jne	.retF
-.retT:	mov	$kT,%ax
+.retT:	mov	$kT,%al
 	ret
 
-Cadr:	mov	(%bx,%di),%di			# contents of decrement register
-	.byte	0x3C				# cmp §scasw,%al (nop next byte)
-Cdr:	scasw					# increments our data index by 2
-Car:	mov	(%di),%ax			# contents of address register!!
-2:	ret
-
 1:	mov	(%bx,%di),%di			# di = Cdr(c)
 Evcon:	push	%di				# save c
 	mov	(%di),%si			# di = Car(c)
@@ -309,6 +320,7 @@ Eval:	test	%ax,%ax				# Eval(e:ax,a:dx):ax
 .sig:	.fill	510 - (. - _start), 1, 0xce
 	.word	0xAA55
 	.type	.sig,@object
+	.type	kDefine,@object
 	.type	kQuote,@object
 	.type	kCond,@object
 	.type	kAtom,@object