Understanding sectorlisp

main.cpp

// Code as output from attempting to understand https://justine.lol/sectorlisp2/
// and written as an exercise to refamiliarize myself with c++

/* 
;;                              ________
;;                             /_  __/ /_  ___
;;                              / / / __ \/ _ \
;;                             / / / / / /  __/
;;                            /_/ /_/ /_/\___/
;;     __    _________ ____     ________          ____
;;    / /   /  _/ ___// __ \   / ____/ /_  ____ _/ / /__  ____  ____ ____
;;   / /    / / \__ \/ /_/ /  / /   / __ \/ __ `/ / / _ \/ __ \/ __ `/ _ \
;;  / /____/ / ___/ / ____/  / /___/ / / / /_/ / / /  __/ / / / /_/ /  __/
;; /_____/___//____/_/       \____/_/ /_/\__,_/_/_/\___/_/ /_/\__, /\___/
;;                                                           /____/
;;
;; The LISP Challenge
;;
;; Pick your favorite programming language
;; Implement the tiniest possible LISP machine that
;; Bootstraps John Mccarthy'S metacircular evaluator below
;; Winning is defined by lines of code for scripting languages
;; Winning is defined by binary footprint for compiled languages
;;
;; Listed Projects
;;
;; - 512 bytes: https://github.com/jart/sectorlisp
;; - 13 kilobytes: https://t3x.org/klisp/
;; - 47 kilobytes: https://github.com/matp/tiny-lisp
;; - 150 kilobytes: https://github.com/JeffBezanson/femtolisp
;; - Send pull request to be listed here
;;
;; @see LISP From Nothing; Nils M. Holm; Lulu Press, Inc. 2020
;; @see Recursive Functions of Symbolic Expressions and Their
;;      Computation By Machine, Part I; John McCarthy, Massachusetts
;;      Institute of Technology, Cambridge, Mass. April 1960

;; NIL ATOM
;; ABSENCE OF VALUE AND TRUTH
NIL

;; CONS CELL
;; BUILDING BLOCK OF DATA STRUCTURES
(CONS NIL NIL)
(CONS (QUOTE X) (QUOTE Y))

;; REFLECTION
;; EVERYTHING IS AN ATOM OR NOT AN ATOM
(ATOM NIL)
(ATOM (CONS NIL NIL))

;; QUOTING
;; CODE IS DATA AND DATA IS CODE
(QUOTE (CONS NIL NIL))
(CONS (QUOTE CONS) (CONS NIL (CONS NIL NIL)))

;; LOGIC
;; BY WAY OF STRING INTERNING
(EQ (QUOTE A) (QUOTE A))
(EQ (QUOTE T) (QUOTE F))

;; FIND FIRST ATOM IN TREE
;; CORRECT RESULT OF EXPRESSION IS `A`
;; RECURSIVE CONDITIONAL FUNCTION BINDING
((LAMBDA (FF X) (FF X))
 (QUOTE (LAMBDA (X)
          (COND ((ATOM X) X)
                ((QUOTE T) (FF (CAR X))))))
 (QUOTE ((A) B C)))

;; LISP IMPLEMENTED IN LISP
;; WITHOUT ANY SUBJECTIVE SYNTACTIC SUGAR
;; RUNS "FIND FIRST ATOM IN TREE" PROGRAM
;; CORRECT RESULT OF EXPRESSION IS STILL `A`
;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND
;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER
;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP
;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE
((LAMBDA (ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
   (EVAL (QUOTE ((LAMBDA (FF X) (FF X))
                 (QUOTE (LAMBDA (X)
                          (COND ((ATOM X) X)
                                ((QUOTE T) (FF (CAR X))))))
                 (QUOTE ((A) B C))))
         ()))
 (QUOTE (LAMBDA (X Y)
          (COND ((EQ Y ()) ())
                ((EQ X (CAR (CAR Y)))
                       (CDR (CAR Y)))
                ((QUOTE T)
                 (ASSOC X (CDR Y))))))
 (QUOTE (LAMBDA (C A)
          (COND ((EVAL (CAR (CAR C)) A)
                 (EVAL (CAR (CDR (CAR C))) A))
                ((QUOTE T) (EVCON (CDR C) A)))))
 (QUOTE (LAMBDA (X Y A)
          (COND ((EQ X ()) A)
                ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
                                 (PAIRLIS (CDR X) (CDR Y) A))))))
 (QUOTE (LAMBDA (M A)
          (COND ((EQ M ()) ())
                ((QUOTE T) (CONS (EVAL (CAR M) A)
                                 (EVLIS (CDR M) A))))))
 (QUOTE (LAMBDA (FN X A)
          (COND
            ((ATOM FN)
             (COND ((EQ FN (QUOTE CAR))  (CAR  (CAR X)))
                   ((EQ FN (QUOTE CDR))  (CDR  (CAR X)))
                   ((EQ FN (QUOTE ATOM)) (ATOM (CAR X)))
                   ((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X))))
                   ((EQ FN (QUOTE EQ))   (EQ   (CAR X) (CAR (CDR X))))
                   ((QUOTE T)            (APPLY (EVAL FN A) X A))))
            ((EQ (CAR FN) (QUOTE LAMBDA))
             (EVAL (CAR (CDR (CDR FN)))
                   (PAIRLIS (CAR (CDR FN)) X A))))))
 (QUOTE (LAMBDA (E A)
          (COND
            ((ATOM E) (ASSOC E A))
            ((ATOM (CAR E))
             (COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
                   ((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
                   ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
            ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))))
*/

#include <cstdio>
#include <cwchar>

int get_list();
int get_object(int);
void print_object(int);
int eval(int e, int a);

// reserved token lookup offsets (used by apply (eval)
#define kT          4
#define kQuote      6
#define kCond       12
#define kRead       17
#define kPrint      22
#define kAtom       28
#define kCar        33
#define kCdr        37
#define kCons       41
#define kEq         46
#define S "NIL\0T\0QUOTE\0COND\0READ\0PRINT\0ATOM\0CAR\0CDR\0CONS\0EQ"
#define M (ram + sizeof(ram) / sizeof(ram[0]) / 2)

int dx; // next character
int cx; // memory state index
int ram[010000];

int cons(int car, int cdr) {
  M[--cx] = cdr;
  M[--cx] = car;
  return cx;
}

int car(int i) {
  return M[i];
}

int cdr(int i) {
  return M[i + 1];
}

int gc(int x, int m, int k) {
  if (x < m) {
    return cons(gc(car(x), m, k), gc(cdr(x), m, k)) + k;
  }
  return x;
}

// look into M segment which holds the registered ast tokens (NIL...EQ)
// and try and match the characters entered into the input buffer segment
int intern() {
  int i, j, x;
  for (i = 0; (x = M[i++]); ) {
    for (j = 0;; ++j) {
      if (x != ram[j]) {
        break;
      }
      if (!x) { // once scan run !x is true so we are at the end
        return i - j - 1;        // if x is 0
      }
      x = M[i++];
    }
    while (x) { // scan to end (0 val) of M segment
      x = M[i++];
    }
  }
  j = 0;
  x = --i; // store the index (over the val but var x)
  while ((M[i++] = ram[j++])) { // append data at ram[j...] to M segment
  }
  return x;
}

void print_char(int c) {
  fputwc(c, stdout);
}

int get_char() {
  int t = dx;
  dx = getchar();
  return t;
}

int get_token() {
  int c, i = 0;
  do {
    if ((c = get_char()) > ' ') { // insert into ram while not a token
      ram[i++] = c;
    }
  } while (c <= ' ' || (c > ')' && dx > ')'));
  ram[i] = 0;
  return c;
}

int add_list(int x) {
  return cons(x, get_list());
}

int get_list() {
  int c = get_token();
  if (c == ')') {
    return 0;
  }
  return add_list(get_object(c));
}

int get_object(int c) {
  if (c == '(') {
    return get_list();
  }
  return intern();
}

int read() {
  return get_object(get_token());
}

void print_atom(int x) {
  int c;
  for (;;) {
    if (!(c = M[x++])) {
      break;
    }
    print_char(c);
  }
}

void print_list(int x) {
  print_char('(');
  print_object(car(x));
  while ((x = cdr(x))) {
    if (x < 0) {
      print_char(' ');
      print_object(car(x));
    } else {
      print_char('.');
      print_object(x);
      break;
    }
  }
  print_char(')');
}

void print_object(int x) {
  if (x < 0) {
    print_list(x);
  } else {
    print_atom(x);
  }
}

int assoc(int x, int y) {
  if (!y) {
    return 0;
  }
  if (x == car(car(y))) {
    return cdr(car(y));
  }
  return assoc(x, cdr(y));
}

int pair_list(int x, int y, int depth) {
  if (x) {
    return cons(cons(car(x), car(y)), pair_list(cdr(x), cdr(y), depth));
  }
  return depth;
}

int apply(int f, int x, int depth) {
  if (f < 0) {
    return eval(car(cdr(cdr(f))), pair_list(car(cdr(f)), x, depth));
  }
  if (f > kEq) {
    return apply(eval(f, depth), x, depth);
  }
  switch (f) {
    case kEq  : return car(x) == car(cdr(x)) ? kT : 0;
    case kCons: return cons(car(x), car(cdr(x)));
    case kAtom: return car(x) < 0 ? 0 : kT;
    case kCar : return car(car(x));
    case kCdr : return cdr(car(x));
    case kRead: return read();
    case kPrint: return (x ? print_object(car(x)) : print_char('\n')), 0;
  }
}

int eval_con(int c, int depth) {
  if (eval(car(car(c)), depth)) {
    return eval(car(cdr(car(c))), depth);
  }
  return eval_con(cdr(c), depth);
}

int eval_list(int m, int depth) {
  if (m) {
    int x = eval(car(m), depth);
    return cons(x, eval_list(cdr(m), depth));
  }
  return 0;
}

int eval(int e, int depth) {
  int x, y, z;
  if (e >= 0) {
    return assoc(e, depth);
  }
  if (car(e) == kQuote) {
    return car(cdr(e));
  }
  x = cx;
  if (car(e) == kCond) {
    e = eval_con(cdr(e), depth);
  } else {
    e = apply(car(e), eval_list(cdr(e), depth), depth);
  }
  y = cx;
  e = gc(e, x, x - y);
  z = cx;
  while (z < y) {
    M[--x] = M[--y];
  }
  cx = x;
  return e;
}

int main(int, char**) {
  for (int i = 0; i < sizeof(S); ++i) {
    M[i] = S[i];
  }
  for (;;) {
    cx = 0;
    int a = read();
    int b = eval(a, 0);
    print_object(b);
    print_char('\n');
  }
}