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