home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / scheme / soid2_4 / siod-v2_4 / c / slib < prev   
Encoding:
Text File  |  1992-06-23  |  37.9 KB  |  1,622 lines
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                        COPYRIGHT (c) 1989 BY                             *
  4.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5.  *               ALL RIGHTS RESERVED                              *
  6.  
  7. Permission to use, copy, modify, distribute and sell this software
  8. and its documentation for any purpose and without fee is hereby
  9. granted, provided that the above copyright notice appear in all copies
  10. and that both that copyright notice and this permission notice appear
  11. in supporting documentation, and that the name of Paradigm Associates
  12. Inc not be used in advertising or publicity pertaining to distribution
  13. of the software without specific, written prior permission.
  14.  
  15. PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  16. ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  17. PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  18. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  19. WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  20. ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  21. SOFTWARE.
  22.  
  23. */
  24.  
  25. /*
  26.  
  27. gjc@paradigm.com
  28.  
  29. Paradigm Associates Inc          Phone: 617-492-6079
  30. 29 Putnam Ave, Suite 6
  31. Cambridge, MA 02138
  32.  
  33.  
  34.    Release 1.0: 24-APR-88
  35.    Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
  36.     Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
  37.     cleaned up uses of NULL/0. Now distributed with siod.scm.
  38.    Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
  39.     plus some bug fixes.
  40.    Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
  41.     define now works properly. vms specific function edit.
  42.    Release 1.4 20-NOV-89. Minor Cleanup and remodularization.
  43.     Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your
  44.     own main loops. Some short-int changes for lightspeed C included.
  45.    Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy
  46.     or mark-and-sweep garbage collection, which assumes that the stack/register
  47.     marking code is correct for your architecture. 
  48.    Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly
  49.     different enough (from 1.3) now that I'm calling it a major release.
  50.    Release 2.1 4-DEC-89. Small reader features, dot, backquote, comma.
  51.    Release 2.2 5-DEC-89. gc,read,print,eval, hooks for user defined datatypes.
  52.    Release 2.3 6-DEC-89. save_forms, obarray intern mechanism. comment char.
  53.    Release 2.3a......... minor speed-ups. i/o interrupt considerations.
  54.    Release 2.4 27-APR-90 gen_readr, for read-from-string.
  55.  
  56.   */
  57.  
  58. #include <stdio.h>
  59. #include <string.h>
  60. #include <ctype.h>
  61. #include <setjmp.h>
  62. #include <signal.h>
  63. #include <math.h>
  64. #ifdef vms
  65. #include <stdlib.h>
  66. #endif
  67.  
  68. #ifdef ARM
  69. #include <stdlib.h>
  70. #endif
  71.  
  72.  
  73.  
  74.  
  75. #include "siod.h"
  76.  
  77. LISP heap_1,heap_2;
  78. LISP heap,heap_end,heap_org;
  79.  
  80. long heap_size = 5000;
  81. long old_heap_used;
  82. long which_heap;
  83. long gc_status_flag = 1;
  84. char *init_file = (char *) NULL;
  85. char tkbuffer[TKBUFFERN];
  86.  
  87. long gc_kind_copying = 1;
  88.  
  89. long gc_cells_allocated = 0;
  90. double gc_time_taken;
  91. LISP *stack_start_ptr;
  92. LISP freelist;
  93.  
  94. jmp_buf errjmp;
  95. long errjmp_ok = 0;
  96. long nointerrupt = 1;
  97. long interrupt_differed = 0;
  98.  
  99. LISP oblistvar = NIL;
  100. LISP truth = NIL;
  101. LISP eof_val = NIL;
  102. LISP sym_errobj = NIL;
  103. LISP sym_progn = NIL;
  104. LISP sym_lambda = NIL;
  105. LISP sym_quote = NIL;
  106. LISP sym_dot = NIL;
  107. LISP open_files = NIL;
  108. LISP unbound_marker = NIL;
  109.  
  110. LISP *obarray;
  111. long obarray_dim = 100;
  112.  
  113. struct catch_frame
  114. {LISP tag;
  115.  LISP retval;
  116.  jmp_buf cframe;
  117.  struct catch_frame *next;};
  118.  
  119. struct gc_protected
  120. {LISP *location;
  121.  long length;
  122.  struct gc_protected *next;};
  123.  
  124. struct catch_frame *catch_framep = (struct catch_frame *) NULL;
  125.  
  126.  
  127. process_cla(argc,argv,warnflag)
  128.  int argc,warnflag; char **argv;
  129. {int k;
  130.  for(k=1;k<argc;++k)
  131.    {if (strlen(argv[k])<2) continue;
  132.     if (argv[k][0] != '-')
  133.       {if (warnflag) printf("bad arg: %s\n",argv[k]);continue;}
  134.     switch(argv[k][1])
  135.       {case 'h':
  136.      heap_size = atol(&(argv[k][2])); break;
  137.        case 'o':
  138.      obarray_dim = atol(&(argv[k][2])); break;
  139.        case 'i':
  140.      init_file = &(argv[k][2]); break;
  141.        case 'g':
  142.      gc_kind_copying = atol(&(argv[k][2])); break;
  143.        default: if (warnflag) printf("bad arg: %s\n",argv[k]);}}}
  144.  
  145. print_welcome()
  146. {printf("Welcome to SIOD, Scheme In One Defun, Version 2.4\n");
  147.  printf("(C) Copyright 1988, 1989, 1990 Paradigm Associates Inc.\n");}
  148.  
  149. print_hs_1()
  150. {printf("heap_size = %ld cells, %ld bytes. GC is %s\n",
  151.         heap_size,heap_size*sizeof(struct obj),
  152.     (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");}
  153.  
  154. print_hs_2()
  155. {if (gc_kind_copying == 1)
  156.    printf("heap_1 at 0x%lX, heap_2 at 0x%lX\n",heap_1,heap_2);
  157.  else
  158.    printf("heap_1 at 0x%lX\n",heap_1);}
  159.  
  160. long no_interrupt(n)
  161.      long n;
  162. {long x;
  163.  x = nointerrupt;
  164.  nointerrupt = n;
  165.  if ((nointerrupt == 0) && (interrupt_differed == 1))
  166.    {interrupt_differed = 0;
  167.     err_ctrl_c();}
  168.  return(x);}
  169.  
  170.  
  171.  
  172. void handle_sigfpe(sig,code,scp)
  173.  long sig,code; struct sigcontext *scp;
  174. {signal(SIGFPE,handle_sigfpe);
  175.  err("floating point exception",NIL);}
  176.  
  177. void handle_sigint(sig,code,scp)
  178.  long sig,code; struct sigcontext *scp;
  179. {signal(SIGINT,handle_sigint);
  180.  if (nointerrupt == 1)
  181.    interrupt_differed = 1;
  182.  else
  183.    err_ctrl_c();}
  184.  
  185. err_ctrl_c()
  186. {err("control-c interrupt",NIL);}
  187.  
  188. LISP get_eof_val()
  189. {return(eof_val);}
  190.  
  191. repl_driver(want_sigint,want_init)
  192.      long want_sigint,want_init;
  193. {int k;
  194.  LISP stack_start;
  195.  stack_start_ptr = &stack_start;
  196.  k = setjmp(errjmp);
  197.  if (k == 2) return;
  198.  if (want_sigint) signal(SIGFPE,handle_sigfpe);
  199.  signal(SIGINT,handle_sigint);
  200.  close_open_files();
  201.  catch_framep = (struct catch_frame *) NULL;
  202.  errjmp_ok = 1;
  203.  interrupt_differed = 0;
  204.  nointerrupt = 0;
  205.  if (want_init && init_file && (k == 0)) vload(init_file,0);
  206.  repl();}
  207.  
  208. #ifdef unix
  209. #include <sys/types.h>
  210. #include <sys/times.h>
  211. struct tms time_buffer;
  212. double myruntime()
  213. {times(&time_buffer);
  214.  return(time_buffer.tms_utime/60.0);}
  215. #else
  216. #ifdef vms
  217. #include <time.h>
  218. double myruntime()
  219. {return(clock() * 1.0e-2);}
  220. #else
  221. #ifdef ARM
  222. /* this is still wrong */
  223. #include <time.h>
  224. double myruntime()
  225. {clock_t x;
  226.  x = clock();
  227.  return(((double) x)/((double) CLOCKS_PER_SEC));}
  228. #else
  229. double myruntime()
  230. {long x;
  231.  long time();
  232.  time(&x);
  233.  return((double) x);}
  234. #endif
  235. #endif
  236. #endif
  237.  
  238.  
  239. void (*repl_puts)() = NULL;
  240. LISP (*repl_read)() = NULL;
  241. LISP (*repl_eval)() = NULL;
  242. void (*repl_print)() = NULL;
  243.  
  244. void set_repl_hooks(puts_f,read_f,eval_f,print_f)
  245.      void (*puts_f)();
  246.      LISP (*read_f)();
  247.      LISP (*eval_f)();
  248.      void (*print_f)();
  249. {repl_puts = puts_f;
  250.  repl_read = read_f;
  251.  repl_eval = eval_f;
  252.  repl_print = print_f;}
  253.  
  254. fput_st(f,st)
  255.      FILE *f;
  256.      char *st;
  257. {long flag;
  258.  flag = no_interrupt(1);
  259.  fprintf(f,"%s",st);
  260.  no_interrupt(flag);}
  261.  
  262. put_st(st)
  263.      char *st;
  264. {fput_st(stdout,st);}
  265.      
  266. grepl_puts(st)
  267.      char *st;
  268. {if (repl_puts == NULL)
  269.    put_st(st);
  270.  else
  271.    (*repl_puts)(st);}
  272.      
  273. repl() 
  274. {LISP x,cw;
  275.  double rt;
  276.  while(1)
  277.    {if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
  278.      {rt = myruntime();
  279.       gc_stop_and_copy();
  280.       sprintf(tkbuffer,
  281.           "GC took %g seconds, %ld compressed to %ld, %ld free\n",
  282.           myruntime()-rt,old_heap_used,heap-heap_org,heap_end-heap);
  283.       grepl_puts(tkbuffer);}
  284.     grepl_puts("> ");
  285.     if (repl_read == NULL) x = lread();
  286.     else x = (*repl_read)();
  287.     if EQ(x,eof_val) break;
  288.     rt = myruntime();
  289.     if (gc_kind_copying == 1)
  290.       cw = heap;
  291.     else
  292.       {gc_cells_allocated = 0;
  293.        gc_time_taken = 0.0;}
  294.     if (repl_eval == NULL) x = leval(x,NIL);
  295.     else x = (*repl_eval)();
  296.     if (gc_kind_copying == 1)
  297.       sprintf(tkbuffer,
  298.           "Evaluation took %g seconds %ld cons work\n",
  299.           myruntime()-rt,
  300.           heap-cw);
  301.     else
  302.       sprintf(tkbuffer,
  303.           "Evaluation took %g seconds (%g in gc) %ld cons work\n",
  304.           myruntime()-rt,
  305.           gc_time_taken,
  306.           gc_cells_allocated);
  307.     grepl_puts(tkbuffer);
  308.     if (repl_print == NULL) lprint(x);
  309.     else (*repl_print)(x);}}
  310.  
  311. err(message,x)
  312.  char *message; LISP x;
  313. {nointerrupt = 1;
  314.  if NNULLP(x) 
  315.     printf("ERROR: %s (see errobj)\n",message);
  316.   else printf("ERROR: %s\n",message);
  317.  if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(errjmp,1);}
  318.  printf("FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n");
  319.  exit(1);}
  320.  
  321.  
  322. LISP lerr(message,x)
  323.      LISP message,x;
  324. {if NSYMBOLP(message) err("argument to error not a symbol",message);
  325.  err(PNAME(message),x);
  326.  return(NIL);}
  327.  
  328. void gc_fatal_error()
  329. {err("ran out of storage",NIL);}
  330.  
  331. #define NEWCELL(_into,_type)          \
  332. {if (gc_kind_copying == 1)            \
  333.    {if ((_into = heap) >= heap_end)   \
  334.       gc_fatal_error();               \
  335.     heap = _into+1;}                  \
  336.  else                                 \
  337.    {if NULLP(freelist)                \
  338.       gc_for_newcell();               \
  339.     _into = freelist;                 \
  340.     freelist = CDR(freelist);         \
  341.     ++gc_cells_allocated;}            \
  342.  (*_into).gc_mark = 0;                \
  343.  (*_into).type = _type;}
  344.  
  345. LISP newcell(type)
  346.      long type;
  347. {LISP z;
  348.  NEWCELL(z,type);
  349.  return(z);}
  350.  
  351. LISP cons(x,y)
  352.      LISP x,y;
  353. {LISP z;
  354.  NEWCELL(z,tc_cons);
  355.  CAR(z) = x;
  356.  CDR(z) = y;
  357.  return(z);}
  358.  
  359. LISP consp(x)
  360.      LISP x;
  361. {if CONSP(x) return(truth); else return(NIL);}
  362.  
  363. LISP car(x)
  364.      LISP x;
  365. {switch TYPE(x)
  366.    {case tc_nil:
  367.       return(NIL);
  368.     case tc_cons:
  369.       return(CAR(x));
  370.     default:
  371.       err("wta to car",x);}}
  372.  
  373. LISP cdr(x)
  374.      LISP x;
  375. {switch TYPE(x)
  376.    {case tc_nil:
  377.       return(NIL);
  378.     case tc_cons:
  379.       return(CDR(x));
  380.     default:
  381.       err("wta to cdr",x);}}
  382.  
  383.  
  384. LISP setcar(cell,value)
  385.      LISP cell, value;
  386. {if NCONSP(cell) err("wta to setcar",cell);
  387.  return(CAR(cell) = value);}
  388.  
  389. LISP setcdr(cell,value)
  390.      LISP cell, value;
  391. {if NCONSP(cell) err("wta to setcdr",cell);
  392.  return(CDR(cell) = value);}
  393.  
  394. LISP flocons(x)
  395.  double x;
  396. {LISP z;
  397.  NEWCELL(z,tc_flonum);
  398.  FLONM(z) = x;
  399.  return(z);}
  400.  
  401. LISP numberp(x)
  402.      LISP x;
  403. {if FLONUMP(x) return(truth); else return(NIL);}
  404.  
  405. LISP plus(x,y)
  406.      LISP x,y;
  407. {LISP z;
  408.  if NFLONUMP(x) err("wta(1st) to plus",x);
  409.  if NFLONUMP(y) err("wta(2nd) to plus",y);
  410.  NEWCELL(z,tc_flonum);
  411.  FLONM(z) = FLONM(x) + FLONM(y);
  412.  return(z);}
  413.  
  414. LISP ltimes(x,y)
  415.  LISP x,y;
  416. {LISP z;
  417.  if NFLONUMP(x) err("wta(1st) to times",x);
  418.  if NFLONUMP(y) err("wta(2nd) to times",y);
  419.  NEWCELL(z,tc_flonum);
  420.  FLONM(z) = FLONM(x)*FLONM(y);
  421.  return(z);}
  422.  
  423. LISP difference(x,y)
  424.  LISP x,y;
  425. {LISP z;
  426.  if NFLONUMP(x) err("wta(1st) to difference",x);
  427.  if NFLONUMP(y) err("wta(2nd) to difference",y);
  428.  NEWCELL(z,tc_flonum);
  429.  FLONM(z) = FLONM(x) - FLONM(y);
  430.  return(z);}
  431.  
  432.  
  433. LISP quotient(x,y)
  434.  LISP x,y;
  435. {LISP z;
  436.  if NFLONUMP(x) err("wta(1st) to quotient",x);
  437.  if NFLONUMP(y) err("wta(2nd) to quotient",y);
  438.  NEWCELL(z,tc_flonum);
  439.  FLONM(z) = FLONM(x)/FLONM(y);
  440.  return(z);}
  441.  
  442. LISP greaterp(x,y)
  443.  LISP x,y;
  444. {if NFLONUMP(x) err("wta(1st) to greaterp",x);
  445.  if NFLONUMP(y) err("wta(2nd) to greaterp",y);
  446.  if (FLONM(x)>FLONM(y)) return(truth);
  447.  return(NIL);}
  448.  
  449. LISP lessp(x,y)
  450.  LISP x,y;
  451. {if NFLONUMP(x) err("wta(1st) to lessp",x);
  452.  if NFLONUMP(y) err("wta(2nd) to lessp",y);
  453.  if (FLONM(x)<FLONM(y)) return(truth);
  454.  return(NIL);}
  455.  
  456. LISP eq(x,y)
  457.  LISP x,y;
  458. {if EQ(x,y) return(truth); else return(NIL);}
  459.  
  460. LISP eql(x,y)
  461.  LISP x,y;
  462. {if EQ(x,y) return(truth); else 
  463.  if NFLONUMP(x) return(NIL); else
  464.  if NFLONUMP(y) return(NIL); else
  465.  if (FLONM(x) == FLONM(y)) return(truth);
  466.  return(NIL);}
  467.  
  468. LISP symcons(pname,vcell)
  469.  char *pname; LISP vcell;
  470. {LISP z;
  471.  NEWCELL(z,tc_symbol);
  472.  PNAME(z) = pname;
  473.  VCELL(z) = vcell;
  474.  return(z);}
  475.  
  476. LISP symbolp(x)
  477.      LISP x;
  478. {if SYMBOLP(x) return(truth); else return(NIL);}
  479.  
  480. LISP symbol_boundp(x,env)
  481.  LISP x,env;
  482. {LISP tmp;
  483.  if NSYMBOLP(x) err("not a symbol",x);
  484.  tmp = envlookup(x,env);
  485.  if NNULLP(tmp) return(truth);
  486.  if EQ(VCELL(x),unbound_marker) return(NIL); else return(truth);}
  487.  
  488. LISP symbol_value(x,env)
  489.  LISP x,env;
  490. {LISP tmp;
  491.  if NSYMBOLP(x) err("not a symbol",x);
  492.  tmp = envlookup(x,env);
  493.  if NNULLP(tmp) return(CAR(tmp));
  494.  tmp = VCELL(x);
  495.  if EQ(tmp,unbound_marker) err("unbound variable",x);
  496.  return(tmp);}
  497.  
  498. char * must_malloc(size)
  499.      unsigned long size;
  500. {char *tmp;
  501.  tmp = (char *) malloc(size);
  502.  if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
  503.  return(tmp);}
  504.  
  505. LISP gen_intern(name,copyp)
  506.      char *name;
  507.      long copyp;
  508. {LISP l,sym,sl;
  509.  char *cname;
  510.  long hash,n,c,flag;
  511.  flag = no_interrupt(1);
  512.  if (obarray_dim > 1)
  513.    {hash = 0;
  514.     n = obarray_dim;
  515.     cname = name;
  516.     while(c = *cname++) hash = ((hash * 17) ^ c) % n;
  517.     sl = obarray[hash];}
  518.  else
  519.    sl = oblistvar;
  520.  for(l=sl;NNULLP(l);l=CDR(l))
  521.    if (strcmp(name,PNAME(CAR(l))) == 0)
  522.      {no_interrupt(flag);
  523.       return(CAR(l));}
  524.  if (copyp == 1)
  525.    {cname = must_malloc(strlen(name)+1);
  526.     strcpy(cname,name);}
  527.  else
  528.    cname = name;
  529.  sym = symcons(cname,unbound_marker);
  530.  if (obarray_dim > 1) obarray[hash] = cons(sym,sl);
  531.  oblistvar = cons(sym,oblistvar);
  532.  no_interrupt(flag);
  533.  return(sym);}
  534.  
  535. LISP cintern(name)
  536.  char *name;
  537. {return(gen_intern(name,0));}
  538.  
  539. LISP rintern(name)
  540.  char *name;
  541. {return(gen_intern(name,1));}
  542.  
  543. LISP subrcons(type,name,f)
  544.  long type; char *name; LISP (*f)();
  545. {LISP z;
  546.  NEWCELL(z,type);
  547.  (*z).storage_as.subr.name = name;
  548.  (*z).storage_as.subr.f = f;
  549.  return(z);}
  550.  
  551.  
  552. LISP closure(env,code)
  553.      LISP env,code;
  554. {LISP z;
  555.  NEWCELL(z,tc_closure);
  556.  (*z).storage_as.closure.env = env;
  557.  (*z).storage_as.closure.code = code;
  558.  return(z);}
  559.  
  560.  
  561. struct gc_protected *protected_registers = NULL;
  562.  
  563. void gc_protect(location)
  564.      LISP *location;
  565. {gc_protect_n(location,1);}
  566.  
  567. void gc_protect_n(location,n)
  568.      LISP *location;
  569.      long n;
  570. {struct gc_protected *reg;
  571.  reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
  572.  (*reg).location = location;
  573.  (*reg).length = n;
  574.  (*reg).next = protected_registers;
  575.   protected_registers = reg;}
  576.  
  577. void gc_protect_sym(location,st)
  578.      LISP *location;
  579.      char *st;
  580. {*location = cintern(st);
  581.  gc_protect(location);}
  582.  
  583. scan_registers()
  584. {struct gc_protected *reg;
  585.  LISP *location;
  586.  long j,n;
  587.  for(reg = protected_registers; reg; reg = (*reg).next)
  588.    {location = (*reg).location;
  589.     n = (*reg).length;
  590.     for(j=0;j<n;++j)
  591.       location[j] = gc_relocate(location[j]);}}
  592.  
  593. init_storage()
  594. {LISP ptr,next,end;
  595.  long j;
  596.  heap_1 = (LISP) must_malloc(sizeof(struct obj)*heap_size);
  597.  heap = heap_1;
  598.  which_heap = 1;
  599.  heap_org = heap;
  600.  heap_end = heap + heap_size;
  601.  if (gc_kind_copying == 1)
  602.    heap_2 = (LISP) must_malloc(sizeof(struct obj)*heap_size);
  603.  else
  604.    {ptr = heap_org;
  605.     end = heap_end;
  606.     while(1)
  607.       {(*ptr).type = tc_free_cell;
  608.        next = ptr + 1;
  609.        if (next < end)
  610.      {CDR(ptr) = next;
  611.       ptr = next;}
  612.        else
  613.      {CDR(ptr) = NIL;
  614.       break;}}
  615.     freelist = heap_org;}
  616.  gc_protect(&oblistvar);
  617.  if (obarray_dim > 1)
  618.    {obarray = (LISP *) must_malloc(sizeof(LISP) * obarray_dim);
  619.     for(j=0;j<obarray_dim;++j)
  620.       obarray[j] = NIL;
  621.     gc_protect_n(obarray,obarray_dim);}
  622.  unbound_marker = cons(cintern("**unbound-marker**"),NIL);
  623.  gc_protect(&unbound_marker);
  624.  eof_val = cons(cintern("eof"),NIL);
  625.  gc_protect(&eof_val);
  626.  gc_protect_sym(&truth,"t");
  627.  setvar(truth,truth,NIL);
  628.  setvar(cintern("nil"),NIL,NIL);
  629.  setvar(cintern("let"),cintern("let-internal-macro"),NIL);
  630.  gc_protect_sym(&sym_errobj,"errobj");
  631.  setvar(sym_errobj,NIL,NIL);
  632.  gc_protect_sym(&sym_progn,"begin");
  633.  gc_protect_sym(&sym_lambda,"lambda");
  634.  gc_protect_sym(&sym_quote,"quote");
  635.  gc_protect_sym(&sym_dot,".");
  636.  gc_protect(&open_files);}
  637.  
  638. void init_subr(name,type,fcn)
  639.  char *name; long type; LISP (*fcn)();
  640. {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
  641.  
  642. LISP assq(x,alist)
  643.      LISP x,alist;
  644. {LISP l,tmp;
  645.  for(l=alist;CONSP(l);l=CDR(l))
  646.    {tmp = CAR(l);
  647.     if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);}
  648.  if EQ(l,NIL) return(NIL);
  649.  err("improper list to assq",alist);}
  650.  
  651. LISP (*user_gc_relocate)() = NULL;
  652. void (*user_gc_scan)() = NULL;
  653. LISP (*user_gc_mark)() = NULL;
  654. void (*user_gc_free)() = NULL;
  655.  
  656. void set_gc_hooks(rel,scan,mark,free,kind)
  657.      LISP (*rel)(),(*mark)();
  658.      void (*scan)(),(*free)();
  659.      long *kind;
  660. {user_gc_relocate = rel;
  661.  user_gc_scan = scan;
  662.  user_gc_mark = mark;
  663.  user_gc_free = free;
  664.  *kind = gc_kind_copying;}
  665.  
  666. LISP gc_relocate(x)
  667.      LISP x;
  668. {LISP new;
  669.  if EQ(x,NIL) return(NIL);
  670.  if ((*x).gc_mark == 1) return(CAR(x));
  671.  switch TYPE(x)
  672.    {case tc_flonum:
  673.     case tc_cons:
  674.     case tc_symbol:
  675.     case tc_closure:
  676.     case tc_subr_0:
  677.     case tc_subr_1:
  678.     case tc_subr_2:
  679.     case tc_subr_3:
  680.     case tc_lsubr:
  681.     case tc_fsubr:
  682.     case tc_msubr:
  683.       if ((new = heap) >= heap_end) gc_fatal_error();
  684.       heap = new+1;
  685.       memcpy(new,x,sizeof(struct obj));
  686.       break;
  687.     case tc_user_1:
  688.     case tc_user_2:
  689.     case tc_user_3:
  690.     case tc_user_4:
  691.     case tc_user_5:
  692.       if (user_gc_relocate != NULL)
  693.     {new = (*user_gc_relocate)(x);
  694.      break;}
  695.     default: err("BUG IN GARBAGE COLLECTOR gc_relocate",NIL);}
  696.  (*x).gc_mark = 1;
  697.  CAR(x) = new;
  698.  return(new);}
  699.  
  700. LISP get_newspace()
  701. {LISP newspace;
  702.  if (which_heap == 1)
  703.    {newspace = heap_2;
  704.     which_heap = 2;}
  705.  else
  706.    {newspace = heap_1;
  707.     which_heap = 1;}
  708.  heap = newspace;
  709.  heap_org = heap;
  710.  heap_end = heap + heap_size;
  711.  return(newspace);}
  712.  
  713. scan_newspace(newspace)
  714.      LISP newspace;
  715. {LISP ptr;
  716.  for(ptr=newspace; ptr < heap; ++ptr)
  717.    {switch TYPE(ptr)
  718.       {case tc_cons:
  719.        case tc_closure:
  720.      CAR(ptr) = gc_relocate(CAR(ptr));
  721.      CDR(ptr) = gc_relocate(CDR(ptr));
  722.      break;
  723.        case tc_symbol:
  724.      VCELL(ptr) = gc_relocate(VCELL(ptr));
  725.      break;
  726.        case tc_user_1:
  727.        case tc_user_2:
  728.        case tc_user_3:
  729.        case tc_user_4:
  730.        case tc_user_5:
  731.      if (user_gc_scan != NULL) (*user_gc_scan)(ptr);
  732.      break;
  733.        default:
  734.      break;}}}
  735.       
  736. gc_stop_and_copy()
  737. {LISP newspace;
  738.  long flag;
  739.  flag = no_interrupt(1);
  740.  errjmp_ok = 0;
  741.  old_heap_used = heap - heap_org;
  742.  newspace = get_newspace();
  743.  scan_registers();
  744.  scan_newspace(newspace);
  745.  errjmp_ok = 1;
  746.  no_interrupt(flag);}
  747.  
  748. gc_for_newcell()
  749. {long flag;
  750.  if (errjmp_ok == 0) gc_fatal_error();
  751.  flag = no_interrupt(1);
  752.  errjmp_ok = 0;
  753.  gc_mark_and_sweep();
  754.  errjmp_ok = 1;
  755.  no_interrupt(flag);
  756.  if NULLP(freelist) gc_fatal_error();}
  757.  
  758. jmp_buf save_regs_gc_mark;
  759.  
  760. gc_mark_and_sweep()
  761. {LISP stack_end;
  762.  gc_ms_stats_start();
  763.  /* This assumes that all registers are saved into the jmp_buff */
  764.  setjmp(save_regs_gc_mark);
  765.  mark_locations((LISP *) save_regs_gc_mark,
  766.         (LISP *) ((char *) save_regs_gc_mark) + sizeof(save_regs_gc_mark));
  767.  mark_protected_registers();
  768.  mark_locations((LISP *) stack_start_ptr,
  769.         (LISP *) &stack_end);
  770. #if THINK_C
  771.  mark_locations((LISP *) ((char *) stack_start_ptr + 2),
  772.         (LISP *) ((char *) &stack_end + 2));
  773. #endif
  774.  gc_sweep();
  775.  gc_ms_stats_end();}
  776.  
  777. double gc_rt;
  778. long gc_cells_collected;
  779.  
  780. gc_ms_stats_start()
  781. {gc_rt = myruntime();
  782.  gc_cells_collected = 0;
  783.  if (gc_status_flag)
  784.    printf("[starting GC]\n");}
  785.  
  786. gc_ms_stats_end()
  787. {gc_rt = myruntime() - gc_rt;
  788.  gc_time_taken = gc_time_taken + gc_rt;
  789.  if (gc_status_flag)
  790.    printf("[GC took %g cpu seconds, %ld cells collected]\n",
  791.       gc_rt,
  792.       gc_cells_collected);}
  793.  
  794.  
  795. void gc_mark(ptr)
  796.      LISP ptr;
  797. {gc_mark_loop:
  798.  if NULLP(ptr) return;
  799.  if ((*ptr).gc_mark) return;
  800.  (*ptr).gc_mark = 1;
  801.  switch ((*ptr).type)
  802.    {case tc_flonum:
  803.       break;
  804.     case tc_cons:
  805.       gc_mark(CAR(ptr));
  806.       ptr = CDR(ptr);
  807.       goto gc_mark_loop;
  808.     case tc_symbol:
  809.       ptr = VCELL(ptr);
  810.       goto gc_mark_loop;
  811.     case tc_closure:
  812.       gc_mark((*ptr).storage_as.closure.code);
  813.       ptr = (*ptr).storage_as.closure.env;
  814.       goto gc_mark_loop;
  815.     case tc_subr_0:
  816.     case tc_subr_1:
  817.     case tc_subr_2:
  818.     case tc_subr_3:
  819.     case tc_lsubr:
  820.     case tc_fsubr:
  821.     case tc_msubr:
  822.       return;
  823.     case tc_user_1:
  824.     case tc_user_2:
  825.     case tc_user_3:
  826.     case tc_user_4:
  827.     case tc_user_5:
  828.       if (user_gc_mark != NULL)
  829.     {ptr = (*user_gc_mark)(ptr);
  830.      goto gc_mark_loop;}
  831.     default:
  832.       err("BUG IN GARBAGE COLLECTOR gc_mark",NIL);}}
  833.  
  834. mark_protected_registers()
  835. {struct gc_protected *reg;
  836.  LISP *location;
  837.  long j,n;
  838.  for(reg = protected_registers; reg; reg = (*reg).next)
  839.    {location = (*reg).location;
  840.     n = (*reg).length;
  841.     for(j=0;j<n;++j)
  842.       gc_mark(location[j]);}}
  843.  
  844. mark_locations(start,end)
  845.      LISP *start,*end;
  846. {LISP *tmp;
  847.  long n;
  848.  if (start > end)
  849.    {tmp = start;
  850.     start = end;
  851.     end = tmp;}
  852.  n = end - start;
  853.  mark_locations_array(start,n);}
  854.  
  855. mark_locations_array(x,n)
  856.      LISP x[];
  857.      long n;
  858. {int j;
  859.  LISP p;
  860.  for(j=0;j<n;++j)
  861.    {p = x[j];
  862.     if ((p >= heap_org) &&
  863.     (p < heap_end) &&
  864.     (((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0) &&
  865.     NTYPEP(p,tc_free_cell))
  866.       gc_mark(p);}}
  867.  
  868.  
  869. gc_sweep()
  870. {LISP ptr,end,nfreelist;
  871.  long n;
  872.  end = heap_end;
  873.  n = 0;
  874.  nfreelist = freelist;
  875.  for(ptr=heap_org; ptr < end; ++ptr)
  876.    if (((*ptr).gc_mark == 0))
  877.      switch((*ptr).type)
  878.        {case tc_free_cell:
  879.       break;
  880.     case tc_user_1:
  881.     case tc_user_2:
  882.     case tc_user_3:
  883.     case tc_user_4:
  884.     case tc_user_5:
  885.       if (user_gc_free != NULL) (*user_gc_free)(ptr);
  886.     default:
  887.       ++n;
  888.       (*ptr).type = tc_free_cell;
  889.       CDR(ptr) = nfreelist;
  890.       nfreelist = ptr;}
  891.    else
  892.      (*ptr).gc_mark = 0;
  893.  gc_cells_collected = n;
  894.  freelist = nfreelist;}
  895.  
  896. LISP user_gc(args)
  897.      LISP args;
  898. {long old_status_flag,flag;
  899.  if (gc_kind_copying == 1)
  900.    err("implementation cannot GC at will with stop-and-copy\n",
  901.        NIL);
  902.  flag = no_interrupt(1);
  903.  errjmp_ok = 0;
  904.  old_status_flag = gc_status_flag;
  905.  if NNULLP(args)
  906.    if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
  907.  gc_mark_and_sweep();
  908.  gc_status_flag = old_status_flag;
  909.  errjmp_ok = 1;
  910.  no_interrupt(flag);
  911.  return(NIL);}
  912.  
  913. LISP gc_status(args)
  914.      LISP args;
  915. {LISP l;
  916.  int n;
  917.  if NNULLP(args) 
  918.    if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
  919.  if (gc_kind_copying == 1)
  920.    {if (gc_status_flag)
  921.       put_st("garbage collection is on\n");
  922.    else
  923.      put_st("garbage collection is off\n");
  924.     sprintf(tkbuffer,"%ld allocated %ld free\n",
  925.         heap - heap_org, heap_end - heap);
  926.     put_st(tkbuffer);}
  927.  else
  928.    {if (gc_status_flag)
  929.       put_st("garbage collection verbose\n");
  930.     else
  931.       put_st("garbage collection silent\n");
  932.     {for(n=0,l=freelist;NNULLP(l); ++n) l = CDR(l);
  933.      sprintf(tkbuffer,"%ld allocated %ld free\n",
  934.          (heap_end - heap_org) - n,n);
  935.      put_st(tkbuffer);}}
  936.  return(NIL);}
  937.  
  938. LISP leval_args(l,env)
  939.      LISP l,env;
  940. {LISP result,v1,v2,tmp;
  941.  if NULLP(l) return(NIL);
  942.  if NCONSP(l) err("bad syntax argument list",l);
  943.  result = cons(leval(CAR(l),env),NIL);
  944.  for(v1=result,v2=CDR(l);
  945.      CONSP(v2);
  946.      v1 = tmp, v2 = CDR(v2))
  947.   {tmp = cons(leval(CAR(v2),env),NIL);
  948.    CDR(v1) = tmp;}
  949.  if NNULLP(v2) err("bad syntax argument list",l);
  950.  return(result);}
  951.  
  952. LISP extend_env(actuals,formals,env)
  953.  LISP actuals,formals,env;
  954. {if SYMBOLP(formals)
  955.    return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
  956.  return(cons(cons(formals,actuals),env));}
  957.  
  958. LISP envlookup(var,env)
  959.  LISP var,env;
  960. {LISP frame,al,fl,tmp;
  961.  for(frame=env;CONSP(frame);frame=CDR(frame))
  962.    {tmp = CAR(frame);
  963.     if NCONSP(tmp) err("damaged frame",tmp);
  964.     for(fl=CAR(tmp),al=CDR(tmp);
  965.     CONSP(fl);
  966.     fl=CDR(fl),al=CDR(al))
  967.       {if NCONSP(al) err("too few arguments",tmp);
  968.        if EQ(CAR(fl),var) return(al);}}
  969.  if NNULLP(frame) err("damaged env",env);
  970.  return(NIL);}
  971.  
  972. LISP (*user_leval)() = NULL;
  973.  
  974. void set_eval_hooks(fcn)
  975.      LISP (*fcn)();
  976. {user_leval = fcn;}
  977.  
  978. LISP leval(x,env)
  979.  LISP x,env;
  980. {LISP tmp,arg1;
  981.  loop:
  982.  switch TYPE(x)
  983.    {case tc_symbol:
  984.       tmp = envlookup(x,env);
  985.       if NNULLP(tmp) return(CAR(tmp));
  986.       tmp = VCELL(x);
  987.       if EQ(tmp,unbound_marker) err("unbound variable",x);
  988.       return(tmp);
  989.     case tc_cons:
  990.       tmp = CAR(x);
  991.       switch TYPE(tmp)
  992.     {case tc_symbol:
  993.        tmp = envlookup(tmp,env);
  994.        if NNULLP(tmp)
  995.          {tmp = CAR(tmp);
  996.           break;}
  997.        tmp = VCELL(CAR(x));
  998.        if EQ(tmp,unbound_marker) err("unbound variable",CAR(x));
  999.        break;
  1000.      case tc_cons:
  1001.        tmp = leval(tmp,env);
  1002.        break;}
  1003.       switch TYPE(tmp)
  1004.     {case tc_subr_0:
  1005.        return(SUBRF(tmp)());
  1006.      case tc_subr_1:
  1007.        return(SUBRF(tmp)(leval(car(CDR(x)),env)));
  1008.      case tc_subr_2:
  1009.        x = CDR(x);
  1010.        arg1 = leval(car(x),env);
  1011.        x = NULLP(x) ? NIL : CDR(x);
  1012.        return(SUBRF(tmp)(arg1,
  1013.                  leval(car(x),env)));
  1014.      case tc_subr_3:
  1015.        x = CDR(x);
  1016.        arg1 = leval(car(x),env);
  1017.        x = NULLP(x) ? NIL : CDR(x);
  1018.        return(SUBRF(tmp)(arg1,
  1019.                  leval(car(x),env),
  1020.                  leval(car(cdr(x)),env)));
  1021.      case tc_lsubr:
  1022.        return(SUBRF(tmp)(leval_args(CDR(x),env)));
  1023.      case tc_fsubr:
  1024.        return(SUBRF(tmp)(CDR(x),env));
  1025.      case tc_msubr:
  1026.        if NULLP(SUBRF(tmp)(&x,&env)) return(x);
  1027.        goto loop;
  1028.      case tc_closure:
  1029.        env = extend_env(leval_args(CDR(x),env),
  1030.                 car((*tmp).storage_as.closure.code),
  1031.                 (*tmp).storage_as.closure.env);
  1032.        x = cdr((*tmp).storage_as.closure.code);
  1033.        goto loop;
  1034.      case tc_symbol:
  1035.        x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
  1036.        x = leval(x,NIL);
  1037.        goto loop;
  1038.      case tc_user_1:
  1039.      case tc_user_2:
  1040.      case tc_user_3:
  1041.      case tc_user_4:
  1042.      case tc_user_5:
  1043.        if (user_leval != NULL)
  1044.          {if NULLP((*user_leval)(tmp,&x,&env)) return(x); else goto loop;}
  1045.      default:
  1046.        err("bad function",tmp);}
  1047.     default:
  1048.       return(x);}}
  1049.  
  1050. LISP setvar(var,val,env)
  1051.  LISP var,val,env;
  1052. {LISP tmp;
  1053.  if NSYMBOLP(var) err("wta(non-symbol) to setvar",var);
  1054.  tmp = envlookup(var,env);
  1055.  if NULLP(tmp) return(VCELL(var) = val);
  1056.  return(CAR(tmp)=val);}
  1057.  
  1058.  
  1059. LISP leval_setq(args,env)
  1060.  LISP args,env;
  1061. {return(setvar(car(args),leval(car(cdr(args)),env),env));}
  1062.  
  1063. LISP syntax_define(args)
  1064.  LISP args;
  1065. {if SYMBOLP(car(args)) return(args);
  1066.  return(syntax_define(
  1067.         cons(car(car(args)),
  1068.     cons(cons(sym_lambda,
  1069.          cons(cdr(car(args)),
  1070.           cdr(args))),
  1071.          NIL))));}
  1072.       
  1073. LISP leval_define(args,env)
  1074.  LISP args,env;
  1075. {LISP tmp,var,val;
  1076.  tmp = syntax_define(args);
  1077.  var = car(tmp);
  1078.  if NSYMBOLP(var) err("wta(non-symbol) to define",var);
  1079.  val = leval(car(cdr(tmp)),env);
  1080.  tmp = envlookup(var,env);
  1081.  if NNULLP(tmp) return(CAR(tmp) = val);
  1082.  if NULLP(env) return(VCELL(var) = val);
  1083.  tmp = car(env);
  1084.  setcar(tmp,cons(var,car(tmp)));
  1085.  setcdr(tmp,cons(val,cdr(tmp)));
  1086.  return(val);}
  1087.  
  1088. LISP leval_if(pform,penv)
  1089.  LISP *pform,*penv;
  1090. {LISP args,env;
  1091.  args = cdr(*pform);
  1092.  env = *penv;
  1093.  if NNULLP(leval(car(args),env)) 
  1094.     *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
  1095.  return(truth);}
  1096.  
  1097. LISP leval_lambda(args,env)
  1098.  LISP args,env;
  1099. {LISP body;
  1100.  if NULLP(cdr(cdr(args)))
  1101.    body = car(cdr(args));
  1102.   else body = cons(sym_progn,cdr(args));
  1103.  return(closure(env,cons(arglchk(car(args)),body)));}
  1104.                          
  1105. LISP leval_progn(pform,penv)
  1106.  LISP *pform,*penv;
  1107. {LISP env,l,next;
  1108.  env = *penv;
  1109.  l = cdr(*pform);
  1110.  next = cdr(l);
  1111.  while(NNULLP(next)) {leval(car(l),env);l=next;next=cdr(next);}
  1112.  *pform = car(l); 
  1113.  return(truth);}
  1114.  
  1115. LISP leval_or(pform,penv)
  1116.  LISP *pform,*penv;
  1117. {LISP env,l,next,val;
  1118.  env = *penv;
  1119.  l = cdr(*pform);
  1120.  next = cdr(l);
  1121.  while(NNULLP(next))
  1122.    {val = leval(car(l),env);
  1123.     if NNULLP(val) {*pform = val; return(NIL);}
  1124.     l=next;next=cdr(next);}
  1125.  *pform = car(l); 
  1126.  return(truth);}
  1127.  
  1128. LISP leval_and(pform,penv)
  1129.  LISP *pform,*penv;
  1130. {LISP env,l,next;
  1131.  env = *penv;
  1132.  l = cdr(*pform);
  1133.  if NULLP(l) {*pform = truth; return(NIL);}
  1134.  next = cdr(l);
  1135.  while(NNULLP(next))
  1136.    {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
  1137.     l=next;next=cdr(next);}
  1138.  *pform = car(l); 
  1139.  return(truth);}
  1140.  
  1141. LISP leval_catch(args,env)
  1142.  LISP args,env;
  1143. {struct catch_frame frame;
  1144.  int k;
  1145.  LISP l,val;
  1146.  frame.tag = leval(car(args),env);
  1147.  frame.next = catch_framep;
  1148.  k = setjmp(frame.cframe);
  1149.  catch_framep = &frame;
  1150.  if (k == 2)
  1151.    {catch_framep = frame.next;
  1152.     return(frame.retval);}
  1153.  for(l=cdr(args); NNULLP(l); l = cdr(l))
  1154.    val = leval(car(l),env);
  1155.  catch_framep = frame.next;
  1156.  return(val);}
  1157.  
  1158. LISP lthrow(tag,value)
  1159.      LISP tag,value;
  1160. {struct catch_frame *l;
  1161.  for(l=catch_framep; l; l = (*l).next)
  1162.    if EQ((*l).tag,tag)
  1163.      {(*l).retval = value;
  1164.       longjmp((*l).cframe,2);}
  1165.  err("no *catch found with this tag",tag);
  1166.  return(NIL);}
  1167.  
  1168. LISP leval_let(pform,penv)
  1169.  LISP *pform,*penv;
  1170. {LISP env,l;
  1171.  l = cdr(*pform);
  1172.  env = *penv;
  1173.  *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
  1174.  *pform = car(cdr(cdr(l)));
  1175.  return(truth);}
  1176.  
  1177. LISP reverse(l)
  1178.  LISP l;
  1179. {LISP n,p;
  1180.  n = NIL;
  1181.  for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
  1182.  return(n);}
  1183.  
  1184. LISP let_macro(form)
  1185.  LISP form;
  1186. {LISP p,fl,al,tmp;
  1187.  fl = NIL;
  1188.  al = NIL;
  1189.  for(p=car(cdr(form));NNULLP(p);p=cdr(p))
  1190.   {tmp = car(p);
  1191.    if SYMBOLP(tmp) {fl = cons(tmp,fl); al = cons(NIL,al);}
  1192.    else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
  1193.  p = cdr(cdr(form));
  1194.  if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
  1195.  setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
  1196.  setcar(form,cintern("let-internal"));
  1197.  return(form);}
  1198.    
  1199.  LISP leval_quote(args,env)
  1200.  LISP args,env;
  1201. {return(car(args));}
  1202.  
  1203. LISP leval_tenv(args,env)
  1204.  LISP args,env;
  1205. {return(env);}
  1206.  
  1207. LISP symbolconc(args)
  1208.      LISP args;
  1209. {long size;
  1210.  LISP l,s;
  1211.  size = 0;
  1212.  tkbuffer[0] = 0;
  1213.  for(l=args;NNULLP(l);l=cdr(l))
  1214.    {s = car(l);
  1215.     if NSYMBOLP(s) err("wta(non-symbol) to symbolconc",s);
  1216.     size = size + strlen(PNAME(s));
  1217.     if (size >  TKBUFFERN) err("symbolconc buffer overflow",NIL);
  1218.     strcat(tkbuffer,PNAME(s));}
  1219.  return(rintern(tkbuffer));}
  1220.  
  1221.  
  1222. void (*user_prin1)() = NULL;
  1223.  
  1224. void set_print_hooks(fcn)
  1225.      void (*fcn)();
  1226. {user_prin1 = fcn;}
  1227.  
  1228. LISP lprin1f(exp,f)
  1229.      LISP exp;
  1230.      FILE *f;
  1231. {LISP tmp;
  1232.  switch TYPE(exp)
  1233.    {case tc_nil:
  1234.       fput_st(f,"()");
  1235.       break;
  1236.    case tc_cons:
  1237.       fput_st(f,"(");
  1238.       lprin1f(car(exp),f);
  1239.       for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
  1240.     {fput_st(f," ");lprin1f(car(tmp),f);}
  1241.       if NNULLP(tmp) {fput_st(f," . ");lprin1f(tmp,f);}
  1242.       fput_st(f,")");
  1243.       break;
  1244.     case tc_flonum:
  1245.       sprintf(tkbuffer,"%g",FLONM(exp));
  1246.       fput_st(f,tkbuffer);
  1247.       break;
  1248.     case tc_symbol:
  1249.       fput_st(f,PNAME(exp));
  1250.       break;
  1251.     case tc_subr_0:
  1252.     case tc_subr_1:
  1253.     case tc_subr_2:
  1254.     case tc_subr_3:
  1255.     case tc_lsubr:
  1256.     case tc_fsubr:
  1257.     case tc_msubr:
  1258.       sprintf(tkbuffer,"#<SUBR(%d) ",TYPE(exp));
  1259.       fput_st(f,tkbuffer);
  1260.       fput_st(f,(*exp).storage_as.subr.name);
  1261.       fput_st(f,">");
  1262.       break;
  1263.     case tc_closure:
  1264.       fput_st(f,"#<CLOSURE ");
  1265.       lprin1f(car((*exp).storage_as.closure.code),f);
  1266.       fput_st(f," ");
  1267.       lprin1f(cdr((*exp).storage_as.closure.code),f);
  1268.       fput_st(f,">");
  1269.       break;
  1270.     case tc_user_1:
  1271.     case tc_user_2:
  1272.     case tc_user_3:
  1273.     case tc_user_4:
  1274.     case tc_user_5:
  1275.       if (user_prin1 != NULL)
  1276.     {(*user_prin1)(exp,f);
  1277.      break;}
  1278.     default:
  1279.       sprintf(tkbuffer,"#<UNKNOWN %d %lX>",TYPE(exp),exp);
  1280.       fput_st(f,tkbuffer);}
  1281.  return(NIL);}
  1282.  
  1283. LISP lprint(exp)
  1284.  LISP exp;
  1285. {lprin1f(exp,stdout);
  1286.  put_st("\n");
  1287.  return(NIL);}
  1288.  
  1289. LISP lreadr(),lreadparen(),lreadtk(),lreadf();
  1290.  
  1291. LISP lread()
  1292. {return(lreadf(stdin));}
  1293.  
  1294. int f_getc(f)
  1295.      FILE *f;
  1296. {long iflag,dflag;
  1297.  int c;
  1298.  iflag = no_interrupt(1);
  1299.  dflag = interrupt_differed;
  1300.  c = getc(f);
  1301. #ifdef VMS
  1302.  if ((dflag == 0) & interrupt_differed & (f == stdin))
  1303.    while((c != 0) & (c != EOF)) c = getc(f);
  1304. #endif
  1305.  no_interrupt(iflag);
  1306.  return(c);}
  1307.  
  1308. void f_ungetc(c,f)
  1309.      int c; FILE *f;
  1310. {ungetc(c,f);}
  1311.  
  1312.  int
  1313. flush_ws(f,eoferr)
  1314.  struct gen_readio *f;
  1315.  char *eoferr;
  1316. {int c,commentp;
  1317.  commentp = 0;
  1318.  while(1)
  1319.    {c = GETC_FCN(f);
  1320.     if (c == EOF) if (eoferr) err(eoferr,NIL); else return(c);
  1321.     if (commentp) {if (c == '\n') commentp = 0;}
  1322.     else if (c == ';') commentp = 1;
  1323.     else if (!isspace(c)) return(c);}}
  1324.  
  1325. LISP lreadf(f)
  1326.      FILE *f;
  1327. {return(gen_read(f_getc,f_ungetc,f));}
  1328.  
  1329. LISP readtl(f)
  1330.   struct gen_readio *f;
  1331. {int c;
  1332.  c = flush_ws(f,(char *)NULL);
  1333.  if (c == EOF) return(eof_val);
  1334.  UNGETC_FCN(c,f);
  1335.  return(lreadr(f));}
  1336.  
  1337. LISP gen_read(f1,f2,x)
  1338.      int (*f1)();
  1339.      void (*f2)();
  1340.      char *x;
  1341. {struct gen_readio f;
  1342.  f.getc_fcn = f1;
  1343.  f.ungetc_fcn = f2;
  1344.  f.cb_argument = x;
  1345.  return(readtl(&f));}
  1346.  
  1347. char *user_ch_readm = "";
  1348. char *user_te_readm = "";
  1349.  
  1350. LISP (*user_readm)() = NULL;
  1351. LISP (*user_readt)() = NULL;
  1352.  
  1353. void set_read_hooks(all_set,end_set,fcn1,fcn2)
  1354.      char *all_set,*end_set;
  1355.      LISP (*fcn1)(),(*fcn2)();
  1356. {user_ch_readm = all_set;
  1357.  user_te_readm = end_set;
  1358.  user_readm = fcn1;
  1359.  user_readt = fcn2;}
  1360.  
  1361. LISP lreadr(f)
  1362.  struct gen_readio *f;
  1363. {int c,j;
  1364.  char *p;
  1365.  c = flush_ws(f,"end of file inside read");
  1366.  switch (c)
  1367.    {case '(':
  1368.       return(lreadparen(f));
  1369.     case ')':
  1370.       err("unexpected close paren",NIL);
  1371.     case '\'':
  1372.       return(cons(sym_quote,cons(lreadr(f),NIL)));
  1373.     case '`':
  1374.       return(cons(cintern("+internal-backquote"),lreadr(f)));
  1375.     case ',':
  1376.       c = GETC_FCN(f);
  1377.       switch(c)
  1378.     {case '@':
  1379.        p = "+internal-comma-atsign";
  1380.        break;
  1381.      case '.':
  1382.        p = "+internal-comma-dot";
  1383.        break;
  1384.      default:
  1385.        p = "+internal-comma";
  1386.        UNGETC_FCN(c,f);}
  1387.       return(cons(cintern(p),lreadr(f)));
  1388.     default:
  1389.       if ((user_readm != NULL) && strchr(user_ch_readm,c))
  1390.     return((*user_readm)(c,f));}
  1391.  p = tkbuffer;
  1392.  *p++ = c;
  1393.  for(j = 1; j<TKBUFFERN; ++j)
  1394.    {c = GETC_FCN(f);
  1395.     if (c == EOF) return(lreadtk(j));
  1396.     if (isspace(c)) return(lreadtk(j));
  1397.     if (strchr("()'`,;",c) || strchr(user_te_readm,c))
  1398.       {UNGETC_FCN(c,f);return(lreadtk(j));}
  1399.     *p++ = c;}
  1400.  err("token larger than TKBUFFERN",NIL);}
  1401.  
  1402. LISP lreadparen(f)
  1403.  struct gen_readio *f;
  1404. {int c;
  1405.  LISP tmp;
  1406.  c = flush_ws(f,"end of file inside list");
  1407.  if (c == ')') return(NIL);
  1408.  UNGETC_FCN(c,f);
  1409.  tmp = lreadr(f);
  1410.  if EQ(tmp,sym_dot)
  1411.    {tmp = lreadr(f);
  1412.     c = flush_ws(f,"end of file inside list");
  1413.     if (c != ')') err("missing close paren",NIL);
  1414.     return(tmp);}
  1415.  return(cons(tmp,lreadparen(f)));}
  1416.  
  1417.  
  1418.  
  1419. LISP lreadtk(j)
  1420.      long j;
  1421. {int k,flag;
  1422.  char c,*p;
  1423.  LISP tmp;
  1424.  int adigit;
  1425.  p = tkbuffer;
  1426.  p[j] = 0;
  1427.  if (user_readt != NULL)
  1428.    {tmp = (*user_readt)(p,j,&flag);
  1429.     if (flag) return(tmp);}
  1430.  if (*p == '-') p+=1;
  1431.  adigit = 0;
  1432.  while(isdigit(*p)) {p+=1; adigit=1;}
  1433.  if (*p=='.')
  1434.    {p += 1;
  1435.     while(isdigit(*p)) {p+=1; adigit=1;}}
  1436.  if (!adigit) goto a_symbol;
  1437.  if (*p=='e')
  1438.    {p+=1;
  1439.     if (*p=='-'||*p=='+') p+=1;
  1440.     if (!isdigit(*p)) goto a_symbol; else p+=1;
  1441.     while(isdigit(*p)) p+=1;}
  1442.  if (*p) goto a_symbol;
  1443.  return(flocons(atof(tkbuffer)));
  1444.  a_symbol:
  1445.  return(rintern(tkbuffer));}
  1446.       
  1447. LISP copy_list(x)
  1448.  LISP x;
  1449. {if NULLP(x) return(NIL);
  1450.  return(cons(car(x),copy_list(cdr(x))));}
  1451.  
  1452. LISP oblistfn()
  1453. {return(copy_list(oblistvar));}
  1454.  
  1455. close_open_files()
  1456. {LISP l;
  1457.  FILE *p;
  1458.  for(l=open_files;NNULLP(l);l=cdr(l))
  1459.    {p = (FILE *) PNAME(car(l));
  1460.     if (p)
  1461.       {printf("closing a file left open\n");
  1462.        fclose(p);}}
  1463.  open_files = NIL;}
  1464.  
  1465. FILE *fopen_care(name,how)
  1466.      char *name,*how;
  1467. {FILE *f;
  1468.  LISP sym;
  1469.  long flag;
  1470.  sym = symcons(0,NIL);
  1471.  open_files = cons(sym,open_files);
  1472.  flag = no_interrupt(1);
  1473.  f = fopen(name,how);
  1474.  if (!f)
  1475.    {perror(name);
  1476.     err("could not open file",NIL);}
  1477.  PNAME(sym) = (char *) f;
  1478.  no_interrupt(flag);
  1479.  return(f);}
  1480.  
  1481. LISP fclose_dq(f,l)
  1482.      FILE *f;
  1483.      LISP l;
  1484. {FILE *p;
  1485.  if NULLP(l) return(l);
  1486.  if (PNAME(CAR(l)) == (char *) f) return(CDR(l));
  1487.  CDR(l) = fclose_dq(f,CDR(l));
  1488.  return(l);}
  1489.  
  1490.  
  1491. fclose_care(f)
  1492.      FILE *f;
  1493. {long flag;
  1494.  LISP l;
  1495.  flag = no_interrupt(1);
  1496.  fclose(f);
  1497.  open_files = fclose_dq(f,open_files);
  1498.  no_interrupt(flag);}
  1499.  
  1500. LISP vload(fname,cflag)
  1501.      char *fname;
  1502.      long cflag;
  1503. {LISP form,result,tail;
  1504.  FILE *f;
  1505.  put_st("loading ");
  1506.  put_st(fname);
  1507.  put_st("\n");
  1508.  f = fopen_care(fname,"r");
  1509.  result = NIL;
  1510.  tail = NIL;
  1511.  while(1)
  1512.    {form = lreadf(f);
  1513.     if EQ(form,eof_val) break;
  1514.     if (cflag)
  1515.       {form = cons(form,NIL);
  1516.        if NULLP(result)
  1517.      result = tail = form;
  1518.        else
  1519.      tail = setcdr(tail,form);}
  1520.     else
  1521.       leval(form,NIL);}
  1522.  fclose_care(f);
  1523.  put_st("done.\n");
  1524.  return(result);}
  1525.  
  1526. LISP load(fname,cflag)
  1527.  LISP fname,cflag;
  1528. {if NSYMBOLP(fname) err("filename not a symbol",fname);
  1529.  return(vload(PNAME(fname),NULLP(cflag) ? 0 : 1));}
  1530.  
  1531. LISP save_forms(fname,forms,how)
  1532.      LISP fname,forms,how;
  1533. {char *cname,*chow;
  1534.  LISP l;
  1535.  FILE *f;
  1536.  if NSYMBOLP(fname) err("filename not a symbol",fname);
  1537.  cname = PNAME(fname);
  1538.  if EQ(how,NIL) chow = "w";
  1539.  else if EQ(how,cintern("a")) chow = "a";
  1540.  else err("bad argument to save-forms",how);
  1541.  put_st((*chow == 'a') ? "appending" : "saving");
  1542.  put_st(" forms to ");
  1543.  put_st(cname);
  1544.  put_st("\n");
  1545.  f = fopen_care(cname,chow);
  1546.  for(l=forms;NNULLP(l);l=cdr(l))
  1547.    {lprin1f(car(l),f);
  1548.     putc('\n',f);}
  1549.  fclose_care(f);
  1550.  put_st("done.\n");
  1551.  return(truth);}
  1552.  
  1553. LISP quit()
  1554. {longjmp(errjmp,2);
  1555.  return(NIL);}
  1556.  
  1557. LISP nullp(x)
  1558.  LISP x;
  1559. {if EQ(x,NIL) return(truth); else return(NIL);}
  1560.  
  1561. LISP arglchk(x)
  1562.  LISP x;
  1563. {LISP l;
  1564.  if SYMBOLP(x) return(x);
  1565.  for(l=x;CONSP(l);l=CDR(l));
  1566.  if NNULLP(l) err("improper formal argument list",x);
  1567.  return(x);}
  1568.  
  1569.  
  1570. init_subrs()
  1571. {init_subr("cons",tc_subr_2,cons);
  1572.  init_subr("car",tc_subr_1,car);
  1573.  init_subr("cdr",tc_subr_1,cdr);
  1574.  init_subr("set-car!",tc_subr_2,setcar);
  1575.  init_subr("set-cdr!",tc_subr_2,setcdr);
  1576.  init_subr("+",tc_subr_2,plus);
  1577.  init_subr("-",tc_subr_2,difference);
  1578.  init_subr("*",tc_subr_2,ltimes);
  1579.  init_subr("/",tc_subr_2,quotient);
  1580.  init_subr(">",tc_subr_2,greaterp);
  1581.  init_subr("<",tc_subr_2,lessp);
  1582.  init_subr("eq?",tc_subr_2,eq);
  1583.  init_subr("eqv?",tc_subr_2,eql);
  1584.  init_subr("assq",tc_subr_2,assq);
  1585.  init_subr("read",tc_subr_0,lread);
  1586.  init_subr("eof-val",tc_subr_0,get_eof_val);
  1587.  init_subr("print",tc_subr_1,lprint);
  1588.  init_subr("eval",tc_subr_2,leval);
  1589.  init_subr("define",tc_fsubr,leval_define);
  1590.  init_subr("lambda",tc_fsubr,leval_lambda);
  1591.  init_subr("if",tc_msubr,leval_if);
  1592.  init_subr("begin",tc_msubr,leval_progn);
  1593.  init_subr("set!",tc_fsubr,leval_setq);
  1594.  init_subr("or",tc_msubr,leval_or);
  1595.  init_subr("and",tc_msubr,leval_and);
  1596.  init_subr("*catch",tc_fsubr,leval_catch);
  1597.  init_subr("*throw",tc_subr_2,lthrow);
  1598.  init_subr("quote",tc_fsubr,leval_quote);
  1599.  init_subr("oblist",tc_subr_0,oblistfn);
  1600.  init_subr("copy-list",tc_subr_1,copy_list);
  1601.  init_subr("gc-status",tc_lsubr,gc_status);
  1602.  init_subr("gc",tc_lsubr,user_gc);
  1603.  init_subr("load",tc_subr_2,load);
  1604.  init_subr("pair?",tc_subr_1,consp);
  1605.  init_subr("symbol?",tc_subr_1,symbolp);
  1606.  init_subr("number?",tc_subr_1,numberp);
  1607.  init_subr("let-internal",tc_msubr,leval_let);
  1608.  init_subr("let-internal-macro",tc_subr_1,let_macro);
  1609.  init_subr("symbol-bound?",tc_subr_2,symbol_boundp);
  1610.  init_subr("symbol-value",tc_subr_2,symbol_value);
  1611.  init_subr("set-symbol-value!",tc_subr_3,setvar);
  1612.  init_subr("the-environment",tc_fsubr,leval_tenv);
  1613.  init_subr("error",tc_subr_2,lerr);
  1614.  init_subr("quit",tc_subr_0,quit);
  1615.  init_subr("not",tc_subr_1,nullp);
  1616.  init_subr("null?",tc_subr_1,nullp);
  1617.  init_subr("env-lookup",tc_subr_2,envlookup);
  1618.  init_subr("reverse",tc_subr_1,reverse);
  1619.  init_subr("symbolconc",tc_lsubr,symbolconc);
  1620.  init_subr("save-forms",tc_subr_3,save_forms);}
  1621.  
  1622.