This change introduces a 2.5kb program that's comes pretty close so far to bootstrapping John McCarthy's metacircular evaluator on bare metal.main
Justine Tunney
2 years ago
parent
fd22e55b42
commit
b6793d42d5
@ -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; |
||||
@ -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))) |
||||
@ -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; |
||||
} |
||||
@ -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
|
||||
@ -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"); |
||||