diff --git a/.gitignore b/.gitignore index e69d341..6979610 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ /lisp +/hash /*.o /*.bin /*.bin.dbg diff --git a/Makefile b/Makefile index d53571a..c1d245f 100644 --- a/Makefile +++ b/Makefile @@ -1,31 +1,57 @@ -CFLAGS = -w -Os -LDFLAGS = -s +CFLAGS ?= -w -O CLEANFILES = \ lisp \ lisp.o \ + hash \ bestline.o \ sectorlisp.o \ sectorlisp.bin \ - sectorlisp.bin.dbg + sectorlisp.bin.dbg \ + brainfuck.o \ + brainfuck.bin \ + brainfuck.bin.dbg .PHONY: all all: lisp \ + hash \ sectorlisp.bin \ - sectorlisp.bin.dbg + sectorlisp.bin.dbg \ + brainfuck.bin \ + brainfuck.bin.dbg .PHONY: clean -clean:; $(RM) lisp lisp.o bestline.o sectorlisp.o sectorlisp.bin sectorlisp.bin.dbg +clean:; $(RM) $(CLEANFILES) 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 - $(AS) -g -o $@ $< + $(AS) $(ASFLAGS) -o $@ $< -sectorlisp.bin.dbg: sectorlisp.o - $(LD) -oformat:binary -Ttext=0x0000 -o $@ $< +sectorlisp.bin.dbg: sectorlisp.o sectorlisp.lds + $(LD) -z max-page-size=512 $(LDFLAGS) -T sectorlisp.lds -o $@ $< sectorlisp.bin: sectorlisp.bin.dbg objcopy -S -O binary sectorlisp.bin.dbg sectorlisp.bin + +brainfuck.o: brainfuck.S + $(AS) $(ASFLAGS) -o $@ $< + +brainfuck.bin.dbg: brainfuck.o brainfuck.lds + $(LD) -z max-page-size=512 $(LDFLAGS) -T brainfuck.lds -o $@ $< + +brainfuck.bin: brainfuck.bin.dbg + objcopy -S -O binary brainfuck.bin.dbg brainfuck.bin + +.PHONY: check +check: + ./checkjumps.sh + gcc -w -c -o /dev/null -xc lisp.js + clang -w -c -o /dev/null -xc lisp.js + gcc -Wall -Werror -c -o /dev/null hash.c + clang -Wall -Werror -c -o /dev/null hash.c + +%.o: %.js + $(COMPILE.c) -xc $(OUTPUT_OPTION) $< diff --git a/bestline.c b/bestline.c index 23ffd64..30ce69b 100644 --- a/bestline.c +++ b/bestline.c @@ -143,6 +143,7 @@ #include #include #include +#include #include #include #include @@ -1799,7 +1800,6 @@ static int enableRawMode(int fd) { raw = orig_termios; raw.c_iflag &= ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON); raw.c_lflag &= ~(ECHO | ICANON | IEXTEN | ISIG); - raw.c_oflag &= ~OPOST; raw.c_iflag |= IUTF8; raw.c_cflag |= CS8; raw.c_cc[VMIN] = 1; @@ -2464,6 +2464,7 @@ static void bestlineRefreshLineForce(struct bestlineState *l) { static void bestlineEditInsert(struct bestlineState *l, const char *p, size_t n) { if (!bestlineGrow(l, l->len + n + 1)) return; + if (*p == ' ' && l->pos && l->buf[l->pos - 1] == ' ') return; memmove(l->buf + l->pos + n, l->buf + l->pos, l->len - l->pos); memcpy(l->buf + l->pos, p, n); l->pos += n; @@ -3010,6 +3011,16 @@ static void bestlineEditSlurp(struct bestlineState *l) { } static void bestlineEditRaise(struct bestlineState *l) { + (void)l; +} + +static char IsBalanced(struct bestlineState *l) { + int i, d; + for (d = i = 0; i < l->len; ++i) { + if (l->buf[i] == '(') ++d; + if (l->buf[i] == ')') --d; + } + return d <= 0; } /** @@ -3112,14 +3123,18 @@ static ssize_t bestlineEdit(int stdin_fd, int stdout_fd, const char *prompt, } break; case '\r': - l.final = 1; - free(history[--historylen]); - history[historylen] = 0; - bestlineEditEnd(&l); - bestlineRefreshLineForce(&l); - if ((p = (char *)realloc(l.buf, l.len + 1))) l.buf = p; - *obuf = l.buf; - return l.len; + if (IsBalanced(&l)) { + l.final = 1; + free(history[--historylen]); + history[historylen] = 0; + bestlineEditEnd(&l); + bestlineRefreshLineForce(&l); + if ((p = (char *)realloc(l.buf, l.len + 1))) l.buf = p; + *obuf = l.buf; + return l.len; + } else { + break; + } case 033: if (nread < 2) break; switch (seq[1]) { diff --git a/brainfuck.S b/brainfuck.S new file mode 100644 index 0000000..19bf532 --- /dev/null +++ b/brainfuck.S @@ -0,0 +1,92 @@ +/*-*- mode:unix-assembly; indent-tabs-mode:t; tab-width:8; coding:utf-8 -*-│ +│vi: set et ft=asm ts=8 tw=8 fenc=utf-8 :vi│ +╞══════════════════════════════════════════════════════════════════════════════╡ +│ Copyright 2021 Justine Alexandra Roberts Tunney │ +│ Some size optimisations by Peter Ferrie │ +│ │ +│ 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. │ +╚─────────────────────────────────────────────────────────────────────────────*/ + +// compliant brainf*#k in 99 bytes +// ++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++ +// ..+++.>>.<-.<.+++.------.--------.>>+.>++.[]$ + + .code16 + .globl _start +_start: mov $0x7e00,%di + push %di +Load: xor %ax,%ax + int $0x16 + stosb + cmp $'[',%al + je Lsb + cmp $']',%al + je Rsb + cmp $'$',%al + jne Load + pop %si +Brain: lodsb + cbw + mov $0x0e,%bh + mov (%di),%bl + sub $'+',%al + jz Inc # + 43 + dec %ax + jz Get # , 44 + dec %ax + jz Dec # - 45 + dec %ax + jz Put # . 46 + cmp $'>'-'.',%al + je Right # > 60 14 + cmp $'<'-'.',%al + je Left # < 62 16 + cmp $']'-'.',%al + je Loop # ] 91 45 + cmp $'['-'.',%al + jne Brain # [ 93 47 +Do: cmp $1,%bl + sbb %bl,%bl +Loop: test %bl,%bl + lodsw + jz Brain + xchg %ax,%si + inc %si + inc %si + .byte 0x80 +Inc: incb (%di) + jmp Brain +Get: int $0x16 + stosb +Left: dec %di + .byte 0x80 +Dec: decb (%di) + .byte 0x3C +Right: inc %di + .byte 0x84 +Put: xchg %bx,%ax + int $0x10 + jmp Brain +Rsb: pop %si + mov %di,(%si) + xchg %si,%ax + .byte 0x3c +Lsb: push %di + stosw + jmp Load + +Sig: .fill 510 - (. - _start), 1, 0xce + .word 0xAA55 + .type Sig,@object + diff --git a/brainfuck.lds b/brainfuck.lds new file mode 100644 index 0000000..08650ca --- /dev/null +++ b/brainfuck.lds @@ -0,0 +1,12 @@ +ENTRY(_start) + +SECTIONS { + . = 0x7c00; + .text : { + *(.text) + *(.rodata .rodata.*) + } + /DISCARD/ : { + *(.*) + } +} diff --git a/checkjumps.sh b/checkjumps.sh new file mode 100755 index 0000000..fe888ee --- /dev/null +++ b/checkjumps.sh @@ -0,0 +1,8 @@ +#!/bin/sh +if objdump -Cwd -Mi8086 sectorlisp.o | cat -n | + grep '[[:xdigit:]][[:xdigit:]] [[:xdigit:]][[:xdigit:]] [[:xdigit:]][[:xdigit:]][[:space:]]*j'; then + echo need to shuffle code around >&2 + exit 1 +else + echo all jump encodings are tiny >&2 +fi diff --git a/hash.c b/hash.c new file mode 100644 index 0000000..e41d393 --- /dev/null +++ b/hash.c @@ -0,0 +1,86 @@ +#ifndef __COSMOPOLITAN__ +#include +#include +#endif + +#define word unsigned long + +static word Null; + +static inline int IsTwoPow(word x) { + return !(x & (x - 1)); +} + +static inline int Bsr(word x) { +#if defined(__GNUC__) && !defined(__STRICT_ANSI__) + return __builtin_clzll(x) ^ 63; +#else + static const char kDebruijn[64] = { + 0, 47, 1, 56, 48, 27, 2, 60, 57, 49, 41, 37, 28, 16, 3, 61, + 54, 58, 35, 52, 50, 42, 21, 44, 38, 32, 29, 23, 17, 11, 4, 62, + 46, 55, 26, 59, 40, 36, 15, 53, 34, 51, 20, 43, 31, 22, 10, 45, + 25, 39, 14, 33, 19, 30, 9, 24, 13, 18, 8, 12, 7, 6, 5, 63, + }; + x |= x >> 1; + x |= x >> 2; + x |= x >> 4; + x |= x >> 8; + x |= x >> 16; + x |= x >> 32; + return kDebruijn[(x * 0x03f79d71b4cb0a89) >> 58]; +#endif +} + +static word Hash(word h, word x, word a, word b, word c) { + return (((h + x) * a + b) >> c) & (Null / 2 - 1); +} + +static word Ok(word a, word b, word c) { + return Hash(Hash(Hash(0, 'L', a, b, c), 'I', a, b, c), 'N', a, b, c) == 0 && + Hash(0, 'T', a, b, c) == 1 && + Hash(0, 'T', a, b, c) != Hash(0, 'U', a, b, c); +} + +static int Usage(const char *prog) { + fprintf(stderr, "Usage: %s NULL\n", prog); + fprintf(stderr, "Finds magic numbers for SectorLISP Hash()\n"); + return 1; +} + +int main(int argc, char *argv[]) { + word a, b, c; + if (argc > 1) { + Null = strtoul(argv[1], 0, 0); + if (Null < 64) { + fprintf(stderr, "Error: Null is too small\n"); + return Usage(argv[0]); + } + if (!IsTwoPow(Null)) { + fprintf(stderr, "Error: Null must be two power\n"); + return Usage(argv[0]); + } + } else { + /* Null = 040000; */ + Null = 64; + } + for (;; Null <<= 1) { + printf("\n"); + printf("#define Null %#lo\n", Null); + fflush(stdout); + for (a = 0; a < Null / 2; ++a) { + for (c = 0; c <= Bsr(Null / 2) / 2; ++c) { + /* for (b = 0; b < Null; ++b) { */ + /* solve 1 = ('T' * a + b) / 2^c for b */ + b = (((1<> %lu) & (Null/2-1);\n", a, b, c); + } else { + printf("return ((h + x) * %lu + %lu) & (Null/2-1);\n", a, b); + } + } + } + } + } + return 0; +} diff --git a/lisp.c b/lisp.c deleted file mode 100644 index 0f9ab1e..0000000 --- a/lisp.c +++ /dev/null @@ -1,246 +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 -#include -#include -#include -#endif - -/*───────────────────────────────────────────────────────────────────────────│─╗ -│ The LISP Challenge § LISP Machine ─╬─│┼ -╚────────────────────────────────────────────────────────────────────────────│*/ - -#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 M (RAM + sizeof(RAM) / sizeof(RAM[0]) / 2) -#define S "NIL\0T\0QUOTE\0COND\0ATOM\0CAR\0CDR\0CONS\0EQ" - -int cx; /* stores negative memory use */ -int dx; /* stores lookahead character */ -int RAM[0100000]; /* your own ibm7090 */ - -Intern() { - int i, j, x; - for (i = 0; (x = M[i++]);) { - for (j = 0;; ++j) { - if (x != RAM[j]) break; - if (!x) return i - j - 1; - x = M[i++]; - } - while (x) - x = M[i++]; - } - j = 0; - x = --i; - while ((M[i++] = RAM[j++])); - return x; -} - -GetChar() { - int c, t; - static char *l, *p; - if (l || (l = p = bestlineWithHistory("* ", "sectorlisp"))) { - if (*p) { - c = *p++ & 255; - } else { - free(l); - l = p = 0; - c = '\n'; - } - t = dx; - dx = c; - return t; - } else { - PrintChar('\n'); - exit(0); - } -} - -PrintChar(b) { - fputwc(b, stdout); -} - -GetToken() { - int c, i = 0; - do if ((c = GetChar()) > ' ') RAM[i++] = c; - while (c <= ' ' || (c > ')' && dx > ')')); - RAM[i] = 0; - return c; -} - -AddList(x) { - return Cons(x, GetList()); -} - -GetList() { - int c = GetToken(); - if (c == ')') return 0; - return AddList(GetObject(c)); -} - -GetObject(c) { - if (c == '(') return GetList(); - return Intern(); -} - -Read() { - return GetObject(GetToken()); -} - -PrintAtom(x) { - int c; - for (;;) { - if (!(c = M[x++])) break; - PrintChar(c); - } -} - -PrintList(x) { - PrintChar('('); - 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) { - PrintList(x); - } else { - PrintAtom(x); - } -} - -Print(e) { - PrintObject(e); - PrintChar('\n'); -} - -/*───────────────────────────────────────────────────────────────────────────│─╗ -│ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator ─╬─│┼ -╚────────────────────────────────────────────────────────────────────────────│*/ - -Car(x) { - return M[x]; -} - -Cdr(x) { - return M[x + 1]; -} - -Cons(car, cdr) { - M[--cx] = cdr; - M[--cx] = car; - return cx; -} - -Gc(x, m, k) { - return x < m ? Cons(Gc(Car(x), m, k), - Gc(Cdr(x), m, k)) + k : x; -} - -Evlis(m, a) { - return m ? Cons(Eval(Car(m), a), - Evlis(Cdr(m), a)) : 0; -} - -Pairlis(x, y, a) { - return x ? Cons(Cons(Car(x), Car(y)), - Pairlis(Cdr(x), Cdr(y), a)) : a; -} - -Assoc(x, y) { - if (!y) return 0; - if (x == Car(Car(y))) return Cdr(Car(y)); - return Assoc(x, Cdr(y)); -} - -Evcon(c, a) { - if (Eval(Car(Car(c)), a)) { - return Eval(Car(Cdr(Car(c))), a); - } else { - return Evcon(Cdr(c), a); - } -} - -Apply(f, x, a) { - if (f < 0) return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(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))); - if (f == kAtom) return Car(x) < 0 ? 0 : kT; - if (f == kCar) return Car(Car(x)); - if (f == kCdr) return Cdr(Car(x)); -} - -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); - C = cx; - while (C < B) - M[--A] = M[--B]; - cx = A; - return e; -} - -/*───────────────────────────────────────────────────────────────────────────│─╗ -│ The LISP Challenge § User Interface ─╬─│┼ -╚────────────────────────────────────────────────────────────────────────────│*/ - -main() { - int i; - setlocale(LC_ALL, ""); - bestlineSetXlatCallback(bestlineUppercase); - for(i = 0; i < sizeof(S); ++i) M[i] = S[i]; - for (;;) { - cx = 0; - Print(Eval(Read(), 0)); - } -} diff --git a/lisp.js b/lisp.js new file mode 100755 index 0000000..afe28ce --- /dev/null +++ b/lisp.js @@ -0,0 +1,772 @@ +/*bin/echo '#-*- indent-tabs-mode:nil;js-indent-level:2;coding:utf-8 -*- + + SectorLISP v2.o (ISC License) + Copyright 2021 Justine Tunney + + This file implements SectorLISP as a C / JavaScript polyglot and + includes friendly branch features such as the undefined behavior + exceptions handlers, optimized interning, and global definitions + +(aset standard-display-table #x2029 [?¶]) ;; emacs protip '>/dev/null +curl -so bestline.c -z bestline.c https://justine.lol/sectorlisp2/bestline.c +curl -so bestline.h -z bestline.h https://justine.lol/sectorlisp2/bestline.h +[ lisp.js -nt lisp ] && cc -w -xc lisp.js bestline.c -o lisp +exec ./lisp "$@" +exit +*/ + +//
` +#include "bestline.h" +#ifndef __COSMOPOLITAN__ +#include +#include +#include +#include +#endif +#define var int +#define function +#define Null 16384 +var M[Null * 2]; +var (*funcall)(); +jmp_buf undefined; +//` + +var ax, cx, dx, depth, panic, fail; +var cHeap, cGets, cSets, cReads, cPrints; +var kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote, kDefine; + +function Get(i) { + ++cGets; + return M[Null + i]; +} + +function Set(i, x) { + ++cSets; + M[Null + i] = x; +} + +function Car(x) { + if (x > 0) Throw(List(kCar, x)); + return x ? Get(x) : +0; +} + +function Cdr(x) { + if (x > 0) Throw(List(kCdr, x)); + return x ? Get(x + 1) : -0; +} + +function Cons(car, cdr) { + if (cx == -Null) Throw(kCons); + Set(--cx, cdr); + Set(--cx, car); + if (cx < cHeap) cHeap = cx; + return cx; +} + +function Probe(h, p) { + return (h + p * p) & (Null / 2 - 1); +} + +function Hash(h, x) { + return (((h + x) * 3083 + 3191) >> 4) & (Null / 2 - 1); +} + +function Intern(x, y, h, p) { + if (x == Get(h) && y == Get(h + Null / 2)) return h; + if (Get(h)) return Intern(x, y, Probe(h, p), p + 1); + Set(h, x); + Set(h + Null/2, y); + return h; +} + +function ReadAtom() { + var x, y; + ax = y = 0; + do x = ReadChar(); + while (x <= Ord(' ')); + if (x > Ord(')') && dx > Ord(')')) y = ReadAtom(); + return Intern(x, y, (ax = Hash(x, ax)), 1); +} + +function ReadList() { + var x, y; + if ((x = Read()) > 0) { + if (Get(x) == Ord(')')) return -0; + if (Get(x) == Ord('.') && !Get(x + 1)) { + x = Read(); + y = ReadList(); + if (!y) { + return x; + } else { + Throw(y); + } + } + } + return Cons(x, ReadList()); +} + +function Read() { + var t; + ++cReads; + t = ReadAtom(); + if (Get(t) != Ord('(')) return t; + return ReadList(); +} + +function PrintAtom(x) { + do PrintChar(Get(x)); + while ((x = Get(x + Null / 2))); +} + +function PrintList(x) { + PrintChar(Ord('(')); + if (x < 0) { + Print(Car(x)); + while ((x = Cdr(x))) { + if (panic && cPrints > panic) { + PrintChar(Ord(' ')); + PrintChar(0x2026); + break; + } + if (x < 0) { + PrintChar(Ord(' ')); + Print(Car(x)); + } else { + PrintChar(Ord(' ')); + PrintChar(Ord('.')); + PrintChar(Ord(' ')); + Print(x); + break; + } + } + } + PrintChar(Ord(')')); +} + +function Print(x) { + ++cPrints; + if (1./x < 0) { + PrintList(x); + } else { + PrintAtom(x); + } +} + +function List(x, y) { + return Cons(x, Cons(y, -0)); +} + +function Gc(A, x) { + var C, B = cx; + x = Copy(x, A, A - B), C = cx; + while (C < B) Set(--A, Get(--B)); + return cx = A, x; +} + +function Evcon(c, a) { + if (c >= 0) Throw(kCond); + if (Eval(Car(Car(c)), a)) { + return Eval(Car(Cdr(Car(c))), a); + } else { + return Evcon(Cdr(c), a); + } +} + +function Peel(x, a) { + return a && x == Car(Car(a)) ? Cdr(a) : a; +} + +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), + Peel(Car(x), a))) : a; +} + +function Assoc(x, y) { + if (!y) Throw(x); + return x == Car(Car(y)) ? Cdr(Car(y)) : Assoc(x, Cdr(y)); +} + +function Apply(f, x, a) { + if (f < 0) return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(f)), x, a)); + if (f == kCons) return Cons(Car(x), Car(Cdr(x))); + if (f == kEq) return Car(x) == Car(Cdr(x)); + if (f == kAtom) return Car(x) >= 0; + if (f == kCar) return Car(Car(x)); + if (f == kCdr) return Cdr(Car(x)); + return funcall(cx, f, Assoc(f, a), x, a); +} + +function Eval(e, a) { + if (!e) return e; + if (e > 0) return Assoc(e, a); + if (Car(e) == kQuote) return Car(Cdr(e)); + if (Car(e) == kCond) return Evcon(Cdr(e), a); + return Apply(Car(e), Evlis(Cdr(e), a), a); +} + +function Funcall(A, f, l, x, a) { + return Gc(A, Apply(l, x, a)); +} + +function Funtrace(A, f, l, x, a) { + var y; + Indent(depth); + Print(f); + Print(x); + PrintChar(Ord('\n')); + depth += 2; + y = Funcall(cx, f, l, x, a); + depth -= 2; + Indent(depth); + Print(f); + Print(x); + PrintChar(Ord(' ')); + PrintChar(0x2192); + PrintChar(Ord(' ')); + Print(y); + PrintChar(Ord('\n')); + return y; +} + +function Indent(i) { + if (i) { + PrintChar(Ord(' ')); + Indent(i - 1); + } +} + +function DumpAlist(a) { + PrintChar(Ord('(')); + PrintChar(Ord('\n')); + for (;a ;a = Cdr(a)) { + PrintChar(Ord('(')); + Print(Car(Car(a))); + PrintChar(Ord(' ')); + PrintChar(Ord('.')); + PrintChar(Ord(' ')); + Print(Cdr(Car(a))); + PrintChar(Ord(')')); + PrintChar(Ord('\n')); + } + PrintChar(Ord(')')); +} + +function DumpDefines(a) { + if (a) { + DumpDefines(Cdr(a)); + PrintChar(Ord('(')); + Print(kDefine); + PrintChar(Ord(' ')); + Print(Car(Car(a))); + PrintChar(Ord(' ')); + PrintChar(Ord('.')); + PrintChar(Ord(' ')); + Print(Cdr(Car(a))); + PrintChar(Ord(')')); + PrintChar(Ord('\n')); + } +} + +function LoadBuiltins() { + Read(); + Read(); + kEq = Read(); + kCar = Read(); + kCdr = Read(); + kAtom = Read(); + kCond = Read(); + kCons = Read(); + kQuote = Read(); + kDefine = Read(); +} + +function Crunch(e, B) { + var x, y, i; + if (e >= 0) return e; + x = Crunch(Car(e), B); + y = Crunch(Cdr(e), B); + for (i = B - 2; i >= cx; i -= 2) { + if (x == Car(i) && + y == Cdr(i)) { + return i - B; + } + } + return Cons(x, y) - B; +} + +function Compact(x) { + var C, B = cx, A = 0; + x = Crunch(x, B), C = cx; + while (C < B) Set(--A, Get(--B)); + return cx = A, x; +} + +function Remove(x, y) { + if (!y) return y; + if (x == Car(Car(y))) return Cdr(y); + return Cons(Car(y), Remove(x, Cdr(y))); +} + +function Define(x, a) { + return Compact(Cons(x, Remove(Car(x), a))); +} + +//
` +//////////////////////////////////////////////////////////////////////////////// +// ANSI POSIX C Specific Code + +Ord(c) { + return c; +} + +Throw(x) { + if (fail < 255) ++fail; + longjmp(undefined, ~x); +} + +PrintChar(b) { + fputwc(b, stdout); +} + +SaveAlist(a) { +} + +ReadChar() { + int b, c, t; + static char *freeme; + static char *line = "NIL T EQ CAR CDR ATOM COND CONS QUOTE DEFINE "; + 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 = '\n'; + } + t = dx; + dx = c; + return t; + } else { + exit(fail); + } +} + +main(argc, argv) + char *argv[]; +{ + var x, a, A; + setlocale(LC_ALL, ""); + bestlineSetXlatCallback(bestlineUppercase); + funcall = Funcall; + for (x = 1; x < argc; ++x) { + if (argv[x][0] == '-' && argv[x][1] == 't') { + funcall = Funtrace; + } else { + fputs("Usage: ", stderr); + fputs(argv[0], stderr); + fputs(" [-t] errput.lisp\n", stderr); + exit(1); + } + } + LoadBuiltins(); + for (a = 0;;) { + A = cx; + if (!(x = setjmp(undefined))) { + x = Read(); + if (x < 0 && Car(x) == kDefine) { + a = Define(Cdr(x), a); + SaveAlist(a); + continue; + } + x = Eval(x, a); + } else { + x = ~x; + PrintChar('?'); + } + Print(x); + PrintChar('\n'); + Gc(A, 0); + } +} + +#if 0 +//` +//////////////////////////////////////////////////////////////////////////////// +// JavaScript Specific Code for https://justine.lol/ + +var a, code, index, output, funcall, M, Null; +var eOutput, eEval, eReset, eLoad, eTrace, ePrograms, eDump; +var eGets, eSets, eMs, eAtoms, eCode, eHeap, eReads, eWrites, eClear; + +function Throw(x) { + throw x; +} + +function Reset() { + var i; + a = 0; + cx = 0; + cHeap = 0; + cGets = 0; + cSets = 0; + cReads = 0; + cPrints = 0; + Null = 16384; + M = new Array(Null * 2); + // for (i = 0; i < M.length; ++i) { + // M[i] = 0; /* make json smaller */ + // } + Load("NIL T EQ CAR CDR ATOM COND CONS QUOTE DEFINE "); + LoadBuiltins() +} + +function PrintU16(c) { + output += String.fromCharCode(c); +} + +function IsHighSurrogate(c) { + return (0xfc00 & c) == 0xd800; +} + +function IsLowSurrogate(c) { + return (0xfc00 & c) == 0xdc00; +} + +function GetHighSurrogate(c) { + return ((c - 0x10000) >> 10) + 0xD800; +} + +function GetLowSurrogate(c) { + return ((c - 0x10000) & 1023) + 0xDC00; +} + +function ComposeUtf16(c, d) { + return ((c - 0xD800) << 10) + (d - 0xDC00) + 0x10000; +} + +function PrintChar(c) { + if (c < 0x10000) { + PrintU16(c); + } else if (c < 0x110000) { + PrintU16(GetHighSurrogate(c)); + PrintU16(GetLowSurrogate(c)); + } else { + PrintU16(0xFFFD); + } +} + +function Ord(s) { + var c, d; + c = s.charCodeAt(0); + if (IsHighSurrogate(c)) { + if (code.length > 1 && IsLowSurrogate((d = s.charCodeAt(1)))) { + c = ComposeUtf16(c, d); + } else { + c = 0xFFFD; + } + } else if (IsLowSurrogate(c)) { + c = 0xFFFD; + } + return c; +} + +function ReadChar() { + var c, d, t; + if (code.length) { + if (index < code.length) { + c = code.charCodeAt(index++); + if (IsHighSurrogate(c)) { + if (index < code.length && + IsLowSurrogate((d = code.charCodeAt(index)))) { + c = ComposeUtf16(c, d), ++index; + } else { + c = 0xFFFD; + } + } else if (IsLowSurrogate(c)) { + c = 0xFFFD; + } + } else { + code = ""; + c = 0; + } + t = dx; + dx = c; + return t; + } else { + Throw(0); + } +} + +function Lisp() { + var x, A, d, t; + d = 0; + cGets = 0; + cSets = 0; + cHeap = cx; + cReads = 0; + cPrints = 0; + output = ""; + while (dx) { + if (dx <= Ord(' ')) { + ReadChar(); + } else { + t = GetMillis(); + A = cx; + try { + x = Read(); + if (x < 0 && Car(x) == kDefine) { + a = Define(Cdr(x), a); + continue; + } + x = Eval(x, a); + } catch (z) { + PrintChar(Ord('?')); + x = z; + } + Print(x); + PrintChar(Ord('\n')); + Gc(A, 0); + d += GetMillis() - t; + } + } + eOutput.innerText = output; + SaveAlist(a); + SaveOutput(); + ReportUsage(d); +} + +function Load(s) { + index = 0; + dx = Ord(' '); + code = s + "\n"; +} + +function OnEval() { + Load(g_editor.getValue()); + Lisp(); + SetStorage("input", g_editor.getValue()); +} + +function OnBeforeUnload() { + SetStorage("input", g_editor.getValue()); +} + +function OnDump() { + var t; + output = ""; + t = GetMillis(); + DumpDefines(a); + eOutput.innerText = output; + t = GetMillis() - t; + SaveOutput(); + ReportUsage(t); +} + +function OnReset(e) { + var t; + output = ""; + t = GetMillis(); + try { + if (!e.shiftKey) DumpDefines(a); + eOutput.innerText = output; + Reset(); + } catch (e) { + /* ignored */ + } + t = GetMillis() - t; + RemoveStorage("alist"); + SaveOutput(); + ReportUsage(t); +} + +function OnClear() { + output = ""; + eOutput.innerText = output; + SaveOutput(); + ReportUsage(0); +} + +function OnTrace() { + var t; + Load(g_editor.getValue()); + t = panic; + depth = 0; + panic = 10000; + funcall = Funtrace; + Lisp(); + funcall = Funcall; + panic = t; +} + +function OnLoad() { + if (ePrograms.className == "dropdown-content") { + ePrograms.className = "dropdown-content show"; + } else { + ePrograms.className = "dropdown-content"; + } +} + +function OnWindowClick(e) { + if (e.target && !e.target.matches("#load")) { + ePrograms.className = "dropdown-content"; + } +} + +function OnWindowKeyDown(e) { + if (e.key == "Escape") { + ePrograms.className = "dropdown-content"; + } +} + +function SaveAlist(a) { + output = ""; + DumpAlist(a); + SetStorage("alist", output); +} + +function RestoreMachine() { + var v; + if ((v = GetStorage("output"))) { + eOutput.innerText = v; + } + if ((v = GetStorage("input"))) { + g_editor.setValue(v); + } + if ((v = GetStorage("alist"))) { + Reset(); + Load(v); + a = Compact(Read()); + } else if ((v = JSON.parse(GetStorage("machine")))) { + M = v[0]; + a = v[1]; + cx = v[2]; + cHeap = cx; + } +} + +function SaveOutput() { + SetStorage("input", g_editor.getValue()); + SetStorage("output", eOutput.innerText); +} + +function FormatInt(i) { + return i.toLocaleString(); +} + +function FormatDuration(d) { + return d ? Math.round(d * 1000) / 1000 : 0; +} + +function ReportUsage(ms) { + var i, atom, code, heap; + code = -cx >> 1; + heap = -cHeap >> 1; + for (atom = i = 0; i < Null / 2; ++i) { + if (M[Null + i]) ++atom; + } + if (eGets) eGets.innerText = FormatInt(cGets); + if (eSets) eSets.innerText = FormatInt(cSets); + if (eMs) eMs.innerText = FormatInt(ms); + if (eAtoms) eAtoms.innerText = FormatInt(atom); + if (eCode) eCode.innerText = FormatInt(code); + if (eHeap) eHeap.innerText = FormatInt(heap - code); + if (eReads) eReads.innerText = FormatInt(cReads); + if (ePrints) ePrints.innerText = FormatInt(cPrints); +} + +function Discount(f) { + return function() { + var x, g, h, s; + g = cGets; + s = cSets; + h = cHeap; + x = f.apply(this, arguments); + cHeap = h; + cSets = s; + cGets = g; + return x; + }; +} + +function GetMillis() { + if (typeof performance != "undefined") { + return performance.now(); + } else { + return 0; + } +} + +function GetStorage(k) { + if (typeof localStorage != "undefined") { + return localStorage.getItem(g_lisp + "." + k); + } else { + return null; + } +} + +function RemoveStorage(k) { + if (typeof localStorage != "undefined") { + localStorage.removeItem(g_lisp + "." + k); + } +} + +function SetStorage(k, v) { + if (typeof localStorage != "undefined") { + localStorage.setItem(g_lisp + "." + k, v); + } +} + +function SetUp() { + funcall = Funcall; + Read = Discount(Read); + Print = Discount(Print); + Define = Discount(Define); + eLoad = document.getElementById("load"); + eReset = document.getElementById("reset"); + eTrace = document.getElementById("trace"); + eOutput = document.getElementById("output"); + eEval = document.getElementById("eval"); + eClear = document.getElementById("clear"); + eDump = document.getElementById("dump"); + ePrograms = document.getElementById("programs"); + eGets = document.getElementById("cGets"); + eSets = document.getElementById("cSets"); + eMs = document.getElementById("cMs"); + eAtoms = document.getElementById("cAtoms"); + eCode = document.getElementById("cCode"); + eHeap = document.getElementById("cHeap"); + eReads = document.getElementById("cReads"); + ePrints = document.getElementById("cPrints"); + window.onkeydown = OnWindowKeyDown; + if (window.onbeforeunload) window.onbeforeunload = OnBeforeUnload; + if (ePrograms) window.onclick = OnWindowClick; + if (eLoad) eLoad.onclick = OnLoad; + if (eReset) eReset.onclick = OnReset; + if (eTrace) eTrace.onclick = OnTrace; + if (eEval) eEval.onclick = OnEval; + if (eDump) eDump.onclick = OnDump; + if (eClear) eClear.onclick = OnClear; +} + +//
` +#endif +//` diff --git a/lisp.lisp b/lisp.lisp index 25a57ab..ebe8c72 100644 --- a/lisp.lisp +++ b/lisp.lisp @@ -61,62 +61,77 @@ NIL ;; FIND FIRST ATOM IN TREE ;; CORRECT RESULT OF EXPRESSION IS `A` ;; RECURSIVE CONDITIONAL FUNCTION BINDING -((LAMBDA (FF X) (FF X)) +((LAMBDA (FF X) + (FF X)) (QUOTE (LAMBDA (X) (COND ((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)))))) - (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)))))) + +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))))) + +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 9fe50a2..03c5b4f 100644 --- a/sectorlisp.S +++ b/sectorlisp.S @@ -19,8 +19,13 @@ │ PERFORMANCE OF THIS SOFTWARE. │ ╚─────────────────────────────────────────────────────────────────────────────*/ -// LISP meta-circular evaluator in a MBR -// Compatible with the original hardware +// LISP meta-circular evaluator in a MBR +// Compatible with the original hardware + +// This is the friendly extended version +// This adds (FOO . BAR) support to Read +// It print errors on undefined behavior +// It can also DEFINE persistent binding .code16 .globl _start @@ -28,33 +33,16 @@ _start: .asciz "NIL" # dec %si ; dec %cx ; dec %sp kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0 start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address .asciz "" -kQuote: .asciz "QUOTE" +kDefine:.asciz "DEFINE" kCond: .asciz "COND" -kAtom: .asciz "ATOM" # ordering matters +kQuote: .asciz "QUOTE" kCar: .asciz "CAR" # ordering matters kCdr: .asciz "CDR" # ordering matters kCons: .asciz "CONS" # ordering matters -kEq: .asciz "EQ" # needs to be last +kEq: .asciz "EQ" # ordering matters +kAtom: .asciz "ATOM" # 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 - xor %sp,%sp # use highest address as stack - mov $2,%bx -main: mov $0x8000,%cx # dl (g_look) is zero or cr - call GetToken - call GetObject - call Eval - xchg %ax,%si - call PrintObject - mov $'\r',%al - call PutChar - jmp main - -GetToken: # GetToken():al, dl is g_look +GetToken: # GetToken():al mov %cx,%di 1: mov %dl,%al cmp $' ',%al @@ -66,7 +54,7 @@ GetToken: # GetToken():al, dl is g_look jbe 1b cmp $')',%al jbe 3f - cmp $')',%dl # dl = g_look + cmp $')',%dl ja 1b 3: mov %bh,(%di) # bh is zero xchg %si,%ax @@ -90,7 +78,7 @@ GetToken: # GetToken():al, dl is g_look .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: @@ -105,54 +93,58 @@ 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) + dec %di +2: scasb + jne 2b jmp 1b -2: rep movsb # memcpy(di,si,cx) +8: rep movsb # memcpy(di,si,cx) 9: pop %cx + pop %cx ret 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 1f # look xchg ret + jne .retDx # look xchg ret mov $'\n',%al jmp PutChar //////////////////////////////////////////////////////////////////////////////// -Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):ax - jz 1f # jump if nil - push (%bx,%di) # save 1 Cdr(x) - lodsw - push (%si) # save 2 Cdr(y) +Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax + jb .retDi # we assume immutable cells + push (%bx,%di) # mark prevents negative gc mov (%di),%di - call Cons # preserves dx - pop %si # restore 2 - pop %di # restore 1 - push %ax # save 3 - call Pairlis - jmp xCons # can be inlined here -1: xchg %dx,%ax + call Gc + pop %di + push %ax + call Gc + pop %di + call Cons + sub %si,%ax # ax -= C - B + add %dx,%ax ret Evlis: test %di,%di # Evlis(m:di,a:dx):ax - jz 1f # jump if nil + jz .retDi # jump if nil push (%bx,%di) # save 1 Cdr(m) mov (%di),%ax call Eval @@ -163,83 +155,95 @@ Evlis: test %di,%di # Evlis(m:di,a:dx):ax xCons: pop %di # restore 2 Cons: xchg %di,%cx # Cons(m:di,a:ax):ax - mov %cx,(%di) + mov %cx,(%di) # must preserve si mov %ax,(%bx,%di) lea 4(%di),%cx -1: xchg %di,%ax - ret - -Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax - jb 1b # we assume immutable cells - push (%bx,%di) # mark prevents negative gc - mov (%di),%di - call Gc - pop %di - push %ax - call Gc - pop %di - call Cons - sub %si,%ax # ax -= C - B - add %dx,%ax +.retDi: xchg %di,%ax ret GetList:call GetToken cmp $')',%al je .retF + cmp $'.',%al # FRIENDLY FEATURE + je 1f # CONS DOT LITERAL call GetObject push %ax # popped by xCons call GetList jmp xCons +1: call Read + push %ax + call GetList + pop %ax + ret -.dflt1: push %si # save x - call Eval - pop %si # restore x -# jmp Apply +.retDx: xchg %dx,%ax + ret +.resolv:push %si + call Assoc # do (fn si) → ((λ ...) si) + pop %si 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 + push %di # for .EvCadr mov (%di),%di # di = Cadr(fn) - call Pairlis - xchg %ax,%dx - pop %di # restore 1 - jmp .EvCadr -.switch:cmp $kEq,%ax # eq is last builtin atom - ja .dflt1 # ah is zero if not above +Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):dx + jz .EvCadr # return if x is nil + xor %ax,%ax # FRIENDLY FEATURE + test %si,%si # DEFAULT NIL ARGS + jz 1f + lodsw # ax = Car(y) + mov (%si),%si # si = Cdr(y) +1: push (%bx,%di) # push Cdr(x) + mov (%di),%di # di = Car(x) + call Cons # Cons(Car(x),Car(y)) + xchg %ax,%di + xchg %dx,%ax + call Cons # Cons(Cons(Car(x),Car(y)),a) + xchg %ax,%dx # a = new list + pop %di # grab Cdr(x) + jmp Pairlis +.switch:cmp $kAtom,%ax # eq is last builtin atom + ja .resolv # ah is zero if not above mov (%si),%di # di = Car(x) + je .ifAtom + cmp $kCons,%ax + jae .ifCons + test %di,%di # FRIENDLY FEATURE + jns .retF # CAR/CDR(NIL)→NIL .ifCar: cmp $kCar,%al je Car -.ifCdr: cmp $kCdr,%al - je Cdr -.ifAtom:cmp $kAtom,%al - jne .ifCons - test %di,%di # test if atom - jns .retT -.retF: xor %ax,%ax # ax = nil - ret -.ifCons:cmp $kCons,%al - mov (%bx,%si),%si # si = Cdr(x) +.ifCdr: jmp Cdr +.ifCons: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 +.ifAtom:test %di,%di # test if atom + jns .retT +.retF: xor %ax,%ax # ax = nil 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 +Define: xchg %dx,%ax + call Cons + jmp .retDx Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax -1: mov (%si),%di +1: test %si,%si # FRIENDLY FEATURE + jns Undef # PRINT ?X IF X∉DX + mov (%si),%di 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!! + ret 1: mov (%bx,%di),%di # di = Cdr(c) Evcon: push %di # save c @@ -249,8 +253,9 @@ Evcon: push %di # save c pop %di # restore c test %ax,%ax # nil test jz 1b - mov (%di),%di # di = Car(c) -.EvCadr:call Cadr # ax = Cadar(c) + push (%di) # push Car(c) +.EvCadr:pop %di + call Cadr # ax = Cadar(c) # jmp Eval Eval: test %ax,%ax # Eval(e:ax,a:dx):ax @@ -263,6 +268,7 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax je Car cmp $kCond,%ax je Evcon # ABC Garbage Collector + jb Define push %dx # save a push %cx # save A push %ax @@ -281,9 +287,43 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax pop %dx # restore a 1: ret +Undef: push %ax + mov $'?',%al + call PutChar + pop %ax + jmp Catch + +Read: call GetToken + call GetObject + ret + +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 + mov %bp,%dx + call Eval + mov %dx,%bp + cmp $kDefine,%ax + je main +Catch: xchg %ax,%si + call PrintObject + mov $'\r',%al + call PutChar + jmp main + .sig: .fill 510 - (. - _start), 1, 0xce .word 0xAA55 .type .sig,@object + .type kDefine,@object .type kQuote,@object .type kCond,@object .type kAtom,@object diff --git a/sectorlisp.lds b/sectorlisp.lds new file mode 100644 index 0000000..eb4ac07 --- /dev/null +++ b/sectorlisp.lds @@ -0,0 +1,12 @@ +ENTRY(_start) + +SECTIONS { + . = 0; + .text : { + *(.text) + *(.rodata .rodata.*) + } + /DISCARD/ : { + *(.*) + } +}