mirror of
https://github.com/jart/cosmopolitan.git
synced 2025-07-07 19:58:30 +00:00
Add The LISP Challenge
This change introduces a 2.5kb program that's comes pretty close so far to bootstrapping John McCarthy's metacircular evaluator on bare metal.
This commit is contained in:
parent
fd22e55b42
commit
b6793d42d5
34 changed files with 1056 additions and 358 deletions
|
@ -49,6 +49,21 @@ o/$(MODE)/tool/build/emubin/%.bin.dbg: \
|
|||
$(TOOL_BUILD_EMUBIN_A).pkg
|
||||
@$(ELFLINK) -e emucrt -z max-page-size=0x10
|
||||
|
||||
o/dbg/tool/build/emubin/lisp.real.com.dbg: \
|
||||
$(TOOL_BUILD_EMUBIN_DEPS) \
|
||||
$(TOOL_BUILD_EMUBIN_A) \
|
||||
o/dbg/tool/build/emubin/lisp.real.o \
|
||||
$(CRT) \
|
||||
$(APE)
|
||||
-@$(APELINK)
|
||||
|
||||
o/tiny/tool/build/emubin/lisp.bin.dbg: \
|
||||
$(TOOL_BUILD_EMUBIN_DEPS) \
|
||||
o/tiny/tool/build/emubin/lisp.real.o \
|
||||
o/tiny/tool/build/emubin/lispstart.o \
|
||||
tool/build/emubin/lisp.lds
|
||||
@$(ELFLINK) -z max-page-size=0x10
|
||||
|
||||
o/tiny/tool/build/emubin/spiral.bin.dbg: \
|
||||
$(TOOL_BUILD_EMUBIN_DEPS) \
|
||||
o/tiny/tool/build/emubin/spiral.real.o
|
||||
|
|
52
tool/build/emubin/lisp.lds
Normal file
52
tool/build/emubin/lisp.lds
Normal file
|
@ -0,0 +1,52 @@
|
|||
/*-*- mode: ld-script; indent-tabs-mode: nil; tab-width: 2; coding: utf-8 -*-│
|
||||
│vi: set et sts=2 tw=2 fenc=utf-8 :vi│
|
||||
╞══════════════════════════════════════════════════════════════════════════════╡
|
||||
│ Copyright 2020 Justine Alexandra Roberts Tunney │
|
||||
│ │
|
||||
│ This program is free software; you can redistribute it and/or modify │
|
||||
│ it under the terms of the GNU General Public License as published by │
|
||||
│ the Free Software Foundation; version 2 of the License. │
|
||||
│ │
|
||||
│ This program is distributed in the hope that it will be useful, but │
|
||||
│ WITHOUT ANY WARRANTY; without even the implied warranty of │
|
||||
│ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU │
|
||||
│ General Public License for more details. │
|
||||
│ │
|
||||
│ You should have received a copy of the GNU General Public License │
|
||||
│ along with this program; if not, write to the Free Software │
|
||||
│ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA │
|
||||
│ 02110-1301 USA │
|
||||
╚─────────────────────────────────────────────────────────────────────────────*/
|
||||
|
||||
ENTRY(_start)
|
||||
|
||||
SECTIONS {
|
||||
|
||||
.text 0x7c00 - 0x600 : {
|
||||
*(.start)
|
||||
rodata = .;
|
||||
*(.rodata .rodata.*)
|
||||
. = 0x1fe;
|
||||
SHORT(0xaa55);
|
||||
*(.text .text.*)
|
||||
. = ALIGN(512);
|
||||
}
|
||||
|
||||
.bss : {
|
||||
bss = .;
|
||||
*(.bss .bss.*)
|
||||
*(COMMON)
|
||||
}
|
||||
|
||||
/DISCARD/ : {
|
||||
*(.*)
|
||||
}
|
||||
}
|
||||
|
||||
syntax = 0x600+2048*2;
|
||||
look = 0x600+2048*2+256;
|
||||
token = 0x600+2048*2+256+1;
|
||||
globals = 0x600+2048*2+256+1+16;
|
||||
index = 0x600+2048*2+256+1+16+2;
|
||||
str = 0x600+2048*2+256+1+16+2+4;
|
||||
v_sectors = SIZEOF(.text) / 512;
|
12
tool/build/emubin/lisp.lisp
Normal file
12
tool/build/emubin/lisp.lisp
Normal file
|
@ -0,0 +1,12 @@
|
|||
(DEFUN FF (X)
|
||||
(COND ((ATOM X) X)
|
||||
((QUOTE T) (FF (CAR X)))))
|
||||
(FF '(A B C))
|
||||
|
||||
((LABEL FF
|
||||
(LAMBDA (X)
|
||||
(COND ((ATOM X)
|
||||
X)
|
||||
((QUOTE T)
|
||||
(FF (CAR X))))))
|
||||
(QUOTE ((A B) C)))
|
632
tool/build/emubin/lisp.real.c
Normal file
632
tool/build/emubin/lisp.real.c
Normal file
|
@ -0,0 +1,632 @@
|
|||
/*-*- 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 │
|
||||
│ │
|
||||
│ This program is free software; you can redistribute it and/or modify │
|
||||
│ it under the terms of the GNU General Public License as published by │
|
||||
│ the Free Software Foundation; version 2 of the License. │
|
||||
│ │
|
||||
│ This program is distributed in the hope that it will be useful, but │
|
||||
│ WITHOUT ANY WARRANTY; without even the implied warranty of │
|
||||
│ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU │
|
||||
│ General Public License for more details. │
|
||||
│ │
|
||||
│ You should have received a copy of the GNU General Public License │
|
||||
│ along with this program; if not, write to the Free Software │
|
||||
│ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA │
|
||||
│ 02110-1301 USA │
|
||||
╚─────────────────────────────────────────────────────────────────────────────*/
|
||||
|
||||
#define TRACE 0
|
||||
#define ERRORS 1
|
||||
#define LONG long
|
||||
#define WORD short
|
||||
#define WORDS 2048
|
||||
|
||||
/*───────────────────────────────────────────────────────────────────────────│─╗
|
||||
│ The LISP Challenge § 8086 PC BIOS / x86_64 Linux System Integration ─╬─│┼
|
||||
╚────────────────────────────────────────────────────────────────────────────│*/
|
||||
|
||||
#define ATOM(x) /* a.k.a. !(x&1) */ \
|
||||
({ \
|
||||
char 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; \
|
||||
})
|
||||
|
||||
#define REAL_READ(BASE, INDEX, DISP) /* a.k.a. b[i] */ \
|
||||
({ \
|
||||
__typeof(*(BASE)) Reg; \
|
||||
if (__builtin_constant_p(INDEX) && !(INDEX)) { \
|
||||
asm("mov\t%c2(%1),%0" \
|
||||
: "=Q"(Reg) \
|
||||
: "bDS"(BASE), "i"((DISP) * sizeof(*(BASE)))); \
|
||||
} else { \
|
||||
asm("mov\t%c3(%1,%2),%0" \
|
||||
: "=Q"(Reg) \
|
||||
: "b"(BASE), "DS"((long)(INDEX) * sizeof(*(BASE))), \
|
||||
"i"((DISP) * sizeof(*(BASE)))); \
|
||||
} \
|
||||
Reg; \
|
||||
})
|
||||
|
||||
#define REAL_READ_ARRAY_FIELD(OBJECT, MEMBER, INDEX, DISP) /* o->m[i] */ \
|
||||
({ \
|
||||
__typeof(*(OBJECT->MEMBER)) Reg; \
|
||||
if (!(OBJECT)) { \
|
||||
asm("mov\t%c2(%1),%0" \
|
||||
: "=Q"(Reg) \
|
||||
: "bDS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \
|
||||
"i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \
|
||||
sizeof(*(OBJECT->MEMBER)) * (DISP))); \
|
||||
} else { \
|
||||
asm("mov\t%c3(%1,%2),%0" \
|
||||
: "=Q"(Reg) \
|
||||
: "b"(OBJECT), "DS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \
|
||||
"i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \
|
||||
sizeof(*(OBJECT->MEMBER)) * (DISP))); \
|
||||
} \
|
||||
Reg; \
|
||||
})
|
||||
|
||||
#define REAL_WRITE_ARRAY_FIELD(OBJECT, MEMBER, INDEX, DISP, VALUE) \
|
||||
do { \
|
||||
__typeof(*(OBJECT->MEMBER)) Reg; \
|
||||
if (!(OBJECT)) { \
|
||||
asm volatile("mov\t%0,%c2(%1)" \
|
||||
: /* manual output */ \
|
||||
: "Q"((__typeof(*(OBJECT->MEMBER)))(VALUE)), \
|
||||
"bDS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \
|
||||
"i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \
|
||||
sizeof(*(OBJECT->MEMBER)) * (DISP)) \
|
||||
: "memory"); \
|
||||
} else { \
|
||||
asm volatile("mov\t%0,%c3(%1,%2)" \
|
||||
: /* manual output */ \
|
||||
: "Q"((__typeof(*(OBJECT->MEMBER)))(VALUE)), "b"(OBJECT), \
|
||||
"DS"((long)(INDEX) * sizeof(*(OBJECT->MEMBER))), \
|
||||
"i"(__builtin_offsetof(__typeof(*(OBJECT)), MEMBER) + \
|
||||
sizeof(*(OBJECT->MEMBER)) * (DISP)) \
|
||||
: "memory"); \
|
||||
} \
|
||||
} while (0)
|
||||
|
||||
static 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 void *CopyMemory(void *di, 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__
|
||||
int rc;
|
||||
int c[14];
|
||||
asm volatile("syscall"
|
||||
: "=a"(rc)
|
||||
: "0"(0x10), "D"(0), "S"(0x5401), "d"(c)
|
||||
: "rcx", "r11", "memory");
|
||||
c[0] &= ~0b0000010111111000; // INPCK|ISTRIP|PARMRK|INLCR|IGNCR|ICRNL|IXON
|
||||
c[2] &= ~0b0000000100110000; // CSIZE|PARENB
|
||||
c[2] |= 0b00000000000110000; // CS8
|
||||
c[3] &= ~0b1000000001011010; // ECHONL|ECHO|ECHOE|IEXTEN|ICANON
|
||||
asm volatile("syscall"
|
||||
: "=a"(rc)
|
||||
: "0"(0x10), "D"(0), "S"(0x5402), "d"(c)
|
||||
: "rcx", "r11", "memory");
|
||||
#endif
|
||||
}
|
||||
|
||||
__attribute__((__noinline__)) static int PrintChar(LONG c) {
|
||||
#ifdef __REAL_MODE__
|
||||
asm volatile("mov\t$0x0E,%%ah\n\t"
|
||||
"int\t$0x10"
|
||||
: /* no outputs */
|
||||
: "a"(c), "b"(7)
|
||||
: "memory");
|
||||
return 0;
|
||||
#else
|
||||
static short buf;
|
||||
int rc;
|
||||
buf = c;
|
||||
asm volatile("syscall"
|
||||
: "=a"(rc)
|
||||
: "0"(1), "D"(1), "S"(&buf), "d"(1)
|
||||
: "rcx", "r11", "memory");
|
||||
return rc;
|
||||
#endif
|
||||
}
|
||||
|
||||
static void PrintString(char *s) {
|
||||
char c;
|
||||
for (;;) {
|
||||
if (!(c = REAL_READ(s, 0, 0))) break;
|
||||
PrintChar(c);
|
||||
++s;
|
||||
}
|
||||
}
|
||||
|
||||
static int XlatChar(LONG c) {
|
||||
if (c >= 'a') {
|
||||
asm volatile("" ::: "memory");
|
||||
if (c <= 'z') c -= 'a' - 'A';
|
||||
}
|
||||
return c;
|
||||
}
|
||||
|
||||
static int EchoChar(LONG c) {
|
||||
if (c == '\b' || c == 0x7F) {
|
||||
PrintString("\b \b");
|
||||
return '\b';
|
||||
} else {
|
||||
PrintChar(c);
|
||||
if (c == '\r') {
|
||||
PrintChar('\n');
|
||||
}
|
||||
return c;
|
||||
}
|
||||
}
|
||||
|
||||
static noinline int ReadChar(void) {
|
||||
int c;
|
||||
#ifdef __REAL_MODE__
|
||||
asm volatile("int\t$0x16" : "=a"(c) : "0"(0) : "memory");
|
||||
#else
|
||||
static int buf;
|
||||
asm volatile("syscall"
|
||||
: "=a"(c)
|
||||
: "0"(0), "D"(0), "S"(&buf), "d"(1)
|
||||
: "rcx", "r11", "memory");
|
||||
c = buf;
|
||||
#endif
|
||||
return EchoChar(XlatChar(c));
|
||||
}
|
||||
|
||||
/*───────────────────────────────────────────────────────────────────────────│─╗
|
||||
│ The LISP Challenge § LISP Machine ─╬─│┼
|
||||
╚────────────────────────────────────────────────────────────────────────────│*/
|
||||
|
||||
#define TYPE_ATOM 0
|
||||
#define TYPE_CONS 1
|
||||
|
||||
#define ATOM_NIL 0
|
||||
#define ATOM_T 8
|
||||
#define ATOM_QUOTE 12
|
||||
#define ATOM_ATOM 24
|
||||
#define ATOM_EQ 34
|
||||
#define ATOM_COND 40
|
||||
#define ATOM_CAR 50
|
||||
#define ATOM_CDR 58
|
||||
#define ATOM_CONS 66
|
||||
#define ATOM_LABEL 76
|
||||
#define ATOM_LAMBDA 88
|
||||
#define ATOM_SET 102
|
||||
#define ATOM_DEFUN 110
|
||||
|
||||
#define Quote(x) List(ATOM_QUOTE, x)
|
||||
#define List(x, y) Cons(x, Cons(y, ATOM_NIL))
|
||||
#define Caar(x) Car(Car(x)) // ((A B C D) (E F G) H I) → A
|
||||
#define Cdar(x) Cdr(Car(x)) // ((A B C D) (E F G) H I) → (B C D)
|
||||
#define Cadar(x) Cadr(Car(x)) // ((A B C D) (E F G) H I) → B
|
||||
#define Caddar(x) Caddr(Car(x)) // ((A B C D) (E F G) H I) → C
|
||||
#define Cadr(x) Car(Cdr(x)) // ((A B C D) (E F G) H I) → (E F G)
|
||||
#define Caddr(x) Cadr(Cdr(x)) // ((A B C D) (E F G) H I) → H
|
||||
|
||||
#define BOOL(x) ((x) ? ATOM_T : ATOM_NIL)
|
||||
#define VALUE(x) ((x) >> 1)
|
||||
|
||||
struct Lisp {
|
||||
WORD memory[WORDS];
|
||||
unsigned char syntax[256];
|
||||
unsigned char look;
|
||||
char token[16];
|
||||
WORD globals;
|
||||
int index;
|
||||
char str[WORDS];
|
||||
};
|
||||
|
||||
const char kSymbols[] aligned(1) = "\
|
||||
NIL\0T\0QUOTE\0ATOM\0EQ\0COND\0CAR\0CDR\0CONS\0LABEL\0LAMBDA\0SET\0DEFUN\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) {
|
||||
q->syntax[' '] = ' ';
|
||||
q->syntax['\t'] = ' ';
|
||||
q->syntax['\r'] = ' ';
|
||||
q->syntax['\n'] = ' ';
|
||||
q->syntax['('] = '(';
|
||||
q->syntax[')'] = ')';
|
||||
q->syntax['.'] = '.';
|
||||
q->syntax['\''] = '\'';
|
||||
}
|
||||
|
||||
forceinline WORD Car(LONG x) {
|
||||
return REAL_READ_ARRAY_FIELD(q, memory, VALUE(x), 0);
|
||||
}
|
||||
|
||||
forceinline WORD Cdr(LONG x) {
|
||||
return REAL_READ_ARRAY_FIELD(q, memory, VALUE(x), 1);
|
||||
}
|
||||
|
||||
static WORD Cons(WORD car, WORD cdr) {
|
||||
int i, c;
|
||||
i = q->index;
|
||||
REAL_WRITE_ARRAY_FIELD(q, memory, i, 0, car);
|
||||
REAL_WRITE_ARRAY_FIELD(q, memory, i, 1, cdr);
|
||||
q->index += 2;
|
||||
c = OBJECT(TYPE_CONS, i);
|
||||
return c;
|
||||
}
|
||||
|
||||
static void SetupBuiltins(void) {
|
||||
CopyMemory(q->str, kSymbols, sizeof(kSymbols));
|
||||
q->globals =
|
||||
Cons(Cons(ATOM_NIL, ATOM_NIL), Cons(Cons(ATOM_T, ATOM_T), ATOM_NIL));
|
||||
}
|
||||
|
||||
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 != REAL_READ(s, j, 0)) {
|
||||
break;
|
||||
}
|
||||
if (!c) {
|
||||
return OBJECT(TYPE_ATOM, z - q->str - j - 1);
|
||||
}
|
||||
c = LODS(z);
|
||||
}
|
||||
while (c) c = LODS(z);
|
||||
c = LODS(z);
|
||||
}
|
||||
--z;
|
||||
StpCpy(z, s);
|
||||
return OBJECT(TYPE_ATOM, SUB((long)z, q->str));
|
||||
}
|
||||
|
||||
forceinline unsigned char XlatSyntax(unsigned char b) {
|
||||
return REAL_READ_ARRAY_FIELD(q, syntax, b, 0); /* a.k.a. q->syntax[b] */
|
||||
}
|
||||
|
||||
static void GetToken(void) {
|
||||
char *t;
|
||||
unsigned char b;
|
||||
b = q->look;
|
||||
t = q->token;
|
||||
while (XlatSyntax(b) == ' ') {
|
||||
b = ReadChar();
|
||||
}
|
||||
if (XlatSyntax(b)) {
|
||||
STOS(t, b);
|
||||
b = ReadChar();
|
||||
} else {
|
||||
while (b && !XlatSyntax(b)) {
|
||||
if (b != '\b') {
|
||||
STOS(t, b);
|
||||
} else if (t > q->token) {
|
||||
--t;
|
||||
}
|
||||
b = ReadChar();
|
||||
}
|
||||
}
|
||||
STOS(t, 0);
|
||||
q->look = b;
|
||||
}
|
||||
|
||||
static WORD ConsumeObject(void) {
|
||||
GetToken();
|
||||
return GetObject();
|
||||
}
|
||||
|
||||
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 AddList(GetQuote());
|
||||
case ')':
|
||||
return ATOM_NIL;
|
||||
case '.':
|
||||
return ConsumeObject();
|
||||
}
|
||||
}
|
||||
|
||||
static WORD GetObject(void) {
|
||||
switch (*q->token & 0xFF) {
|
||||
default:
|
||||
return Intern(q->token);
|
||||
case '\'':
|
||||
return GetQuote();
|
||||
case '(':
|
||||
return GetList();
|
||||
}
|
||||
}
|
||||
|
||||
static WORD ReadObject(void) {
|
||||
q->look = ReadChar();
|
||||
GetToken();
|
||||
return GetObject();
|
||||
}
|
||||
|
||||
static WORD Read(void) {
|
||||
return ReadObject();
|
||||
}
|
||||
|
||||
static void PrintAtom(LONG x) {
|
||||
PrintString(q->str + VALUE(x));
|
||||
}
|
||||
|
||||
static void PrintList(LONG x) {
|
||||
PrintChar('(');
|
||||
PrintObject(Car(x));
|
||||
while ((x = Cdr(x))) {
|
||||
if (!ATOM(x)) {
|
||||
PrintChar(' ');
|
||||
PrintObject(Car(x));
|
||||
} else {
|
||||
PrintString(" . ");
|
||||
PrintObject(x);
|
||||
}
|
||||
}
|
||||
PrintChar(')');
|
||||
}
|
||||
|
||||
static void PrintObject(LONG x) {
|
||||
if (ATOM(x)) {
|
||||
PrintAtom(x);
|
||||
} else {
|
||||
PrintList(x);
|
||||
}
|
||||
}
|
||||
|
||||
static void Print(LONG i) {
|
||||
PrintObject(i);
|
||||
PrintString("\r\n");
|
||||
}
|
||||
|
||||
__attribute__((__noreturn__)) static void Reset(void) {
|
||||
asm volatile("jmp\tRepl");
|
||||
__builtin_unreachable();
|
||||
}
|
||||
|
||||
__attribute__((__noreturn__)) static void OnUndefined(LONG x) {
|
||||
PrintString("UNDEF! ");
|
||||
Print(x);
|
||||
Reset();
|
||||
}
|
||||
|
||||
__attribute__((__noreturn__)) static void OnArity(void) {
|
||||
PrintString("ARITY!\n");
|
||||
Reset();
|
||||
}
|
||||
|
||||
#if !ERRORS
|
||||
#define OnUndefined(x) __builtin_unreachable()
|
||||
#define OnArity() __builtin_unreachable()
|
||||
#endif
|
||||
|
||||
/*───────────────────────────────────────────────────────────────────────────│─╗
|
||||
│ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator ─╬─│┼
|
||||
╚────────────────────────────────────────────────────────────────────────────│*/
|
||||
|
||||
static WORD Atom(LONG x) {
|
||||
return BOOL(ATOM(x));
|
||||
}
|
||||
|
||||
static WORD Null(LONG x) {
|
||||
return BOOL(!x);
|
||||
}
|
||||
|
||||
static WORD Eq(LONG x, LONG y) {
|
||||
return BOOL(x == y); /* undefiled if !ATOM(x)||!ATOM(y) */
|
||||
}
|
||||
|
||||
static WORD Assoc(LONG x, LONG y) {
|
||||
for (;;) {
|
||||
if (!y) OnUndefined(x);
|
||||
if (Eq(Caar(y), x)) break;
|
||||
y = Cdr(y);
|
||||
}
|
||||
return Cdar(y);
|
||||
}
|
||||
|
||||
static WORD Append(LONG x, LONG y) {
|
||||
if (x) {
|
||||
return Cons(Car(x), Append(Cdr(x), y));
|
||||
} else {
|
||||
return y;
|
||||
}
|
||||
}
|
||||
|
||||
/**
|
||||
* Gives list of pairs of corresponding elements of the lists x and y.
|
||||
* E.g. pair[(A,B,C);(X,(Y,Z),U)] = ((A.X),(B.(Y,Z)),(C.U))
|
||||
* @note recoded to make lists in dot notation
|
||||
* @note it's zip() basically
|
||||
*/
|
||||
static WORD Pair(LONG x, LONG y) {
|
||||
if (!x && !y) {
|
||||
return ATOM_NIL;
|
||||
} else if (!ATOM(x) && !ATOM(y)) {
|
||||
return Cons(Cons(Car(x), Car(y)), Pair(Cdr(x), Cdr(y)));
|
||||
} else {
|
||||
OnArity();
|
||||
}
|
||||
}
|
||||
|
||||
static WORD Appq(long m) {
|
||||
if (m) {
|
||||
return Cons(List(ATOM_QUOTE, Car(m)), Appq(Cdr(m)));
|
||||
} else {
|
||||
return ATOM_NIL;
|
||||
}
|
||||
}
|
||||
|
||||
static WORD Apply(long f, long a) {
|
||||
return Eval(Cons(f, Appq(a)), ATOM_NIL);
|
||||
}
|
||||
|
||||
static WORD Evcon(LONG c, LONG a) {
|
||||
if (Eval(Caar(c), a)) {
|
||||
return Eval(Cadar(c), a);
|
||||
} else {
|
||||
return Evcon(Cdr(c), a);
|
||||
}
|
||||
}
|
||||
|
||||
static WORD Evlis(LONG m, LONG a) {
|
||||
if (m) {
|
||||
return Cons(Eval(Car(m), a), Evlis(Cdr(m), a));
|
||||
} else {
|
||||
return ATOM_NIL;
|
||||
}
|
||||
}
|
||||
|
||||
static WORD Set(LONG e) {
|
||||
WORD name, value;
|
||||
name = Car(e);
|
||||
value = Cadr(e);
|
||||
q->globals = Cons(Cons(name, value), q->globals);
|
||||
return value;
|
||||
}
|
||||
|
||||
static WORD Defun(LONG e) {
|
||||
WORD name, args, body, lamb;
|
||||
name = Car(e);
|
||||
args = Cadr(e);
|
||||
body = Caddr(e);
|
||||
lamb = Cons(ATOM_LAMBDA, List(args, body));
|
||||
q->globals = Cons(Cons(name, lamb), q->globals);
|
||||
return name;
|
||||
}
|
||||
|
||||
static WORD Evaluate(LONG e, LONG a) {
|
||||
if (ATOM(e)) {
|
||||
return Assoc(e, a);
|
||||
} else if (ATOM(Car(e))) {
|
||||
switch (Car(e)) {
|
||||
case ATOM_QUOTE:
|
||||
return Cadr(e);
|
||||
case ATOM_ATOM:
|
||||
return Atom(Eval(Cadr(e), a));
|
||||
case ATOM_EQ:
|
||||
return Eq(Eval(Cadr(e), a), Eval(Caddr(e), a));
|
||||
case ATOM_COND:
|
||||
return Evcon(Cdr(e), a);
|
||||
case ATOM_CAR:
|
||||
return Car(Eval(Cadr(e), a));
|
||||
case ATOM_CDR:
|
||||
return Cdr(Eval(Cadr(e), a));
|
||||
case ATOM_CONS:
|
||||
return Cons(Eval(Cadr(e), a), Eval(Caddr(e), a));
|
||||
case ATOM_DEFUN:
|
||||
return Defun(Cdr(e));
|
||||
case ATOM_SET:
|
||||
return Set(Cdr(e));
|
||||
default:
|
||||
return Eval(Cons(Assoc(Car(e), a), Evlis(Cdr(e), a)), a);
|
||||
}
|
||||
} else if (Eq(Caar(e), ATOM_LABEL)) {
|
||||
return Eval(Cons(Caddar(e), Cdr(e)), Cons(Cons(Cadar(e), Car(e)), a));
|
||||
} else if (Eq(Caar(e), ATOM_LAMBDA)) {
|
||||
return Eval(Caddar(e), Append(Pair(Cadar(e), Evlis(Cdr(e), a)), a));
|
||||
} else {
|
||||
OnUndefined(Caar(e));
|
||||
}
|
||||
}
|
||||
|
||||
static WORD Eval(LONG e, LONG a) {
|
||||
#if TRACE
|
||||
PrintString("->");
|
||||
Print(e);
|
||||
#endif
|
||||
e = Evaluate(e, a);
|
||||
#if TRACE
|
||||
PrintString("<-");
|
||||
Print(e);
|
||||
#endif
|
||||
return e;
|
||||
}
|
||||
|
||||
/*───────────────────────────────────────────────────────────────────────────│─╗
|
||||
│ The LISP Challenge § User Interface ─╬─│┼
|
||||
╚────────────────────────────────────────────────────────────────────────────│*/
|
||||
|
||||
void Repl(void) {
|
||||
for (;;) {
|
||||
PrintString("* ");
|
||||
Print(Eval(Read(), q->globals));
|
||||
}
|
||||
}
|
||||
|
||||
int main(int argc, char *argv[]) {
|
||||
RawMode();
|
||||
SetupSyntax();
|
||||
SetupBuiltins();
|
||||
PrintString("THE LISP CHALLENGE V1\r\n"
|
||||
"VISIT GITHUB.COM/JART\r\n");
|
||||
Repl();
|
||||
return 0;
|
||||
}
|
52
tool/build/emubin/lispstart.S
Normal file
52
tool/build/emubin/lispstart.S
Normal file
|
@ -0,0 +1,52 @@
|
|||
/*-*- 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 │
|
||||
│ │
|
||||
│ This program is free software; you can redistribute it and/or modify │
|
||||
│ it under the terms of the GNU General Public License as published by │
|
||||
│ the Free Software Foundation; version 2 of the License. │
|
||||
│ │
|
||||
│ This program is distributed in the hope that it will be useful, but │
|
||||
│ WITHOUT ANY WARRANTY; without even the implied warranty of │
|
||||
│ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU │
|
||||
│ General Public License for more details. │
|
||||
│ │
|
||||
│ You should have received a copy of the GNU General Public License │
|
||||
│ along with this program; if not, write to the Free Software │
|
||||
│ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA │
|
||||
│ 02110-1301 USA │
|
||||
╚─────────────────────────────────────────────────────────────────────────────*/
|
||||
|
||||
.code16
|
||||
.section .start,"ax",@progbits
|
||||
_start: jmp 1f
|
||||
1: ljmp $0x600>>4,$2f
|
||||
2: push %cs
|
||||
pop %ds
|
||||
push %cs
|
||||
pop %es
|
||||
mov $0x70000>>4,%ax
|
||||
cli
|
||||
mov %ax,%ss
|
||||
xor %sp,%sp
|
||||
sti
|
||||
cld
|
||||
xor %ax,%ax
|
||||
xor %di,%di
|
||||
mov $0x7c00-0x600,%cx
|
||||
rep stosb
|
||||
xchg %di,%bx
|
||||
inc %cx
|
||||
xor %dh,%dh
|
||||
mov $v_sectors+0x0200,%ax
|
||||
int $0x13
|
||||
xor %bp,%bp
|
||||
sub $6,%sp
|
||||
call main
|
||||
nop
|
||||
.type _start,@function
|
||||
.size _start,.-_start
|
||||
.globl _start
|
||||
.globl v_sectors
|
||||
.globl main
|
|
@ -19,6 +19,7 @@
|
|||
╚─────────────────────────────────────────────────────────────────────────────*/
|
||||
#include "tool/build/emubin/poke.h"
|
||||
#include "tool/build/emubin/real.h"
|
||||
#include "tool/build/emubin/realstart.inc"
|
||||
|
||||
/*
|
||||
m=tiny; make -j12 MODE=$m o/$m/tool/build/{tinyemu,emulator}.com \
|
||||
|
|
|
@ -3,14 +3,6 @@
|
|||
#if !(__ASSEMBLER__ + __LINKER__ + 0)
|
||||
COSMOPOLITAN_C_START_
|
||||
|
||||
asm(".pushsection .start,\"ax\",@progbits\n\t"
|
||||
".globl\t_start\n"
|
||||
"_start:\n\t"
|
||||
"jmp\t1f\n1:\t"
|
||||
"call\tmain\n\t"
|
||||
"nop\n\t"
|
||||
".popsection");
|
||||
|
||||
forceinline void SetEs(int base) {
|
||||
asm volatile("mov%z0\t%0,%%es" : /* no outputs */ : "r"(base));
|
||||
}
|
||||
|
|
7
tool/build/emubin/realstart.inc
Normal file
7
tool/build/emubin/realstart.inc
Normal file
|
@ -0,0 +1,7 @@
|
|||
asm(".pushsection .start,\"ax\",@progbits\n\t"
|
||||
".globl\t_start\n"
|
||||
"_start:\n\t"
|
||||
"jmp\t1f\n1:\t"
|
||||
"call\tmain\n\t"
|
||||
"nop\n\t"
|
||||
".popsection");
|
|
@ -19,6 +19,7 @@
|
|||
╚─────────────────────────────────────────────────────────────────────────────*/
|
||||
#include "tool/build/emubin/poke.h"
|
||||
#include "tool/build/emubin/real.h"
|
||||
#include "tool/build/emubin/realstart.inc"
|
||||
|
||||
#define signbit(x) __builtin_signbit(x)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue