/* LISP100 
 * A string based implementation of "Recursive Functions of Symbolic
 * Expressions and Their Computation by Machine", John McCarthy, April 1960. */
#include <stdio.h>
#include <string.h>
#include <strings.h>
#include <ctype.h>
#include <stdlib.h>
typedef char *Q;
char heap[128*1024*1024], *hp=heap;
Q global_env = "NIL", eval(Q,Q);
#define DEFUN(nam,sig,res) Q nam sig { char *old = hp; return reset(old,(res)); }extern int goo
#define DE(nam,aux,res) nam { aux; return (res); }extern int goo
DE(int tcharp (char c),, !c || isspace(c) || strchr("()",c));
DE(Q ws (Q s),, (*s && isspace((unsigned char)*s)) ? ws(s+1) : s);
Q endof (Q s) {
  if (*s == '(') for (int nest = 1; *(++s) && nest; nest += *s=='('?1:*s==')'?-1:0);
  else while (!tcharp(*s)) s++;
  return s; }
DE(char *reset (char *old, char *s), Q e=endof(s),
   (hp=memcpy(old,s,(size_t)(e-s))+(e-s)+1, old[e-s]='\0', old));
DE(Q cpy (Q x), size_t n,
   (x=ws(x),n=(size_t)(endof(x)-x),sprintf(hp,"%.*s",(int)n,x),(hp+=n+1)-n-1));
Q error (char *msg, Q arg) {
  fprintf(stderr,"ERROR: %s - %s\n", msg, cpy(arg)); abort(); }
DE(Q p (Q s, Q e), Q r=hp,
   (hp+=1+sprintf(hp,"(%.*s)",(int)(e-s),s),r));
DE(int null (Q x),,
   (*(x=ws(x))=='(' && *ws(x+1)==')') || (!strncasecmp(x,"NIL",3) && tcharp(x[3])));
DE(int atom (Q x),, null(x) || *ws(x)!='(');
DE(int eq (Q x, Q y), ssize_t n,
   null(x) ? null(y) :
   null(y) ? 0 :
   (y=ws(y), x=ws(x), n=endof(x)-x,
    n==endof(y)-y && !strncasecmp(x,y,(size_t)n)));
DE(Q car (Q x),, atom(x=ws(x)) ? error("Not a cons", x) : x+1);
Q cdr (Q x) {
  if (atom(x=ws(x))) error("Not a cons", x);
  char *y = ws(endof(x+1));
  if(*y==')') return "NIL";
  if(*y=='.'&&tcharp(y[1])) return ws(y+1);
  char *z=y; while(*z&&*z!=')') z=ws(endof(z));
  if(!*z)error("Bust in cdr",x);
  return p(y,z); }
Q cons (Q x, Q y) {
  if(null(y=ws(y))) return p(x,endof(x));
  Q xe=endof(x=ws(x)), ye=endof(y), r=hp, d="";
  if(atom(y)) d = ". "; else ye--, y=ws(y+1);
  hp += 1+sprintf (r, "(%.*s %s%.*s)", (int)(xe-x), x, d, (int)(ye-y), y);
  return r; }
DEFUN(evcon, (Q c, Q a), !null(eval(car(car(c)),a)) ? eval(car(cdr(car(c))),a) : evcon (cdr(c), a));
DEFUN(evlis, (Q m, Q a), null(m) ? "NIL" : cons(eval(car(m),a),evlis(cdr(m),a)));
DEFUN(assoc, (Q x, Q y), eq(x,car(car(y))) ? car(cdr(car(y))) : assoc(x, cdr(y)));
DEFUN(append, (Q x, Q y), null(x) ? y : cons (car (x), append (cdr (x), y)));
DEFUN (pair, (Q x, Q y),
       (null(x) && null(y) ? "NIL" :
        !atom(x) && !atom(y) ? cons(cons(car(x),cons(car(y),"NIL")), pair(cdr(x),cdr(y))) :
        error ("Bust in pair: ",cons(x,cons(y,"NIL")))));
DEFUN(eval, (Q e, Q a),
    ( atom (e) ? assoc (e, a) :
      atom (car (e)) ?
      ( eq (car (e), "QUOTE") ? car (cdr (e)) :
        eq (car (e), "ATOM") ? atom (eval (car (cdr (e)), a))?"T":"NIL" :
        eq (car (e), "EQ") ? eq (eval (car (cdr (e)), a), eval (car(cdr(cdr (e))), a))?"T":"NIL" :
        eq (car (e), "COND") ? evcon (cdr (e), a) :
        eq (car (e), "CAR") ? car (eval (car (cdr (e)), a)) :
        eq (car (e), "CDR") ? cdr (eval (car (cdr (e)), a)) :
        eq (car (e), "CONS") ? cons (eval (car (cdr (e)), a), eval (car (cdr (cdr (e))), a)) :
        eval (cons (assoc (car(e),a),cdr(e)),a)) :
      eq (car (car (e)), "LABEL") ? eval (cons (car(cdr(cdr(car(e)))), cdr (e)),
                                          cons (cons (car(cdr(car(e))), cons (car (e), "NIL")), a)) :
      eq (car (car (e)), "LAMBDA") ? eval (car(cdr(cdr(car(e)))),
                                           append (pair (car(cdr(car(e))), evlis (cdr (e), a)), a)) :
      error("Bad form",e)));
Q topeval (Q x) {
  if (!atom(x) && eq(car(x),"DEFUN")) {
    global_env = cons (cons (car(cdr(x)), cons (cons("LAMBDA",cdr(cdr(x))),"NIL")), global_env);
    return cpy(car(car(global_env))); }
  return cpy(eval (x, global_env)); }
void repl (FILE *input, FILE *output, char *p1, char *p2) {
  char *buf, *old = hp, *p, *r=""; int c, nest=0;
  goto doit;
  for(;;) {
    if ((c=getc(input))==EOF) break;
    while(c==';') do if((c=getc(input))==EOF) return; while(c!='\n');
    nest+=c=='('?1:c==')'?-1:0;
    *p++=(char)c;*p=0;
    if(nest==0 && (isspace(c)||(c==')')) && *ws(buf)) {
      hp = p+1; r=(topeval(buf));
    doit:
      fprintf(output,"%s%s",r,p1);fflush(output);p1=p2;
      global_env = reset(old,global_env);
      buf=p=hp; } } }
int main (int argc, char **argv) {
  for(FILE *f=fopen("init.lisp","r"); f; fclose(f), f=0)
    repl(f,stdout, ";; Loading \"init.lisp\"\n",", ");
  repl(stdin,stdout, "\n;; Welcome to LISP100, enjoy your stay.\nLISP> ", "\nLISP> ");
  printf("\nTake care.\n");
  return 0; }
/* --Gilbert Baumann, 2021-11-19 */