sjs/sectorlisp
1
0
Fork 0
mirror of https://github.com/samsonjs/sectorlisp.git synced 2026-04-27 14:57:41 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Initial import

Browse source
This commit is contained in:
Justine Tunney 2020-10-26 11:25:18 -07:00
commit a561e031ae
17 changed files with 1639 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
/lisp
/*.o
/*.bin
/*.bin.dbg

66
Makefile Normal file
View file

@ -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 $< $@

14
NOTICE Normal file
View file

@ -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.

48
README.md Normal file
View file

@ -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.
<p align="center">
<img alt="Binary Footprint Comparison"
width="750" height="348" src="bin/footprint.png">
</p>
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
<p align="center">
<a href="https://youtu.be/hvTHZ6E0Abo">
<img alt="booting sectorlisp in emulator"
width="960" height="540" src="bin/sectorlisp.gif"></a>
</p>
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).

BIN
bin/footprint.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 11 KiB

BIN
bin/lisp.elf.linux Executable file
View file

Binary file not shown.

BIN
bin/sectorlisp.bin Executable file
View file

Binary file not shown.

BIN
bin/sectorlisp.gif Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 2.4 MiB

BIN
bin/yodawg.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 63 KiB

452
lisp.c Normal file
View file

@ -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;
}

180
lisp.h Normal file
View file

@ -0,0 +1,180 @@
#ifndef SECTORLISP_H_
#define SECTORLISP_H_
#include <unistd.h>
#include <termios.h>
#include <sys/ioctl.h>
/*───────────────────────────────────────────────────────────────────────────│─╗
│ 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_ */

35
lisp.lds Normal file
View file

@ -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;

116
lisp.lisp Normal file
View file

@ -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)))))))

177
realify.sed Normal file
View file

@ -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//

23
realify.sh Executable file
View file

@ -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 "$@"

479
sectorlisp.S Normal file
View file

@ -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 ""

45
start.S Normal file
View file

@ -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