Why won't my little lisp QUOTE?

Question

I've been writing up a micro-mini-lisp based on the encoding in minilisp, the McCarthy paper (as emended by the Roots of Lisp), and using a (possibly objectionable) style based on the J Incunabulum. And using the PP_NARG macro from here. I was also motivated by my previous project, a codegolf'ed lambda calculus interpreter which I later discovered to be eerily similar to the 1999 ioccc Lisp interpreter, particularly in the use of cursors rather than pointers to refer to memory addresses.

It mostly seems to work, including the reader code. But, although eval(ATOM(QUOTE X)) is correctly yielding T, and eval(ATOM(QUOTE(X Y Z))) is correctly yielding NIL, and eval(QUOTE X) yields X, and eval(QUOTE(X Y Z)) yields (X Y Z); the weird result is eval(QUOTE(ATOM(QUOTE X))) yields ATOM, not the full sub-expression ATOM(QUOTE X).

I suppose it's a long-shot, and I didn't exactly make it easy, but can anyone help me figure out where it's going wrong with the quoting?

By the way, unlike my description above, the interpreter is limited to single-character tokens, so QUOTE is Q and ATOM is A. (github)

/*cf.
http://www.ioccc.org/1989/jar.2.c
http://leon.bottou.org/projects/minilisp
http://www.jsoftware.com/jwiki/Essays/Incunabulum
http://www-formal.stanford.edu/jmc/recursive/recursive.html
http://www.paulgraham.com/rootsoflisp.html
https://codegolf.stackexchange.com/questions/284/write-an-interpreter-for-the-untyped-lambda-calculus/3290#3290
 */
#include<assert.h>
#include<signal.h>
#include<stdarg.h>
#include<stdio.h>
#include<stdlib.h>
#include<unistd.h>
#include"ppnarg.h"
#define R return
int*m,*n,msz;
tag(x){R x&3;}
val(x){R x>>2;}
#define ALPHA 'T'
#define NIL   (0)
#define T atom(ALPHA)
atom(x){R((x-ALPHA)<<2)|1;}
number(x){R(x<<2)|3;}
listp(x){R tag(x)==0;}
atomp(x){R tag(x)==1;}
objectp(x){R tag(x)==2;}
numberp(x){R tag(x)==3;}
consp(x){R x&&listp(x);}
car(x){R consp(x)?val(x)[m]:0;}
cdr(x){R consp(x)?val(x)[m+1]:0;}
caar(x){R car(car(x));}
cadr(x){R car(cdr(x));}
cadar(x){R car(cdr(car(x)));}
caddr(x){R car(cdr(cdr(x)));}
caddar(x){R car(cdr(cdr(car(x))));}
cons(x,y){int z;R z=n-m,*n++=x,*n++=y,z<<2;}
rplaca(x,y){R consp(x)?val(x)[m]=y:0;}
rplacd(x,y){R consp(x)?val(x)[m+1]=y:0;}
eq(x,y){R atomp(x)&&atomp(y)?x==y:0;}
ff(x){R atomp(x)?x:ff(car(x));}
subst(x,y,z){R atomp(z)?(eq(z,y)?x:z):
        cons(subst(x,y,car(z)),subst(x,y,cdr(z)));}
equal(x,y){R(atomp(x)&&atomp(y)&&eq(x,y))
    ||(consp(x)&&consp(y)&&equal(car(x),car(y))&&equal(cdr(x),cdr(y)));}
null(x){R listp(x)&&(val(x)==0);}
lista(int c,int*a){int z=NIL;for(;c;)z=cons(a[--c],z);R z;}
listn(int c,...){va_list a;int*z=n;
    va_start(a,c);for(;c--;)*n++=va_arg(a,int);va_end(a);
    c=n-z;R lista(c,z);}
#define list(...) listn(PP_NARG(__VA_ARGS__),__VA_ARGS__)
append(x,y){R null(x)?y:cons(car(x),append(cdr(x),y));}
among(x,y){R !null(y)&&equal(x,car(y))||among(x,cdr(y));}
pair(x,y){R null(x)&&null(y)?NIL:
    consp(x)&&consp(y)?cons(list(car(x),car(y)),pair(cdr(x),cdr(y))):0;}
assoc(x,y){R eq(caar(y),x)?cadar(y):assoc(x,cdr(y));}
sub2(x,z){R null(x)?z:eq(caar(x),z)?cadar(x):sub2(cdr(x),z);}
sublis(x,y){R atom(y)?sub2(x,y):cons(sublis(x,car(y)),sublis(x,cdr(y)));}
apply(f,args){R eval(cons(f,appq(args)),NIL);}
appq(m){R null(m)?NIL:cons(list(atom('Q'),car(m)),appq(cdr(m)));}
eval(e,a){R numberp(e)?e:
    atomp(e)?assoc(e,a):
    atomp(car(e))?(
    /*QUOTE*/      eq(car(e),atom('Q'))?cadr(e):
    /*ATOM*/       eq(car(e),atom('A'))?atomp(eval(cadr(e),a)):
    /*EQ*/         eq(car(e),atom('E'))?eval(cadr(e),a)==eval(caddr(e),a):
    /*COND*/       eq(car(e),atom('D'))?evcon(cdr(e),a):
    /*CAR*/        eq(car(e),atom('H'))?car(eval(cadr(e),a)):
    /*CDR*/        eq(car(e),atom('R'))?cdr(eval(cadr(e),a)):
    /*CONS*/       eq(car(e),atom('C'))?cons(eval(cadr(e),a),eval(caddr(e),a)):
        //eval(cons(assoc(car(e),a),evlis(cdr(e),a)),a) ):/*cf. Roots of Lisp*/
        eval(cons(assoc(car(e),a),cdr(e)),a) ):
    eq(caar(e),atom('M'))?          /*LABEL*/
        eval(cons(caddar(e),cdr(e)),cons(list(cadar(e),car(e)),a)):
    eq(caar(e),atom('L'))?          /*LAMBDA*/
        eval(caddar(e),append(pair(cadar(e),evlis(cdr(e),a)),a)):0;}
evcon(c,a){R eval(caar(c),a)?eval(cadar(c),a):evcon(cdr(c),a);}
evlis(m,a){R null(m)?NIL:cons(eval(car(m),a),evlis(cdr(m),a));}
maplist(x,f){R null(x)?NIL:cons(apply(f,x),maplist(cdr(x),f));}

prn(x){atomp(x)?printf("'%c' ",val(x)+ALPHA):
    numberp(x)?printf("%d ",val(x)):
    objectp(x)?printf("OBJ %d ",val(x)):
    consp(x)?printf("( "),prn(car(x)),prn(cdr(x)),printf(") "):
    0//printf("NIL ")
    ;}

#define LPAR '('
#define RPAR ')'
rd(char **p){int t,u,v,z;
    if(!(**p))R 0;
    if(**p==' ')R ++(*p),rd(p);
    if(**p==RPAR)R ++(*p),atom(RPAR);
    if(**p==LPAR){++(*p);
        z=NIL;u=rd(p);z=cons(u,z);
        while(u=rd(p),!eq(u,atom(RPAR)))
            //u=cons(u,NIL),
            z=append(z,u);
        R z;}
    if(**p>='0'&&**p<='9')R ++(*p),number(*((*p)-1)-'0');
    R ++(*p),atom(*((*p)-1));}

void fix(x){signal(SIGSEGV,fix);sbrk(msz);msz*=2;}
int main(){
    assert((-1>>1)==-1); /*right-shift must be sign-preserving*/
    n=m=sbrk(sizeof(int)*(msz=getpagesize()));*n++=0;*n++=0;
    //signal(SIGSEGV,fix); /*might let it run longer, obscures problems*/
    char *s="(Q (A (Q X)))";
    char *p=s;
    int a=rd(&p);
    printf("%s\n",s);

    int x,y;
    x = a;
    y = NIL;

    prn(x);
    x = eval(x,y);
    printf("\nEVAL\n");

    printf("x: %d\n", x);
    printf("0: %o\n", x);
    printf("0x: %x\n", x);
    printf("tag(x): %d\n",tag(x));
    printf("val(x): %d\n",val(x));
    printf("car(x): %d\n",car(x));
    printf("cdr(x): %d\n",cdr(x));
    prn(x);

    R 0;
}

Here's the same code processed by indent.

/*cf.
http://www.ioccc.org/1989/jar.2.c
http://leon.bottou.org/projects/minilisp
http://www.jsoftware.com/jwiki/Essays/Incunabulum
http://www-formal.stanford.edu/jmc/recursive/recursive.html
http://www.paulgraham.com/rootsoflisp.html
 */
#include<assert.h>
#include<signal.h>
#include<stdarg.h>
#include<stdio.h>
#include<stdlib.h>
#include<unistd.h>
#include"ppnarg.h"
#define R return
int *m, *n, msz;
tag (x)
{
  R x & 3;
}

val (x)
{
  R x >> 2;
}

#define ALPHA 'T'
#define NIL   (0)
#define T atom(ALPHA)
atom (x)
{
  R ((x - ALPHA) << 2) | 1;
}

number (x)
{
  R (x << 2) | 3;
}

listp (x)
{
  R tag (x) == 0;
}

atomp (x)
{
  R tag (x) == 1;
}

objectp (x)
{
  R tag (x) == 2;
}

numberp (x)
{
  R tag (x) == 3;
}

consp (x)
{
  R x && listp (x);
}

car (x)
{
  R consp (x) ? val (x)[m] : 0;
}

cdr (x)
{
  R consp (x) ? val (x)[m + 1] : 0;
}

caar (x)
{
  R car (car (x));
}

cadr (x)
{
  R car (cdr (x));
}

cadar (x)
{
  R car (cdr (car (x)));
}

caddr (x)
{
  R car (cdr (cdr (x)));
}

caddar (x)
{
  R car (cdr (cdr (car (x))));
}

cons (x, y)
{
  int z;
  R z = n - m, *n++ = x, *n++ = y, z << 2;
}

rplaca (x, y)
{
  R consp (x) ? val (x)[m] = y : 0;
}

rplacd (x, y)
{
  R consp (x) ? val (x)[m + 1] = y : 0;
}

eq (x, y)
{
  R atomp (x) && atomp (y) ? x == y : 0;
}

ff (x)
{
  R atomp (x) ? x : ff (car (x));
}

subst (x, y, z)
{
  R atomp (z) ? (eq (z, y) ? x : z) :
    cons (subst (x, y, car (z)), subst (x, y, cdr (z)));
}

equal (x, y)
{
  R (atomp (x) && atomp (y) && eq (x, y))
    || (consp (x) && consp (y) && equal (car (x), car (y))
    && equal (cdr (x), cdr (y)));
}

null (x)
{
  R listp (x) && (val (x) == 0);
}

lista (int c, int *a)
{
  int z = NIL;
  for (; c;)
    z = cons (a[--c], z);
  R z;
}

listn (int c, ...)
{
  va_list a;
  int *z = n;
  va_start (a, c);
  for (; c--;)
    *n++ = va_arg (a, int);
  va_end (a);
  c = n - z;
  R lista (c, z);
}

#define list(...) listn(PP_NARG(__VA_ARGS__),__VA_ARGS__)
append (x, y)
{
  R null (x) ? y : cons (car (x), append (cdr (x), y));
}

among (x, y)
{
  R ! null (y) && equal (x, car (y)) || among (x, cdr (y));
}

pair (x, y)
{
  R null (x) && null (y) ? NIL :
    consp (x)
    && consp (y) ? cons (list (car (x), car (y)),
             pair (cdr (x), cdr (y))) : 0;
}

assoc (x, y)
{
  R eq (caar (y), x) ? cadar (y) : assoc (x, cdr (y));
}

sub2 (x, z)
{
  R null (x) ? z : eq (caar (x), z) ? cadar (x) : sub2 (cdr (x), z);
}

sublis (x, y)
{
  R atom (y) ? sub2 (x, y) : cons (sublis (x, car (y)), sublis (x, cdr (y)));
}

apply (f, args)
{
  R eval (cons (f, appq (args)), NIL);
}

appq (m)
{
  R null (m) ? NIL : cons (list (atom ('Q'), car (m)), appq (cdr (m)));
}

eval (e, a)
{
  R numberp (e) ? e :
    atomp (e) ? assoc (e, a) :
    atomp (car (e)) ? ( /*QUOTE*/ eq (car (e), atom ('Q')) ? cadr (e) :
               /*ATOM*/ eq (car (e),
                    atom ('A')) ? atomp (eval (cadr (e),
                                   a)) : /*EQ*/
               eq (car (e), atom ('E')) ? eval (cadr (e),
                            a) == eval (caddr (e),
                                    a) :
               /*COND*/ eq (car (e), atom ('D')) ? evcon (cdr (e),
                                  a) : /*CAR*/
               eq (car (e),
               atom ('H')) ? car (eval (cadr (e),
                            a)) : /*CDR*/ eq (car (e),
                                      atom
                                      ('R')) ?
               cdr (eval (cadr (e), a)) : /*CONS*/ eq (car (e),
                                   atom ('C')) ?
               cons (eval (cadr (e), a), eval (caddr (e), a)) :
               //eval(cons(assoc(car(e),a),evlis(cdr(e),a)),a) ):/*cf. Roots of Lisp*/
               eval (cons (assoc (car (e), a), cdr (e)), a)) :
    eq (caar (e), atom ('M')) ? /*LABEL*/
    eval (cons (caddar (e), cdr (e)), cons (list (cadar (e), car (e)), a)) :
    eq (caar (e), atom ('L')) ? /*LAMBDA*/
    eval (caddar (e), append (pair (cadar (e), evlis (cdr (e), a)), a)) : 0;
}

evcon (c, a)
{
  R eval (caar (c), a) ? eval (cadar (c), a) : evcon (cdr (c), a);
}

evlis (m, a)
{
  R null (m) ? NIL : cons (eval (car (m), a), evlis (cdr (m), a));
}

maplist (x, f)
{
  R null (x) ? NIL : cons (apply (f, x), maplist (cdr (x), f));
}

prn (x)
{
  atomp (x) ? printf ("'%c' ", val (x) + ALPHA) : numberp (x) ? printf ("%d ", val (x)) : objectp (x) ? printf ("OBJ %d ", val (x)) : consp (x) ? printf ("( "), prn (car (x)), prn (cdr (x)), printf (") ") : 0    //printf("NIL ")
    ;
}

#define LPAR '('
#define RPAR ')'
rd (char **p)
{
  int t, u, v, z;
  if (!(**p))
    R 0;
  if (**p == ' ')
    R++ (*p), rd (p);
  if (**p == RPAR)
    R++ (*p), atom (RPAR);
  if (**p == LPAR)
    {
      ++(*p);
      z = NIL;
      u = rd (p);
      z = cons (u, z);
      while (u = rd (p), !eq (u, atom (RPAR)))
    //u=cons(u,NIL),
    z = append (z, u);
      R z;
    }
  if (**p >= '0' && **p <= '9')
    R++ (*p), number (*((*p) - 1) - '0');
  R++ (*p), atom (*((*p) - 1));
}

void
fix (x)
{
  signal (SIGSEGV, fix);
  sbrk (msz);
  msz *= 2;
}

int
main ()
{
  assert ((-1 >> 1) == -1); /*right-shift must be sign-preserving */
  n = m = sbrk (sizeof (int) * (msz = getpagesize ()));
  *n++ = 0;
  *n++ = 0;
  //signal(SIGSEGV,fix); /*might let it run longer, obscures problems*/
  char *s = "(Q (A (Q X)))";
  char *p = s;
  int a = rd (&p);
  printf ("%s\n", s);

  int x, y;
  x = a;
  y = NIL;

  prn (x);
  x = eval (x, y);
  printf ("\nEVAL\n");

  printf ("x: %d\n", x);
  printf ("0: %o\n", x);
  printf ("0x: %x\n", x);
  printf ("tag(x): %d\n", tag (x));
  printf ("val(x): %d\n", val (x));
  printf ("car(x): %d\n", car (x));
  printf ("cdr(x): %d\n", cdr (x));
  prn (x);

  R 0;
}

Here's the guts of main again, the testing portion.

    char *s="(Q (A (Q X)))";
    char *p=s;
    int a=rd(&p);
    printf("%s\n",s);

    int x,y;
    x = a;
    y = NIL;

    prn(x);
    x = eval(x,y);
    printf("\nEVAL\n");

    printf("x: %d\n", x);
    printf("0: %o\n", x);
    printf("0x: %x\n", x);
    printf("tag(x): %d\n",tag(x));
    printf("val(x): %d\n",val(x));
    printf("car(x): %d\n",car(x));
    printf("cdr(x): %d\n",cdr(x));
    prn(x);

And the output I'm getting is:

(Q (A (Q X)))
( 'Q' ( 'A' ( 'Q' 'X' ) ) ) 
EVAL
x: -75
0: 37777777665
0x: ffffffb5
tag(x): 1
val(x): -19
car(x): 0
cdr(x): 0
'A' 

Answer 1

It does perfectly right:

The sub expression

(QUOTE(ATOM(QUOTE X)))

is

(ATOM 'X)

and

(eval (atom 'x))

is

'X 

(true)

Answer 2

Your reader is wrong, and your printer is lying to you.

Hint: try reading a list with more than one element, like (1 2 3 4 5).

The problem is that rd calls append with the element it just read as the second argument. (The fix is already there, commented out.) In the test case above, that just happens to be a list itself, so append works. But the datum you're actually passing to eval is actually

(Q . (A . (Q . X)))

when printed correctly, or

(Q A Q . X)

with the standard list abbreviation.

And so yes, eval returns A, which is the right answer, unless you want to check that there are no unexpected terms.

The bug in the printer is that for pairs you print the cdr as if it were an element. You should print a dot between the car and the cdr, or you should write a helper function prnlst that does the abbreviated list printing.

Answer 3

Much belated, but I finally got the reader and printer functions to (appear to) work with the above code.

prn(x){atomp(x)?printf("'%c' ",val(x)+ALPHA):
    numberp(x)?printf("%d ",val(x)):
    objectp(x)?printf("OBJ %d ",val(x)):
    consp(x)?printf("( "),prn(car(x)),printf(". "),prn(cdr(x)),printf(") "):
    printf("NIL ");}

prnlst(x){
    x==NIL?0:
    !consp(x)?prn(x):
    printf("( "),prnrem(x);
}
prnrem(x){
    if(x==NIL)R;// printf(")0 ");
    if(car(x)!=NIL)
        prn(car(x));
    else
        R;// printf(") ");
    null(cdr(x))?
        printf(") "):
    !listp(cdr(x))?
        prn(cdr(x)),printf(") "):
    printf(" "),prnlst(car(cdr(x))),prnrem(cdr(cdr(x))),printf(") ");
}

#define LPAR '('
#define RPAR ')'
rd(char**p){int t,u,v,z;
    if(!(**p))R 0;
    if(**p==' ')R++(*p),rd(p);
    if(**p==RPAR)R++(*p),atom(RPAR);
    if(**p==LPAR){++(*p);
        z=NIL;
        u=rd(p);
        z=cons(u,NIL);
        while(u=rd(p),!eq(u,atom(RPAR)))
            u=cons(u,NIL),
            z=append(z,u);
        R z;}
    if(**p>='0'&&**p<='9')R++(*p),number(*((*p)-1)-'0');
    R++(*p),atom(*((*p)-1));}

And now that it appears to be working, I've made a project page for it on github.