diff --git a/Makefile b/Makefile index 500b434..4080d03 100644 --- a/Makefile +++ b/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) $< diff --git a/lisp.c b/lisp.c deleted file mode 100644 index 3fbdd95..0000000 --- a/lisp.c +++ /dev/null @@ -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 -#include -#include -#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(); -} diff --git a/lisp.lisp b/lisp.lisp index 2554631..ebe8c72 100644 --- a/lisp.lisp +++ b/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) diff --git a/sectorlisp.S b/sectorlisp.S index a604f19..ca497c6 100644 --- a/sectorlisp.S +++ b/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 +Read: call GetToken + call GetObject + ret + +Define: call Read + push %ax + call Read + pop %di + call Cons + xchg %ax,%di + xchg %bp,%ax + call Cons + 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 -main: call GetToken - call GetObject - mov %dx,save(%bx) + xor %bp,%bp +main: xor %dx,%dx + call Read + cmp $kDefine,%ax + je Define + mov %bp,%dx call Eval - test %ax,%ax - jns Print - push %ax - xchg %ax,%di - xchg %dx,%ax - call Cons - xchg %ax,%dx - pop %ax -Print: xchg %ax,%si +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