File content as of revision 9:2a47b9ff8911:

///* A minimal Lisp interpreter
//   Copyright 2004 Andru Luvisi
//
//   This program is free software; you can redistribute it and/or modify
//   it under the terms of the GNU General Public License as published by
//   the Free Software Foundation; either version 2 of the License , or
//   (at your option) any later version.
//
//   This program is distributed in the hope that it will be useful,
//   but WITHOUT ANY WARRANTY; without even the implied warranty of
//   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
//   GNU General Public License for more details.
//
//   You should have received a copy of the GNU General Public License
//   along with this program. If not, write to the Free Software
//   Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
// */
//
//
//#include <stdio.h>
//#include <stdlib.h>
//#include <stdarg.h>
//#include <string.h>
//#include <ctype.h>
//#include "main.h"
//
//#define error(X) do { printf("ERROR: %s\n", X); } while (0)
//#define out_buf_size 5000
//#define in_buf_size 5000
//
//int out_counter = 0;
//int in_counter = 0;
//char out_buf[out_buf_size];
//char in_buf [in_buf_size];
//
//char lisp_exit = 0;
//
//void init_buf()
//{
//    for(int i = 0; i < out_buf_size; i++)
//        out_buf[i] = 0;
//
//    for(int i = 0; i < in_buf_size; i++)
//        in_buf[i] = 0;
//
//    out_buf[out_buf_size - 1] = 0;
//    out_counter = 0;
//    in_counter = 0;
//}
//
//char getc_2()
//{
//    //draw_vincent_string("getc2");
//    in_counter++;
//    if(in_counter >= in_buf_size)
//    {
//        lisp_exit = 1;
//        return EOF;
//    }
//
//    char next_char = in_buf[in_counter - 1];
//
//    if(next_char == 0)
//    {
//        lisp_exit = 1;
//        return EOF;
//    }
//
//    return in_buf[in_counter-1];
//}
//
//void ungetc_2(char c)
//{
//    in_counter--;
//}
//
//
//char* strdup_2(char* in)
//{
//    char* new_string = (char*)malloc(strlen(in));
//    strcpy(new_string,in);
//    return new_string;
//}
//
//void write_out(char* str)
//{
//    printf("write_out: %s\n",str);
//
//    int len = strlen(str);
//
//    if(len + out_counter < out_buf_size)
//    {
//        printf("BUUFER OVERLFOW!\n");
//        return;
//    }
//
//    memcpy(out_buf + out_counter, str, len);
//}
//
//int line_num = 1;
//int total_malloc = 0;
//
///*** List Structured Memory ***/
//enum otype { INT, SYM, CONS, PROC, PRIMOP };
//typedef struct obj {
//  enum otype type;
//  int line_num;
//  struct obj *p[1];
//} obj;
//typedef obj * (*primop)(obj *);
//obj *all_symbols, *top_env, *nil, *tee, *quote, 
//    *s_if, *s_lambda, *s_define, *s_setb, *s_begin;
//
//#define cons(X, Y)            omake(CONS, 2, (X), (Y))
//
//obj *car(obj *X) {
//  if(X == 0) {
//    sprintf(out_buf + strlen(out_buf),"warning: car argument null on line %d\n", line_num);
//    return nil;
//  }
//  if(X == nil)
//    return nil;
//  if(X->type != CONS) {
//    sprintf(out_buf + strlen(out_buf),"warning: car argument not a list (%d) on line %d\n", X->p[0], X->line_num);
//    return nil;
//  }
//  return X->p[0];
//}
//
//obj *cdr(obj *X) {
//  if(X == nil)
//    return nil;
//  if(X->type != CONS) {
//    sprintf(out_buf + strlen(out_buf),"warning: cdr argument not a list on line %d\n", X->line_num); 
//    return nil;    
//  }
//  if(X->p[1] == 0) {
//    sprintf(out_buf + strlen(out_buf),"error: cdr list element is zero-pointer at %d\n", X->line_num);
//    return nil;
//  }
//  return X->p[1];
//}
//
//#define setcar(X,Y)           (((X)->p[0]) = (Y))
//#define setcdr(X,Y)           (((X)->p[1]) = (Y))
//#define mkint(X)              omake(INT, 1, (obj *)(X))
//#define intval(X)             ((int)((X)->type == INT ? (X)->p[0] : 0)) // intval for INT only
//#define mksym(X)              omake(SYM, 1, (obj *)(X))
//#define symname(X)            ((char *)((X)->p[0]))
//#define mkprimop(X)           omake(PRIMOP, 1, (obj *)(X))
//#define primopval(X)          ((primop)(X)->p[0])
//#define mkproc(X,Y,Z)         omake(PROC, 3, (X), (Y), (Z))
//#define procargs(X)           ((X)->p[0])
//#define proccode(X)           ((X)->p[1])
//#define procenv(X)            ((X)->p[2])
//#define isnil(X)              ((X) == nil)
//
//obj *omake(enum otype type, int count, ...) {
//  obj *ret;
//  va_list ap;
//  int i;
//  va_start(ap, count);
//  int object_size = sizeof(obj) + (count - 1)*sizeof(obj *);
//  total_malloc += object_size;
//  if(type == INT)
//      printf("malloc %d bytes for INT\r\n",object_size);
//    if(type == SYM)
//      printf("malloc %d bytes for SYM\r\n",object_size);
//        if(type == CONS)
//      printf("malloc %d bytes for CONS\r\n",object_size);
//    if(type == SYM)
//      printf("malloc %d bytes for PROC\r\n",object_size);
//        if(type == PRIMOP)
//      printf("malloc %d bytes for PRIMOP\r\n",object_size);
//
////enum otype { INT, SYM, CONS, PROC, PRIMOP };
//  ret = (obj *) malloc(object_size);
//  ret->type = type;
//  ret->line_num = line_num;
//  for(i = 0; i < count; i++) ret->p[i] = va_arg(ap, obj *);
//  va_end(ap);
//  return ret;
//}
//
//obj *findsym(char *name) {
//  obj *symlist;
//  for(symlist = all_symbols; !isnil(symlist); symlist = cdr(symlist))
//    if(!strcmp(name, symname(car(symlist))))
//      return symlist;
//  return nil;
//}
//
//obj *intern(char *name) {
//  obj *op = findsym(name);
//  if(!isnil(op)) return car(op);
//  op = mksym(name);
//  all_symbols = cons(op, all_symbols);
//  return op;
//}
//
///*** Environment ***/
//#define extend(ENV, SYM, VAL) (cons(cons((SYM), (VAL)), (ENV)))
//
//obj *multiple_extend(obj *env, obj *syms, obj *vals) {
//  return isnil(syms) ? 
//         env : 
//         multiple_extend(extend(env, car(syms), car(vals)),
//                         cdr(syms), cdr(vals));
//}
//
//obj *extend_top(obj *sym, obj *val) {
//  setcdr(top_env, cons(cons(sym, val), cdr(top_env)));
//  return val;
//}
//
//obj *assoc(obj *key, obj *alist) {
//  if(isnil(alist)) return nil;
//  if(car(car(alist)) == key) return car(alist);
//  return assoc(key, cdr(alist));
//}
//
///*** Input/Output ***/
////FILE *ifp;
//char *token_la;
//int la_valid = 0;
//#define MAXLEN 100
//char buf[MAXLEN];
//int bufused;
//
//void add_to_buf(char ch) { if(bufused < MAXLEN - 1) buf[bufused++] = ch; }
//char *buf2str()          { buf[bufused++] = '\0'; return strdup_2(buf); }
////void setinput(FILE *fp)  { ifp = fp; }
//void putback_token(char *token) { token_la = token; la_valid = 1; }
//
//void myexit(int code);
//
//char *gettoken() {
//  int ch;
//  char comment=0;
//
//  bufused = 0;
//  if(la_valid) { la_valid = 0; return token_la; }
//  do {
//    if((ch = getc_2()) == EOF) {myexit(0); return NULL;} // replace with serial
//    //draw_vincent_string("gettoken");
//    if(ch == ';')      comment = 1;
//    if(ch == '\n') {
//      comment = 0;
//      line_num++;
//    }
//
//  } while(isspace(ch) || comment);
//
//
//  add_to_buf(ch);
//  if(strchr("()\'", ch)) return buf2str();
//  for(;;) {
//    if(lisp_exit) { return NULL; }
//    if((ch = getc_2()) == EOF) {myexit(0); return NULL;}
//    if(strchr("()\'", ch) || isspace(ch)) {
//      ungetc_2(ch);
//      return buf2str();
//    }
//    add_to_buf(ch);
//  }
//}
//
//obj *readlist();
//
//obj *readobj() {
//  char *token;
//
//  token = gettoken();
//  if(token == NULL) return NULL;
//  if(!strcmp(token, "(")) return readlist();
//  if(!strcmp(token, "\'")) return cons(quote, cons(readobj(), nil));
//
//  if(token[strspn(token, "0123456789")] == '\0'
//     || (token[0] == '-' && strlen(token) > 1)) 
//    return mkint(atoi(token));
//  return intern(token);
//}
//
//obj *readlist() {
//  char *token = gettoken();
//  if(token == NULL) return NULL;
//  obj *tmp;
//  if(!strcmp(token, ")")) return nil;
//  if(!strcmp(token, ".")) {
//    tmp = readobj();
//    if(strcmp(gettoken(), ")")) myexit(1);
//    return tmp;
//  }
//  putback_token(token);
//  tmp = readobj(); /* Must force evaluation order */
//  return cons(tmp, readlist());
//}
//
//void writeobj(obj *op) {
//  
//  if(op == NULL) { return; }
//  switch(op->type) {
//    case INT:  sprintf(out_buf + strlen(out_buf),"%d", intval(op));  break;
//    case CONS: 
//    //draw_vincent_string("  write_cons  ");
//        sprintf(out_buf + strlen(out_buf),"(");
//        for(;;) {
//            writeobj(car(op));
//            if(isnil(cdr(op))) {
//                sprintf(out_buf + strlen(out_buf),")");
//                break;
//            }
//            op = cdr(op);
//            if(op->type != CONS) {
//                sprintf(out_buf + strlen(out_buf)," . ");
//                writeobj(op);
//                sprintf(out_buf + strlen(out_buf),")");
//                break;
//            }
//            sprintf(out_buf + strlen(out_buf)," ");
//        }
//        break;
//    case SYM:
//    
//        if(isnil(op)) sprintf(out_buf + strlen(out_buf),"()");
//        else          sprintf(out_buf + strlen(out_buf),"%s", symname(op));
//        break;
//    case PRIMOP: sprintf(out_buf + strlen(out_buf),"#<PRIMOP>"); break;
//    case PROC:   sprintf(out_buf + strlen(out_buf),"#<PROC>"); break;
//    default: myexit(1);
//  }
//}
//
///*** Evaluator (Eval/no Apply) ***/
//obj *evlis(obj *exps, obj *env);
//
//obj *eval(obj *exp, obj *env) {
//  if(lisp_exit) return NULL;
//  obj *tmp, *proc, *vals;
//
//  eval_start:
//  
//  if(exp == NULL) return nil;
//  if(exp == nil) return nil;
//
//
//  switch(exp->type) {
//    case INT:   return exp;
//    case SYM:   tmp = assoc(exp, env);
//
//      if(tmp == nil) {
//        sprintf(out_buf + strlen(out_buf), "Unbound symbol ");
//        writeobj(exp);
//        sprintf(out_buf + strlen(out_buf), "\n");
//        return nil;
//      }
//      return cdr(tmp);
//
//
//
//    case CONS: 
//      if(car(exp) == s_if) {
//        if(eval(car(cdr(exp)), env) != nil)
//          return eval(car(cdr(cdr(exp))), env);
//        else
//          return eval(car(cdr(cdr(cdr(exp)))), env);
//      }
//      if(car(exp) == s_lambda)
//        return mkproc(car(cdr(exp)), cdr(cdr(exp)), env);
//      if(car(exp) == quote)
//        return car(cdr(exp));
//      if(car(exp) == s_define)
//        return(extend_top(car(cdr(exp)),
//                          eval(car(cdr(cdr(exp))), env)));
//      if(car(exp) == s_setb) {
//        obj *pair   = assoc(car(cdr(exp)), env);
//        obj *newval = eval(car(cdr(cdr(exp))), env);
//        setcdr(pair, newval);
//        return newval;
//      }
//      if(car(exp) == s_begin) {
//        exp = cdr(exp);
//        if(exp == nil) return nil;
//        for(;;) {
//          if(cdr(exp) == nil) {
//            exp = car(exp);
//            goto eval_start;
//          }
//          eval(car(exp), env);
//          exp = cdr(exp);
//        }
//      }
//      proc = eval(car(exp), env);
//      vals = evlis(cdr(exp), env);
//      if(proc->type == PRIMOP)
//        return (*primopval(proc))(vals);
//      if(proc->type == PROC) {
//        /* For dynamic scope, use env instead of procenv(proc) */
//        env = multiple_extend(procenv(proc), procargs(proc), vals);
//        exp = cons(s_begin, proccode(proc));
//        goto eval_start;
//      }
//      sprintf(out_buf + strlen(out_buf),"Bad PROC type\n");
//      return nil;
//    case PRIMOP: return exp;
//    case PROC:   return exp;
//  }
//  /* Not reached */
//  return exp; 
//}
//
//obj *evlis(obj *exps, obj *env) {
//  if(exps == nil) return nil;
//  return cons(eval(car(exps), env), 
//              evlis(cdr(exps), env));
//}
//
///*** Primitives ***/
//obj *prim_sum(obj *args) {
//  int sum;
//  for(sum = 0; !isnil(args); sum += intval(car(args)), args = cdr(args));
//  return mkint(sum);
//}
//
//obj *prim_sub(obj *args) {
//  int sum;
//  for(sum = intval(car(args)), args = cdr(args); 
//      !isnil(args); 
//      sum -= intval(car(args)), args = cdr(args));
//  return mkint(sum);
//}
//
//obj *prim_prod(obj *args) {
//  int prod;
//  for(prod = 1; !isnil(args); prod *= intval(car(args)), args = cdr(args));
//  return mkint(prod);
//}
//obj *prim_divide(obj *args) {
//  int prod = intval(car(args));
//  args = cdr(args);
//  while(!isnil(args)) {
//    prod /= intval(car(args));
//    args = cdr(args);
//  }
//
//  return mkint(prod);
//}
//
//obj *prim_gt(obj *args) {
//  return intval(car(args)) > intval(car(cdr(args))) ? tee : nil;
//}
//
//obj *prim_lt(obj *args) {
//  return intval(car(args)) < intval(car(cdr(args))) ? tee : nil;
//}
//obj *prim_ge(obj *args) {
//  return intval(car(args)) >= intval(car(cdr(args))) ? tee : nil;
//}
//obj *prim_le(obj *args) {
//  return intval(car(args)) <= intval(car(cdr(args))) ? tee : nil;
//}
//obj *prim_numeq(obj *args) {
//  return intval(car(args)) == intval(car(cdr(args))) ? tee : nil;
//}
//
//obj *prim_cons(obj *args) { return cons(car(args), car(cdr(args))); }
//obj *prim_car(obj *args)  { return car(car(args)); }
//obj *prim_cdr(obj *args)  { return cdr(car(args)); }
//
//
///*** Helpers *****/
//
//obj *prim_print(obj *args) {
//  while(!isnil(args)) {
//    writeobj(car(args));
//    args = cdr(args);
//    sprintf(out_buf + strlen(out_buf)," ");
//  }
//  sprintf(out_buf + strlen(out_buf),"\n");
//  return nil;
//}
//
///*** Initialization ***/
//void init_sl3() {
//  nil = mksym("nil");
//  all_symbols = cons(nil, nil);
//  top_env  = cons(cons(nil, nil), nil);
//  tee      = intern("t");
//  extend_top(tee, tee);
//  quote    = intern("quote");
//  s_if     = intern("if");
//  s_lambda = intern("lambda");
//  s_define = intern("define");
//  s_setb   = intern("set!");
//  s_begin  = intern("begin");
//  extend_top(intern("+"), mkprimop(prim_sum));
//  extend_top(intern("-"), mkprimop(prim_sub));
//  extend_top(intern("*"), mkprimop(prim_prod));
//  extend_top(intern("/"), mkprimop(prim_divide));
//  extend_top(intern("="), mkprimop(prim_numeq));
//
//  extend_top(intern(">"), mkprimop(prim_gt));
//  extend_top(intern(">="), mkprimop(prim_ge));
//
//  extend_top(intern("<"), mkprimop(prim_lt));
//  extend_top(intern("<="), mkprimop(prim_le));
//
//  extend_top(intern("cons"), mkprimop(prim_cons));
//  extend_top(intern("car"),  mkprimop(prim_car));
//  extend_top(intern("cdr"),  mkprimop(prim_cdr));
//
//  extend_top(intern("print"),  mkprimop(prim_print));
//}
//
//char* get_output()
//{
//    return out_buf;
//}
//
//int lisp_init = 0;
//
///*** Main Driver ***/
//int run_lisp(char* input) {
//  if(!lisp_init)
//  { 
//    init_sl3();
//    lisp_init = 1;
//  }
//    
//    init_buf();
//      
//
//  lisp_exit = 0;
//  strcpy(in_buf, input);
//  if(!strncmp(input,"clear",4)){ clear_all_text(); return 0; }
//  if(!strncmp(input,"mem",3))
//  {
//     char memuse[40];
//     sprintf(memuse,"MEM: %d bytes",total_malloc);
//     draw_vincent_string(memuse);
//     return;
//  }
//  in_buf[in_buf_size - 1] = 0;
//  //new_line();
//  //draw_vincent_string(in_buf);
//  //new_line();
//  //print_vincent_string(in_buf);
////  if(argc == 2)
////  {
////      memcpy(in_buf,argv[1],strlen(argv[1]));
////      printf("%s\n",in_buf);
////  }
////  else
//    //sprintf(in_buf,"(+ 2 2)\n");
////  char test_in[] = "(+ 2 2)\n";
////  FILE* input_stream = open_memstream(test_in,8);
////  fprintf(input_stream,"(+ 2 3)\n");
////  char test_out[50];
////  FILE* output_stream = fmemopen(test_out,50,"w");
//  //setinput(input_stream);
//  int lisp_count = 0;
//  while(!lisp_exit) {
//    writeobj(eval(readobj(), top_env));
//    //fflush(output_stream);
//    printf("\n");
//    printf("%s\n",out_buf);
//    
//    lisp_count++;
//    if(lisp_count > 500) break;
//    //printf("outstream: %s\n",test_out);
//  }
//  draw_vincent_string(out_buf);
//  //draw_vincent_string("done!");
//  return 0;
//}
//
//void myexit(int code) {
//  printf("%d bytes left hanging\n", total_malloc);
//  lisp_exit = 1;
//}