File content as of revision 10:1163fb31b0a7:

/* 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;
}