sl3.c

   1 /* A minimal Lisp interpreter
   2    Copyright 2004 Andru Luvisi
   3
   4    This program is free software; you can redistribute it and/or modify
   5    it under the terms of the GNU General Public License as published by
   6    the Free Software Foundation; either version 2 of the License , or
   7    (at your option) any later version.
   8
   9    This program is distributed in the hope that it will be useful,
  10    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12    GNU General Public License for more details.
  13
  14    You should have received a copy of the GNU General Public License
  15    along with this program. If not, write to the Free Software
  16    Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  17  */
  18
  19
  20 #include <stdio.h>
  21 #include <stdlib.h>
  22 #include <stdarg.h>
  23 #include <string.h>
  24 #include <ctype.h>
  25
  26 #define error(X) do { fprintf(stderr, "%s\n", X); exit(1); } while (0)
  27
  28 /*** List Structured Memory ***/
  29 enum otype { INT, SYM, CONS, PROC, PRIMOP };
  30 typedef struct obj {
  31   enum otype type;
  32   struct obj *p[1];
  33 } obj;
  34 typedef obj * (*primop)(obj *);
  35 obj *all_symbols, *top_env, *nil, *tee, *quote,
  36     *s_if, *s_lambda, *s_define, *s_setb;
  37
  38 #define cons(X, Y)            omake(CONS, 2, (X), (Y))
  39 #define car(X)                ((X)->p[0])
  40 #define cdr(X)                ((X)->p[1])
  41 #define setcar(X,Y)           (((X)->p[0]) = (Y))
  42 #define setcdr(X,Y)           (((X)->p[1]) = (Y))
  43 #define mkint(X)              omake(INT, 1, (obj *)(X))
  44 #define intval(X)             ((int)((X)->p[0]))
  45 #define mksym(X)              omake(SYM, 1, (obj *)(X))
  46 #define symname(X)            ((char *)((X)->p[0]))
  47 #define mkprimop(X)           omake(PRIMOP, 1, (obj *)(X))
  48 #define primopval(X)          ((primop)(X)->p[0])
  49 #define mkproc(X,Y,Z)         omake(PROC, 3, (X), (Y), (Z))
  50 #define procargs(X)           ((X)->p[0])
  51 #define proccode(X)           ((X)->p[1])
  52 #define procenv(X)            ((X)->p[2])
  53 #define isnil(X)              ((X) == nil)
  54
  55 obj *omake(enum otype type, int count, ...) {
  56   obj *ret;
  57   va_list ap;
  58   int i;
  59   va_start(ap, count);
  60   ret = (obj *) malloc(sizeof(obj) + (count - 1)*sizeof(obj *));
  61   ret->type = type;
  62   for(i = 0; i < count; i++) ret->p[i] = va_arg(ap, obj *);
  63   va_end(ap);
  64   return ret;
  65 }
  66
  67 obj *findsym(char *name) {
  68   obj *symlist;
  69   for(symlist = all_symbols; !isnil(symlist); symlist = cdr(symlist))
  70     if(!strcmp(name, symname(car(symlist))))
  71       return symlist;
  72   return nil;
  73 }
  74
  75 obj *intern(char *name) {
  76   obj *op = findsym(name);
  77   if(!isnil(op)) return car(op);
  78   op = mksym(name);
  79   all_symbols = cons(op, all_symbols);
  80   return op;
  81 }
  82
  83 /*** Environment ***/
  84 #define extend(ENV, SYM, VAL) (cons(cons((SYM), (VAL)), (ENV)))
  85
  86 obj *multiple_extend(obj *env, obj *syms, obj *vals) {
  87   return isnil(syms) ?
  88          env :
  89          multiple_extend(extend(env, car(syms), car(vals)),
  90                          cdr(syms), cdr(vals));
  91 }
  92
  93 obj *extend_top(obj *sym, obj *val) {
  94   setcdr(top_env, cons(cons(sym, val), cdr(top_env)));
  95   return val;
  96 }
  97
  98 obj *assoc(obj *key, obj *alist) {
  99   if(isnil(alist)) return nil;
 100   if(car(car(alist)) == key) return car(alist);
 101   return assoc(key, cdr(alist));
 102 }
 103
 104 /*** Input/Output ***/
 105 FILE *ifp;
 106 char *token_la;
 107 int la_valid = 0;
 108 #define MAXLEN 100
 109 char buf[MAXLEN];
 110 int bufused;
 111
 112 void add_to_buf(char ch) { if(bufused < MAXLEN - 1) buf[bufused++] = ch; }
 113 char *buf2str()          { buf[bufused++] = '\0'; return strdup(buf); }
 114 void setinput(FILE *fp)  { ifp = fp; }
 115 void putback_token(char *token) { token_la = token; la_valid = 1; }
 116
 117 char *gettoken() {
 118   int ch;
 119
 120   bufused = 0;
 121   if(la_valid) { la_valid = 0; return token_la; }
 122   do {
 123     if((ch = getc(ifp)) == EOF) exit(0);
 124   } while(isspace(ch));
 125   add_to_buf(ch);
 126   if(strchr("()\'", ch)) return buf2str();
 127   for(;;) {
 128     if((ch = getc(ifp)) == EOF) exit(0);
 129     if(strchr("()\'", ch) || isspace(ch)) {
 130       ungetc(ch, ifp);
 131       return buf2str();
 132     }
 133     add_to_buf(ch);
 134   }
 135 }
 136
 137 obj *readlist();
 138 obj *readobj() {
 139   char *token;
 140
 141   token = gettoken();
 142   if(!strcmp(token, "(")) return readlist();
 143   if(!strcmp(token, "\'")) return cons(quote, cons(readobj(), nil));
 144   if(token[strspn(token, "0123456789")] == '\0') return mkint(atoi(token));
 145   return intern(token);
 146 }
 147
 148 obj *readlist() {
 149   char *token = gettoken();
 150   obj *tmp;
 151   if(!strcmp(token, ")")) return nil;
 152   if(!strcmp(token, ".")) {
 153     tmp = readobj();
 154     if(strcmp(gettoken(), ")")) exit(1);
 155     return tmp;
 156   }
 157   putback_token(token);
 158   tmp = readobj(); /* Must force evaluation order */
 159   return cons(tmp, readlist());
 160 }
 161
 162 void writeobj(FILE *ofp, obj *op) {
 163   switch(op->type) {
 164     case INT:  fprintf(ofp, "%d", intval(op)); break;
 165     case CONS:
 166                 fprintf(ofp, "(");
 167                 for(;;) {
 168                         writeobj(ofp, car(op));
 169                         if(isnil(cdr(op))) {
 170                                 fprintf(ofp, ")");
 171                                 break;
 172                         }
 173                         op = cdr(op);
 174                         if(op->type != CONS) {
 175                                 fprintf(ofp, " . ");
 176                                 writeobj(ofp, op);
 177                                 fprintf(ofp, ")");
 178                                 break;
 179                         }
 180                         fprintf(ofp, " ");
 181                 }
 182                 break;
 183     case SYM:
 184                 if(isnil(op)) fprintf(ofp, "()");
 185                 else          fprintf(ofp, "%s", symname(op));
 186                 break;
 187     case PRIMOP: fprintf(ofp, "#<PRIMOP>"); break;
 188     case PROC:   fprintf(ofp, "#<PROC>"); break;
 189     default: exit(1);
 190   }
 191 }
 192
 193 /*** Evaluator (Eval/Apply) ***/
 194 obj *evlis(obj *exps, obj *env);
 195 obj *progn(obj *exps, obj *env);
 196 obj *apply(obj *proc, obj *vals, obj *env);
 197
 198 obj *eval(obj *exp, obj *env) {
 199   obj *tmp;
 200
 201   if(exp == nil) return nil;
 202
 203   switch(exp->type) {
 204     case INT: return exp;
 205     case SYM:   tmp = assoc(exp, env);
 206                 if(tmp == nil) error("Unbound symbol");
 207                 return cdr(tmp);
 208     case CONS:  if(car(exp) == s_if) {
 209                   if(eval(car(cdr(exp)), env) != nil)
 210                     return eval(car(cdr(cdr(exp))), env);
 211                   else
 212                     return eval(car(cdr(cdr(cdr(exp)))), env);
 213                 }
 214                 if(car(exp) == s_lambda)
 215                   return mkproc(car(cdr(exp)), cdr(cdr(exp)), env);
 216                 if(car(exp) == quote)
 217                   return car(cdr(exp));
 218                 if(car(exp) == s_define)
 219                   return(extend_top(car(cdr(exp)),
 220                                     eval(car(cdr(cdr(exp))), env)));
 221                 if(car(exp) == s_setb) {
 222                   obj *pair   = assoc(car(cdr(exp)), env);
 223                   obj *newval = eval(car(cdr(cdr(exp))), env);
 224                   setcdr(pair, newval);
 225                   return newval;
 226                 }
 227                 return apply(eval(car(exp), env), evlis(cdr(exp), env), env);
 228     case PRIMOP: return exp;
 229     case PROC:   return exp;
 230   }
 231   /* Not reached */
 232   return exp;
 233 }
 234
 235 obj *evlis(obj *exps, obj *env) {
 236   if(exps == nil) return nil;
 237   return cons(eval(car(exps), env),
 238               evlis(cdr(exps), env));
 239 }
 240
 241 obj *progn(obj *exps, obj *env) {
 242   if(exps == nil) return nil;
 243   for(;;) {
 244     if(cdr(exps) == nil)
 245       return eval(car(exps), env);
 246     eval(car(exps), env);
 247     exps = cdr(exps);
 248   }
 249 }
 250
 251 obj *apply(obj *proc, obj *vals, obj *env) {
 252   if(proc->type == PRIMOP)
 253     return (*primopval(proc))(vals);
 254   if(proc->type == PROC) {
 255     /* For dynamic scope, use env instead of procenv(proc) */
 256     return progn(proccode(proc),
 257                  multiple_extend(procenv(proc), procargs(proc), vals));
 258   }
 259   error("Bad argument to apply");
 260   /* Not reached */
 261   return nil;
 262 }
 263
 264 /*** Primitives ***/
 265 obj *prim_sum(obj *args) {
 266   int sum;
 267   for(sum = 0; !isnil(args); sum += intval(car(args)), args = cdr(args));
 268   return mkint(sum);
 269 }
 270
 271 obj *prim_sub(obj *args) {
 272   int sum;
 273   for(sum = intval(car(args)), args = cdr(args);
 274       !isnil(args);
 275       sum -= intval(car(args)), args = cdr(args));
 276   return mkint(sum);
 277 }
 278
 279 obj *prim_prod(obj *args) {
 280   int prod;
 281   for(prod = 1; !isnil(args); prod *= intval(car(args)), args = cdr(args));
 282   return mkint(prod);
 283 }
 284
 285 obj *prim_numeq(obj *args) {
 286   return intval(car(args)) == intval(car(cdr(args))) ? tee : nil;
 287 }
 288
 289 obj *prim_cons(obj *args) { return cons(car(args), car(cdr(args))); }
 290 obj *prim_car(obj *args)  { return car(car(args)); }
 291 obj *prim_cdr(obj *args)  { return cdr(car(args)); }
 292
 293 /*** Initialization ***/
 294 void init_sl3() {
 295   nil = mksym("nil");
 296   all_symbols = cons(nil, nil);
 297   top_env  = cons(cons(nil, nil), nil);
 298   tee      = intern("t");
 299   extend_top(tee, tee);
 300   quote    = intern("quote");
 301   s_if     = intern("if");
 302   s_lambda = intern("lambda");
 303   s_define = intern("define");
 304   s_setb   = intern("set!");
 305   extend_top(intern("+"), mkprimop(prim_sum));
 306   extend_top(intern("-"), mkprimop(prim_sub));
 307   extend_top(intern("*"), mkprimop(prim_prod));
 308   extend_top(intern("="), mkprimop(prim_numeq));
 309   extend_top(intern("cons"), mkprimop(prim_cons));
 310   extend_top(intern("car"),  mkprimop(prim_car));
 311   extend_top(intern("cdr"),  mkprimop(prim_cdr));
 312 }
 313
 314 /*** Main Driver ***/
 315 int main() {
 316   init_sl3();
 317   setinput(stdin);
 318   for(;;) {
 319     writeobj(stdout, eval(readobj(), top_env));
 320     printf("\n");
 321   }
 322   return 0;
 323 }