Monorepo for Aesthetic.Computer
aesthetic.computer
1/* tinylisp-opt.c with NaN boxing (optimized version) by Robert A. van Engelen 2022 */
2#include <stdlib.h>
3#include <stdio.h>
4#include <string.h>
5#define I unsigned
6#define L double
7#define T(x) *(unsigned long long*)&x>>48
8#define A (char*)cell
9#define N 1024
10I hp=0,sp=N,ATOM=0x7ff8,PRIM=0x7ff9,CONS=0x7ffa,CLOS=0x7ffb,NIL=0x7ffc;
11L cell[N],nil,tru,err,env;
12L box(I t,I i) { L x; *(unsigned long long*)&x = (unsigned long long)t<<48|i; return x; }
13I ord(L x) { return *(unsigned long long*)&x; }
14L num(L n) { return n; }
15I equ(L x,L y) { return *(unsigned long long*)&x == *(unsigned long long*)&y; }
16L atom(const char *s) {
17 I i = 0; while (i < hp && strcmp(A+i,s)) i += strlen(A+i)+1;
18 if (i == hp && (hp += strlen(strcpy(A+i,s))+1) > sp<<3) abort();
19 return box(ATOM,i);
20}
21L cons(L x,L y) { cell[--sp] = x; cell[--sp] = y; if (hp > sp<<3) abort(); return box(CONS,sp); }
22L car(L p) { return (T(p)&~(CONS^CLOS)) == CONS ? cell[ord(p)+1] : err; }
23L cdr(L p) { return (T(p)&~(CONS^CLOS)) == CONS ? cell[ord(p)] : err; }
24L pair(L v,L x,L e) { return cons(cons(v,x),e); }
25L closure(L v,L x,L e) { return box(CLOS,ord(pair(v,x,equ(e,env) ? nil : e))); }
26L assoc(L v,L e) { while (T(e) == CONS && !equ(v,car(car(e)))) e = cdr(e); return T(e) == CONS ? cdr(car(e)) : err; }
27I not(L x) { return T(x) == NIL; }
28I let(L x) { return !not(x) && !not(cdr(x)); }
29L eval(L,L),parse();
30L evlis(L t,L e) {
31 L s,*p;
32 for (s = nil,p = &s; T(t) == CONS; p = cell+sp,t = cdr(t)) *p = cons(eval(car(t),e),nil);
33 if (T(t) == ATOM) *p = assoc(t,e);
34 return s;
35}
36L evarg(L *t,L *e,I *a) {
37 L x;
38 if (T(*t) == ATOM) *t = assoc(*t,*e),*a = 1;
39 x = car(*t); *t = cdr(*t);
40 return *a ? x : eval(x,*e);
41}
42L f_eval(L t,L *e) { I a = 0; return evarg(&t,e,&a); }
43L f_quote(L t,L *_) { return car(t); }
44L f_cons(L t,L *e) { I a = 0; L x = evarg(&t,e,&a); return cons(x,evarg(&t,e,&a)); }
45L f_car(L t,L *e) { I a = 0; return car(evarg(&t,e,&a)); }
46L f_cdr(L t,L *e) { I a = 0; return cdr(evarg(&t,e,&a)); }
47L f_add(L t,L *e) { I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n += evarg(&t,e,&a); return num(n); }
48L f_sub(L t,L *e) { I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n -= evarg(&t,e,&a); return num(n); }
49L f_mul(L t,L *e) { I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n *= evarg(&t,e,&a); return num(n); }
50L f_div(L t,L *e) { I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n /= evarg(&t,e,&a); return num(n); }
51L f_int(L t,L *e) { I a = 0; L n = evarg(&t,e,&a); return n<1e16 && n>-1e16 ? (long long)n : n; }
52L f_lt(L t,L *e) { I a = 0; L n = evarg(&t,e,&a); return n - evarg(&t,e,&a) < 0 ? tru : nil; }
53L f_eq(L t,L *e) { I a = 0; L x = evarg(&t,e,&a); return equ(x,evarg(&t,e,&a)) ? tru : nil; }
54L f_pair(L t,L *e) { I a = 0; L x = evarg(&t,e,&a); return T(x) == CONS ? tru : nil; }
55L f_not(L t,L *e) { I a = 0; return not(evarg(&t,e,&a)) ? tru : nil; }
56L f_or(L t,L *e) { I a = 0; L x = nil; while (!not(t) && not(x)) x = evarg(&t,e,&a); return x; }
57L f_and(L t,L *e) { I a = 0; L x = tru; while (!not(t) && !not(x)) x = evarg(&t,e,&a); return x; }
58L f_cond(L t,L *e) { while (!not(t) && not(eval(car(car(t)),*e))) t = cdr(t); return car(cdr(car(t))); }
59L f_if(L t,L *e) { return car(cdr(not(eval(car(t),*e)) ? cdr(t) : t)); }
60L f_leta(L t,L *e) { for (; let(t); t = cdr(t)) *e = pair(car(car(t)),eval(car(cdr(car(t))),*e),*e); return car(t); }
61L f_lambda(L t,L *e) { return closure(car(t),car(cdr(t)),*e); }
62L f_define(L t,L *e) { env = pair(car(t),eval(car(cdr(t)),*e),env); return car(t); }
63struct { const char *s; L (*f)(L,L*); short t; } prim[] = {
64{"eval", f_eval, 1},{"quote", f_quote, 0},{"cons", f_cons,0},{"car", f_car, 0},{"cdr",f_cdr,0},{"+", f_add, 0},
65{"-", f_sub, 0},{"*", f_mul, 0},{"/", f_div, 0},{"int", f_int, 0},{"<", f_lt, 0},{"eq?", f_eq, 0},
66{"or", f_or, 0},{"and", f_and, 0},{"not", f_not, 0},{"cond",f_cond,1},{"if", f_if, 1},{"let*",f_leta,1},
67{"lambda",f_lambda,0},{"define",f_define,0},{"pair?",f_pair,0},{0}};
68void assign(L v,L x,L e) { while (!equ(v,car(car(e)))) e = cdr(e); cell[ord(car(e))] = x; }
69L eval(L x,L e) {
70 I a; L f,v,d,g = nil,h;
71 while (1) {
72 if (T(x) == ATOM) return assoc(x,e);
73 if (T(x) != CONS) return x;
74 f = eval(car(x),e); x = cdr(x);
75 if (T(f) == PRIM) {
76 x = prim[ord(f)].f(x,&e);
77 if (prim[ord(f)].t) continue;
78 return x;
79 }
80 if (T(f) != CLOS) return err;
81 v = car(car(f));
82 if (equ(f,g)) d = e;
83 else if (not(d = cdr(f))) d = env;
84 for (a = 0; T(v) == CONS; v = cdr(v)) d = pair(car(v),evarg(&x,&e,&a),d);
85 if (T(v) == ATOM) d = pair(v,a ? x : evlis(x,e),d);
86 if (equ(f,g)) {
87 for (; !equ(d,e) && sp == ord(d); d = cdr(d),sp += 4) assign(car(car(d)),cdr(car(d)),e);
88 for (; !equ(d,h) && sp == ord(d); d = cdr(d)) sp += 4;
89 }
90 x = cdr(car(f)); e = d; g = f; h = e;
91 }
92}
93char buf[40],see = ' ';
94void look() { int c = getchar(); see = c; if (c == EOF) exit(0); }
95I seeing(char c) { return c == ' ' ? see > 0 && see <= c : see == c; }
96char get() { char c = see; look(); return c; }
97char scan() {
98 int i = 0;
99 while (seeing(' ')) look();
100 if (seeing('(') || seeing(')') || seeing('\'')) buf[i++] = get();
101 else do buf[i++] = get(); while (i < 39 && !seeing('(') && !seeing(')') && !seeing(' '));
102 return buf[i] = 0,*buf;
103}
104L Read() { return scan(),parse(); }
105L list() {
106 L t,*p;
107 for (t = nil,p = &t; ; *p = cons(parse(),nil),p = cell+sp) {
108 if (scan() == ')') return t;
109 if (*buf == '.' && !buf[1]) return *p = Read(),scan(),t;
110 }
111}
112L parse() {
113 L n; int i;
114 if (*buf == '(') return list();
115 if (*buf == '\'') return cons(atom("quote"),cons(Read(),nil));
116 return sscanf(buf,"%lg%n",&n,&i) > 0 && !buf[i] ? n : atom(buf);
117}
118void print(L);
119void printlist(L t) {
120 for (putchar('('); ; putchar(' ')) {
121 print(car(t));
122 if (not(t = cdr(t))) break;
123 if (T(t) != CONS) { printf(" . "); print(t); break; }
124 }
125 putchar(')');
126}
127void print(L x) {
128 if (T(x) == NIL) printf("()");
129 else if (T(x) == ATOM) printf("%s",A+ord(x));
130 else if (T(x) == PRIM) printf("<%s>",prim[ord(x)].s);
131 else if (T(x) == CONS) printlist(x);
132 else if (T(x) == CLOS) printf("{%u}",ord(x));
133 else printf("%.10lg",x);
134}
135void gc() { sp = ord(env); }
136int main() {
137 I i; printf("tinylisp");
138 nil = box(NIL,0); err = atom("ERR"); tru = atom("#t"); env = pair(tru,tru,nil);
139 for (i = 0; prim[i].s; ++i) env = pair(atom(prim[i].s),box(PRIM,i),env);
140 while (1) { printf("\n%u>",sp-hp/8); print(eval(Read(),env)); gc(); }
141}