home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume15 / siod / siod.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-06-06  |  27.5 KB  |  1,106 lines
  1. /* Scheme In One Defun, but in C this time.
  2.    (c) Copyright 1988 George Carrette, gjc@bu-it.bu.edu
  3.    For demonstration purposes only.
  4.  
  5.    If your interests run to practical applications of symbolic programming
  6.    techniques, in LISP, Macsyma, C, or other language:
  7.  
  8.    Paradigm Associates Inc          Phone: 617-492-6079
  9.    29 Putnam Ave, Suite 6
  10.    Cambridge, MA 02138
  11.  
  12.    Release 1.0: 24-APR-88
  13.    Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
  14.     Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
  15.     cleaned up uses of NULL/0. Now distributed with siod.scm.
  16.    Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
  17.     plus some bug fixes.
  18.    Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
  19.     define now works properly. vms specific function edit.
  20.  
  21.    This example is small, has a garbage collector, and can run a good deal
  22.    of the code in Structure and Interpretation of Computer Programs.
  23.    (Start it up with the siod.scm file for more features).
  24.    Replacing the evaluator with an explicit control "flat-coded" one
  25.    as in chapter 5 would allow garbage collection to take place
  26.    at any time, not just at toplevel in the read-eval-print loop,
  27.    as herein implemented. This is left as an exersize for the reader.
  28.  
  29.    Techniques used will be familiar to most lisp implementors.
  30.    Having objects be all the same size, and having only two statically
  31.    allocated spaces simplifies and speeds up both consing and gc considerably.
  32.    The MSUBR hack allows for a modular implementation of tail recursion,
  33.    an extension of the FSUBR that is, as far as I know, original.
  34.  
  35.    Error handling is rather crude. A topic taken with machine fault,
  36.    exception handling, tracing, debugging, and state recovery
  37.    which we could cover in detail, but clearly beyond the scope of
  38.    this implementation. Suffice it to say that if you have a good
  39.    symbolic debugger you can set a break point at "err" and observe
  40.    in detail all the arguments and local variables of the procedures
  41.    in question, since there is no ugly "casting" of data types.
  42.    If X is an offending or interesting object then examining
  43.    X->type will give you the type, and X->storage_as.cons will
  44.    show the car and the cdr.
  45.  
  46.   */
  47.  
  48. #include <stdio.h>
  49. #include <string.h>
  50. #include <ctype.h>
  51. #include <setjmp.h>
  52. #include <signal.h>
  53. #include <math.h>
  54.  
  55. struct obj
  56. {short gc_mark;
  57.  short type;
  58.  union {struct {struct obj * car;
  59.         struct obj * cdr;} cons;
  60.     struct {double data;} flonum;
  61.     struct {char *pname;
  62.         struct obj * vcell;} symbol;
  63.     struct {char *name;
  64.         struct obj * (*f)();} subr;
  65.     struct {struct obj *env;
  66.         struct obj *code;} closure;}
  67.  storage_as;};
  68.  
  69. #define CAR(x) ((*x).storage_as.cons.car)
  70. #define CDR(x) ((*x).storage_as.cons.cdr)
  71. #define PNAME(x) ((*x).storage_as.symbol.pname)
  72. #define VCELL(x) ((*x).storage_as.symbol.vcell)
  73. #define SUBRF(x) (*((*x).storage_as.subr.f))
  74. #define FLONM(x) ((*x).storage_as.flonum.data)
  75.  
  76. struct obj *heap_1;
  77. struct obj *heap_2;
  78. struct obj *heap,*heap_end,*heap_org;
  79. long heap_size = 5000;
  80. long old_heap_used;
  81. int which_heap;
  82. int gc_status_flag = 1;
  83. char *init_file = (char *) NULL;
  84.  
  85. #define TKBUFFERN 100
  86.  
  87. char tkbuffer[TKBUFFERN];
  88.  
  89. jmp_buf errjmp;
  90. int errjmp_ok = 0;
  91. int nointerrupt = 1;
  92.  
  93. struct obj *cons(), *car(), *cdr(), *setcar(), *setcdr(),*consp();
  94. struct obj *symcons(),*rintern(),*cintern(),*cintern_soft(),*symbolp();
  95. struct obj *flocons(),*plus(),*ltimes(),*difference(),*quotient();
  96. struct obj *greaterp(),*lessp(),*eq(),*eql(),*numberp();
  97. struct obj *assq();
  98. struct obj *lread(),*leval(),*lprint(),*lprin1();
  99. struct obj *lreadr(),*lreadparen(),*lreadtk(),*lreadf();
  100. struct obj *subrcons(),*closure();
  101. struct obj *leval_define(),*leval_lambda(),*leval_if();
  102. struct obj *leval_progn(),*leval_setq(),*leval_let(),*let_macro();
  103. struct obj *leval_args(),*extend_env(),*setvar();
  104. struct obj *leval_quote(),*leval_and(),*leval_or();
  105. struct obj *oblistfn(),*copy_list();
  106. struct obj *gc_relocate(),*get_newspace(),*gc_status();
  107. struct obj *vload(),*load();
  108. struct obj *leval_tenv(),*lerr(),*quit(),*nullp();
  109. struct obj *symbol_boundp(),*symbol_value();
  110. struct obj *envlookup(),*arglchk(),*sys_edit(),*reverse();
  111.  
  112.  
  113. int handle_sigfpe();
  114. int handle_sigint();
  115.  
  116. #define NIL ((struct obj *) 0)
  117. #define EQ(x,y) ((x) == (y))
  118. #define NEQ(x,y) ((x) != (y))
  119. #define NULLP(x) EQ(x,NIL)
  120. #define NNULLP(x) NEQ(x,NIL)
  121.  
  122. #define TYPE(x) (((x) == NIL) ? 0 : ((*(x)).type))
  123.  
  124. #define TYPEP(x,y) (TYPE(x) == (y))
  125. #define NTYPEP(x,y) (TYPE(x) != (y))
  126.  
  127. #define tc_nil    0
  128. #define tc_cons   1
  129. #define tc_flonum 2
  130. #define tc_symbol 3
  131. #define tc_subr_0 4
  132. #define tc_subr_1 5
  133. #define tc_subr_2 6
  134. #define tc_subr_3 7
  135. #define tc_lsubr  8
  136. #define tc_fsubr  9
  137. #define tc_msubr  10
  138. #define tc_closure 11
  139.  
  140. init_subrs()
  141. {init_subr("cons",tc_subr_2,cons);
  142.  init_subr("car",tc_subr_1,car);
  143.  init_subr("cdr",tc_subr_1,cdr);
  144.  init_subr("set-car!",tc_subr_2,setcar);
  145.  init_subr("set-cdr!",tc_subr_2,setcdr);
  146.  init_subr("+",tc_subr_2,plus);
  147.  init_subr("-",tc_subr_2,difference);
  148.  init_subr("*",tc_subr_2,ltimes);
  149.  init_subr("/",tc_subr_2,quotient);
  150.  init_subr(">",tc_subr_2,greaterp);
  151.  init_subr("<",tc_subr_2,lessp);
  152.  init_subr("eq?",tc_subr_2,eq);
  153.  init_subr("eqv?",tc_subr_2,eql);
  154.  init_subr("assq",tc_subr_2,assq);
  155.  init_subr("read",tc_subr_0,lread);
  156.  init_subr("print",tc_subr_1,lprint);
  157.  init_subr("eval",tc_subr_2,leval);
  158.  init_subr("define",tc_fsubr,leval_define);
  159.  init_subr("lambda",tc_fsubr,leval_lambda);
  160.  init_subr("if",tc_msubr,leval_if);
  161.  init_subr("begin",tc_msubr,leval_progn);
  162.  init_subr("set!",tc_fsubr,leval_setq);
  163.  init_subr("or",tc_msubr,leval_or);
  164.  init_subr("and",tc_msubr,leval_and);
  165.  init_subr("quote",tc_fsubr,leval_quote);
  166.  init_subr("oblist",tc_subr_0,oblistfn);
  167.  init_subr("copy-list",tc_subr_1,copy_list);
  168.  init_subr("gc-status",tc_lsubr,gc_status);
  169.  init_subr("load",tc_subr_1,load);
  170.  init_subr("pair?",tc_subr_1,consp);
  171.  init_subr("symbol?",tc_subr_1,symbolp);
  172.  init_subr("number?",tc_subr_1,numberp);
  173.  init_subr("let-internal",tc_msubr,leval_let);
  174.  init_subr("let-internal-macro",tc_subr_1,let_macro);
  175.  init_subr("symbol-bound?",tc_subr_2,symbol_boundp);
  176.  init_subr("symbol-value",tc_subr_2,symbol_value);
  177.  init_subr("set-symbol-value!",tc_subr_3,setvar);
  178.  init_subr("the-environment",tc_fsubr,leval_tenv);
  179.  init_subr("error",tc_subr_2,lerr);
  180.  init_subr("quit",tc_subr_0,quit);
  181.  init_subr("not",tc_subr_1,nullp);
  182.  init_subr("null?",tc_subr_1,nullp);
  183.  init_subr("env-lookup",tc_subr_2,envlookup);
  184. #ifdef vms
  185.  init_subr("edit",tc_subr_1,sys_edit);
  186. #endif
  187.  init_subr("reverse",tc_subr_1,reverse);
  188.  }
  189.  
  190. struct obj *oblist = NIL;
  191. struct obj *truth = NIL;
  192. struct obj *eof_val = NIL;
  193. struct obj *sym_errobj = NIL;
  194. struct obj *sym_progn = NIL;
  195. struct obj *sym_lambda = NIL;
  196. struct obj *sym_quote = NIL;
  197. struct obj *open_files = NIL;
  198. struct obj *unbound_marker = NIL;
  199.  
  200. scan_registers()
  201. {oblist = gc_relocate(oblist);
  202.  eof_val = gc_relocate(eof_val);
  203.  truth = gc_relocate(truth);
  204.  sym_errobj = gc_relocate(sym_errobj);
  205.  sym_progn = gc_relocate(sym_progn);
  206.  sym_lambda = gc_relocate(sym_lambda);
  207.  sym_quote = gc_relocate(sym_quote);
  208.  open_files = gc_relocate(open_files);
  209.  unbound_marker = gc_relocate(unbound_marker);}
  210.  
  211. main(argc,argv)
  212.  int argc; char **argv;
  213. {printf("Welcome to SIOD, Scheme In One Defun, Version 1.3\n");
  214.  printf("(C) Copyright 1988, George Carrette\n");
  215.  process_cla(argc,argv);
  216.  printf("heap_size = %d cells, %d bytes\n",
  217.         heap_size,heap_size*sizeof(struct obj));
  218.  init_storage();
  219.  printf("heap_1 at 0x%X, heap_2 at 0x%X\n",heap_1,heap_2);
  220.  repl_driver();
  221.  printf("EXIT\n");}
  222.  
  223. process_cla(argc,argv)
  224.  int argc; char **argv;
  225. {int k;
  226.  for(k=1;k<argc;++k)
  227.    {if (strlen(argv[k])<2) continue;
  228.     if (argv[k][0] != '-') {printf("bad arg: %s\n",argv[k]);continue;}
  229.     switch(argv[k][1])
  230.       {case 'h':
  231.      heap_size = atol(&(argv[k][2])); break;
  232.        case 'i':
  233.      init_file = &(argv[k][2]); break;
  234.        default: printf("bad arg: %s\n",argv[k]);}}}
  235.  
  236. repl_driver()
  237. {int k;
  238.  k = setjmp(errjmp);
  239.  if (k == 2) return;
  240.  signal(SIGFPE,handle_sigfpe);
  241.  signal(SIGINT,handle_sigint);
  242.  close_open_files();
  243.  errjmp_ok = 1;
  244.  nointerrupt = 0;
  245.  if (init_file && (k == 0)) vload(init_file);
  246.  repl();}
  247.  
  248. #ifdef unix
  249. #ifdef sun
  250. double myruntime(){return(clock()*1.0e-6);}
  251. #else
  252. #ifdef encore
  253. double myruntime(){return(clock()*1.0e-6);}
  254. #else
  255. #include <sys/types.h>
  256. #include <sys/times.h>
  257. struct tms time_buffer;
  258. double myruntime(){times(&time_buffer);return(time_buffer.tms_utime/60.0);}
  259. #endif
  260. #endif
  261. #else
  262. #ifdef vms
  263. #include <stdlib.h>
  264. double myruntime(){return(clock() * 1.0e-2);}
  265. #include <descrip.h>
  266.  struct obj *
  267. sys_edit(fname)
  268.  struct obj *fname;
  269. {struct dsc$descriptor_s d;
  270.  if NTYPEP(fname,tc_symbol) err("filename not a symbol",fname);
  271.  d.dsc$b_dtype = DSC$K_DTYPE_T;
  272.  d.dsc$b_class = DSC$K_CLASS_S;
  273.  d.dsc$w_length = strlen(PNAME(fname));
  274.  d.dsc$a_pointer = PNAME(fname);
  275.  nointerrupt = 1;
  276.  edt$edit(&d);
  277.  nointerrupt = 0;
  278.  return(fname);}
  279. #else
  280. double myruntime(){long x;long time();time(&x);return(x);}
  281. #endif
  282. #endif
  283.  
  284. handle_sigfpe(sig,code,scp)
  285.  int sig,code; struct sigcontext *scp;
  286. {signal(SIGFPE,handle_sigfpe);
  287.  err("floating point exception",NIL);}
  288.  
  289. handle_sigint(sig,code,scp)
  290.  int sig,code; struct sigcontext *scp;
  291. {signal(SIGINT,handle_sigint);
  292.  if (nointerrupt == 0) err("control-c interrupt",NIL);
  293.  printf("interrupts disabled\n");}
  294.  
  295. repl() 
  296. {struct obj *x,*cw;
  297.  double rt;
  298.  while(1)
  299.    {if ((gc_status_flag) || heap >= heap_end)
  300.      {rt = myruntime();
  301.       gc();
  302.       printf("GC took %g seconds, %d compressed to %d, %d free\n",
  303.              myruntime()-rt,old_heap_used,heap-heap_org,heap_end-heap);}
  304.     printf("> ");
  305.     x = lread();
  306.     if EQ(x,eof_val) break;
  307.     rt = myruntime();
  308.     cw = heap;
  309.     x = leval(x,NIL);
  310.     printf("Evaluation took %g seconds %d cons work\n",
  311.        myruntime()-rt,heap-cw);
  312.     lprint(x);}}
  313.  
  314. err(message,x)
  315.  char *message; struct obj *x;
  316. {nointerrupt = 1;
  317.  if NNULLP(x) 
  318.     printf("ERROR: %s (see errobj)\n",message);
  319.   else printf("ERROR: %s\n",message);
  320.  if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(errjmp,1);}
  321.  printf("FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n");
  322.  exit(1);}
  323.  
  324.  struct obj *
  325. lerr(message,x)
  326.  struct obj *message,*x;
  327. {if NTYPEP(message,tc_symbol) err("argument to error not a symbol",message);
  328.  err(PNAME(message),x);
  329.  return(NIL);}
  330.  
  331.  struct obj *
  332. cons(x,y)
  333.  struct obj *x,*y;
  334. {register struct obj *z;
  335.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  336.  heap = z+1;
  337.  (*z).gc_mark = 0;
  338.  (*z).type = tc_cons;
  339.  CAR(z) = x;
  340.  CDR(z) = y;
  341.  return(z);}
  342.  
  343.  struct obj *
  344. consp(x)
  345.  struct obj *x;
  346. {if TYPEP(x,tc_cons) return(truth); else return(NIL);}
  347.  
  348.  struct obj *
  349. car(x)
  350.  struct obj *x;
  351. {switch TYPE(x)
  352.    {case tc_nil:
  353.       return(NIL);
  354.     case tc_cons:
  355.       return(CAR(x));
  356.     default:
  357.       err("wta to car",x);}}
  358.  
  359.  struct obj *
  360. cdr(x)
  361.  struct obj *x;
  362. {switch TYPE(x)
  363.    {case tc_nil:
  364.       return(NIL);
  365.     case tc_cons:
  366.       return(CDR(x));
  367.     default:
  368.       err("wta to cdr",x);}}
  369.  
  370.  struct obj *
  371. setcar(cell,value)
  372.  struct obj *cell,*value;
  373. {if NTYPEP(cell,tc_cons) err("wta to setcar",cell);
  374.  return(CAR(cell) = value);}
  375.  
  376.  struct obj *
  377. setcdr(cell,value)
  378.  struct obj *cell,*value;
  379. {if NTYPEP(cell,tc_cons) err("wta to setcdr",cell);
  380.  return(CDR(cell) = value);}
  381.  
  382.  struct obj *
  383. flocons(x)
  384.  double x;
  385. {register struct obj *z;
  386.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  387.  heap = z+1;
  388.  (*z).gc_mark = 0;
  389.  (*z).type = tc_flonum;
  390.  (*z).storage_as.flonum.data = x;
  391.  return(z);}
  392.  
  393.  struct obj *
  394. numberp(x)
  395.  struct obj *x;
  396. {if TYPEP(x,tc_flonum) return(truth); else return(NIL);}
  397.  
  398.  struct obj *
  399. plus(x,y)
  400.  struct obj *x,*y;
  401. {if NTYPEP(x,tc_flonum) err("wta(1st) to plus",x);
  402.  if NTYPEP(y,tc_flonum) err("wta(2nd) to plus",y);
  403.  return(flocons(FLONM(x)+FLONM(y)));}
  404.  
  405.  struct obj *
  406. ltimes(x,y)
  407.  struct obj *x,*y;
  408. {if NTYPEP(x,tc_flonum) err("wta(1st) to times",x);
  409.  if NTYPEP(y,tc_flonum) err("wta(2nd) to times",y);
  410.  return(flocons(FLONM(x)*FLONM(y)));}
  411.  
  412.  struct obj *
  413. difference(x,y)
  414.  struct obj *x,*y;
  415. {if NTYPEP(x,tc_flonum) err("wta(1st) to difference",x);
  416.  if NTYPEP(y,tc_flonum) err("wta(2nd) to difference",y);
  417.  return(flocons(FLONM(x)-FLONM(y)));}
  418.  
  419.  struct obj *
  420. quotient(x,y)
  421.  struct obj *x,*y;
  422. {if NTYPEP(x,tc_flonum) err("wta(1st) to quotient",x);
  423.  if NTYPEP(y,tc_flonum) err("wta(2nd) to quotient",y);
  424.  return(flocons(FLONM(x)/FLONM(y)));}
  425.  
  426.  struct obj *
  427. greaterp(x,y)
  428.  struct obj *x,*y;
  429. {if NTYPEP(x,tc_flonum) err("wta(1st) to greaterp",x);
  430.  if NTYPEP(y,tc_flonum) err("wta(2nd) to greaterp",y);
  431.  if (FLONM(x)>FLONM(y)) return(truth);
  432.  return(NIL);}
  433.  
  434.  struct obj *
  435. lessp(x,y)
  436.  struct obj *x,*y;
  437. {if NTYPEP(x,tc_flonum) err("wta(1st) to lessp",x);
  438.  if NTYPEP(y,tc_flonum) err("wta(2nd) to lessp",y);
  439.  if (FLONM(x)<FLONM(y)) return(truth);
  440.  return(NIL);}
  441.  
  442.   struct obj *
  443. eq(x,y)
  444.  struct obj *x,*y;
  445. {if EQ(x,y) return(truth); else return(NIL);}
  446.  
  447.   struct obj *
  448. eql(x,y)
  449.  struct obj *x,*y;
  450. {if EQ(x,y) return(truth); else 
  451.  if NTYPEP(x,tc_flonum) return(NIL); else
  452.  if NTYPEP(y,tc_flonum) return(NIL); else
  453.  if (FLONM(x) == FLONM(y)) return(truth);
  454.  return(NIL);}
  455.  
  456.  struct obj *
  457. symcons(pname,vcell)
  458.  char *pname; struct obj *vcell;
  459. {register struct obj *z;
  460.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  461.  heap = z+1;
  462.  (*z).gc_mark = 0;
  463.  (*z).type = tc_symbol;
  464.  PNAME(z) = pname;
  465.  VCELL(z) = vcell;
  466.  return(z);}
  467.  
  468.  struct obj *
  469. symbolp(x)
  470.  struct obj *x;
  471. {if TYPEP(x,tc_symbol) return(truth); else return(NIL);}
  472.  
  473.  struct obj *
  474. symbol_boundp(x,env)
  475.  struct obj *x,*env;
  476. {struct obj *tmp;
  477.  if NTYPEP(x,tc_symbol) err("not a symbol",x);
  478.  tmp = envlookup(x,env);
  479.  if NNULLP(tmp) return(truth);
  480.  if EQ(VCELL(x),unbound_marker) return(NIL); else return(truth);}
  481.  
  482.  struct obj *
  483. symbol_value(x,env)
  484.  struct obj *x,*env;
  485. {struct obj *tmp;
  486.  if NTYPEP(x,tc_symbol) err("not a symbol",x);
  487.  tmp = envlookup(x,env);
  488.  if NNULLP(tmp) return(CAR(tmp));
  489.  tmp = VCELL(x);
  490.  if EQ(tmp,unbound_marker) err("unbound variable",x);
  491.  return(tmp);}
  492.  
  493.  struct obj *
  494. cintern_soft(name)
  495.  char *name;
  496. {struct obj *l;
  497.  for(l=oblist;NNULLP(l);l=CDR(l))
  498.    if (strcmp(name,PNAME(CAR(l))) == 0) return(CAR(l));
  499.  return(NIL);}
  500.  
  501.  struct obj *
  502. cintern(name)
  503.  char *name;
  504. {struct obj *sym;
  505.  sym = cintern_soft(name);
  506.  if(sym) return(sym);
  507.  sym = symcons(name,unbound_marker);
  508.  oblist = cons(sym,oblist);
  509.  return(sym);}
  510.  
  511.  char *
  512. must_malloc(size)
  513.  unsigned long size;
  514. {char *tmp;
  515.  tmp = (char *) malloc(size);
  516.  if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
  517.  return(tmp);}
  518.  
  519.  struct obj *
  520. rintern(name)
  521.  char *name;
  522. {struct obj *sym;
  523.  char *newname;
  524.  sym = cintern_soft(name);
  525.  if(sym) return(sym);
  526.  newname = must_malloc(strlen(name)+1);
  527.  strcpy(newname,name);
  528.  sym = symcons(newname,unbound_marker);
  529.  oblist = cons(sym,oblist);
  530.  return(sym);}
  531.  
  532.  struct obj *
  533. subrcons(type,name,f)
  534.  int type; char *name; struct obj * (*f)();
  535. {register struct obj *z;
  536.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  537.  heap = z+1;
  538.  (*z).gc_mark = 0;
  539.  (*z).type = type;
  540.  (*z).storage_as.subr.name = name;
  541.  (*z).storage_as.subr.f = f;
  542.  return(z);}
  543.  
  544.  struct obj *
  545. closure(env,code)
  546.  struct obj *env,*code;
  547. {register struct obj *z;
  548.  if ((z = heap) >= heap_end) err("ran out of storage",NIL);
  549.  heap = z+1;
  550.  (*z).gc_mark = 0;
  551.  (*z).type = tc_closure;
  552.  (*z).storage_as.closure.env = env;
  553.  (*z).storage_as.closure.code = code;
  554.  return(z);}
  555.  
  556. init_storage()
  557. {int j;
  558.  heap_1 = (struct obj *)must_malloc(sizeof(struct obj)*heap_size);
  559.  heap_2 = (struct obj *)must_malloc(sizeof(struct obj)*heap_size);
  560.  heap = heap_1;
  561.  which_heap = 1;
  562.  heap_org = heap;
  563.  heap_end = heap + heap_size;
  564.  unbound_marker = cons(cintern("**unbound-marker**"),NIL);
  565.  eof_val = cons(cintern("eof"),NIL);
  566.  truth = cintern("t");
  567.  setvar(truth,truth,NIL);
  568.  setvar(cintern("nil"),NIL,NIL);
  569.  setvar(cintern("let"),cintern("let-internal-macro"),NIL);
  570.  sym_errobj = cintern("errobj");
  571.  setvar(sym_errobj,NIL,NIL);
  572.  sym_progn = cintern("begin");
  573.  sym_lambda = cintern("lambda");
  574.  sym_quote = cintern("quote");
  575.  init_subrs();}
  576.  
  577. init_subr(name,type,fcn)
  578.  char *name; int type; struct obj *(*fcn)();
  579. {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
  580.  
  581.  struct obj *
  582. assq(x,alist)
  583.  struct obj *x,*alist;
  584. {register struct obj *l,*tmp;
  585.  for(l=alist;TYPEP(l,tc_cons);l=CDR(l))
  586.    {tmp = CAR(l);
  587.     if (TYPEP(tmp,tc_cons) && EQ(CAR(tmp),x)) return(tmp);}
  588.  if EQ(l,NIL) return(NIL);
  589.  err("improper list to assq",alist);}
  590.  
  591.  struct obj *
  592. gc_relocate(x)
  593.  struct obj *x;
  594. {struct obj *new;
  595.  if EQ(x,NIL) return(NIL);
  596.  if ((*x).gc_mark == 1) return(CAR(x));
  597.  switch TYPE(x)
  598.    {case tc_flonum:
  599.       new = flocons(FLONM(x));
  600.       break;
  601.     case tc_cons:
  602.       new = cons(CAR(x),CDR(x));
  603.       break;
  604.     case tc_symbol:
  605.       new = symcons(PNAME(x),VCELL(x));
  606.       break;
  607.     case tc_closure:
  608.       new = closure((*x).storage_as.closure.env,
  609.             (*x).storage_as.closure.code);
  610.       break;
  611.     case tc_subr_0:
  612.     case tc_subr_1:
  613.     case tc_subr_2:
  614.     case tc_subr_3:
  615.     case tc_lsubr:
  616.     case tc_fsubr:
  617.     case tc_msubr:
  618.       new = subrcons(TYPE(x),
  619.              (*x).storage_as.subr.name,
  620.              (*x).storage_as.subr.f);
  621.       break;
  622.     default: err("BUG IN GARBAGE COLLECTOR gc_relocate",NIL);}
  623.  (*x).gc_mark = 1;
  624.  CAR(x) = new;
  625.  return(new);}
  626.  
  627.  struct obj *
  628. get_newspace()
  629. {struct obj * newspace;
  630.  if (which_heap == 1)
  631.    {newspace = heap_2;
  632.     which_heap = 2;}
  633.  else
  634.    {newspace = heap_1;
  635.     which_heap = 1;}
  636.  heap = newspace;
  637.  heap_org = heap;
  638.  heap_end = heap + heap_size;
  639.  return(newspace);}
  640.  
  641. scan_newspace(newspace)
  642.  struct obj  *newspace;
  643. {register struct obj *ptr;
  644.  for(ptr=newspace; ptr < heap; ++ptr)
  645.    {switch TYPE(ptr)
  646.       {case tc_cons:
  647.        case tc_closure:
  648.      CAR(ptr) = gc_relocate(CAR(ptr));
  649.      CDR(ptr) = gc_relocate(CDR(ptr));
  650.      break;
  651.        case tc_symbol:
  652.      VCELL(ptr) = gc_relocate(VCELL(ptr));
  653.      break;
  654.        default:
  655.      break;}}}
  656.       
  657. gc()
  658. {struct obj *newspace;
  659.  errjmp_ok = 0;
  660.  nointerrupt = 1;
  661.  old_heap_used = heap - heap_org;
  662.  newspace = get_newspace();
  663.  scan_registers();
  664.  scan_newspace(newspace);
  665.  errjmp_ok = 1;
  666.  nointerrupt = 0;}
  667.  
  668.  struct obj *
  669. gc_status(args)
  670.  struct obj *args;
  671. {if NNULLP(args) 
  672.   if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
  673.  if (gc_status_flag)
  674.   printf("garbage collection is on\n"); else
  675.   printf("garbage collection is off\n");
  676.  printf("%d allocated %d free\n",heap - heap_org, heap_end - heap);
  677.  return(NIL);}
  678.  
  679.  struct obj *
  680. leval_args(l,env)
  681.  struct obj *l,*env;
  682. {struct obj *result,*v1,*v2,*tmp;
  683.  if NULLP(l) return(NIL);
  684.  if NTYPEP(l,tc_cons) err("bad syntax argument list",l);
  685.  result = cons(leval(CAR(l),env),NIL);
  686.  for(v1=result,v2=CDR(l);
  687.      TYPEP(v2,tc_cons);
  688.      v1 = tmp, v2 = CDR(v2))
  689.   {tmp = cons(leval(CAR(v2),env),NIL);
  690.    CDR(v1) = tmp;}
  691.  if NNULLP(v2) err("bad syntax argument list",l);
  692.  return(result);}
  693.  
  694.  struct obj *
  695. extend_env(actuals,formals,env)
  696.  struct obj *actuals,*formals,*env;
  697. {if TYPEP(formals,tc_symbol)
  698.     return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
  699.  return(cons(cons(formals,actuals),env));}
  700.  
  701.  struct obj *
  702. envlookup(var,env)
  703.  struct obj *var,*env;
  704. {struct obj *frame,*al,*fl,*tmp;
  705.  for(frame=env;TYPEP(frame,tc_cons);frame=CDR(frame))
  706.    {tmp = CAR(frame);
  707.     if NTYPEP(tmp,tc_cons) err("damaged frame",tmp);
  708.     for(fl=CAR(tmp),al=CDR(tmp);
  709.     TYPEP(fl,tc_cons);
  710.     fl=CDR(fl),al=CDR(al))
  711.       {if NTYPEP(al,tc_cons) err("too few arguments",tmp);
  712.        if EQ(CAR(fl),var) return(al);}}
  713.  if NNULLP(frame) err("damaged env",env);
  714.  return(NIL);}
  715.  
  716.  struct obj *
  717. leval(x,env)
  718.  struct obj *x,*env;
  719. {struct obj *tmp;
  720.  loop:
  721.  switch TYPE(x)
  722.    {case tc_symbol:
  723.       tmp = envlookup(x,env);
  724.       if (tmp) return(CAR(tmp));
  725.       tmp = VCELL(x);
  726.       if EQ(tmp,unbound_marker) err("unbound variable",x);
  727.       return(tmp);
  728.     case tc_cons:
  729.       tmp = leval(CAR(x),env);
  730.       switch TYPE(tmp)
  731.     {case tc_subr_0:
  732.        return(SUBRF(tmp)());
  733.      case tc_subr_1:
  734.        return(SUBRF(tmp)(leval(car(CDR(x)),env)));
  735.      case tc_subr_2:
  736.        return(SUBRF(tmp)(leval(car(CDR(x)),env),
  737.                  leval(car(cdr(CDR(x))),env)));
  738.      case tc_subr_3:
  739.        return(SUBRF(tmp)(leval(car(CDR(x)),env),
  740.                  leval(car(cdr(CDR(x))),env),
  741.                  leval(car(cdr(cdr(CDR(x)))),env)));
  742.      case tc_lsubr:
  743.        return(SUBRF(tmp)(leval_args(CDR(x),env)));
  744.      case tc_fsubr:
  745.        return(SUBRF(tmp)(CDR(x),env));
  746.      case tc_msubr:
  747.        if NULLP(SUBRF(tmp)(&x,&env)) return(x);
  748.        goto loop;
  749.      case tc_closure:
  750.        env = extend_env(leval_args(CDR(x),env),
  751.                 car((*tmp).storage_as.closure.code),
  752.                 (*tmp).storage_as.closure.env);
  753.        x = cdr((*tmp).storage_as.closure.code);
  754.        goto loop;
  755.      case tc_symbol:
  756.        x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
  757.        x = leval(x,NIL);
  758.        goto loop;
  759.      default:
  760.        err("bad function",tmp);}
  761.     default:
  762.       return(x);}}
  763.  
  764.  struct obj *
  765. setvar(var,val,env)
  766.  struct obj *var,*val,*env;
  767. {struct obj *tmp;
  768.  if NTYPEP(var,tc_symbol) err("wta(non-symbol) to setvar",var);
  769.  tmp = envlookup(var,env);
  770.  if NULLP(tmp) return(VCELL(var) = val);
  771.  return(CAR(tmp)=val);}
  772.  
  773.  
  774.  struct obj *
  775. leval_setq(args,env)
  776.  struct obj *args,*env;
  777. {return(setvar(car(args),leval(car(cdr(args)),env),env));}
  778.  
  779.  struct obj *
  780. syntax_define(args)
  781.  struct obj *args;
  782. {if TYPEP(car(args),tc_symbol) return(args);
  783.  return(syntax_define(
  784.         cons(car(car(args)),
  785.     cons(cons(sym_lambda,
  786.          cons(cdr(car(args)),
  787.           cdr(args))),
  788.          NIL))));}
  789.       
  790.  struct obj *
  791. leval_define(args,env)
  792.  struct obj *args,*env;
  793. {struct obj *tmp,*var,*val;
  794.  tmp = syntax_define(args);
  795.  var = car(tmp);
  796.  if NTYPEP(var,tc_symbol) err("wta(non-symbol) to define",var);
  797.  val = leval(car(cdr(tmp)),env);
  798.  tmp = envlookup(var,env);
  799.  if NNULLP(tmp) return(CAR(tmp) = val);
  800.  if NULLP(env) return(VCELL(var) = val);
  801.  tmp = car(env);
  802.  setcar(tmp,cons(var,car(tmp)));
  803.  setcdr(tmp,cons(val,cdr(tmp)));
  804.  return(val);}
  805.  
  806.  struct obj *
  807. leval_if(pform,penv)
  808.  struct obj **pform,**penv;
  809. {struct obj *args,*env;
  810.  args = cdr(*pform);
  811.  env = *penv;
  812.  if NNULLP(leval(car(args),env)) 
  813.     *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
  814.  return(truth);}
  815.  
  816.  struct obj *
  817. leval_lambda(args,env)
  818.  struct obj *args,*env;
  819. {struct obj *body;
  820.  if NULLP(cdr(cdr(args)))
  821.    body = car(cdr(args));
  822.   else body = cons(sym_progn,cdr(args));
  823.  return(closure(env,cons(arglchk(car(args)),body)));}
  824.                          
  825.  struct obj *
  826. leval_progn(pform,penv)
  827.  struct obj **pform,**penv;
  828. {struct obj *env,*l,*next;
  829.  env = *penv;
  830.  l = cdr(*pform);
  831.  next = cdr(l);
  832.  while(NNULLP(next)) {leval(car(l),env);l=next;next=cdr(next);}
  833.  *pform = car(l); 
  834.  return(truth);}
  835.  
  836.  struct obj *
  837. leval_or(pform,penv)
  838.  struct obj **pform,**penv;
  839. {struct obj *env,*l,*next,*val;
  840.  env = *penv;
  841.  l = cdr(*pform);
  842.  next = cdr(l);
  843.  while(NNULLP(next))
  844.    {val = leval(car(l),env);
  845.     if NNULLP(val) {*pform = val; return(NIL);}
  846.     l=next;next=cdr(next);}
  847.  *pform = car(l); 
  848.  return(truth);}
  849.  
  850.  struct obj *
  851. leval_and(pform,penv)
  852.  struct obj **pform,**penv;
  853. {struct obj *env,*l,*next;
  854.  env = *penv;
  855.  l = cdr(*pform);
  856.  if NULLP(l) {*pform = truth; return(NIL);}
  857.  next = cdr(l);
  858.  while(NNULLP(next))
  859.    {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
  860.     l=next;next=cdr(next);}
  861.  *pform = car(l); 
  862.  return(truth);}
  863.  
  864.  struct obj *
  865. leval_let(pform,penv)
  866.  struct obj **pform,**penv;
  867. {struct obj *env,*l;
  868.  l = cdr(*pform);
  869.  env = *penv;
  870.  *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
  871.  *pform = car(cdr(cdr(l)));
  872.  return(truth);}
  873.  
  874.  struct obj *
  875. reverse(l)
  876.  struct obj *l;
  877. {struct obj *n,*p;
  878.  n = NIL;
  879.  for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
  880.  return(n);}
  881.  
  882.  struct obj *
  883. let_macro(form)
  884.  struct obj *form;
  885. {struct obj *p,*fl,*al,*tmp;
  886.  fl = NIL;
  887.  al = NIL;
  888.  for(p=car(cdr(form));NNULLP(p);p=cdr(p))
  889.   {tmp = car(p);
  890.    if TYPEP(tmp,tc_symbol) {fl = cons(tmp,fl); al = cons(NIL,al);}
  891.    else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
  892.  p = cdr(cdr(form));
  893.  if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
  894.  setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
  895.  setcar(form,cintern("let-internal"));
  896.  return(form);}
  897.    
  898.   struct obj *
  899. leval_quote(args,env)
  900.  struct obj *args,*env;
  901. {return(car(args));}
  902.  
  903.  struct obj *
  904. leval_tenv(args,env)
  905.  struct obj *args,*env;
  906. {return(env);}
  907.  
  908.  struct obj *
  909. lprint(exp)
  910.  struct obj *exp;
  911. {lprin1(exp);
  912.  printf("\n");
  913.  return(NIL);}
  914.  
  915.  struct obj *
  916. lprin1(exp)
  917.  struct obj *exp;
  918. {struct obj *tmp;
  919.  switch TYPE(exp)
  920.    {case tc_nil:
  921.       printf("()");
  922.       break;
  923.    case tc_cons:
  924.       printf("(");
  925.       lprin1(car(exp));
  926.       for(tmp=cdr(exp);TYPEP(tmp,tc_cons);tmp=cdr(tmp))
  927.     {printf(" ");lprin1(car(tmp));}
  928.       if NNULLP(tmp) {printf(" . ");lprin1(tmp);}
  929.       printf(")");
  930.       break;
  931.     case tc_flonum:
  932.       printf("%g",FLONM(exp));
  933.       break;
  934.     case tc_symbol:
  935.       printf("%s",PNAME(exp));
  936.       break;
  937.     case tc_subr_0:
  938.     case tc_subr_1:
  939.     case tc_subr_2:
  940.     case tc_subr_3:
  941.     case tc_lsubr:
  942.     case tc_fsubr:
  943.     case tc_msubr:
  944.       printf("#<SUBR(%d) %s>",TYPE(exp),(*exp).storage_as.subr.name);
  945.       break;
  946.     case tc_closure:
  947.       printf("#<CLOSURE ");
  948.       lprin1(car((*exp).storage_as.closure.code));
  949.       printf(" ");
  950.       lprin1(cdr((*exp).storage_as.closure.code));
  951.       printf(">");
  952.       break;}
  953.  return(NIL);}
  954.  
  955.  struct obj *
  956. lread()
  957. {return(lreadf(stdin));}
  958.  
  959.  int
  960. flush_ws(f,eoferr)
  961.  FILE *f;
  962.  char *eoferr;
  963. {int c;
  964.  while(1)
  965.    {c = getc(f);
  966.     if (c == EOF) if (eoferr) err(eoferr,NIL); else return(c);
  967.     if (isspace(c)) continue;
  968.     return(c);}}
  969.  
  970.  struct obj *
  971. lreadf(f)
  972.  FILE *f;
  973. {int c;
  974.  c = flush_ws(f,(char *)NULL);
  975.  if (c == EOF) return(eof_val);
  976.  ungetc(c,f);
  977.  return(lreadr(f));}
  978.  
  979.  struct obj *
  980. lreadr(f)
  981.  FILE *f;
  982. {int c,j;
  983.  char *p;
  984.  c = flush_ws(f,"end of file inside read");
  985.  switch (c)
  986.    {case '(':
  987.       return(lreadparen(f));
  988.     case ')':
  989.       err("unexpected close paren",NIL);
  990.     case '\'':
  991.       return(cons(sym_quote,cons(lreadr(f),NIL)));}
  992.  p = tkbuffer;
  993.  *p++ = c;
  994.  for(j = 1; j<TKBUFFERN; ++j)
  995.    {c = getc(f);
  996.     if (c == EOF) return(lreadtk(j));
  997.     if (isspace(c)) return(lreadtk(j));
  998.     if (strchr("()'",c)) {ungetc(c,f);return(lreadtk(j));}
  999.     *p++ = c;}
  1000.  err("token larger than TKBUFFERN",NIL);}
  1001.  
  1002. struct obj *
  1003. lreadparen(f)
  1004.  FILE *f;
  1005. {int c;
  1006.  struct obj *tmp;
  1007.  c = flush_ws(f,"end of file inside list");
  1008.  if (c == ')') return(NIL);
  1009.  ungetc(c,f);
  1010.  tmp = lreadr(f);
  1011.  return(cons(tmp,lreadparen(f)));}
  1012.  
  1013.  struct obj *
  1014. lreadtk(j)
  1015.  int j;
  1016. {int k;
  1017.  char c,*p;
  1018.  p = tkbuffer;
  1019.  p[j] = 0;
  1020.  if (*p == '-') p+=1;
  1021.  { int adigit = 0;
  1022.    while(isdigit(*p)) {p+=1; adigit=1;}
  1023.    if (*p=='.') {
  1024.      p += 1;
  1025.      while(isdigit(*p)) {p+=1; adigit=1;}}
  1026.    if (!adigit) goto a_symbol; }
  1027.  if (*p=='e') {
  1028.    p+=1;
  1029.    if (*p=='-'||*p=='+') p+=1;
  1030.    if (!isdigit(*p)) goto a_symbol; else p+=1;
  1031.    while(isdigit(*p)) p+=1; }
  1032.  if (*p) goto a_symbol;
  1033.  return(flocons(atof(tkbuffer)));
  1034.  a_symbol:
  1035.  return(rintern(tkbuffer));}
  1036.       
  1037.  struct obj *
  1038. copy_list(x)
  1039.  struct obj *x;
  1040. {if NULLP(x) return(NIL);
  1041.  return(cons(car(x),copy_list(cdr(x))));}
  1042.  
  1043.  struct obj *
  1044. oblistfn()
  1045. {return(copy_list(oblist));}
  1046.  
  1047. close_open_files()
  1048. {struct obj *l;
  1049.  FILE *p;
  1050.  for(l=open_files;NNULLP(l);l=cdr(l))
  1051.    {p = (FILE *) PNAME(car(l));
  1052.     if (p)
  1053.       {printf("closing a file left open\n");
  1054.        fclose(p);}}
  1055.  open_files = NIL;}
  1056.  
  1057.  
  1058.  struct obj *
  1059. vload(fname)
  1060.  char *fname;
  1061. {struct obj *sym,*form;
  1062.  FILE *f;
  1063.  printf("loading %s\n",fname);
  1064.  sym = symcons(0,NIL);
  1065.  open_files = cons(sym,open_files);
  1066.  PNAME(sym) = (char *) fopen(fname,"r");
  1067.  f = (FILE *) PNAME(sym);
  1068.  if (!f) {open_files = cdr(open_files);
  1069.       printf("Could not open file\n");
  1070.       return(NIL);}
  1071.  while(1)
  1072.    {form = lreadf(f);
  1073.     if EQ(form,eof_val) break;
  1074.     leval(form,NIL);}
  1075.  fclose(f);
  1076.  open_files = cdr(open_files);
  1077.  printf("done.\n");
  1078.  return(truth);}
  1079.  
  1080.  struct obj *
  1081. load(fname)
  1082.  struct obj *fname;
  1083. {if NTYPEP(fname,tc_symbol) err("filename not a symbol",fname);
  1084.  return(vload(PNAME(fname)));}
  1085.  
  1086.  struct obj *
  1087. quit()
  1088. {longjmp(errjmp,2);
  1089.  return(NIL);}
  1090.  
  1091.  struct obj *
  1092. nullp(x)
  1093.  struct obj *x;
  1094. {if EQ(x,NIL) return(truth); else return(NIL);}
  1095.  
  1096.  struct obj *
  1097. arglchk(x)
  1098.  struct obj *x;
  1099. {struct obj *l;
  1100.  if TYPEP(x,tc_symbol) return(x);
  1101.  for(l=x;TYPEP(l,tc_cons);l=CDR(l));
  1102.  if NNULLP(l) err("improper formal argument list",x);
  1103.  return(x);}
  1104.  
  1105.    
  1106.