cosmopolitan/tool/build/emubin/lisp.c

736 lines
22 KiB
C
Raw Normal View History

/*-*- 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.
*/
#define TRACE 0
#define ERRORS 1
#define LONG long
#define WORD short
#define WORDS 8192
/*───────────────────────────────────────────────────────────────────────────│─╗
The LISP Challenge § Impure x86_64 Linux 8086 PC BIOS System Integration
*/
#define TYPE(x) /* a.k.a. x&1 */ \
({ \
char IsAtom; \
asm("test%z1\t$1,%1" : "=@ccnz"(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_(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; \
})
/* #ifdef __REAL_MODE__ */
#define REAL_READ(BASE, INDEX, DISP) /* a.k.a. b[i] */ \
(sizeof(*(BASE)) == 1 ? REAL_READ_("=Q", BASE, INDEX, DISP) \
: REAL_READ_("=r", BASE, INDEX, DISP))
/* #else */
/* #define REAL_READ(BASE, INDEX, DISP) BASE[INDEX + DISP] */
/* #endif */
#define REAL_READ_ARRAY_FIELD_(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; \
})
/* #ifdef __REAL_MODE__ */
#define REAL_READ_ARRAY_FIELD(OBJECT, MEMBER, INDEX, DISP) /* o->m[i] */ \
(sizeof(*(OBJECT->MEMBER)) == 1 \
? REAL_READ_ARRAY_FIELD_("=Q", OBJECT, MEMBER, INDEX, DISP) \
: REAL_READ_ARRAY_FIELD_("=r", OBJECT, MEMBER, INDEX, DISP))
/* #else */
/* #define REAL_READ_ARRAY_FIELD(o, m, i, d) o->m[i + d] */
/* #endif */
#define REAL_WRITE_ARRAY_FIELD_(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)
/* #ifdef __REAL_MODE__ */
#define REAL_WRITE_ARRAY_FIELD(OBJECT, MEMBER, INDEX, DISP, VALUE) \
do { \
__typeof(*(OBJECT->MEMBER)) Reg; \
switch (sizeof(*(OBJECT->MEMBER))) { \
case 1: \
REAL_WRITE_ARRAY_FIELD_("Q", OBJECT, MEMBER, INDEX, DISP, VALUE); \
break; \
default: \
REAL_WRITE_ARRAY_FIELD_("ri", OBJECT, MEMBER, INDEX, DISP, VALUE); \
break; \
} \
} while (0)
/* #else */
/* #define REAL_WRITE_ARRAY_FIELD(o, m, i, d, v) o->m[i + d] = v */
/* #endif */
long jb[8];
int setjmp(void *) __attribute__((__returns_twice__));
int longjmp(void *, int) __attribute__((__noreturn__));
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, 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 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;
asm volatile("syscall"
: "=a"(rc)
: "0"(1), "D"(1), "S"(&buf), "d"(1)
: "rcx", "r11", "memory");
#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 == 0x7F) return '\b';
if (c >= 'a') {
asm volatile("" ::: "memory");
if (c <= 'z') c -= 'a' - 'A';
}
return c;
}
static int EchoChar(LONG c) {
if (c != '\b') {
PrintChar(c);
if (c == '\r') {
PrintChar('\n');
}
}
return c;
}
__attribute__((__noinline__)) 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 § Pure Original LISP Machine
*/
#define ATOM 0
#define CONS 1
#define 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, 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 : NIL)
#define VALUE(x) ((x) >> 1)
#define PTR(i) ((i) << 1 | CONS)
#define ARRAYLEN(A) \
((sizeof(A) / sizeof(*(A))) / ((unsigned)!(sizeof(A) % sizeof(*(A)))))
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\0T\0QUOTE\0ATOM\0EQ\0COND\0CAR\0CDR\0CONS\0LABEL\0LAMBDA\0SET\0DEFUN\0";
_Alignas(WORD) const WORD kGlobals[] = {
[0] = PTR(2), // ((T . T) (NIL . NIL))
[1] = PTR(4), //
[2] = ATOM_T, // (T . T)
[3] = ATOM_T, //
[4] = PTR(6), // ((NIL . NIL))
[5] = NIL, //
[6] = NIL, // (NIL . NIL)
[7] = NIL, //
};
#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['\''] = '\'';
}
static inline WORD Car(LONG x) {
return REAL_READ_ARRAY_FIELD(q, mem, VALUE(x), 0);
}
static inline WORD Cdr(LONG x) {
return REAL_READ_ARRAY_FIELD(q, mem, VALUE(x), 1);
}
static WORD Cons(WORD car, WORD cdr) {
#if TRACE
PrintString("CONS->");
Print(car);
PrintString(" ");
Print(cdr);
#endif
int i, cell;
i = q->index;
REAL_WRITE_ARRAY_FIELD(q, mem, i, 0, car);
REAL_WRITE_ARRAY_FIELD(q, mem, i, 1, cdr);
q->index = i + 2;
cell = OBJECT(CONS, i);
#if TRACE
PrintString("CONS<-");
Print(cell);
#endif
return cell;
}
static void SetupBuiltins(void) {
CopyMemory(q->str, kSymbols, sizeof(kSymbols));
CopyMemory(q->mem, kGlobals, sizeof(kGlobals));
q->index = ARRAYLEN(kGlobals);
q->globals = PTR(0);
}
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;
}
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(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));
}
forceinline unsigned char XlatSyntax(unsigned char b) {
return REAL_READ_ARRAY_FIELD(q, syntax, b, 0);
}
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) {
PrintString("\b \b");
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 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 (TYPE(x) == CONS) {
PrintChar(' ');
PrintObject(Car(x));
} else {
PrintString(" . ");
PrintObject(x);
}
}
PrintChar(')');
}
static void PrintObject(LONG x) {
if (TYPE(x) == ATOM) {
PrintAtom(x);
} else {
PrintList(x);
}
}
static void Print(LONG i) {
PrintObject(i);
PrintString("\r\n");
}
__attribute__((__noreturn__)) static void Reset(void) {
longjmp(jb, 1);
}
__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(TYPE(x) == ATOM);
}
static WORD Null(LONG x) {
return BOOL(!x);
}
static WORD Eq(LONG x, LONG y) {
return BOOL(x == y); /* undefined if !Atom(x)||!Atom(y) */
}
static WORD Assoc(LONG x, LONG y) {
if (Null(y)) OnUndefined(x);
if (Eq(Caar(y), x)) return Cdar(y);
return Assoc(x, Cdr(y));
}
static WORD Append(LONG x, LONG y) {
#if TRACE
PrintString("APPEND->");
Print(x);
PrintString(" ");
Print(y);
#endif
if (!Null(x)) {
x = Cons(Car(x), Append(Cdr(x), y));
} else {
x = y;
}
#if TRACE
PrintString("APPEND<-");
Print(x);
#endif
return x;
}
/**
* 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 (Null(x) && Null(y)) {
return NIL;
} else if (TYPE(x) == CONS && TYPE(y) == CONS) {
return Cons(Cons(Car(x), Car(y)), Pair_(Cdr(x), Cdr(y)));
} else {
OnArity();
}
}
static WORD Pair(LONG x, LONG y) {
#if TRACE
PrintString("PAIR->");
Print(x);
PrintString(" ");
Print(y);
#endif
x = Pair_(x, y);
#if TRACE
PrintString("PAIR<-");
Print(x);
#endif
return x;
}
static WORD Appq(long m) {
if (m) {
return Cons(List(ATOM_QUOTE, Car(m)), Appq(Cdr(m)));
} else {
return NIL;
}
}
static WORD Apply(long f, long a) {
return Eval(Cons(f, Appq(a)), 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 NIL;
}
}
static WORD Evlis(LONG m, LONG a) {
#if TRACE
PrintString("EVLIS->");
Print(m);
PrintString(" ");
Print(a);
#endif
m = Evlis_(m, a);
#if TRACE
PrintString("EVLIS<-");
Print(m);
#endif
return m;
}
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);
PrintString(" ");
Print(a);
#endif
e = Evaluate(e, a);
#if TRACE
PrintString("<-");
Print(e);
#endif
return e;
}
/*───────────────────────────────────────────────────────────────────────────│─╗
The LISP Challenge § User Interface
*/
void Repl(void) {
setjmp(jb);
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;
}