aesthetic.computer
Monorepo for Aesthetic.Computer
aesthetic.computer
1/* tinylisp-float.c with single float precision NaN boxing 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 float
7#define T(x) *(uint32_t*)&x>>20
8#define A (char*)cell
9#define N 1024 /* N should not exceed 262144 = 2^20/4 cells = 1048576 bytes */
10I hp=0,sp=N,ATOM=0x7fc,PRIM=0x7fd,CONS=0x7fe,CLOS=0x7ff,NIL=0xfff;
11L cell[N],nil,tru,err,env;
12L box(I t,I i) { L x; *(uint32_t*)&x = (uint32_t)t<<20|i; return x; }
13I ord(L x) { return *(uint32_t*)&x & 0xfffff; }
14L num(L n) { return n; }
15I equ(L x,L y) { return *(uint32_t*)&x == *(uint32_t*)&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<<2) abort();
19 return box(ATOM,i);
20}
21L cons(L x,L y) { cell[--sp] = x; cell[--sp] = y; if (hp > sp<<2) 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) { return T(t) == CONS ? cons(eval(car(t),e),evlis(cdr(t),e)) : T(t) == ATOM ? assoc(t,e) : nil; }
31L f_eval(L t,L e) { return eval(car(evlis(t,e)),e); }
32L f_quote(L t,L _) { return car(t); }
33L f_cons(L t,L e) { return t = evlis(t,e),cons(car(t),car(cdr(t))); }
34L f_car(L t,L e) { return car(car(evlis(t,e))); }
35L f_cdr(L t,L e) { return cdr(car(evlis(t,e))); }
36L f_add(L t,L e) { L n = car(t = evlis(t,e)); while (!not(t = cdr(t))) n += car(t); return num(n); }
37L f_sub(L t,L e) { L n = car(t = evlis(t,e)); while (!not(t = cdr(t))) n -= car(t); return num(n); }
38L f_mul(L t,L e) { L n = car(t = evlis(t,e)); while (!not(t = cdr(t))) n *= car(t); return num(n); }
39L f_div(L t,L e) { L n = car(t = evlis(t,e)); while (!not(t = cdr(t))) n /= car(t); return num(n); }
40L f_int(L t,L e) { L n = car(evlis(t,e)); return n<1e7 && n>-1e7 ? (long long)n : n; }
41L f_lt(L t,L e) { return t = evlis(t,e),car(t) - car(cdr(t)) < 0 ? tru : nil; }
42L f_eq(L t,L e) { return t = evlis(t,e),equ(car(t),car(cdr(t))) ? tru : nil; }
43L f_pair(L t,L e) { L x = car(evlis(t,e)); return T(x) == CONS ? tru : nil; }
44L f_or(L t,L e) { L x = nil; while (!not(t) && not(x = eval(car(t),e))) t = cdr(t); return x; }
45L f_and(L t,L e) { L x = tru; while (!not(t) && !not(x = eval(car(t),e))) t = cdr(t); return x; }
46L f_not(L t,L e) { return not(car(evlis(t,e))) ? tru : nil; }
47L f_cond(L t,L e) { while (!not(t) && not(eval(car(car(t)),e))) t = cdr(t); return eval(car(cdr(car(t))),e); }
48L f_if(L t,L e) { return eval(car(cdr(not(eval(car(t),e)) ? cdr(t) : t)),e); }
49L 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 eval(car(t),e); }
50L f_lambda(L t,L e) { return closure(car(t),car(cdr(t)),e); }
51L f_define(L t,L e) { env = pair(car(t),eval(car(cdr(t)),e),env); return car(t); }
52struct { const char *s; L (*f)(L,L); } prim[] = {
53{"eval", f_eval },{"car",f_car},{"-",f_sub},{"<", f_lt },{"or", f_or },{"cond",f_cond},{"lambda",f_lambda},
54{"quote",f_quote},{"cdr",f_cdr},{"*",f_mul},{"int",f_int},{"and",f_and},{"if", f_if },{"define",f_define},
55{"cons", f_cons },{"+", f_add},{"/",f_div},{"eq?",f_eq },{"not",f_not},{"let*",f_leta},{"pair?", f_pair },{0}};
56L bind(L v,L t,L e) { return not(v) ? e : T(v) == CONS ? bind(cdr(v),cdr(t),pair(car(v),car(t),e)) : pair(v,t,e); }
57L reduce(L f,L t,L e) { return eval(cdr(car(f)),bind(car(car(f)),evlis(t,e),not(cdr(f)) ? env : cdr(f))); }
58L apply(L f,L t,L e) { return T(f) == PRIM ? prim[ord(f)].f(t,e) : T(f) == CLOS ? reduce(f,t,e) : err; }
59L eval(L x,L e) { return T(x) == ATOM ? assoc(x,e) : T(x) == CONS ? apply(eval(car(x),e),cdr(x),e) : x; }
60char buf[40],see = ' ';
61void look() { int c = getchar(); see = c; if (c == EOF) exit(0); }
62I seeing(char c) { return c == ' ' ? see > 0 && see <= c : see == c; }
63char get() { char c = see; look(); return c; }
64char scan() {
65 int i = 0;
66 while (seeing(' ')) look();
67 if (seeing('(') || seeing(')') || seeing('\'')) buf[i++] = get();
68 else do buf[i++] = get(); while (i < 39 && !seeing('(') && !seeing(')') && !seeing(' '));
69 return buf[i] = 0,*buf;
70}
71L Read() { return scan(),parse(); }
72L list() { L x; return scan() == ')' ? nil : !strcmp(buf, ".") ? (x = Read(),scan(),x) : (x = parse(),cons(x,list())); }
73L quote() { return cons(atom("quote"),cons(Read(),nil)); }
74L atomic() { L n; int i; return sscanf(buf,"%g%n",&n,&i) > 0 && !buf[i] ? n : atom(buf); }
75L parse() { return *buf == '(' ? list() : *buf == '\'' ? quote() : atomic(); }
76void print(L);
77void printlist(L t) {
78 for (putchar('('); ; putchar(' ')) {
79 print(car(t));
80 if (not(t = cdr(t))) break;
81 if (T(t) != CONS) { printf(" . "); print(t); break; }
82 }
83 putchar(')');
84}
85void print(L x) {
86 if (T(x) == NIL) printf("()");
87 else if (T(x) == ATOM) printf("%s",A+ord(x));
88 else if (T(x) == PRIM) printf("<%s>",prim[ord(x)].s);
89 else if (T(x) == CONS) printlist(x);
90 else if (T(x) == CLOS) printf("{%u}",ord(x));
91 else printf("%g",x);
92}
93void gc() { sp = ord(env); }
94int main() {
95 I i; printf("tinylisp");
96 nil = box(NIL,0); err = atom("ERR"); tru = atom("#t"); env = pair(tru,tru,nil);
97 for (i = 0; prim[i].s; ++i) env = pair(atom(prim[i].s),box(PRIM,i),env);
98 while (1) { printf("\n%u>",sp-hp/4); print(eval(Read(),env)); gc(); }
99}