Diff: lisp.cpp

Revision:

9:2a47b9ff8911

Child:

10:1163fb31b0a7

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp.cpp	Sat Mar 10 05:09:55 2018 +0000
@@ -0,0 +1,580 @@
+///* 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;
+//}
\ No newline at end of file