2

我一直在基于minilisp中的编码、McCarthy 论文（由Lisp 的根修订）以及使用基于J Incunabulum的（可能令人反感的）风格编写了一个微型迷你 lisp 。并从这里使用PP_NARG宏。我也受到我之前的项目的启发，这是一个codegolf 的 lambda 演算解释器，后来我发现它与1999 年的 ioccc Lisp 解释器非常相似，特别是在使用游标而不是指针来引用内存地址方面。

它似乎主要工作，包括阅读器代码。但是，虽然eval(ATOM(QUOTE X))是正确的让步T，并且eval(ATOM(QUOTE(X Y Z)))是正确的让步NIL，并且eval(QUOTE X)让步X，并且eval(QUOTE(X Y Z))让步(X Y Z)；奇怪的结果是eval(QUOTE(ATOM(QUOTE X)))yield ATOM，而不是完整的 sub-expression ATOM(QUOTE X)。

我想这是一个远射，而且我并没有完全让它变得容易，但是任何人都可以帮我找出引用的问题所在吗？

顺便说一句，与我上面的描述不同，解释器仅限于单字符标记，因此QUOTEisQ和ATOMis 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;
}

这是由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;
}

main这是测试部分的胆量。

    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);

我得到的输出是：

(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'
4

3 回答 3

4

你的读者错了，你的打印机在骗你。

提示：尝试阅读包含多个元素的列表，例如(1 2 3 4 5).

问题是使用它刚刚读取的元素作为第二个参数进行调用rd。（修复程序已经存在，注释掉了。）在上面的测试用例中，这恰好是一个列表本身，所以有效。但是你实际传递给的数据实际上是appendappendeval

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

正确打印时，或

(Q A Q . X)

带有标准列表缩写。

所以是的，eval返回A，这是正确的答案，除非你想检查没有意外的条款。

打印机中的错误是对于您打印 cdr 的对，就好像它是一个元素一样。您应该在 car 和 cdr 之间打印一个点，或者您应该编写一个辅助函数prnlst来执行缩写列表打印。

于 2013-08-07T14:19:16.680 回答
0

晚了很多，但我终于让阅读器和打印机功能（似乎）与上面的代码一起工作。

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));}

现在它似乎正在工作，我在github上为它制作了一个项目页面。

于 2014-02-22T09:01:55.033 回答
-1

它完全正确：

子表达式

(QUOTE(ATOM(QUOTE X)))

是

(ATOM 'X)

和

(eval (atom 'x))

是

'X

（真的）

于 2013-08-07T13:10:53.880 回答