From 3b26982d9c06cd43760604b6364df197a782333e Mon Sep 17 00:00:00 2001 From: Alain Greppin Date: Tue, 28 Sep 2021 12:13:39 +0200 Subject: [PATCH] Eval based on LISP 1.5 manual, 509 bytes --- Makefile | 12 +- lisp.c | 159 ++++++------- lisp.h | 2 +- sectorlisp.S | 653 +++++++++++++++++++++------------------------------ 4 files changed, 351 insertions(+), 475 deletions(-) diff --git a/Makefile b/Makefile index 25ba5df..51e1f6a 100644 --- a/Makefile +++ b/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 $@ $< diff --git a/lisp.c b/lisp.c index 8d999fe..8f18311 100644 --- a/lisp.c +++ b/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 CONS 1 +#define ATOM 1 +#define CONS 0 -#define NIL 0 -#define UNDEFINED 8 -#define ATOM_T 30 -#define ATOM_QUOTE 34 -#define ATOM_ATOM 46 -#define ATOM_EQ 56 -#define ATOM_COND 62 -#define ATOM_CAR 72 -#define ATOM_CDR 80 -#define ATOM_CONS 88 -#define ATOM_LAMBDA 98 +#define NIL (ATOM | 0) +#define UNDEFINED (ATOM | 8) +#define ATOM_T (ATOM | 30) +#define ATOM_QUOTE (ATOM | 34) +#define ATOM_COND (ATOM | 46) +#define ATOM_ATOM (ATOM | 56) +#define ATOM_CAR (ATOM | 66) +#define ATOM_CDR (ATOM | 74) +#define ATOM_CONS (ATOM | 82) +#define ATOM_EQ (ATOM | 92) +#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 - return v ? Cons(Cons(Car(v), Eval(Car(a), e)), Bind(Cdr(v), Cdr(a), e)) : e; +static WORD Assoc(long x, long a) { + return a != NIL ? Caar(a) == x ? Cdar(a) : Assoc(x, Cdr(a)) : NIL; } -static WORD Assoc(long x, long y) { - return y ? Eq(Caar(y), x) ? Cdar(y) : Assoc(x, Cdr(y)) : NIL; +static WORD Pairlis(WORD x, WORD y, WORD a) { + 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) { - if (Atom(e)) { - return Assoc(e, a); - } else if (Atom(Car(e))) { - switch (Car(e)) { - case NIL: - return UNDEFINED; - case ATOM_QUOTE: - return Cadr(e); - case ATOM_ATOM: - return Atom(Arg1(e, a)); - case ATOM_EQ: - return Eq(Arg1(e, a), Arg2(e, a)); - case ATOM_COND: - return Evcon(Cdr(e), a); - case ATOM_CAR: - return Car(Arg1(e, a)); - case ATOM_CDR: - return Cdr(Arg1(e, a)); - case ATOM_CONS: - return Cons(Arg1(e, a), Arg2(e, a)); - default: - return Eval(Cons(Assoc(Car(e), a), Cdr(e)), a); +static WORD Evlis(WORD m, WORD a) { + if (m == NIL) + return NIL; + WORD di = Eval(Car(m), a); + WORD si = Evlis(Cdr(m), a); + return Cons(di, si); +} + +static WORD Apply(WORD fn, WORD x, WORD a) { + if (ISATOM(fn)) { + switch (fn) { + case NIL: + return UNDEFINED; + case ATOM_CAR: + return Caar(x); + case ATOM_CDR: + return Cdar(x); + case ATOM_ATOM: + return ISATOM(Car(x)) ? ATOM_T : NIL; + case ATOM_CONS: + return Cons(Car(x), Cadr(x)); + case ATOM_EQ: + 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) { - WORD r; -#if TRACE - PrintString("->"); - Print(e); - PrintString(" "); - Print(a); -#endif - e = Evaluate(e, a); -#if TRACE - PrintString("<-"); - Print(e); -#endif - return e; +static WORD Eval(WORD e, WORD a) { + if (ISATOM(e)) + return Assoc(e, a); + + WORD ax = Car(e); + if (ISATOM(ax)) { + if (ax == ATOM_QUOTE) + return Cadr(e); + if (ax == ATOM_COND) + return Evcon(Cdr(e), a); + if (ax == ATOM_LAMBDA) + return e; + } + + return Apply(ax, Evlis(Cdr(e), a), a); } /*───────────────────────────────────────────────────────────────────────────│─╗ diff --git a/lisp.h b/lisp.h index f7d3dde..3dd6e84 100644 --- a/lisp.h +++ b/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; \ }) diff --git a/sectorlisp.S b/sectorlisp.S index b00acd0..b7342c3 100644 --- a/sectorlisp.S +++ b/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 -// 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 +// LISP meta-circular evaluator in a MBR -#define NIL 0 -#define UNDEFINED 8 -#define ATOM_T 30 -#define ATOM_QUOTE 34 -#define ATOM_ATOM 46 -#define ATOM_EQ 56 -#define ATOM_COND 62 -#define ATOM_CAR 72 -#define ATOM_CDR 80 -#define ATOM_CONS 88 -#define ATOM_LAMBDA 98 +.set NIL, 1 +.set ATOM_T, 9 +.set ATOM_QUOTE, 13 +.set ATOM_COND, 25 +.set ATOM_ATOM, 35 +.set ATOM_CAR, 45 +.set ATOM_CDR, 53 +.set ATOM_CONS, 61 +.set ATOM_EQ, 71 -#define STR 0x4186 +.set q.token, 0x4000 +.set q.str, 0x4080 +.set boot, 0x7c00 //////////////////////////////////////////////////////////////////////////////// -.section .start,"ax",@progbits -.globl main +.section .text,"ax",@progbits +.globl _start .code16 -main: mov $q.syntax,%bx - mov $32,%al - mov %al,32(%bx) - mov %al,13(%bx) - mov %al,10(%bx) - movw $10536,40(%bx) - movb $46,46(%bx) - mov $STR,%di +_start: jmp .init # some bios scan for short jump +.type kSymbols,@object; +kSymbols: + .ascii "NIL\0T\0QUOTE\0COND\0ATOM\0CAR\0CDR\0CONS\0EQ" + +.type .init,@function +.init: ljmp $0x600>>4,$_begin # end of bios data roundup page +_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 - mov %ax,q.look +0: mov $'\n',%dl call GetToken call GetObject - xchg %ax,%di - mov q.globals,%si + mov $NIL,%dx call Eval - xchg %ax,%di call PrintObject - mov $kCrlf,%si - 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 + mov $'\r',%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 -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 +GetToken: # GetToken():al, dl is q.look mov $q.token,%di -// 𝑠𝑙𝑖𝑑𝑒 - -Intern: mov %di,%bx - mov $STR,%si -0: mov %bx,%di - push %si - lodsb - test %al,%al - jne 2f - pop %di - push %di - mov %bx,%si -4: lodsb +1: mov %dl,%al + cmp $' ',%al + jbe 2f stosb - test %al,%al - jnz 4b -6: pop %ax - sub $STR,%ax - shl %ax - 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 + xchg %ax,%cx +2: call GetChar # bh = 0 after PutChar + xchg %ax,%dx # dl = q.look + cmp $' ',%al + jbe 1b cmp $')',%al - je 2f - cmp $'.',%al - je 1f - call GetObject - push %ax # save - call GetList - xchg %ax,%si - pop %di # restore - jmp Cons -1: call GetToken - jmp GetObject -2: xor %ax,%ax + jbe 3f + cmp $')',%dl + ja 1b +3: movb %bh,(%di) + xchg %cx,%ax ret -EvalCons: - push %dx # save - mov 2(%bx),%bx - mov %bx,%di - call Cadr - xchg %ax,%di - mov %bp,%si - call Eval - mov %bp,%si - pop %di # restore - push %ax # save - call Arg1 - pop %si # restore - xchg %ax,%di - pop %bp -// jmp Cons -// 𝑠𝑙𝑖𝑑𝑒 - -Cons: mov $q.index,%bx - mov (%bx),%ax - addw $2,(%bx) - shl %ax - mov %ax,%bx - 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 +GetObject: # called just after GetToken + cmpb $'(',%al + je GetList + mov $q.token,%si +.Intern: + mov %si,%bx # save s + mov $q.str,%di + xor %al,%al +0: mov $-1,%cl + push %di # save 1 +1: cmpsb + jne 2f + cmp -1(%di),%al + jne 1b + jmp 4f +2: pop %si # drop 1 + mov %bx,%si # restore s + repne scasb + cmp (%di),%al + jne 0b + push %di # StpCpy +3: lodsb + stosb test %al,%al - je 1f - call PutChar - jmp 0b -1: ret + jnz 3b +4: pop %ax # restore 1 + add $-q.str,%ax # stc + adc %ax,%ax # ax = 2 * ax + carry +.ret: ret -PutChar:push %bx # don't clobber bp,bx,di,si,cx - push %bp # original ibm pc scroll up bug +PrintObject: # PrintObject(x:ax) + 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 %bx - ret +# pop %bp # preserves al +# pop %bx + 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: - 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 +Evlis: cmp $NIL,%di # Evlis(m:di,a:dx):ax je 1f - mov (%bx),%di - and $-2,%di - cmpw $ATOM_LAMBDA,(%di) - 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 + push 2(%di) # save 1 Cdr(m) + mov (%di),%ax + push %dx # save a call Eval - mov %bp,%si - pop %di # restore - push %ax # save - call Arg1 - pop %dx # restore - cmp %dx,%ax - jmp 3f -EvalCdr: - push $2 - jmp EvalCarCdr -EvalUndefined: - mov $UNDEFINED,%ax -9: pop %bp + pop %dx # restore a + pop %di # restore 1 + push %ax # save 2 + call Evlis + xchg %ax,%si + pop %di # restore 2 +# jmp Cons +Cons: xchg %di,%ax + mov %fs,%di + push %di + stosw + xchg %si,%ax + stosw + mov %di,%fs + pop %ax ret -EvalCond: - mov 2(%bx),%bx - and $-2,%bx - mov (%bx),%di - and $-2,%di +1: xchg %di,%ax + ret + +Pairlis:cmp $NIL,%di # Pairlis(x:di,y:si,a:dx):ax + je 1f + push 2(%di) # save 1 Cdr(x) + push 2(%si) # save 2 Cdr(y) mov (%di),%di - mov %bp,%si - push %bx # save + mov (%si),%si + 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 - test %ax,%ax - je EvalCond - 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 + pop %dx # restore a + pop %si # restore x + jmp Apply -//////////////////////////////////////////////////////////////////////////////// -.section .rodata,"a",@progbits +Eval: test $1,%al # Eval(e:ax,a:dx):ax + 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 " . " -kCrlf: .string "\r\n" -kSymbols: - .string "NIL" - .string "*UNDEFINED" - .string "T" - .string "QUOTE" - .string "ATOM" - .string "EQ" - .string "COND" - .string "CAR" - .string "CDR" - .string "CONS" - .string "LAMBDA" +Cadr: mov 2(%di),%di # contents of decrement register + mov (%di),%ax # contents of address register + ret + +Evcon: push %di # save c + mov (%di),%di # di = Car(c) + mov (%di),%ax # ax = Caar(c) + push %dx # save a + call Eval + pop %dx # restore a + pop %di # restore c + cmp $NIL,%ax + jne 2f + 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