commit a561e031aec03270459f85e9038f7951798f7fd3 Author: Justine Tunney Date: Mon Oct 26 11:25:18 2020 -0700 Initial import diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e69d341 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +/lisp +/*.o +/*.bin +/*.bin.dbg diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..416c19d --- /dev/null +++ b/Makefile @@ -0,0 +1,66 @@ +CFLAGS ?= -g +CFLAGS += -fno-pie +LDFLAGS += -no-pie # -s -static -N + +REALFLAGS = \ + -Os \ + -D__REAL_MODE__ \ + -wrapper ./realify.sh \ + -ffixed-r8 \ + -ffixed-r9 \ + -ffixed-r10 \ + -ffixed-r11 \ + -ffixed-r12 \ + -ffixed-r13 \ + -ffixed-r14 \ + -ffixed-r15 \ + -mno-red-zone \ + -fcall-used-rbx \ + -fno-jump-tables \ + -fno-shrink-wrap \ + -fno-schedule-insns2 \ + -flive-range-shrinkage \ + -fno-omit-frame-pointer \ + -momit-leaf-frame-pointer \ + -mpreferred-stack-boundary=3 \ + -fno-delete-null-pointer-checks + +CLEANFILES = \ + lisp \ + lisp.o \ + lisp.real.o \ + sectorlisp.o \ + start.o \ + lisp.bin \ + sectorlisp.bin \ + lisp.bin.dbg \ + sectorlisp.bin.dbg + +lisp: lisp.o + +.PHONY: all +all: lisp \ + lisp.bin \ + lisp.bin.dbg \ + sectorlisp.bin \ + sectorlisp.bin.dbg + +.PHONY: clean +clean:; $(RM) $(CLEANFILES) + +lisp.bin.dbg: start.o lisp.real.o lisp.lds +sectorlisp.bin.dbg: start.o sectorlisp.o lisp.lds + +start.o: start.S +lisp.o: lisp.c lisp.h +lisp.real.o: lisp.c lisp.h +sectorlisp.o: sectorlisp.S + +%.real.o: %.c + $(CC) $(CPPFLAGS) $(CFLAGS) $(REALFLAGS) -c -o $@ $< + +%.bin.dbg: + $(LD) $(LDFLAGS) -static -o $@ $(patsubst %.lds,-T %.lds,$^) + +%.bin: %.bin.dbg + objcopy -SO binary $< $@ diff --git a/NOTICE b/NOTICE new file mode 100644 index 0000000..ca40314 --- /dev/null +++ b/NOTICE @@ -0,0 +1,14 @@ +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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..8735a31 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# sectorlisp + +sectorlisp is an effort to bootstrap John McCarthy's meta-circular +evaluator on bare metal from a 512-byte boot sector. + +![Yo dawg, I heard you like LISP so I put a LISP in your LISP so you can eval while you eval](bin/yodawg.png) + +## Motivations + +Much of the information about LISP online tends to focus on +[wild macros](http://www.paulgraham.com/onlisp.html), +[JIT compilation](http://pixielang.org/), or its merits as +[a better XML](http://www.defmacro.org/ramblings/lisp.html) +as well as [a better JSON](https://stopa.io/post/265). However +there's been comparatively little focus on the +[primary materials](https://people.cs.umass.edu/~emery/classes/cmpsci691st/readings/PL/LISP.pdf) +from the 1950's which emphasize the radically simple nature of +LISP, as best evidenced by the meta-circular evaluator above. + +

+ Binary Footprint Comparison +

+ +This project aims to promote the radical simplicity of the essential +elements of LISP's original design, by building the tiniest LISP machine +possible. With a binary footprint less than one kilobyte, that's capable +of running natively without dependencies on modern PCs, sectorlisp might +be the tiniest self-hosting LISP interpreter to date. + +We're still far off however from reaching our goal, which is to have +sectorilsp be small enough to fit in the master boot record of a floppy +disk, like [sectorforth](https://github.com/cesarblum/sectorforth). If +you can help this project reach its goal, please send us a pull request! + +## Demo + +

+ + booting sectorlisp in emulator +

+ +The video above demonstrates how to boot sectorlisp in the blinkenlights +emulator, to bootstrap the meta-circular evaluator, which evaluates a +program for finding the first element in a tree. + +You can [watch the full demo on YouTube](https://youtu.be/hvTHZ6E0Abo). diff --git a/bin/footprint.png b/bin/footprint.png new file mode 100644 index 0000000..f63aa3c Binary files /dev/null and b/bin/footprint.png differ diff --git a/bin/lisp.elf.linux b/bin/lisp.elf.linux new file mode 100755 index 0000000..0459c4e Binary files /dev/null and b/bin/lisp.elf.linux differ diff --git a/bin/sectorlisp.bin b/bin/sectorlisp.bin new file mode 100755 index 0000000..c9c6cde Binary files /dev/null and b/bin/sectorlisp.bin differ diff --git a/bin/sectorlisp.gif b/bin/sectorlisp.gif new file mode 100644 index 0000000..b481730 Binary files /dev/null and b/bin/sectorlisp.gif differ diff --git a/bin/yodawg.png b/bin/yodawg.png new file mode 100644 index 0000000..547cae4 Binary files /dev/null and b/bin/yodawg.png differ diff --git a/lisp.c b/lisp.c new file mode 100644 index 0000000..0b7d085 --- /dev/null +++ b/lisp.c @@ -0,0 +1,452 @@ +/*-*- 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 "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) +#define PROMPT 1 // show repl prompt +#define WORD short +#define WORDS 8192 + +/*───────────────────────────────────────────────────────────────────────────│─╗ +│ The LISP Challenge § LISP Machine ─╬─│┼ +╚────────────────────────────────────────────────────────────────────────────│*/ + +#define ATOM 0 +#define CONS 1 + +#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 BOOL(x) ((x) ? ATOM_T : NIL) +#define VALUE(x) ((x) >> 1) +#define PTR(i) ((i) << 1 | CONS) + +struct Lisp { + WORD mem[WORDS]; + unsigned char syntax[256]; + WORD look; + WORD globals; + WORD index; + char token[128]; + char str[WORDS]; +}; + +_Static_assert(sizeof(struct Lisp) <= 0x7c00 - 0x600, + "LISP Machine too large for real mode"); + +_Alignas(char) const char kSymbols[] = "NIL\0" + "*UNDEFINED\0" + "T\0" + "QUOTE\0" + "ATOM\0" + "EQ\0" + "COND\0" + "CAR\0" + "CDR\0" + "CONS\0" + "LAMBDA\0"; + +#ifdef __REAL_MODE__ +static struct Lisp *const q; +#else +static struct Lisp q[1]; +#endif + +static void Print(long); +static WORD GetList(void); +static WORD GetObject(void); +static void PrintObject(long); +static WORD Eval(long, long); + +static void SetupSyntax(void) { + unsigned char *syntax = q->syntax; + asm("" : "+bSD"(syntax)); + syntax[' '] = ' '; + syntax['\r'] = ' '; + syntax['\n'] = ' '; + syntax['('] = '('; + syntax[')'] = ')'; + syntax['.'] = '.'; +#if QUOTES + syntax['\''] = '\''; +#endif +} + +static void SetupBuiltins(void) { + CopyMemory(q->str, kSymbols, sizeof(kSymbols)); +} + +static inline WORD Car(long x) { + return PEEK_ARRAY(q, mem, VALUE(x), 0); +} + +static inline WORD Cdr(long x) { + return PEEK_ARRAY(q, mem, VALUE(x), 1); +} + +static WORD Set(long i, long k, long v) { + POKE_ARRAY(q, mem, VALUE(i), 0, k); + POKE_ARRAY(q, mem, VALUE(i), 1, v); + return i; +} + +static WORD Cons(WORD car, WORD cdr) { + int i, cell; + i = q->index; + POKE_ARRAY(q, mem, i, 0, car); + POKE_ARRAY(q, mem, i, 1, cdr); + q->index = i + 2; + cell = OBJECT(CONS, i); + return cell; +} + +static char *StpCpy(char *d, char *s) { + char c; + do { + c = LODS(s); // a.k.a. c = *s++ + STOS(d, c); // a.k.a. *d++ = c + } while (c); + return d; +} + +static WORD Intern(char *s) { + int j, cx; + char c, *z, *t; + z = q->str; + c = LODS(z); + while (c) { + for (j = 0;; ++j) { + if (c != PEEK(s, j, 0)) { + break; + } + if (!c) { + return OBJECT(ATOM, z - q->str - j - 1); + } + c = LODS(z); + } + while (c) c = LODS(z); + c = LODS(z); + } + --z; + StpCpy(z, s); + return OBJECT(ATOM, SUB((long)z, q->str)); +} + +static unsigned char XlatSyntax(unsigned char b) { + return PEEK_ARRAY(q, syntax, b, 0); +} + +static void PrintString(char *s) { + char c; + for (;;) { + if (!(c = PEEK(s, 0, 0))) break; + PrintChar(c); + ++s; + } +} + +static int GetChar(void) { + int c; + c = ReadChar(); +#if RETRO + if (c >= 'a') { + CompilerBarrier(); + if (c <= 'z') c -= 'a' - 'A'; + } +#endif +#if DELETE + if (c == '\b') return c; +#endif + PrintChar(c); + if (c == '\r') PrintChar('\n'); + return c; +} + +static void GetToken(void) { + char *t; + unsigned char b, x; + b = q->look; + t = q->token; + for (;;) { + x = XlatSyntax(b); + if (x != ' ') break; + b = GetChar(); + } + if (x) { + STOS(t, b); + b = GetChar(); + } else { + while (b && !x) { + if (!DELETE || b != '\b') { + STOS(t, b); + } else if (t > q->token) { + PrintString("\b \b"); + if (t > q->token) --t; + } + b = GetChar(); + x = XlatSyntax(b); + } + } + STOS(t, 0); + q->look = b; +} + +static WORD ConsumeObject(void) { + GetToken(); + return GetObject(); +} + +static WORD Cadr(long x) { + return Car(Cdr(x)); // ((A B C D) (E F G) H I) → (E F G) +} + +static WORD List(long x, long y) { + return Cons(x, Cons(y, NIL)); +} + +static WORD Quote(long x) { + return List(ATOM_QUOTE, x); +} + +static WORD GetQuote(void) { + return Quote(ConsumeObject()); +} + +static WORD AddList(WORD x) { + return Cons(x, GetList()); +} + +static WORD GetList(void) { + GetToken(); + switch (*q->token & 0xFF) { + default: + return AddList(GetObject()); + case ')': + return NIL; + case '.': + return ConsumeObject(); +#if QUOTES + case '\'': + return AddList(GetQuote()); +#endif + } +} + +static WORD GetObject(void) { + switch (*q->token & 0xFF) { + default: + return Intern(q->token); + case '(': + return GetList(); +#if QUOTES + case '\'': + return GetQuote(); +#endif + } +} + +static WORD ReadObject(void) { + q->look = GetChar(); + GetToken(); + return GetObject(); +} + +static WORD Read(void) { + return ReadObject(); +} + +static void PrintAtom(long x) { + PrintString(q->str + VALUE(x)); +} + +static void PrintList(long x) { +#if QUOTES + if (Car(x) == ATOM_QUOTE) { + PrintChar('\''); + PrintObject(Cadr(x)); + return; + } +#endif + PrintChar('('); + PrintObject(Car(x)); + while ((x = Cdr(x))) { + if (!ISATOM(x)) { + PrintChar(' '); + PrintObject(Car(x)); + } else { + PrintString(" . "); + PrintObject(x); + break; + } + } + PrintChar(')'); +} + +static void PrintObject(long x) { + if (ISATOM(x)) { + PrintAtom(x); + } else { + PrintList(x); + } +} + +static void Print(long i) { + PrintObject(i); + PrintString("\r\n"); +} + +/*───────────────────────────────────────────────────────────────────────────│─╗ +│ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator ─╬─│┼ +╚────────────────────────────────────────────────────────────────────────────│*/ + +static WORD Atom(long x) { + return BOOL(ISATOM(x)); +} + +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 +} + +static WORD Cdar(long x) { + return Cdr(Car(x)); // ((A B C D) (E F G) H I) → (B C D) +} + +static WORD Cadar(long x) { + return Cadr(Car(x)); // ((A B C D) (E F G) H I) → B +} + +static WORD Caddr(long x) { + return Cadr(Cdr(x)); // ((A B C D) (E F G) H I) → H +} + +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); +} + +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 y) { + return y ? Eq(Caar(y), x) ? Cdar(y) : Assoc(x, Cdr(y)) : NIL; +} + +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); + } + } else if (Eq(Caar(e), ATOM_LAMBDA)) { + return Eval(Caddar(e), Bind(Cadar(e), Cdr(e), a)); + } else { + 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; +} + +/*───────────────────────────────────────────────────────────────────────────│─╗ +│ The LISP Challenge § User Interface ─╬─│┼ +╚────────────────────────────────────────────────────────────────────────────│*/ + +void Repl(void) { + for (;;) { +#if PROMPT + PrintString("* "); +#endif + Print(Eval(Read(), q->globals)); + } +} + +int main(int argc, char *argv[]) { + RawMode(); + SetupSyntax(); + SetupBuiltins(); +#if PROMPT + PrintString("THE LISP CHALLENGE V1\r\n" + "VISIT GITHUB.COM/JART\r\n"); +#endif + Repl(); + return 0; +} diff --git a/lisp.h b/lisp.h new file mode 100644 index 0000000..f7d3dde --- /dev/null +++ b/lisp.h @@ -0,0 +1,180 @@ +#ifndef SECTORLISP_H_ +#define SECTORLISP_H_ +#include +#include +#include + +/*───────────────────────────────────────────────────────────────────────────│─╗ +│ The LISP Challenge § Richard Stallman Math 55 Systems Integration Code ─╬─│┼ +╚────────────────────────────────────────────────────────────────────────────│*/ + +#define CompilerBarrier() asm volatile("" ::: "memory") + +#define ISATOM(x) /* a.k.a. !(x&1) */ \ + ({ \ + _Bool IsAtom; \ + asm("test%z1\t$1,%1" : "=@ccz"(IsAtom) : "Qm"((char)x)); \ + IsAtom; \ + }) + +#define OBJECT(t, v) /* a.k.a. v<<1|t */ \ + ({ \ + __typeof(v) Val = (v); \ + asm("shl\t%0" : "+r"(Val)); \ + Val | (t); \ + }) + +#define SUB(x, y) /* a.k.a. x-y */ \ + ({ \ + __typeof(x) Reg = (x); \ + asm("sub\t%1,%0" : "+rm"(Reg) : "g"(y)); \ + Reg; \ + }) + +#define STOS(di, c) asm("stos%z1" : "+D"(di), "=m"(*(di)) : "a"(c)) +#define LODS(si) \ + ({ \ + typeof(*(si)) c; \ + asm("lods%z2" : "+S"(si), "=a"(c) : "m"(*(si))); \ + c; \ + }) + +static inline void *SetMemory(void *di, int al, unsigned long cx) { + asm("rep stosb" + : "=D"(di), "=c"(cx), "=m"(*(char(*)[cx])di) + : "0"(di), "1"(cx), "a"(al)); + return di; +} + +static inline void *CopyMemory(void *di, const void *si, unsigned long cx) { + asm("rep movsb" + : "=D"(di), "=S"(si), "=c"(cx), "=m"(*(char(*)[cx])di) + : "0"(di), "1"(si), "2"(cx)); + return di; +} + +static void RawMode(void) { +#ifndef __REAL_MODE__ + struct termios t; + if (ioctl(1, TCGETS, &t) != -1) { + t.c_cc[VMIN] = 1; + t.c_cc[VTIME] = 1; + t.c_iflag &= ~(INPCK | ISTRIP | PARMRK | INLCR | IGNCR | ICRNL | IXON); + t.c_lflag &= ~(IEXTEN | ICANON | ECHO | ECHONL); + t.c_cflag &= ~(CSIZE | PARENB); + t.c_oflag &= ~OPOST; + t.c_cflag |= CS8; + t.c_iflag |= IUTF8; + ioctl(1, TCSETS, &t); + } +#endif +} + +__attribute__((__noinline__)) static void PrintChar(long c) { +#ifdef __REAL_MODE__ + asm volatile("mov\t$0x0E,%%ah\n\t" + "int\t$0x10" + : /* no outputs */ + : "a"(c), "b"(7) + : "memory"); +#else + static short buf; + int rc; + buf = c; + write(1, &buf, 1); +#endif +} + +static int ReadChar(void) { + int c; +#ifdef __REAL_MODE__ + asm volatile("int\t$0x16" : "=a"(c) : "0"(0) : "memory"); + c &= 0xff; +#else + static int buf; + read(0, &buf, 1); + c = buf; +#endif + return c; +} + +#define PEEK_(REG, BASE, INDEX, DISP) \ + ({ \ + __typeof(*(BASE)) Reg; \ + if (__builtin_constant_p(INDEX) && !(INDEX)) { \ + asm("mov\t%c2(%1),%0" \ + : REG(Reg) \ + : "bDS"(BASE), "i"((DISP) * sizeof(*(BASE))), \ + "m"(BASE[(INDEX) + (DISP)])); \ + } else { \ + asm("mov\t%c3(%1,%2),%0" \ + : REG(Reg) \ + : "b"(BASE), "DS"((long)(INDEX) * sizeof(*(BASE))), \ + "i"((DISP) * sizeof(*(BASE))), "m"(BASE[(INDEX) + (DISP)])); \ + } \ + Reg; \ + }) + +#define PEEK(BASE, INDEX, DISP) /* a.k.a. b[i] */ \ + (sizeof(*(BASE)) == 1 ? PEEK_("=Q", BASE, INDEX, DISP) \ + : PEEK_("=r", BASE, INDEX, DISP)) + +#define PEEK_ARRAY_(REG, OBJECT, MEMBER, INDEX, DISP) \ + ({ \ + __typeof(*(OBJECT->MEMBER)) Reg; \ + if (!(OBJECT)) { \ + asm("mov\t%c2(%1),%0" \ + : REG(Reg) \ + : "bDS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \ + "i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \ + sizeof(*(OBJECT->MEMBER)) * (DISP)), \ + "m"(OBJECT->MEMBER)); \ + } else { \ + asm("mov\t%c3(%1,%2),%0" \ + : REG(Reg) \ + : "b"(OBJECT), "DS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \ + "i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \ + sizeof(*(OBJECT->MEMBER)) * (DISP)), \ + "m"(OBJECT->MEMBER)); \ + } \ + Reg; \ + }) + +#define PEEK_ARRAY(OBJECT, MEMBER, INDEX, DISP) /* o->m[i] */ \ + (sizeof(*(OBJECT->MEMBER)) == 1 \ + ? PEEK_ARRAY_("=Q", OBJECT, MEMBER, INDEX, DISP) \ + : PEEK_ARRAY_("=r", OBJECT, MEMBER, INDEX, DISP)) + +#define POKE_ARRAY_(REG, OBJECT, MEMBER, INDEX, DISP, VALUE) \ + do { \ + if (!(OBJECT)) { \ + asm("mov\t%1,%c3(%2)" \ + : "=m"(OBJECT->MEMBER) \ + : REG((__typeof(*(OBJECT->MEMBER)))(VALUE)), \ + "bDS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \ + "i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \ + sizeof(*(OBJECT->MEMBER)) * (DISP))); \ + } else { \ + asm("mov\t%1,%c4(%2,%3)" \ + : "=m"(OBJECT->MEMBER) \ + : REG((__typeof(*(OBJECT->MEMBER)))(VALUE)), "b"(OBJECT), \ + "DS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \ + "i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \ + sizeof(*(OBJECT->MEMBER)) * (DISP))); \ + } \ + } while (0) + +#define POKE_ARRAY(OBJECT, MEMBER, INDEX, DISP, VALUE) /* o->m[i]=v */ \ + do { \ + __typeof(*(OBJECT->MEMBER)) Reg; \ + switch (sizeof(*(OBJECT->MEMBER))) { \ + case 1: \ + POKE_ARRAY_("Q", OBJECT, MEMBER, INDEX, DISP, VALUE); \ + break; \ + default: \ + POKE_ARRAY_("r", OBJECT, MEMBER, INDEX, DISP, VALUE); \ + break; \ + } \ + } while (0) + +#endif /* SECTORLISP_H_ */ diff --git a/lisp.lds b/lisp.lds new file mode 100644 index 0000000..622addd --- /dev/null +++ b/lisp.lds @@ -0,0 +1,35 @@ +ENTRY(_start) + +SECTIONS { + + .text 0x7c00 - 0x600 : { + *(.start) + rodata = .; + *(.rodata .rodata.*) + . = 0x1fe; + SHORT(0xaa55); + *(.text .text.*) + /*BYTE(0x90);*/ + _etext = .; + . = ALIGN(512); + } + + .bss : { + bss = .; + *(.bss .bss.*) + *(COMMON) + } + + /DISCARD/ : { + *(.*) + } +} + +boot = 0x7c00; +q.syntax = 8192*2; +q.look = 8192*2+256; +q.globals = 8192*2+256+2; +q.index = 8192*2+256+2+2; +q.token = 8192*2+256+2+2+2; +q.str = 8192*2+256+2+2+2+128; +v_sectors = SIZEOF(.text) / 512; diff --git a/lisp.lisp b/lisp.lisp new file mode 100644 index 0000000..e25df93 --- /dev/null +++ b/lisp.lisp @@ -0,0 +1,116 @@ +;; (setq lisp-indent-function 'common-lisp-indent-function) +;; (paredit-mode) + +;; ________ +;; /_ __/ /_ ___ +;; / / / __ \/ _ \ +;; / / / / / / __/ +;; /_/ /_/ /_/\___/ +;; __ _________ ____ ________ ____ +;; / / / _/ ___// __ \ / ____/ /_ ____ _/ / /__ ____ ____ ____ +;; / / / / \__ \/ /_/ / / / / __ \/ __ `/ / / _ \/ __ \/ __ `/ _ \ +;; / /____/ / ___/ / ____/ / /___/ / / / /_/ / / / __/ / / / /_/ / __/ +;; /_____/___//____/_/ \____/_/ /_/\__,_/_/_/\___/_/ /_/\__, /\___/ +;; /____/ +;; +;; The LISP Challenge +;; +;; Pick your favorite programming language +;; Implement the tiniest possible LISP machine that +;; Bootstraps John Mccarthy'S metacircular evaluator below +;; Winning is defined by lines of code for scripting languages +;; Winning is defined by binary footprint for compiled languages +;; +;; Listed Projects +;; +;; - 948 bytes: https://github.com/jart/sectorlisp +;; - 13 kilobytes: https://t3x.org/klisp/ +;; - 150 kilobytes: https://github.com/JeffBezanson/femtolisp +;; - Send pull request to be listed here +;; +;; @see LISP From Nothing; Nils M. Holm; Lulu Press, Inc. 2020 +;; @see Recursive Functions of Symbolic Expressions and Their +;; Computation By Machine, Part I; John McCarthy, Massachusetts +;; Institute of Technology, Cambridge, Mass. April 1960 + +;; NIL ATOM +;; ABSENCE OF VALUE AND TRUTH +NIL + +;; CONS CELL +;; BUILDING BLOCK OF DATA STRUCTURES +(CONS NIL NIL) + +;; REFLECTION +;; EVERYTHING IS AN ATOM OR NOT AN ATOM +(ATOM NIL) +(ATOM (CONS NIL NIL)) + +;; QUOTING +;; CODE IS DATA AND DATA IS CODE +(QUOTE (CONS NIL NIL)) +(CONS (QUOTE CONS) (CONS NIL (CONS NIL NIL))) + +;; LOGIC +;; BY WAY OF STRING INTERNING +(EQ (QUOTE A) (QUOTE A)) +(EQ (QUOTE T) (QUOTE F)) + +;; FIND FIRST ATOM IN TREE +;; CORRECT RESULT OF EXPRESSION IS `A` +;; RECURSIVE CONDITIONAL FUNCTION BINDING +((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 +((LAMBDA (ASSOC EVCON BIND APPEND EVAL) + (EVAL (QUOTE ((LAMBDA (FF X) (FF X)) + (QUOTE (LAMBDA (X) + (COND ((ATOM X) X) + ((QUOTE T) (FF (CAR X)))))) + (QUOTE ((A) B C)))) + NIL)) + (QUOTE (LAMBDA (X E) + (COND ((EQ E NIL) NIL) + ((EQ X (CAR (CAR E))) (CDR (CAR E))) + ((QUOTE T) (ASSOC X (CDR E)))))) + (QUOTE (LAMBDA (C E) + (COND ((EVAL (CAR (CAR C)) E) (EVAL (CAR (CDR (CAR C))) E)) + ((QUOTE T) (EVCON (CDR C) E))))) + (QUOTE (LAMBDA (V A E) + (COND ((EQ V NIL) E) + ((QUOTE T) (CONS (CONS (CAR V) (EVAL (CAR A) E)) + (BIND (CDR V) (CDR A) E)))))) + (QUOTE (LAMBDA (A B) + (COND ((EQ A NIL) B) + ((QUOTE T) (CONS (CAR A) (APPEND (CDR A) B)))))) + (QUOTE (LAMBDA (E A) + (COND + ((ATOM E) (ASSOC E A)) + ((ATOM (CAR E)) + (COND + ((EQ (CAR E) NIL) (QUOTE *UNDEFINED)) + ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E))) + ((EQ (CAR E) (QUOTE ATOM)) (ATOM (EVAL (CAR (CDR E)) A))) + ((EQ (CAR E) (QUOTE EQ)) (EQ (EVAL (CAR (CDR E)) A) + (EVAL (CAR (CDR (CDR E))) A))) + ((EQ (CAR E) (QUOTE CAR)) (CAR (EVAL (CAR (CDR E)) A))) + ((EQ (CAR E) (QUOTE CDR)) (CDR (EVAL (CAR (CDR E)) A))) + ((EQ (CAR E) (QUOTE CONS)) (CONS (EVAL (CAR (CDR E)) A) + (EVAL (CAR (CDR (CDR E))) A))) + ((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A)) + ((EQ (CAR E) (QUOTE LABEL)) (EVAL (CAR (CDR (CDR E))) + (APPEND (CAR (CDR E)) A))) + ((EQ (CAR E) (QUOTE LAMBDA)) E) + ((QUOTE T) (EVAL (CONS (EVAL (CAR E) A) (CDR E)) A)))) + ((EQ (CAR (CAR E)) (QUOTE LAMBDA)) + (EVAL (CAR (CDR (CDR (CAR E)))) + (BIND (CAR (CDR (CAR E))) (CDR E) A))))))) diff --git a/realify.sed b/realify.sed new file mode 100644 index 0000000..fa82fe5 --- /dev/null +++ b/realify.sed @@ -0,0 +1,177 @@ +#-*-mode:sed;indent-tabs-mode:t;tab-width:8;coding:utf-8-*-┐ +#───vi: et ft=sed ts=8 tw=8 fenc=utf-8 :vi─────────────────┘ +# +# SYNOPSIS +# +# sed -i -f realify.sed foo.s +# +# OVERVIEW +# +# This converts ints and longs to shorts while preserving System V ABI +# x86_64 compatibility. This works better than gcc -m16 because we can +# avoid the ASZ and OSZ prefixes in most cases while also avoiding the +# legacy 32-bit calling conventions. + +# remove comments +s/[ \t][ \t]*#.*// + +s/leave\(q\|\)/leavew/ +s/call\(q\|\)/callw/ +s/ret\(q\|\)/retw/ +s/popq\t%rbp/pop\t%bp/ +s/pushq\t%rbp/push\t%bp/ +s/pushq\t\(.*\)/sub\t$6,%sp\n\tpush\t\1/ +s/popq\t\(.*\)/pop\t\1\n\tadd\t$6,%sp/ + +# # preserve hardcoded stack offsets +# # bloats code size 13% +# s/leave\(q\|\)/leavew\n\tadd\t$6,%sp/ +# s/call\(q\|\)\t/sub\t$6,%sp\n\tcallw\t/ +# s/ret\(q\|\)/retw\t$6/ +# s/pushq\t\(.*\)/sub\t$6,%sp\n\tpush\t\1/ +# s/popq\t\(.*\)/pop\t\1\n\tadd\t$6,%sp/ + +s/, /,/g + +# 32-bitify +s/rax/eax/g +s/rbx/ebx/g +s/rcx/ecx/g +s/rdx/edx/g +s/rbp/ebp/g +s/rdi/edi/g +s/rsi/esi/g +s/rsp/esp/g + +# unextension +s/movswl/mov/ +s/movzwl/mov/ +s/movslq/mov/ +s/movzlq/mov/ +s/movsbl/movsbw/ + +# unsuffix +s/^\(\t\(fild\|fist\|fistp\|fiadd\|fisub\|fisubr\|fimul\|fidiv\|fidivr\|ficom\)\)q\t/\1\t/ +s/^\(\t\(mov\|add\|adc\|cmp\|test\|lea\|sbb\|mul\|imul\|div\|idiv\|in\|out\|xor\|sub\|and\|or\|rol\|ror\|rcl\|rcr\|shl\|shr\|sal\|sar\|inc\|dec\|not\|neg\)\)l\t/\1w\t/ +s/^\(\t[a-z]*\)q\t/\1w\t/ +s/movsww/mov/ + +# remove fluff +s/mov\t%eax,%eax// +s/mov\t%ebx,%ebx// +s/mov\t%ecx,%ecx// +s/mov\t%edx,%edx// +s/mov\t%ebp,%ebp// +s/mov\t%edi,%edi// +s/mov\t%esi,%esi// +s/mov\t%esp,%esp// + +# make pic absolute +s/(%rip)// + +# legal real mode modrm +s/(%ebx)/(%bx)/ +s/(%edi)/(%di)/ +s/(%esi)/(%si)/ +s/(%ebp)/(%bp)/ +s/(%ebx,%esi\(,1\|\))/(%bx,%si)/ +s/(%ebx,%edi\(,1\|\))/(%bx,%di)/ +s/(%ebp,%esi\(,1\|\))/(%bp,%si)/ +s/(%ebp,%edi\(,1\|\))/(%bp,%di)/ + +# we need the asz prefix +s/(%eax,%eax/(%EAX,%EAX/ +s/(%eax,%ebp/(%EAX,%EBP/ +s/(%eax,%ebx/(%EAX,%EBX/ +s/(%eax,%ecx/(%EAX,%ECX/ +s/(%eax,%edi/(%EAX,%EDI/ +s/(%eax,%edx/(%EAX,%EDX/ +s/(%eax,%esi/(%EAX,%ESI/ +s/(%ebp,%eax/(%EBP,%EAX/ +s/(%ebp,%ebp/(%EBP,%EBP/ +s/(%ebp,%ebx/(%EBP,%EBX/ +s/(%ebp,%ecx/(%EBP,%ECX/ +s/(%ebp,%edi/(%EBP,%EDI/ +s/(%ebp,%edx/(%EBP,%EDX/ +s/(%ebp,%esi/(%EBP,%ESI/ +s/(%ebx,%eax/(%EBX,%EAX/ +s/(%ebx,%ebp/(%EBX,%EBP/ +s/(%ebx,%ebx/(%EBX,%EBX/ +s/(%ebx,%ecx/(%EBX,%ECX/ +s/(%ebx,%edi/(%EBX,%EDI/ +s/(%ebx,%edx/(%EBX,%EDX/ +s/(%ebx,%esi/(%EBX,%ESI/ +s/(%ecx,%eax/(%ECX,%EAX/ +s/(%ecx,%ebp/(%ECX,%EBP/ +s/(%ecx,%ebx/(%ECX,%EBX/ +s/(%ecx,%ecx/(%ECX,%ECX/ +s/(%ecx,%edi/(%ECX,%EDI/ +s/(%ecx,%edx/(%ECX,%EDX/ +s/(%ecx,%esi/(%ECX,%ESI/ +s/(%edi,%eax/(%EDI,%EAX/ +s/(%edi,%ebp/(%EDI,%EBP/ +s/(%edi,%ebx/(%EDI,%EBX/ +s/(%edi,%ecx/(%EDI,%ECX/ +s/(%edi,%edi/(%EDI,%EDI/ +s/(%edi,%edx/(%EDI,%EDX/ +s/(%edi,%esi/(%EDI,%ESI/ +s/(%edx,%eax/(%EDX,%EAX/ +s/(%edx,%ebp/(%EDX,%EBP/ +s/(%edx,%ebx/(%EDX,%EBX/ +s/(%edx,%ecx/(%EDX,%ECX/ +s/(%edx,%edi/(%EDX,%EDI/ +s/(%edx,%edx/(%EDX,%EDX/ +s/(%edx,%esi/(%EDX,%ESI/ +s/(%esi,%eax/(%ESI,%EAX/ +s/(%esi,%ebp/(%ESI,%EBP/ +s/(%esi,%ebx/(%ESI,%EBX/ +s/(%esi,%ecx/(%ESI,%ECX/ +s/(%esi,%edi/(%ESI,%EDI/ +s/(%esi,%edx/(%ESI,%EDX/ +s/(%esi,%esi/(%ESI,%ESI/ +s/(%esp,%eax/(%ESP,%EAX/ +s/(%esp,%ebp/(%ESP,%EBP/ +s/(%esp,%ebx/(%ESP,%EBX/ +s/(%esp,%ecx/(%ESP,%ECX/ +s/(%esp,%edi/(%ESP,%EDI/ +s/(%esp,%edx/(%ESP,%EDX/ +s/(%esp,%esi/(%ESP,%ESI/ +s/(,%eax/(,%EAX/ +s/(,%ebx/(,%EBX/ +s/(,%ecx/(,%ECX/ +s/(,%edx/(,%EDX/ +s/(,%esi/(,%ESI/ +s/(,%edi/(,%EDI/ +s/(,%ebp/(,%EBP/ +s/(%eax)/(%EAX)/ +s/(%ecx)/(%ECX)/ +s/(%edx)/(%EDX)/ +s/(%esp)/(%ESP)/ + +# 16bitify +s/eax/ax/g +s/ebx/bx/g +s/ecx/cx/g +s/edx/dx/g +s/ebp/bp/g +s/edi/di/g +s/esi/si/g +s/esp/sp/g + +# sigh :\ +# gcc needs a flag for not using rex byte regs. workaround: +# - %dil can be avoided through copious use of STOS() macro +# - %sil can be avoided through copious use of LODS() macro +# - %bpl shouldn't be allocated due to -fno-omit-frame-pointer +# - %spl shouldn't be allocated like ever +# beyond that there's only a few cases where %dil and %sil +# need some handcoded asm() macros to workaround, for example +# if ARG1 is long and you say (ARG1 & 1) gcc will use %dil +# so just kludge it using asm("and\t$1,%0" : "+Q"(ARG1)) +#s/dil/bl/g +#s/sil/bh/g +#s/spl/bl/g +#s/bpl/bh/g + +# nope +s/cltq// diff --git a/realify.sh b/realify.sh new file mode 100755 index 0000000..66d20b5 --- /dev/null +++ b/realify.sh @@ -0,0 +1,23 @@ +#!/bin/sh +# +# SYNOPSIS +# +# gcc -g0 -Os -wrapper realify.sh -ffixed-r{8,9,1{0,1,2,4,5}} +# +# OVERVIEW +# +# Reconfigures x86_64 compiler to emit 16-bit PC boot code. + +if [ "${1##*/}" = as ]; then + for x; do + if [ "${x##*.}" = s ]; then + { + printf "\t.code16gcc" + sed -f realify.sed "$x" + } >"$x".tmp + mv -f "$x".tmp "$x" + fi + done +fi + +exec "$@" diff --git a/sectorlisp.S b/sectorlisp.S new file mode 100644 index 0000000..40921aa --- /dev/null +++ b/sectorlisp.S @@ -0,0 +1,479 @@ +/*-*- 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 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. │ +╚─────────────────────────────────────────────────────────────────────────────*/ + +/ @fileoverview lisp.c built for real mode with manual tuning +/ binary footprint is approximately 960 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 400 +/ bytes we can bootstrap the metacircular evaluator in an 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 + +#define SYNTAX 0x4000 +#define LOOK 0x4100 +#define GLOBALS 0x4102 +#define INDEX 0x4104 +#define TOKEN 0x4106 +#define STR 0x41c8 + +//////////////////////////////////////////////////////////////////////////////// +.section .start,"ax",@progbits +.globl main +.code16 + +main: mov $SYNTAX,%bx + movb $32,32(%bx) + movb $32,13(%bx) + movb $32,10(%bx) + movw $10536,40(%bx) + movb $46,46(%bx) + mov $STR,%di + mov $kSymbols,%si + mov $57,%cx + rep movsb +0: call GetChar + mov %ax,LOOK + call GetToken + call GetObject + xchg %ax,%di + mov GLOBALS,%si + call Eval + xchg %ax,%di + call PrintObject + mov $kCrlf,%di + call PrintString + jmp 0b + +PutChar:push %bx + push %bp # original ibm pc scroll up bug + mov $0x0007,%bx # normal mda/cga style page zero + xchg %di,%ax # character to display + mov $0x0E,%ah # teletype output + int $0x10 # vidya service + pop %bp # result dil→al + pop %bx + ret + +GetChar:xor %ax,%ax # get keystroke + int $0x16 # keyboard service + xor %ah,%ah # ah is bios scancode + push %ax # al is ascii character + xchg %ax,%di # result is ax + call PutChar + cmp $'\r,%al + jne 1f + mov $'\n,%di + call PutChar +1: pop %ax + ret + +PrintString: + mov %di,%dx +0: mov %dx,%di + mov (%di),%al + test %al,%al + je 1f + xchg %ax,%di + call PutChar + inc %dx + jmp 0b +1: ret + +GetToken: + xor %bx,%bx + mov $SYNTAX,%si + mov LOOK,%ax + mov $TOKEN,%cx +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 + xchg %cx,%di + stosb + xchg %di,%cx + call GetChar + jmp 4f +2: test %bl,%bl + jne 4f + xchg %cx,%di + stosb + xchg %di,%cx + call GetChar + mov %ax,%bx + mov (%bx,%si),%bl +3: test %al,%al + jne 2b +4: mov %cx,%di + movb $0,(%di) + mov %al,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,TOKEN + je 1f + mov $TOKEN,%di + jmp Intern +1: #jmp GetList +/ 𝑠𝑙𝑖𝑑𝑒 + +GetList:call GetToken + mov TOKEN,%al + cmp $'),%al + je 2f + cmp $'.,%al + je 1f + call GetObject + push %ax + call GetList + xchg %ax,%si + pop %di + jmp Cons +1: call GetToken + jmp GetObject +2: xor %ax,%ax + ret + +EvalCons: + push %dx # save + mov 2(%bx),%bx + mov %bx,%di + call Cadr + mov %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 $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 + mov %sp,%bp + push %dx + push %dx + xchg %si,%bx + and $-2,%bx + and $-2,%di + mov %di,-4(%bp) + mov 2(%bx),%si + mov 2(%di),%di + push %bx # save no. 1 + call Bind + pop %bx # rest no. 1 + push %ax # save no. 2 + mov (%bx),%bx + mov %bx,%di + mov -2(%bp),%si + call Eval + mov -4(%bp),%di + mov (%di),%di + xchg %ax,%si + call Cons + pop %si # rest no. 2 + xchg %ax,%di + leave + jmp Cons +1: xchg %dx,%ax + ret + +EvalCdr: + mov %dx,%di + mov %bp,%si + call Arg1 + and $-2,%ax + mov %ax,%di + mov 2(%di),%ax + pop %bp + ret + +//////////////////////////////////////////////////////////////////////////////// +.text + +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 + +Arg1: call Cadr + xchg %ax,%di + jmp Eval + +PrintObject: + push %bp + mov %di,%bp + test $1,%di + setz %al + shr %di + test %al,%al + je 1f + add $STR,%di + pop %bp + jmp PrintString +1: mov $40,%di + call PutChar +2: mov %bp,%bx + and $-2,%bx + mov (%bx),%di + call PrintObject + mov %bp,%bx + and $-2,%bx + mov 2(%bx),%bx + mov %bx,%bp + test %bx,%bx + je 4f + test $1,%bl + je 3f + mov $0x20,%di + call PutChar + jmp 2b +3: mov $kDot,%di + call PrintString + mov %bp,%di + call PrintObject +4: mov $41,%di + pop %bp + jmp PutChar + +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),%ax + and $-2,%ax + mov %ax,%di + mov (%di),%ax + cmp $ATOM_LAMBDA,%ax + jne EvalUndefined + mov 2(%bx),%si + mov (%bx),%di + push %bx + call Cadr + mov %si,%si + mov %ax,%di + mov %bp,%dx + call Bind + mov %ax,%bp + pop %bx + mov (%bx),%bx + mov %bx,%di + and $-2,%di + mov 2(%di),%di + jmp 8f +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 + xchg %dx,%di + pop %bp + jmp Cadr +1: cmp $ATOM_EQ,%ax + jne EvalCall + push %dx + mov 2(%bx),%bx + mov %bx,%di + call Cadr + mov %ax,%di + mov %bp,%si + call Eval + mov %bp,%si + pop %di # restore + push %ax # save + call Arg1 + pop %dx # restore + cmp %dx,%ax + jmp 3f +2: cmp $ATOM_CDR,%ax + je EvalCdr + cmp $ATOM_CONS,%ax + je EvalCons + cmp $ATOM_CAR,%ax + jne EvalCall + mov %bp,%si + mov %dx,%di + call Arg1 + and $-2,%ax + xchg %ax,%di + mov (%di),%ax + jmp 9f +EvalAtom: + mov %bp,%si + mov %dx,%di + call Arg1 + test $1,%al +3: mov $ATOM_T,%ax + je 9f + xor %ax,%ax + jmp 9f +EvalCond: + mov 2(%bx),%bx + mov %bx,%bx + and $-2,%bx + mov (%bx),%di + push %bx # save + and $-2,%di + mov (%di),%di + mov %bp,%si + call Eval + test %ax,%ax + pop %bx # restore + je EvalCond + mov (%bx),%bx + mov %bx,%di + jmp 8f +EvalCall: + mov 2(%bx),%cx + mov (%bx),%bx + mov %bx,%di + mov %bp,%si + call Assoc + mov %cx,%si + mov %ax,%di + call Cons + jmp 1f +8: call Cadr +1: mov %ax,%dx + jmp 0b +EvalUndefined: + mov $UNDEFINED,%ax +9: pop %bp + ret + +Intern: push %bp + xchg %di,%bx + mov $STR,%si +0: lodsb + test %al,%al + je 4f + xor %dx,%dx +1: mov %dx,%bp + mov %dx,%di + mov (%bx,%di),%cl + cmp %cl,%al + jne 3f + inc %dx + test %al,%al + jne 2f + mov %bp,%cx + sub %cx,%si + lea -STR-1(%si),%ax + jmp 6f +2: lodsb + jmp 1b +3: test %al,%al + je 0b + lodsb + jmp 3b +4: lea -1(%si),%dx + mov %dx,%di + xchg %bx,%si +0: lodsb + stosb + test %al,%al + jnz 0b + xchg %dx,%ax + sub $STR,%ax +6: shl %ax + pop %bp + ret + +//////////////////////////////////////////////////////////////////////////////// +.section .rodata,"a",@progbits + +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" + .string "" diff --git a/start.S b/start.S new file mode 100644 index 0000000..0376be3 --- /dev/null +++ b/start.S @@ -0,0 +1,45 @@ +/*-*- 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 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. │ +╚─────────────────────────────────────────────────────────────────────────────*/ +.section .start,"ax",@progbits +.globl _start +.code16 + +_start: jmp 1f # some bios scan for short jump +1: ljmp $0x600>>4,$_begin # end of bios data roundup page + +_begin: push %cs # memory model cs=ds=es = 0x600 + pop %ds + push %cs + pop %es + mov $0x70000>>4,%ax # last 64k of first 480k memory + cli # create stack in higher memory + mov %ax,%ss # carefully avoids i8086 errata + xor %sp,%sp + sti + cld + xor %ax,%ax + xor %di,%di + mov $0x7c00-0x600,%cx + rep stosb # clears our bss memory + xchg %di,%bx # start buffer at 07c00 + inc %cx # start at first sector + xor %dh,%dh # drive dl head zero + mov $0x0200+v_sectors,%ax # read sectors + int $0x13 # disk service + jmp main