/*-*- 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 2022 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. │ ╚─────────────────────────────────────────────────────────────────────────────*/ #ifndef __COSMOPOLITAN__ #include #include #include #include #include #include #include #include #include #endif #include "blc.h" #define USAGE \ " [-?hubBdsarvnNlS] [FILE...] expr.txt 2>memory.txt\n\ Binary Lambda Calculus Virtual Machine\n\ \n\ FLAGS\n\ \n\ -h help\n\ -r redex log\n\ -b binary 8-bit i/o\n\ -B debug print binary\n\ -l print lambda notation\n\ -v variable log [implies -r]\n\ -a action log [implies -r]\n\ -s full machine state logging\n\ -n disables name rewriting rules\n\ -N disables most unicode symbolism\n\ -d dump terms on successful exit\n" #define NIL 23 #define TRUE 27 #define FALSE 23 #define REF(c) (++(c)->refs, c) static const char kRom[] = { APP, 0, // 0 (λ 0 λ 0 (λ 0 wr0 wr1) put) (main gro) ABS, // 2 λ 0 λ 0 (λ 0 wr0 wr1) put APP, 0, // 3 VAR, 0, // 5 ABS, // 7 APP, // 8 ABS, // 9 λ 0 λ 0 wr0 wr1 APP, 2, // 10 VAR, // 12 IOP, // 13 ABS, // 14 λ 0 wr0 wr1 APP, 4, // 15 APP, 1, // 17 VAR, // 19 IOP, // 20 wr0 IOP, 0, // 21 wr1 ABS, // 23 (λλ 0) a.k.a. nil ABS, // 24 exit VAR, // 25 0, // 26 exit[0] ABS, // 27 (λλ 1) a.k.a. true ABS, // 28 VAR, 1, // 29 }; static int postdump; static int kLazy[256]; void Quit(int sig) { Dump(0, end, stderr); exit(128 + sig); } void PrintUsage(const char *prog, int rc, FILE *f) { fputs("Usage: ", f); fputs(prog, f); fputs(USAGE, f); exit(rc); } int Backref(int x) { return x - (end + 1); } static inline void Expand(int c) { if (end >= TERMS) Error(5, "OUT OF TERMS"); mem[end++] = c; } void Gc(struct Closure *p) { for (; p && p != &root; p = p->envp) { if (--p->refs) break; Gc(p->next); p->next = frep; frep = p; } } void Var(void) { int i, x; struct Closure *t, *e; e = t = envp; x = mem[ip + 1]; for (i = 0; i < x && e != &root; ++i) { e = e->next; } if (e == &root) Error(10 + x, "UNDEFINED VARIABLE %d", x); ip = e->term; envp = REF(e->envp); Gc(t); } void Gro(void) { int c = fgetc(stdin); if (c != -1) { Expand(ABS); Expand(APP); Expand(4); Expand(APP); Expand(Backref(binary ? kLazy[c] : c & 1 ? FALSE : TRUE)); Expand(VAR); Expand(0); } else { Expand(ABS); Expand(ABS); Expand(VAR); Expand(0); } } void Put(void) { int bit; long newip; if (!binary) { co = '0' + (ip & 1); fputc(co, stdout); newip = 2; } else if (mem[ip + 1] & 1) { // ip ∈ {6,13} fputc(co, stdout); newip = 2; } else { // ip ∈ {20,21} newip = 9; // (λ 0 (λ 0 wr1 wr0)) bit = ip & 1; co = (co * 2) | bit; } if (ferror(stdout)) { exit(55); } ip = newip; } void Bye(void) { int rc = mem[ip + 2]; // (λ 0) [exitcode] if (rc) Error(rc, "CONTINUATIONS EXHAUSTED"); if (postdump && !rc) Dump(0, end, stderr); exit(0); } // pops continuation and pushes it to environment void Abs(void) { if (!contp) Bye(); struct Closure *t = contp; contp = t->next; t->next = envp; envp = t; ++ip; } struct Closure *Alloc(void) { struct Closure *t; if (!(t = frep)) { if (!(t = calloc(1, sizeof(struct Closure)))) { Error(6, "OUT OF HEAP"); } } frep = t->next; t->refs = 1; ++heap; return t; } // pushes continuation for argument void App(void) { int x = mem[ip + 1]; struct Closure *t = Alloc(); t->term = ip + 2 + x; t->envp = t->term > 21 && t->term != end ? REF(envp) : &root; t->next = contp; contp = t; ip += 2; } int LoadByte(int c) { int i, r = end; for (i = 7; i >= 0; --i) { Expand(ABS); Expand(APP); Expand(i ? +4 : Backref(NIL)); Expand(APP); Expand(Backref(c & (1 << i) ? FALSE : TRUE)); Expand(VAR); Expand(0); } return r; } void LoadRom(void) { long i; for (; end < sizeof(kRom) / sizeof(*kRom); ++end) { mem[end] = kRom[end]; } mem[4] = binary ? 2 : 9; if (binary) { for (i = 0; i < 256; ++i) { kLazy[i] = LoadByte(i); } } mem[1] = end - 2; } void Iop(void) { if (ip == end) { Gro(); } else { Put(); // ip ∈ {6,13,20,21} } Gc(envp); envp = &root; } static void Rex(void) { if (slog) PrintMachineState(stderr); if (rlog && (alog || mem[ip] != APP)) { PrintExpressions(stderr, alog, vlog); } switch (mem[ip]) { case VAR: Var(); break; case APP: App(); break; case ABS: Abs(); break; case IOP: Iop(); break; default: Error(7, "CORRUPT TERM"); } } void Krivine(void) { int main; long gotoget; LoadRom(); mem[end++] = APP; gotoget = end++; main = end; mem[gotoget] = Parse(1, stdin).n; if (rlog) { Print(main, 1, 0, stderr); fputs("\n", stderr); if (alog) { fputs("⟿ wrap[", stderr); Print(0, 1, 0, stderr); fputs("]\n", stderr); } } for (;;) Rex(); } void LoadFlags(int argc, char *argv[]) { int i; const char *prog; prog = argc ? argv[0] : "lambda"; while ((i = getopt(argc, argv, "?hubBdsarvnNlS")) != -1) { switch (i) { case 'b': binary = 1; break; case 'S': safer = 1; break; case 'n': noname = 1; break; case 'N': asciiname = 1; break; case 'B': style = 2; break; case 'l': style = 1; break; case 's': slog = 1; break; case 'r': rlog = 1; break; case 'a': rlog = 1; alog = 1; break; case 'v': rlog = 1; vlog = 1; break; case 'd': postdump = 1; break; case '?': case 'h': PrintUsage(prog, 0, stdout); default: PrintUsage(prog, 1, stderr); } } } int main(int argc, char *argv[]) { struct rlimit rlim = {512 * 1024 * 1024, 512 * 1024 * 1024}; setrlimit(RLIMIT_AS, &rlim); signal(SIGQUIT, Quit); signal(SIGPIPE, Quit); LoadFlags(argc, argv); setlocale(LC_ALL, ""); setvbuf(stdout, 0, _IOLBF, 0); setvbuf(stderr, 0, _IOLBF, 0); Krivine(); }