lambda.c

/*-*- 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 <assert.h>
#include <ctype.h>
#include <locale.h>
#include <signal.h>
#include <stdlib.h>
#include <sys/resource.h>
#include <sys/time.h>
#include <unistd.h>
#include <wchar.h>
#endif
#include "blc.h"

#define USAGE \
  " [-?hubBdsarvnNlS] [FILE...] <stdin >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;
}

/*
 * Called from Abs() when a lambda is reached with no continuation. The
 * original code unconditionally treated mem[ip+2] as an exit code:
 *
 *   int rc = mem[ip + 2];                       // (λ 0) [exitcode]
 *   if (rc) Error(rc, "CONTINUATIONS EXHAUSTED");
 *
 * That assumes ip is at a `λ.N` ABS whose body is exactly `VAR N`, in which
 * case mem[ip+1]==VAR and mem[ip+2]==N. The intent was to reach this via the
 * exit ABS at ROM position 24 (mem[24]=ABS, mem[25]=VAR, mem[26]=0), giving
 * a clean exit(0).
 *
 * In practice the wrapper allows execution to terminate at other ABS
 * positions whose bodies are not `VAR N`. For example, in bit mode, when
 * the lazy input list bottoms out via NIL, control commonly returns to
 * ip=14 (the inner `λ. 0 wr0 wr1`). There mem[15]=APP and mem[16]=4 (a
 * span operand), so the old code reported a spurious "CONTINUATIONS
 * EXHAUSTED" error and exited 4. Reproducer:
 *
 *   ( cat /tmp/AIT/bin/take1k.blc; printf 'hello world!' ) | ./lambda
 *
 * Tromp's `uni` exits 0 with identical output bytes on the same input.
 *
 * The fix preserves the original intent: only interpret mem[ip+2] as an
 * exit code when the body actually looks like `VAR N`. Otherwise exit
 * cleanly.
 */
void Bye(void) {
  if (mem[ip + 1] == VAR) {
    int rc = mem[ip + 2];
    if (rc) Error(rc, "CONTINUATIONS EXHAUSTED");
  }
  if (postdump) 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();
}