thp

#include <stdio.h>
#include <ctype.h>
#include <stdlib.h>
#include <string.h>

#define nil 0

enum
{
    Nil = 0,
    List = 1,
    Atom = 2,
    ATOMSZ = 64,
};

typedef struct O O;

struct O
{
    union {
        O *o[2];
        char *a;
    };
    int type;
};

char *atomstr(O *o);
O *mka(char *c);
O *cons(O *car, O *cdr);
O *car(O *o);
O *cdr(O *o);
O *r(void);
void prin1(O *o);
void pl(O *o[2], int paren);
O *eval(O *o, O *env);

char *
atomstr(O *o)
{
    if(o == nil)
        return "";
    if(o->type != Atom)
        return "";

    return o->a;
}

O *
mka(char *c)
{
    O *o;

    o = malloc(sizeof(O));

    o->a = c;
    o->type = Atom;
    return o;
}

O *
cons(O *car, O *cdr)
{
    O *o;

    o = malloc(sizeof(O));

    o->o[0] = car;
    o->o[1] = cdr;
    o->type = List;

    return o;
}

O *
car(O *o)
{
    if(o == nil)
        return nil;
    if(o->type != List)
        return nil;

    return o->o[0];
}

O *
cdr(O *o)
{
    if(o == nil)
        return nil;
    if(o->type != List)
        return nil;

    return o->o[1];
}

int
skipspace(void)
{
    int c;

    while((c = getc(stdin)) >= 0){
        if(!isspace(c))
            break;
    }
    return c;
}

O *
rdatom(int c)
{
    int i;
    char *s;

    s = malloc(ATOMSZ + 1);
    if(s == nil)
        return nil;

    for(i = 0; i < ATOMSZ; ++i){
        if(!isgraph(c) || c == '(' || c == ')')
            break;
        s[i] = c;
        c = getc(stdin);
    }
    ungetc(c, stdin);
    s[i] = '\0';

    if(i == 0){
        free(s);
        return nil;
    }
    return mka(s);
}

O *
rdlist(void)
{
    O *car, *cdr;
    int c;

    c = skipspace();

    if(c == ')')
        return nil;

    ungetc(c, stdin);

    car = r();
    c = skipspace();
    if(c == '.'){
        cdr = r();
        c = skipspace();
        if(c != ')')
            return nil;
        return cons(car, cdr);
    }else{
        ungetc(c, stdin);
        cdr = rdlist();
        return cons(car, cdr);
    }
}

O *
r(void)
{
    int c;

    c = skipspace();

    if(c == '(')
        return rdlist();
    if(!isprint(c) || c == ')')
        return nil;
    return rdatom(c);
}

/* XXX should it take o, or o->o[2] ? */
void
pl(O *o[2], int paren)
{
    if(o == nil)
        return;

    if(paren)
        printf("(");

    prin1(o[0]);

    if(o[1] == nil)
        goto end;
    switch(o[1]->type){
    case Nil:
        break;
    case List:
        printf(" ");
        pl(o[1]->o, 0);
        break;
    case Atom:
        printf(" . ");
        prin1(o[1]);
        break;
    }

end:
    if(paren)
        printf(")");
}

/* XXX externally-consumable prin1 should wrap this and bioflush, */
/* XXX so we can bioprint inside.  (bioflush unsuitable; equiv to print() since recursive.) */
void
prin1(O *o)
{
    if(o == nil){
        printf("nil");
        return;
    }
    switch(o->type){
    case Nil:
        printf("nil");
        return;
    case List:
        pl(o->o, 1);
        return;
    case Atom:
        printf("%s", o->a);
        return;
    default:
        printf("invalid type");
        return;
    }
}


/* XXX need to distinguish numbers. */
O *
evala(O *o, O *env)
{
    O *v;
    char *a;

    if(o == nil)
        return nil;
    if(o->type != Atom)
        return nil;

    a = atomstr(o);

    for(v = env; v != nil; v = cdr(v)){
        if(strcmp(atomstr(car(car(v))), a) == 0)
            return car(cdr(car(v)));
    }
    return o;
}

O *
evalargs(O *o, O *env)
{
    if(o == nil)
        return nil;
    if(o->type != List)
        return o;

    return cons(eval(car(o), env), evalargs(cdr(o), env));
}

//O *
//args2env(O *proto, O *args, O *env)
//{
//  while(proto != nil){
//      env = cons(cons(car(proto), cons(car(args), nil)), env);
//      proto = cdr(proto);
//      args = cdr(args);
//  }
//
//  return env;
//}

/* XXX how to do partial application? */
O *
args2env(O *proto, O *args, O *env)
{
    if(proto == nil)
        return env;

    return cons(cons(car(proto), cons(car(args), nil)), args2env(cdr(proto), cdr(args), env));
}

/* XXX expensive */
O *
splice(O *head, O *tail)
{
    if(head == nil)
        return tail;
    return cons(car(head), splice(cdr(head), tail));
}

O *
lambda(O *o, O *env)
{
    O *f, *args;

    if(o == nil)
        return nil;

    f = car(o);
    if(f == nil)
        return nil;
    if(f->type != List)
        return nil;

    if(strcmp(atomstr(car(f)), "CLOSURE") == 0){
        env =  splice(car(cdr(f)), env); /* XXX expensive! especially on every function call! */
        args = evalargs(cdr(o), env);
        printf("closure args: "); prin1(args); printf("\n");
        env = args2env(car(cdr(cdr(f))), args, env);
        return eval(car(cdr(cdr(cdr(f)))), env);
    }

    if(strcmp(atomstr(car(f)), "LAMBDA") == 0){
        args = evalargs(cdr(o), env);
        printf("lambda args: "); prin1(args); printf("\n");
        env = args2env(car(cdr(f)), args, env);
        //print("env: "); prin1(env); print("\n");
        //print("body: "); prin1(cdr(cdr(f))); print("\n");
        //print("evaling body: "); prin1(eval(cdr(cdr(f)), env)); print("\n");
        return eval(car(cdr(cdr(f))), env);
    }

    printf("reached bottom of lambda\n");
    return nil;
}

/* (NAME (alist)) */
/* Need to pass a list of local variables. */
/* Need to handle all special forms here.  def/defun cond lambda let */
/* Default case: lookup a in local variable list. */
/* XXX closures! */
/* XXX need to eval args! eg (let ((a (+ 1 2))) ...) */
O *
eval(O *o, O *env)
{
    char *a;
    O *vars;

    if(o == nil)
        return nil;
    if(o->type != List)
        return evala(o, env);

    o = cons(eval(car(o), env), cdr(o));

    if(car(o) != nil && car(o)->type == List)
        return lambda(o, env);

    a = atomstr(car(o));

    if(strcmp(a, "CLOSURE") == 0){
        return o;
    }
    if(strcmp(a, "LAMBDA") == 0){
        return cons(mka("CLOSURE"), cons(env, cdr(o)));
    }
    o = cdr(o);

    if(strcmp(a, "CONS") == 0){
        o = evalargs(o, env);
        return cons(car(o), car(cdr(o)));
    }
    if(strcmp(a, "CAR") == 0)
        return car(eval(car(o), env));
    if(strcmp(a, "CDR") == 0)
        return cdr(eval(car(o), env));
    if(strcmp(a, "IF") == 0){
        /* (IF (cond expr) expr) */
        if(eval(car(car(o)), env) != nil)
            return eval(car(cdr(car(o))), env);
        else
            return eval(car(cdr(o)), env);
    }
    if(strcmp(a, "LET") == 0){
        /* (let ((x 6) (n 3)) (cond etc...)) */
        for(vars = car(o); vars != nil; vars = cdr(vars))
            env = cons(cons(car(car(vars)), cons(eval(car(cdr(car(vars))), env), nil)), env);
        //prin1(env);
        //prin1(car(cdr(o)));
        return eval(car(cdr(o)), env);
    }
    if(strcmp(a, "QUOTE") == 0)
        return car(o);

    printf("eval reached bottom oops\n");
    return nil;
}

void
main(void)
{
    O *o;

    printf("Welcome to Lisp\n");
    for(;;){
        printf("> ");
        o = eval(r(), nil);
        prin1(o);
        printf("\n");
        if(o == nil) return;
    }
}