Edinburgh Speech Tools  2.4-release
 All Classes Functions Variables Typedefs Enumerations Enumerator Friends Pages
slib.cc
1 /* Scheme In One Defun, but in C this time.
2 
3  * COPYRIGHT (c) 1988-1994 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  Release 2.9a 10-AUG-93. Minor changes for Windows NT.
62  Release 3.0 12-JAN-94. Release it, include changes/cleanup recommended by
63  andreasg@nynexst.com for the OS2 C++ compiler. Compilation and running
64  tested using DEC C, VAX C. WINDOWS NT. GNU C on SPARC.
65 
66  Festival/Edinburgh Speech Tools changes (awb@cstr.ed.ac.uk) 1996-1999
67  Note there have been substantial changes to this from its original
68  form which may have introduced bugs. Please contact Alan W Black
69  (awb@cstr.ed.ac.uk) first if you find problems unless you can confirm
70  they also exist in the original siod-3.0 release
71 
72  March 1999 split off functions into different files to make it easier
73  for our documentation purposes, sorry maybe this should be called
74  SNIOD now :-), or maybe Scheme in one Directory.
75 
76  */
77 
78 #include <cstdio>
79 #include <cstring>
80 #include <cctype>
81 #include <csignal>
82 #include <cmath>
83 #include <cstdlib>
84 #include <ctime>
85 
86 #include "EST_unix.h"
87 
88 #include "EST_cutils.h"
89 #include "siod.h"
90 #include "siodp.h"
91 
92 #ifdef WIN32
93 #include "winsock2.h"
94 #endif
95 
96 static int restricted_function_call(LISP l);
97 static long repl(struct repl_hooks *h);
98 static void gc_mark_and_sweep(void);
99 static void gc_ms_stats_start(void);
100 static void gc_ms_stats_end(void);
101 static void mark_protected_registers(void);
102 static void mark_locations(LISP *start,LISP *end);
103 static void gc_sweep(void);
104 static void mark_locations_array(LISP *x,long n);
105 static LISP lreadr(struct gen_readio *f);
106 static LISP lreadparen(struct gen_readio *f);
107 static LISP lreadstring(struct gen_readio *f);
108 
109 const char *siod_version(void)
110 {return("3.0 FIELD TEST");}
111 
112 LISP heap_1,heap_2;
113 LISP heap,heap_end,heap_org;
114 long heap_size = DEFAULT_HEAP_SIZE;
115 long old_heap_used;
116 long which_heap;
117 long gc_status_flag = 0;
118 long show_backtrace = 0;
119 char *init_file = (char *) NULL;
120 char *tkbuffer = NULL;
121 long gc_kind_copying = 0;
122 long gc_cells_allocated = 0;
123 double gc_time_taken;
124 LISP *stack_start_ptr;
125 LISP freelist;
126 
127 long nointerrupt = 1;
128 long interrupt_differed = 0;
129 LISP oblistvar = NIL;
130 LISP current_env = NIL;
131 static LISP siod_backtrace = NIL;
132 LISP restricted = NIL;
133 LISP truth = NIL;
134 LISP eof_val = NIL;
135 LISP sym_errobj = NIL;
136 LISP sym_quote = NIL;
137 LISP sym_dot = NIL;
138 LISP unbound_marker = NIL;
139 LISP *obarray;
140 long obarray_dim = 100;
141 struct catch_frame *catch_framep = (struct catch_frame *) NULL;
142 void (*repl_puts)(char *) = NULL;
143 LISP (*repl_read)(void) = NULL;
144 LISP (*repl_eval)(LISP) = NULL;
145 void (*repl_print)(LISP) = NULL;
146 repl_getc_fn siod_fancy_getc = f_getc;
147 repl_ungetc_fn siod_fancy_ungetc = f_ungetc;
148 LISP *inums;
149 LISP siod_docstrings = NIL; /* for builtin functions */
150 long inums_dim = 100;
151 struct user_type_hooks *user_types = NULL;
152 struct gc_protected *protected_registers = NULL;
153 jmp_buf save_regs_gc_mark;
154 double gc_rt;
155 long gc_cells_collected;
156 static const char *user_ch_readm = "";
157 static const char *user_te_readm = "";
158 LISP (*user_readm)(int, struct gen_readio *) = NULL;
159 LISP (*user_readt)(char *,long, int *) = NULL;
160 void (*fatal_exit_hook)(void) = NULL;
161 #ifdef THINK_C
162 int ipoll_counter = 0;
163 #endif
164 FILE *fwarn=NULL;
165 int siod_interactive = 1;
166 
167 extern "C" {
168 int el_pos = -1; // actually used by readline
169 }
170 const char *repl_prompt = "siod>";
171 const char *siod_prog_name = "siod";
172 const char *siod_primary_prompt = "siod> ";
173 const char *siod_secondary_prompt = "> ";
174 
175 // A list of objects with gc_free_once set in their user_type_hooks structure
176 // whose gc_free function has been called in the current GC sweep.
177 void **dead_pointers = NULL;
178 int size_dead_pointers = 0;
179 int num_dead_pointers = 0;
180 #define DEAD_POINTER_GROWTH (10)
181 
182 static LISP set_restricted(LISP l);
183 
184 char *stack_limit_ptr = NULL;
185 long stack_size =
186 #ifdef THINK_C
187  10000;
188 #else
189  500000;
190 #endif
191 
192 void NNEWCELL(LISP *_into,long _type)
193 {if NULLP(freelist)
194  {
195  gc_for_newcell();
196  }
197  *_into = freelist;
198  freelist = CDR(freelist);
199  ++gc_cells_allocated;
200 
201  (*_into)->gc_mark = 0;
202  (*_into)->type = (short) _type;
203 }
204 
205 void need_n_cells(int n)
206 {
207  /* Check there are N cells available, and force gc if not */
208  LISP x = NIL;
209  int i;
210 
211  for (i=0; i<n; i++)
212  x = cons(NIL,x);
213 
214  return;
215 }
216 
217 static void start_rememberring_dead(void)
218 {
219  num_dead_pointers=0;
220 }
221 
222 static int is_dead(void *ptr)
223 {
224  int i;
225  for(i=0; i<num_dead_pointers; i++)
226  if (dead_pointers[i] == ptr)
227  return 1;
228  return 0;
229 }
230 
231 static void mark_as_dead(void *ptr)
232 {
233  int i;
234  if (num_dead_pointers == size_dead_pointers)
235  dead_pointers = wrealloc(dead_pointers, void *, size_dead_pointers += DEAD_POINTER_GROWTH);
236 
237  for(i=0; i<num_dead_pointers; i++)
238  if (dead_pointers[i] == ptr)
239  return;
240 
241  dead_pointers[num_dead_pointers++] = ptr;
242 }
243 
244 void siod_print_welcome(EST_String extra_info)
245 {printf("Welcome to SIOD, Scheme In One Defun, Version %s\n",
246  siod_version());
247  printf("(C) Copyright 1988-1994 Paradigm Associates Inc.\n");
248  if (extra_info != "")
249  printf("%s\n", (const char *)extra_info);
250 }
251 
252 void siod_print_welcome(void)
253 {
254  siod_print_welcome("");
255 }
256 
257 void print_hs_1(void)
258 {printf("heap_size = %ld cells, %ld bytes. %ld inums. GC is %s\n",
259  heap_size,(long)(heap_size*sizeof(struct obj)),
260  inums_dim,
261  (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");}
262 
263 void print_hs_2(void)
264 {if (gc_kind_copying == 1)
265  printf("heap_1 at %p, heap_2 at %p\n",(void *)heap_1,(void *)heap_2);
266  else
267  printf("heap_1 at %p\n",(void *)heap_1);}
268 
269 /* I don't have a clean way to do this but need to reset this if */
270 /* ctrl-c occurs. */
271 int audsp_mode = FALSE;
272 int siod_ctrl_c = FALSE;
273 
274 static void err_ctrl_c(void)
275 {
276  audsp_mode = FALSE;
277  siod_ctrl_c = TRUE;
278  err("control-c interrupt",NIL);}
279 
280 long no_interrupt(long n)
281 {long x;
282  x = nointerrupt;
283  nointerrupt = n;
284  if ((nointerrupt == 0) && (interrupt_differed == 1))
285  {interrupt_differed = 0;
286  err_ctrl_c();}
287  return(x);}
288 
289 extern "C" void handle_sigfpe(int sig SIG_restargs)
290 {(void)sig;
291  signal(SIGFPE,handle_sigfpe);
292  /* Solaris seems to need a relse before it works again */
293 #ifdef __svr4__
294  sigrelse(SIGFPE);
295 #endif
296  /* linux needs to unmask sigfpe to allow for next one */
297 #ifdef __linux__
298  sigset_t set1;
299  sigemptyset(&set1);
300  sigaddset(&set1,SIGFPE);
301  sigprocmask(SIG_UNBLOCK,&set1,NULL);
302 #endif
303  signal(SIGFPE,handle_sigfpe);
304  err("floating point exception",NIL);}
305 
306 extern "C" void handle_sigint(int sig SIG_restargs)
307 {(void)sig;
308  signal(SIGINT,handle_sigint);
309  /* Solaris seems to need a relse before it works again */
310 #ifdef __svr4__
311  sigrelse(SIGINT);
312 #endif
313  /* linux needs to unmask sigint to allow for next one */
314 #ifdef __linux__
315  sigset_t set1;
316  sigemptyset(&set1);
317  sigaddset(&set1,SIGINT);
318  sigprocmask(SIG_UNBLOCK,&set1,NULL);
319 #endif
320  signal(SIGINT,handle_sigint);
321  if (nointerrupt == 1)
322  interrupt_differed = 1;
323  else
324  err_ctrl_c();}
325 
326 void siod_reset_prompt(void)
327 {
328  el_pos = -1; /* flush remaining input on that line */
329  repl_prompt = siod_primary_prompt;
330  interrupt_differed = 0;
331  nointerrupt = 0;
332 }
333 
334 long repl_driver(long want_sigint,long want_init,struct repl_hooks *h)
335 {int k;
336  struct repl_hooks hd;
337  LISP stack_start;
338  stack_start_ptr = &stack_start;
339  stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
340  est_errjmp = walloc(jmp_buf,1);
341  k = setjmp(*est_errjmp);
342  if(k)
343  {
344  sock_acknowledge_error(); /* if there is a client let them know */
345  siod_reset_prompt();
346  }
347  if (k == 2) return(2);
348  siod_ctrl_c = FALSE;
349  if (want_sigint) signal(SIGINT,handle_sigint);
350  close_open_files();
351  catch_framep = (struct catch_frame *) NULL;
352  errjmp_ok = 1;
353  interrupt_differed = 0;
354  nointerrupt = 0;
355  if (want_init && init_file && (k == 0)) vload(init_file,0);
356  // Can't see where else to put this
357  if ((siod_interactive) && (!isatty(0)))
358  { // editline (or its replacement) would do this if stdin was a terminal
359  fprintf(stdout,"%s",repl_prompt);
360  fflush(stdout);
361  }
362  if (!h)
363  {hd.repl_puts = repl_puts;
364  hd.repl_read = repl_read;
365  hd.repl_eval = repl_eval;
366  hd.repl_print = repl_print;
367  return(repl(&hd));}
368  else
369  return(repl(h));}
370 
371 static void ignore_puts(char *st)
372 {(void)st;}
373 
374 static void noprompt_puts(char *st)
375 {if (strcmp(st,"> ") != 0)
376  put_st(st);}
377 
378 static char *repl_c_string_arg = NULL;
379 static long repl_c_string_flag = 0;
380 
381 static LISP repl_c_string_read(void)
382 {LISP s;
383  if (repl_c_string_arg == NULL)
384  return(eof_val);
385  s = strcons(strlen(repl_c_string_arg),repl_c_string_arg);
386  repl_c_string_arg = NULL;
387  return(read_from_string(get_c_string(s)));}
388 
389 static void ignore_print(LISP x)
390 {(void)x;
391  repl_c_string_flag = 1;}
392 
393 static void not_ignore_print(LISP x)
394 {repl_c_string_flag = 1;
395  pprint(x);}
396 
397 long repl_c_string(char *str,
398  long want_sigint,long want_init,long want_print)
399 {struct repl_hooks h;
400  long retval;
401  if (want_print)
402  h.repl_puts = noprompt_puts;
403  else
404  h.repl_puts = ignore_puts;
405  h.repl_read = repl_c_string_read;
406  h.repl_eval = NULL;
407  if (want_print)
408  h.repl_print = not_ignore_print;
409  else
410  h.repl_print = ignore_print;
411  repl_c_string_arg = str;
412  repl_c_string_flag = 0;
413  retval = repl_driver(want_sigint,want_init,&h);
414  if (retval != 0)
415  return(retval);
416  else if (repl_c_string_flag == 1)
417  return(0);
418  else
419  return(2);}
420 
421 #ifdef unix
422 #include <sys/types.h>
423 #include <sys/times.h>
424 double myruntime(void)
425 {double total;
426  struct tms b;
427  times(&b);
428  total = b.tms_utime;
429  total += b.tms_stime;
430  return(total / 60.0);}
431 #else
432 #if defined(THINK_C) | defined(WIN32) | defined(VMS)
433 #ifndef CLOCKS_PER_SEC
434 #define CLOCKS_PER_SEC CLK_TCK
435 #endif
436 double myruntime(void)
437 {return(((double) clock()) / ((double) CLOCKS_PER_SEC));}
438 #else
439 double myruntime(void)
440 {time_t x;
441  time(&x);
442  return((double) x);}
443 #endif
444 #endif
445 
446 void set_repl_hooks(void (*puts_f)(char *),
447  LISP (*read_f)(void),
448  LISP (*eval_f)(LISP),
449  void (*print_f)(LISP))
450 {repl_puts = puts_f;
451  repl_read = read_f;
452  repl_eval = eval_f;
453  repl_print = print_f;}
454 
455 void fput_st(FILE *f,const char *st)
456 {long flag;
457  if (f != NULL) /* so we can block warning messages easily */
458  {
459  flag = no_interrupt(1);
460  fprintf(f,"%s",st);
461  no_interrupt(flag);
462  }
463 }
464 
465 void put_st(const char *st)
466 {fput_st(stdout,st);}
467 
468 void grepl_puts(char *st,void (*repl_putss)(char *))
469 {if (repl_putss == NULL)
470  {fput_st(fwarn,st);
471  if (fwarn != NULL) fflush(stdout);}
472  else
473  (*repl_putss)(st);}
474 
475 static void display_backtrace(LISP args)
476 {
477  /* Display backtrace information */
478  LISP l;
479  int i;
480  int local_show_backtrace = show_backtrace;
481  show_backtrace = 0; // so we don't recurse if an error occurs
482 
483  if (cdr(args) == NIL)
484  {
485  printf("BACKTRACE:\n");
486  for (i=0,l=siod_backtrace; l != NIL; l=cdr(l),i++)
487  {
488  fprintf(stdout,"%4d: ",i);
489  pprintf(stdout,car(l),3,72,2,2);
490  fprintf(stdout,"\n");
491  }
492  }
493  else if (FLONUMP(car(cdr(args))))
494  {
495  printf("BACKTRACE:\n");
496  int nth = (int)FLONM(car(cdr(args)));
497  LISP frame = siod_nth(nth,siod_backtrace);
498  fprintf(stdout,"%4d: ",nth);
499  pprintf(stdout,frame,3,72,-1,-1);
500  fprintf(stdout,"\n");
501  }
502 
503  show_backtrace = local_show_backtrace;
504 }
505 
506 static long repl(struct repl_hooks *h)
507 {LISP x,cw = 0;
508  double rt;
509  gc_kind_copying = 0;
510  while(1)
511  {
512 #if 0
513  if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
514  {rt = myruntime();
515  gc_stop_and_copy();
516  sprintf(tkbuffer,
517  "GC took %g seconds, %ld compressed to %ld, %ld free\n",
518  myruntime()-rt,old_heap_used,
519  (long)(heap-heap_org),(long)(heap_end-heap));
520  grepl_puts(tkbuffer,h->repl_puts);}
521  /* grepl_puts("> ",h->repl_puts); */
522 #endif
523  if (h->repl_read == NULL)
524  x = lread();
525  else
526  x = (*h->repl_read)();
527  if EQ(x,eof_val) break;
528  rt = myruntime();
529  if (gc_kind_copying == 1)
530  cw = heap;
531  else
532  {gc_cells_allocated = 0;
533  gc_time_taken = 0.0;}
534  /* Check if its a debugger command */
535  if ((TYPE(x) == tc_cons) &&
536  (TYPE(car(x)) == tc_symbol) &&
537  (streq(":backtrace",get_c_string(car(x)))))
538  {
539  display_backtrace(x);
540  x = NIL;
541  }
542  else if ((restricted != NIL) &&
543  (restricted_function_call(x) == FALSE))
544  err("Expression contains functions not in restricted list",x);
545  else
546  {
547  siod_backtrace = NIL; /* reset backtrace info */
548  if (h->repl_eval == NULL)
549  x = leval(x,NIL);
550  else
551  x = (*h->repl_eval)(x);
552  }
553  if (gc_kind_copying == 1)
554  sprintf(tkbuffer,
555  "Evaluation took %g seconds %ld cons work\n",
556  myruntime()-rt,
557  (long)(heap-cw));
558  else
559  sprintf(tkbuffer,
560  "Evaluation took %g seconds (%g in gc) %ld cons work\n",
561  myruntime()-rt,
562  gc_time_taken,
563  gc_cells_allocated);
564  grepl_puts(tkbuffer,h->repl_puts);
565  setvar(rintern("!"),x,NIL); /* save value in var called '!' */
566  if (h->repl_print == NULL)
567  {
568  if (siod_interactive)
569  pprint(x); /* pretty print the result */
570  }
571  else
572  (*h->repl_print)(x);}
573  return(0);}
574 
575 void set_fatal_exit_hook(void (*fcn)(void))
576 {fatal_exit_hook = fcn;}
577 
578 static LISP err(const char *message, LISP x, const char *s)
579 {
580  nointerrupt = 1;
581  if NNULLP(x)
582  {
583  fprintf(stderr,"SIOD ERROR: %s %s: ",
584  (message) ? message : "?",
585  (s) ?s : ""
586  );
587  lprin1f(x,stderr);
588  fprintf(stderr,"\n");
589  fflush(stderr);
590  }
591  else
592  {
593  fprintf(stderr,"SIOD ERROR: %s %s\n",
594  (message) ? message : "?",
595  (s) ? s : ""
596  );
597  fflush(stderr);
598  }
599 
600  if (show_backtrace == 1)
601  display_backtrace(NIL);
602 
603  if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(*est_errjmp,1);}
604  close_open_files(); /* can give clue to where error is */
605  fprintf(stderr,"%s: fatal error exiting.\n",siod_prog_name);
606  if (fatal_exit_hook)
607  (*fatal_exit_hook)();
608  else
609  exit(1);
610  return(NIL);
611 }
612 
613 LISP err(const char *message, LISP x)
614 {
615  return err(message, x, NULL);
616 }
617 
618 LISP err(const char *message, const char *x)
619 {
620  return err(message, NULL, x);
621 }
622 
623 LISP errswitch(void)
624 {return(err("BUG. Reached impossible case",NIL));}
625 
626 void err_stack(char *ptr)
627  /* The user could be given an option to continue here */
628 {(void)ptr;
629  err("the currently assigned stack limit has been exceded",NIL);}
630 
631 LISP stack_limit(LISP amount,LISP silent)
632 {if NNULLP(amount)
633  {stack_size = get_c_int(amount);
634  stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);}
635  if NULLP(silent)
636  {sprintf(tkbuffer,"Stack_size = %ld bytes, [%p,%p]\n",
637  stack_size,(void *)stack_start_ptr,(void *)stack_limit_ptr);
638  put_st(tkbuffer);
639  return(NIL);}
640  else
641  return(flocons(stack_size));}
642 
643 const char *get_c_string(LISP x)
644 {
645  if (NULLP(x))
646  return "nil";
647  else if TYPEP(x,tc_symbol)
648  return(PNAME(x));
649  else if TYPEP(x,tc_flonum)
650  {
651  if (FLONMPNAME(x) == NULL)
652  {
653  char b[TKBUFFERN];
654  sprintf(b,"%.8g",FLONM(x));
655  FLONMPNAME(x) = (char *)must_malloc(strlen(b)+1);
656  sprintf(FLONMPNAME(x),"%s",b);
657  }
658  return FLONMPNAME(x);
659  }
660  else if TYPEP(x,tc_string)
661  return(x->storage_as.string.data);
662  else
663  err("not a symbol or string",x);
664  return(NULL);}
665 
666 LISP lerr(LISP message, LISP x)
667 {err(get_c_string(message),x);
668  return(NIL);}
669 
670 void gc_fatal_error(void)
671 {err("ran out of storage",NIL);}
672 
673 LISP newcell(long type)
674 {LISP z;
675  NEWCELL(z,type);
676  return(z);}
677 
678 LISP flocons(double x)
679 {LISP z;
680  long n=0;
681  if ((inums_dim > 0) &&
682  ((x - (n = (long)x)) == 0) &&
683  (x >= 0) &&
684  (n < inums_dim))
685  return(inums[n]);
686  NEWCELL(z,tc_flonum);
687  FLONMPNAME(z) = NULL;
688  FLONM(z) = x;
689  return(z);}
690 
691 LISP symcons(char *pname,LISP vcell)
692 {LISP z;
693  NEWCELL(z,tc_symbol);
694  PNAME(z) = pname;
695  VCELL(z) = vcell;
696  return(z);}
697 
698 char *must_malloc(unsigned long size)
699 {char *tmp;
700  tmp = walloc(char,size);
701  if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
702  return(tmp);}
703 
704 LISP gen_intern(char *name,int require_copy)
705 {LISP l,sym,sl;
706  const unsigned char *cname;
707  long hash=0,n,c,flag;
708  flag = no_interrupt(1);
709  if (name == NULL)
710  return NIL;
711  else if (obarray_dim > 1)
712  {hash = 0;
713  n = obarray_dim;
714  cname = (unsigned char *)name;
715  while((c = *cname++)) hash = ((hash * 17) ^ c) % n;
716  sl = obarray[hash];}
717  else
718  sl = oblistvar;
719  for(l=sl;NNULLP(l);l=CDR(l))
720  if (strcmp(name,PNAME(CAR(l))) == 0)
721  {no_interrupt(flag);
722  return(CAR(l));}
723  /* Need a new symbol */
724  if (require_copy)
725  sym = symcons(wstrdup(name),unbound_marker);
726  else
727  sym = symcons(name,unbound_marker);
728  if (obarray_dim > 1) obarray[hash] = cons(sym,sl);
729  oblistvar = cons(sym,oblistvar);
730  no_interrupt(flag);
731  return(sym);}
732 
733 LISP cintern(const char *name)
734 {
735  char *dname = (char *)(void *)name;
736  return(gen_intern(dname,FALSE));
737 }
738 
739 LISP rintern(const char *name)
740 {
741  if (name == 0)
742  return NIL;
743  char *dname = (char *)(void *)name;
744  return gen_intern(dname,TRUE);
745 }
746 
747 LISP intern(LISP name)
748 {return(rintern(get_c_string(name)));}
749 
750 LISP subrcons(long type, const char *name, SUBR_FUNC f)
751 {LISP z;
752  NEWCELL(z,type);
753  (*z).storage_as.subr.name = name;
754  (*z).storage_as.subr0.f = f;
755  return(z);}
756 
757 LISP closure(LISP env,LISP code)
758 {LISP z;
759  NEWCELL(z,tc_closure);
760  (*z).storage_as.closure.env = env;
761  (*z).storage_as.closure.code = code;
762  return(z);}
763 
764 void gc_unprotect(LISP *location)
765 {
766  /* allow LISP values in a location top be gc'ed again */
767  struct gc_protected *reg,*l;
768  for(l=0,reg = protected_registers; reg; reg = reg->next)
769  {
770  if (reg->location == location)
771  break;
772  l = reg;
773  }
774  if (reg == 0)
775  {
776  fprintf(stderr,"Cannot unprotected %lx: never protected\n",
777  (unsigned long)*location);
778  fflush(stderr);
779  }
780  else if (l==0) /* its the first one in the list that needs to be deleted */
781  {
782  reg = protected_registers;
783  protected_registers = reg->next;
784  wfree(reg);
785  }
786  else
787  {
788  reg = l->next;
789  l->next = reg->next;
790  wfree(reg);
791  }
792 
793  return;
794 }
795 
796 void gc_protect(LISP *location)
797 {
798  struct gc_protected *reg;
799  for(reg = protected_registers; reg; reg = reg->next)
800  {
801  if (reg->location == location)
802  return; // already protected
803  }
804  // not protected so add it
805  gc_protect_n(location,1);
806 }
807 
808 void gc_protect_n(LISP *location,long n)
809 {struct gc_protected *reg;
810  reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
811  (*reg).location = location;
812  (*reg).length = n;
813  (*reg).next = protected_registers;
814  protected_registers = reg;}
815 
816 void gc_protect_sym(LISP *location,const char *st)
817 {*location = cintern(st);
818  gc_protect(location);}
819 
820 void scan_registers(void)
821 {struct gc_protected *reg;
822  LISP *location;
823  long j,n;
824  for(reg = protected_registers; reg; reg = (*reg).next)
825  {location = (*reg).location;
826  n = (*reg).length;
827  for(j=0;j<n;++j)
828  location[j] = gc_relocate(location[j]);}}
829 
830 static void init_storage_1(int init_heap_size)
831 {LISP ptr,next,end;
832  long j;
833  tkbuffer = (char *) must_malloc(TKBUFFERN+1);
834  heap_1 = (LISP) must_malloc(sizeof(struct obj)*init_heap_size);
835  heap = heap_1;
836  which_heap = 1;
837  heap_org = heap;
838  heap_end = heap + init_heap_size;
839  if (gc_kind_copying == 1)
840  heap_2 = (LISP) must_malloc(sizeof(struct obj)*init_heap_size);
841  else
842  {ptr = heap_org;
843  end = heap_end;
844  while(1)
845  {(*ptr).type = tc_free_cell;
846  next = ptr + 1;
847  if (next < end)
848  {CDR(ptr) = next;
849  ptr = next;}
850  else
851  {CDR(ptr) = NIL;
852  break;}}
853  freelist = heap_org;}
854  gc_protect(&oblistvar);
855  gc_protect(&siod_backtrace);
856  gc_protect(&current_env);
857  if (obarray_dim > 1)
858  {obarray = (LISP *) must_malloc(sizeof(LISP) * obarray_dim);
859  for(j=0;j<obarray_dim;++j)
860  obarray[j] = NIL;
861  gc_protect_n(obarray,obarray_dim);}
862  unbound_marker = cons(cintern("**unbound-marker**"),NIL);
863  gc_protect(&unbound_marker);
864  eof_val = cons(cintern("eof"),NIL);
865  gc_protect(&eof_val);
866  gc_protect(&siod_docstrings);
867  gc_protect_sym(&truth,"t");
868  setvar(truth,truth,NIL);
869  setvar(cintern("nil"),NIL,NIL);
870  setvar(cintern("let"),cintern("let-internal-macro"),NIL);
871  gc_protect_sym(&sym_errobj,"errobj");
872  setvar(sym_errobj,NIL,NIL);
873  gc_protect_sym(&sym_quote,"quote");
874  gc_protect_sym(&sym_dot,".");
875  gc_protect(&open_files);
876  if (inums_dim > 0)
877  {inums = (LISP *) must_malloc(sizeof(LISP) * inums_dim);
878  for(j=0;j<inums_dim;++j)
879  {NEWCELL(ptr,tc_flonum);
880  FLONM(ptr) = j;
881  FLONMPNAME(ptr) = NULL;
882  inums[j] = ptr;}
883  gc_protect_n(inums,inums_dim);}}
884 
885 void init_storage(int init_heap_size)
886 {
887  init_storage_1(init_heap_size);
888  LISP stack_start;
889  stack_start_ptr = &stack_start;
890  stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
891 }
892 
893 void init_subr(const char *name, long type, SUBR_FUNC fcn)
894 {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
895 void init_subr(const char *name, long type, SUBR_FUNC fcn,const char *doc)
896 {LISP lname = cintern(name);
897  setvar(lname,subrcons(type,name,fcn),NIL);
898  setdoc(lname,cstrcons(doc));}
899 
900 /* New versions requiring documentation strings */
901 void init_subr_0(const char *name, LISP (*fcn)(void),const char *doc)
902 {init_subr(name,tc_subr_0,(SUBR_FUNC)fcn,doc);}
903 void init_subr_1(const char *name, LISP (*fcn)(LISP),const char *doc)
904 {init_subr(name,tc_subr_1,(SUBR_FUNC)fcn,doc);}
905 void init_subr_2(const char *name, LISP (*fcn)(LISP,LISP),const char *doc)
906 {init_subr(name,tc_subr_2,(SUBR_FUNC)fcn,doc);}
907 void init_subr_3(const char *name, LISP (*fcn)(LISP,LISP,LISP),const char *doc)
908 {init_subr(name,tc_subr_3,(SUBR_FUNC)fcn,doc);}
909 void init_subr_4(const char *name, LISP (*fcn)(LISP,LISP,LISP,LISP),const char *doc)
910 {init_subr(name,tc_subr_4,(SUBR_FUNC)fcn,doc);}
911 void init_lsubr(const char *name, LISP (*fcn)(LISP),const char *doc)
912 {init_subr(name,tc_lsubr,(SUBR_FUNC)fcn,doc);}
913 void init_fsubr(const char *name, LISP (*fcn)(LISP,LISP),const char *doc)
914 {init_subr(name,tc_fsubr,(SUBR_FUNC)fcn,doc);}
915 void init_msubr(const char *name, LISP (*fcn)(LISP *,LISP *),const char *doc)
916 {init_subr(name,tc_msubr,(SUBR_FUNC)fcn,doc);}
917 
918 struct user_type_hooks *get_user_type_hooks(long type)
919 {long n;
920  if (user_types == NULL)
921  {n = sizeof(struct user_type_hooks) * tc_table_dim;
922  user_types = (struct user_type_hooks *) must_malloc(n);
923  memset(user_types,0,n);}
924  if ((type >= 0) && (type < tc_table_dim))
925  return(&user_types[type]);
926  else
927  err("type number out of range",NIL);
928  return(NULL);}
929 
930 int siod_register_user_type(const char *name)
931 {
932  // Register a new object type for LISP
933  static int siod_user_type = tc_first_user_type;
934  int new_type = siod_user_type;
935  struct user_type_hooks *th;
936 
937  if (new_type == tc_table_dim)
938  {
939  cerr << "SIOD: no more new types allowed, tc_table_dim needs increased"
940  << endl;
941  return tc_table_dim-1;
942  }
943  else
944  siod_user_type++;
945 
946  th=get_user_type_hooks(new_type);
947  th->name = wstrdup(name);
948  return new_type;
949 }
950 
951 void set_gc_hooks(long type,
952  int gc_free_once,
953  LISP (*rel)(LISP),
954  LISP (*mark)(LISP),
955  void (*scan)(LISP),
956  void (*free)(LISP),
957  void (*clear)(LISP),
958  long *kind)
959 {struct user_type_hooks *p;
960  p = get_user_type_hooks(type);
961  p->gc_free_once = gc_free_once;
962  p->gc_relocate = rel;
963  p->gc_scan = scan;
964  p->gc_mark = mark;
965  p->gc_free = free;
966  p->gc_clear = clear;
967  *kind = gc_kind_copying;}
968 
969 LISP gc_relocate(LISP x)
970 {LISP nw;
971  struct user_type_hooks *p;
972  if EQ(x,NIL) return(NIL);
973  if ((*x).gc_mark == 1) return(CAR(x));
974  switch TYPE(x)
975  {case tc_flonum:
976  if (FLONMPNAME(x) != NULL)
977  wfree(FLONMPNAME(x)); /* free the print name */
978  FLONMPNAME(x) = NULL;
979  case tc_cons:
980  case tc_symbol:
981  case tc_closure:
982  case tc_subr_0:
983  case tc_subr_1:
984  case tc_subr_2:
985  case tc_subr_3:
986  case tc_subr_4:
987  case tc_lsubr:
988  case tc_fsubr:
989  case tc_msubr:
990  if ((nw = heap) >= heap_end) gc_fatal_error();
991  heap = nw+1;
992  memcpy(nw,x,sizeof(struct obj));
993  break;
994  default:
995  p = get_user_type_hooks(TYPE(x));
996  if (p->gc_relocate)
997  nw = (*p->gc_relocate)(x);
998  else
999  {if ((nw = heap) >= heap_end) gc_fatal_error();
1000  heap = nw+1;
1001  memcpy(nw,x,sizeof(struct obj));}}
1002  (*x).gc_mark = 1;
1003  CAR(x) = nw;
1004  return(nw);}
1005 
1006 LISP get_newspace(void)
1007 {LISP newspace;
1008  if (which_heap == 1)
1009  {newspace = heap_2;
1010  which_heap = 2;}
1011  else
1012  {newspace = heap_1;
1013  which_heap = 1;}
1014  heap = newspace;
1015  heap_org = heap;
1016  heap_end = heap + heap_size;
1017  return(newspace);}
1018 
1019 void scan_newspace(LISP newspace)
1020 {LISP ptr;
1021  struct user_type_hooks *p;
1022  for(ptr=newspace; ptr < heap; ++ptr)
1023  {switch TYPE(ptr)
1024  {case tc_cons:
1025  case tc_closure:
1026  CAR(ptr) = gc_relocate(CAR(ptr));
1027  CDR(ptr) = gc_relocate(CDR(ptr));
1028  break;
1029  case tc_symbol:
1030  VCELL(ptr) = gc_relocate(VCELL(ptr));
1031  break;
1032  case tc_flonum:
1033  case tc_subr_0:
1034  case tc_subr_1:
1035  case tc_subr_2:
1036  case tc_subr_3:
1037  case tc_subr_4:
1038  case tc_lsubr:
1039  case tc_fsubr:
1040  case tc_msubr:
1041  break;
1042  default:
1043  p = get_user_type_hooks(TYPE(ptr));
1044  if (p->gc_scan) (*p->gc_scan)(ptr);}}}
1045 
1046 void free_oldspace(LISP space,LISP end)
1047 {LISP ptr;
1048  struct user_type_hooks *p;
1049  for(ptr=space; ptr < end; ++ptr)
1050  if (ptr->gc_mark == 0)
1051  switch TYPE(ptr)
1052  {case tc_cons:
1053  case tc_closure:
1054  case tc_symbol:
1055  break;
1056  case tc_flonum:
1057  if (FLONMPNAME(ptr) != NULL)
1058  wfree(FLONMPNAME(ptr)); /* free the print name */
1059  FLONMPNAME(ptr) = NULL;
1060  break;
1061  case tc_string:
1062  wfree(ptr->storage_as.string.data);
1063  break;
1064  case tc_subr_0:
1065  case tc_subr_1:
1066  case tc_subr_2:
1067  case tc_subr_3:
1068  case tc_subr_4:
1069  case tc_lsubr:
1070  case tc_fsubr:
1071  case tc_msubr:
1072  break;
1073  default:
1074  p = get_user_type_hooks(TYPE(ptr));
1075  if (p->gc_free)
1076  (*p->gc_free)(ptr);
1077  }
1078 }
1079 
1080 void gc_stop_and_copy(void)
1081 {LISP newspace,oldspace,end;
1082  long flag;
1083  int ej_ok;
1084  flag = no_interrupt(1);
1085  fprintf(stderr,"GC ing \n");
1086  ej_ok = errjmp_ok;
1087  errjmp_ok = 0;
1088  oldspace = heap_org;
1089  end = heap;
1090  old_heap_used = end - oldspace;
1091  newspace = get_newspace();
1092  scan_registers();
1093  scan_newspace(newspace);
1094  free_oldspace(oldspace,end);
1095  errjmp_ok = ej_ok;
1096  no_interrupt(flag);}
1097 
1098 void gc_for_newcell(void)
1099 {long flag;
1100  int ej_ok;
1101 /* if (errjmp_ok == 0) gc_fatal_error(); */
1102  flag = no_interrupt(1);
1103  ej_ok = errjmp_ok;
1104  errjmp_ok = 0;
1105  gc_mark_and_sweep();
1106  errjmp_ok = ej_ok;
1107  no_interrupt(flag);
1108  if NULLP(freelist) gc_fatal_error();}
1109 
1110 static void gc_mark_and_sweep(void)
1111 {LISP stack_end;
1112  gc_ms_stats_start();
1113  setjmp(save_regs_gc_mark);
1114  mark_locations((LISP *) save_regs_gc_mark,
1115  (LISP *) (((char *) save_regs_gc_mark) + sizeof(save_regs_gc_mark)));
1116  mark_protected_registers();
1117  mark_locations((LISP *) stack_start_ptr,
1118  (LISP *) &stack_end);
1119 #ifdef THINK_C
1120  mark_locations((LISP *) ((char *) stack_start_ptr + 2),
1121  (LISP *) ((char *) &stack_end + 2));
1122 #endif
1123  gc_sweep();
1124  gc_ms_stats_end();}
1125 
1126 static void gc_ms_stats_start(void)
1127 {gc_rt = myruntime();
1128  gc_cells_collected = 0;
1129  if (gc_status_flag)
1130  fprintf(stderr,"[starting GC]\n");}
1131 
1132 static void gc_ms_stats_end(void)
1133 {gc_rt = myruntime() - gc_rt;
1134  gc_time_taken = gc_time_taken + gc_rt;
1135  if (gc_status_flag)
1136  fprintf(stderr,"[GC took %g cpu seconds, %ld cells collected]\n",
1137  gc_rt,
1138  gc_cells_collected);}
1139 
1140 void gc_mark(LISP ptr)
1141 {struct user_type_hooks *p;
1142 
1143  gc_mark_loop:
1144  if NULLP(ptr) return;
1145  if ((*ptr).gc_mark) return;
1146  (*ptr).gc_mark = 1;
1147  switch ((*ptr).type)
1148  {case tc_flonum:
1149  break;
1150  case tc_cons:
1151  gc_mark(CAR(ptr));
1152  ptr = CDR(ptr);
1153  goto gc_mark_loop;
1154  case tc_symbol:
1155  ptr = VCELL(ptr);
1156  goto gc_mark_loop;
1157  case tc_closure:
1158  gc_mark((*ptr).storage_as.closure.code);
1159  ptr = (*ptr).storage_as.closure.env;
1160  goto gc_mark_loop;
1161  case tc_subr_0:
1162  case tc_subr_1:
1163  case tc_subr_2:
1164  case tc_subr_3:
1165  case tc_subr_4:
1166  break;
1167  case tc_string:
1168  break;
1169  case tc_lsubr:
1170  case tc_fsubr:
1171  case tc_msubr:
1172  break;
1173  default:
1174  p = get_user_type_hooks(TYPE(ptr));
1175  if (p->gc_mark)
1176  ptr = (*p->gc_mark)(ptr);}}
1177 
1178 static void mark_protected_registers(void)
1179 {struct gc_protected *reg;
1180  LISP *location;
1181  long j,n;
1182  for(reg = protected_registers; reg; reg = (*reg).next)
1183  {
1184  location = (*reg).location;
1185  n = (*reg).length;
1186  for(j=0;j<n;++j)
1187  gc_mark(location[j]);}}
1188 
1189 static void mark_locations(LISP *start,LISP *end)
1190 {LISP *tmp;
1191  long n;
1192  if (start > end)
1193  {tmp = start;
1194  start = end;
1195  end = tmp;}
1196  n = end - start;
1197  mark_locations_array(start,n);}
1198 
1199 static void mark_locations_array(LISP *x,long n)
1200 {int j;
1201  LISP p;
1202  for(j=0;j<n;++j)
1203  {p = x[j];
1204  if ((p >= heap_org) &&
1205  (p < heap_end) &&
1206  (((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0) &&
1207  NTYPEP(p,tc_free_cell))
1208  gc_mark(p);}}
1209 
1210 static void gc_sweep(void)
1211 {LISP ptr,end,nfreelist;
1212  long n;
1213  struct user_type_hooks *p;
1214  end = heap_end;
1215  n = 0;
1216  nfreelist = NIL;
1217  start_rememberring_dead();
1218  for(ptr=heap_org; ptr < end; ++ptr)
1219  if (((*ptr).gc_mark) == 0)
1220  {switch((*ptr).type)
1221  {case tc_flonum:
1222  if (FLONMPNAME(ptr) != NULL)
1223  wfree(FLONMPNAME(ptr)); /* free the print name */
1224  FLONMPNAME(ptr) = NULL;
1225  break;
1226  case tc_string:
1227  wfree(ptr->storage_as.string.data);
1228  break;
1229  case tc_free_cell:
1230  case tc_cons:
1231  case tc_closure:
1232  case tc_symbol:
1233  case tc_subr_0:
1234  case tc_subr_1:
1235  case tc_subr_2:
1236  case tc_subr_3:
1237  case tc_subr_4:
1238  case tc_lsubr:
1239  case tc_fsubr:
1240  case tc_msubr:
1241  break;
1242  default:
1243  p = get_user_type_hooks(TYPE(ptr));
1244  if (p->gc_free)
1245  {
1246  if (p->gc_free_once)
1247  {
1248  if (!is_dead(USERVAL(ptr)))
1249  {
1250  (*p->gc_free)(ptr);
1251  mark_as_dead(USERVAL(ptr));
1252  }
1253  }
1254  else
1255  (*p->gc_free)(ptr);
1256  }
1257  }
1258  ++n;
1259  (*ptr).type = tc_free_cell;
1260  CDR(ptr) = nfreelist;
1261  nfreelist = ptr;
1262  }
1263  else
1264  {
1265  (*ptr).gc_mark = 0;
1266  p = get_user_type_hooks(TYPE(ptr));
1267  if (p->gc_clear)
1268  (*p->gc_clear)(ptr);
1269  }
1270  gc_cells_collected = n;
1271  freelist = nfreelist;
1272 }
1273 
1274 LISP user_gc(LISP args)
1275 {long old_status_flag,flag;
1276  int ej_ok;
1277  if (gc_kind_copying == 1)
1278  err("implementation cannot GC at will with stop-and-copy\n",
1279  NIL);
1280  flag = no_interrupt(1);
1281  ej_ok = errjmp_ok;
1282  errjmp_ok = 0;
1283  old_status_flag = gc_status_flag;
1284  if NNULLP(args)
1285  {
1286  if NULLP(car(args))
1287  gc_status_flag = 0;
1288  else
1289  gc_status_flag = 1;
1290  }
1291  gc_mark_and_sweep();
1292  gc_status_flag = old_status_flag;
1293  errjmp_ok = ej_ok;
1294  no_interrupt(flag);
1295 
1296  return(NIL);}
1297 
1298 LISP set_backtrace(LISP n)
1299 {
1300  if (n)
1301  show_backtrace = 1;
1302  else
1303  show_backtrace = 0;
1304  return n;
1305 }
1306 
1307 LISP gc_status(LISP args)
1308 {LISP l;
1309  int n;
1310  if NNULLP(args)
1311  {
1312  if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
1313  }
1314  if (gc_kind_copying == 1)
1315  {if (gc_status_flag)
1316  fput_st(fwarn,"garbage collection is on\n");
1317  else
1318  fput_st(fwarn,"garbage collection is off\n");
1319  sprintf(tkbuffer,"%ld allocated %ld free\n",
1320  (long)(heap - heap_org),(long)(heap_end - heap));
1321  fput_st(fwarn,tkbuffer);}
1322  else
1323  {if (gc_status_flag)
1324  fput_st(fwarn,"garbage collection verbose\n");
1325  else
1326  fput_st(fwarn,"garbage collection silent\n");
1327  {for(n=0,l=freelist;NNULLP(l); ++n) l = CDR(l);
1328  sprintf(tkbuffer,"%ld allocated %ld free\n",
1329  (long)((heap_end - heap_org) - n),(long)n);
1330  fput_st(fwarn,tkbuffer);}}
1331  return(NIL);}
1332 
1333 LISP leval_args(LISP l,LISP env)
1334 {LISP result,v1,v2,tmp;
1335  if NULLP(l) return(NIL);
1336  if NCONSP(l) err("bad syntax argument list",l);
1337  result = cons(leval(CAR(l),env),NIL);
1338  for(v1=result,v2=CDR(l);
1339  CONSP(v2);
1340  v1 = tmp, v2 = CDR(v2))
1341  {tmp = cons(leval(CAR(v2),env),NIL);
1342  CDR(v1) = tmp;}
1343  if NNULLP(v2) err("bad syntax argument list",l);
1344  return(result);}
1345 
1346 LISP extend_env(LISP actuals,LISP formals,LISP env)
1347 {
1348  if SYMBOLP(formals)
1349  return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
1350  else
1351  return(cons(cons(formals,actuals),env));
1352 }
1353 
1354 #define ENVLOOKUP_TRICK 1
1355 LISP global_var = NIL;
1356 LISP global_env = NIL;
1357 
1358 LISP envlookup(LISP var,LISP env)
1359 {LISP frame,al,fl,tmp;
1360  global_var = var;
1361  global_env = env;
1362  for(frame=env;CONSP(frame);frame=CDR(frame))
1363  {tmp = CAR(frame);
1364  if NCONSP(tmp) err("damaged frame",tmp);
1365  for(fl=CAR(tmp),al=CDR(tmp);CONSP(fl);fl=CDR(fl),al=CDR(al))
1366  {if NCONSP(al) err("too few arguments",tmp);
1367  if EQ(CAR(fl),var) return(al);}
1368  /* suggested by a user. It works for reference (although conses)
1369  but doesn't allow for set! to work properly... */
1370 #if (ENVLOOKUP_TRICK)
1371  if (SYMBOLP(fl) && EQ(fl, var)) return(cons(al, NIL));
1372 #endif
1373  }
1374  if NNULLP(frame)
1375  err("damaged env",env);
1376  return(NIL);}
1377 
1378 void set_eval_hooks(long type,LISP (*fcn)(LISP, LISP *,LISP *))
1379 {struct user_type_hooks *p;
1380  p = get_user_type_hooks(type);
1381  p->leval = fcn;}
1382 
1383 LISP leval(LISP x,LISP qenv)
1384 {LISP tmp,arg1,rval;
1385  LISP env;
1386  struct user_type_hooks *p;
1387  env = qenv;
1388  STACK_CHECK(&x);
1389  siod_backtrace = cons(x,siod_backtrace);
1390  loop:
1391  INTERRUPT_CHECK();
1392  current_env = env;
1393  switch TYPE(x)
1394  {case tc_symbol:
1395  tmp = envlookup(x,env);
1396  if NNULLP(tmp)
1397  {
1398  siod_backtrace = cdr(siod_backtrace);
1399  return(CAR(tmp));
1400  }
1401  tmp = VCELL(x);
1402  if EQ(tmp,unbound_marker) err("unbound variable",x);
1403  siod_backtrace = cdr(siod_backtrace);
1404  return tmp;
1405  case tc_cons:
1406  tmp = CAR(x);
1407  switch TYPE(tmp)
1408  {case tc_symbol:
1409  tmp = envlookup(tmp,env);
1410  if NNULLP(tmp)
1411  {tmp = CAR(tmp);
1412  break;}
1413  tmp = VCELL(CAR(x));
1414  if EQ(tmp,unbound_marker) err("unbound variable",CAR(x));
1415  break;
1416  case tc_cons:
1417  tmp = leval(tmp,env);
1418  break;}
1419  switch TYPE(tmp)
1420  {case tc_subr_0:
1421  rval = SUBR0(tmp)();
1422  siod_backtrace = cdr(siod_backtrace);
1423  return rval;
1424  case tc_subr_1:
1425  rval = SUBR1(tmp)(leval(car(CDR(x)),env));
1426  siod_backtrace = cdr(siod_backtrace);
1427  return rval;
1428  case tc_subr_2:
1429  x = CDR(x);
1430  arg1 = leval(car(x),env);
1431  x = NULLP(x) ? NIL : CDR(x);
1432  rval = SUBR2(tmp)(arg1,leval(car(x),env));
1433  siod_backtrace = cdr(siod_backtrace);
1434  return rval;
1435  case tc_subr_3:
1436  x = CDR(x);
1437  arg1 = leval(car(x),env);
1438  x = NULLP(x) ? NIL : CDR(x);
1439  rval = SUBR3(tmp)(arg1,leval(car(x),env),leval(car(cdr(x)),env));
1440  siod_backtrace = cdr(siod_backtrace);
1441  return rval;
1442  case tc_subr_4:
1443  x = CDR(x);
1444  arg1 = leval(car(x),env);
1445  x = NULLP(x) ? NIL : CDR(x);
1446  rval = SUBR4(tmp)(arg1,leval(car(x),env),
1447  leval(car(cdr(x)),env),
1448  leval(car(cdr(cdr(x))),env));
1449  siod_backtrace = cdr(siod_backtrace);
1450  return rval;
1451  case tc_lsubr:
1452  rval = SUBR1(tmp)(leval_args(CDR(x),env));
1453  siod_backtrace = cdr(siod_backtrace);
1454  return rval;
1455  case tc_fsubr:
1456  rval = SUBR2(tmp)(CDR(x),env);
1457  siod_backtrace = cdr(siod_backtrace);
1458  return rval;
1459  case tc_msubr:
1460  if NULLP(SUBRM(tmp)(&x,&env))
1461  {
1462  siod_backtrace = cdr(siod_backtrace);
1463  return(x);
1464  }
1465  goto loop;
1466  case tc_closure:
1467  env = extend_env(leval_args(CDR(x),env),
1468  car((*tmp).storage_as.closure.code),
1469  (*tmp).storage_as.closure.env);
1470  x = cdr((*tmp).storage_as.closure.code);
1471  goto loop;
1472  case tc_symbol:
1473  x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
1474  x = leval(x,NIL);
1475  goto loop;
1476  default:
1477  p = get_user_type_hooks(TYPE(tmp));
1478  if (p->leval)
1479  {if NULLP((*p->leval)(tmp,&x,&env))
1480  {
1481  siod_backtrace = cdr(siod_backtrace);
1482  return(x);
1483  }
1484  else
1485  goto loop;}
1486  err("bad function",tmp);}
1487  default:
1488  siod_backtrace = cdr(siod_backtrace);
1489  return(x);}}
1490 
1491 void set_print_hooks(long type,
1492  void (*prin1)(LISP, FILE *),
1493  void (*print_string)(LISP, char *)
1494  )
1495 {struct user_type_hooks *p;
1496  p = get_user_type_hooks(type);
1497  p->prin1 = prin1;
1498  p->print_string = print_string;
1499 }
1500 
1501 void set_io_hooks(long type,
1502  LISP (*fast_print)(LISP,LISP),
1503  LISP (*fast_read)(int,LISP))
1504 
1505 {struct user_type_hooks *p;
1506  p = get_user_type_hooks(type);
1507  p->fast_print = fast_print;
1508  p->fast_read = fast_read;
1509 }
1510 
1511 void set_type_hooks(long type,
1512  long (*c_sxhash)(LISP,long),
1513  LISP (*equal)(LISP,LISP))
1514 
1515 
1516 {struct user_type_hooks *p;
1517  p = get_user_type_hooks(type);
1518  p->c_sxhash = c_sxhash;
1519  p->equal = equal;
1520 }
1521 
1522 int f_getc(FILE *f)
1523 {long iflag;
1524  int c;
1525  iflag = no_interrupt(1);
1526  c = getc(f);
1527  if ((c == '\n') && (f == stdin) && (siod_interactive))
1528  {
1529  fprintf(stdout,"%s",repl_prompt);
1530  fflush(stdout);
1531  }
1532  no_interrupt(iflag);
1533  return(c);}
1534 
1535 void f_ungetc(int c, FILE *f)
1536 {ungetc(c,f);}
1537 
1538 #ifdef WIN32
1539 int winsock_unget_buffer;
1540 bool winsock_unget_buffer_unused=true;
1541 bool use_winsock_unget_buffer;
1542 
1543 int f_getc_winsock(HANDLE h)
1544 {long iflag,dflag;
1545  char c;
1546  DWORD lpNumberOfBytesRead;
1547  iflag = no_interrupt(1);
1548  if (use_winsock_unget_buffer)
1549  {
1550  use_winsock_unget_buffer = false;
1551  return winsock_unget_buffer;
1552  }
1553 
1554  if (SOCKET_ERROR == recv((SOCKET)h,&c,1,0))
1555  {
1556  if (WSAECONNRESET == GetLastError()) // The connection was closed.
1557  c=EOF;
1558  else
1559  cerr << "f_getc_winsock(): error reading from socket\n";
1560  }
1561 
1562  winsock_unget_buffer=c;
1563  winsock_unget_buffer_unused = false;
1564 
1565  no_interrupt(iflag);
1566  return(c);}
1567 
1568 void f_ungetc_winsock(int c, HANDLE h)
1569 {
1570  if (winsock_unget_buffer_unused)
1571  {
1572  cerr << "f_ungetc_winsock: tried to unget before reading socket\n";
1573  }
1574 use_winsock_unget_buffer = true;}
1575 #endif
1576 
1577 int flush_ws(struct gen_readio *f,const char *eoferr)
1578 {int c,commentp;
1579  commentp = 0;
1580  while(1)
1581  {c = GETC_FCN(f);
1582  if (c == EOF) { if (eoferr) err(eoferr,NIL); else return(c); }
1583  if (commentp) {if (c == '\n') commentp = 0;}
1584  else if (c == ';') commentp = 1;
1585  else if (!isspace(c)) return(c);}}
1586 
1587 LISP lreadf(FILE *f)
1588 {struct gen_readio s;
1589  if ((f == stdin) && (isatty(0)) && (siod_interactive))
1590  { /* readline (if selected) stuff -- only works with a terminal */
1591  s.getc_fcn = (int (*)(char *))siod_fancy_getc;
1592  s.ungetc_fcn = (void (*)(int, char *))siod_fancy_ungetc;
1593  s.cb_argument = (char *) f;
1594  }
1595  else /* normal stuff */
1596  {
1597  s.getc_fcn = (int (*)(char *))f_getc;
1598  s.ungetc_fcn = (void (*)(int, char *))f_ungetc;
1599  s.cb_argument = (char *) f;
1600  }
1601  return(readtl(&s));}
1602 
1603 #ifdef WIN32
1604 LISP lreadwinsock(void)
1605 {
1606  struct gen_readio s;
1607  s.getc_fcn = (int (*)(char *))f_getc_winsock;
1608  s.ungetc_fcn = (void (*)(int, char *))f_ungetc_winsock;
1609  s.cb_argument = (char *) siod_server_socket;
1610  return(readtl(&s));}
1611 #endif
1612 
1613 LISP readtl(struct gen_readio *f)
1614 {int c;
1615  c = flush_ws(f,(char *)NULL);
1616  if (c == EOF) return(eof_val);
1617  UNGETC_FCN(c,f);
1618  return(lreadr(f));}
1619 
1620 void set_read_hooks(char *all_set,char *end_set,
1621  LISP (*fcn1)(int, struct gen_readio *),
1622  LISP (*fcn2)(char *,long, int *))
1623 {user_ch_readm = all_set;
1624  user_te_readm = end_set;
1625  user_readm = fcn1;
1626  user_readt = fcn2;}
1627 
1628 static LISP lreadr(struct gen_readio *f)
1629 {int c,j;
1630  char *p;
1631  const char *pp, *last_prompt;
1632  LISP rval;
1633  STACK_CHECK(&f);
1634  p = tkbuffer;
1635  c = flush_ws(f,"end of file inside read");
1636  switch (c)
1637  {case '(':
1638  last_prompt = repl_prompt;
1639  repl_prompt = siod_secondary_prompt;
1640  rval = lreadparen(f);
1641  repl_prompt = last_prompt;
1642  return rval;
1643  case ')':
1644  err("unexpected close paren",NIL);
1645  case '\'':
1646  return(cons(sym_quote,cons(lreadr(f),NIL)));
1647  case '`':
1648  return(cons(cintern("+internal-backquote"),lreadr(f)));
1649  case ',':
1650  c = GETC_FCN(f);
1651  switch(c)
1652  {case '@':
1653  pp = "+internal-comma-atsign";
1654  break;
1655  case '.':
1656  pp = "+internal-comma-dot";
1657  break;
1658  default:
1659  pp = "+internal-comma";
1660  UNGETC_FCN(c,f);}
1661  return(cons(cintern(pp),lreadr(f)));
1662  case '"':
1663  last_prompt = repl_prompt;
1664  repl_prompt = siod_secondary_prompt;
1665  rval = lreadstring(f);
1666  repl_prompt = last_prompt;
1667  return rval;
1668  default:
1669  if ((user_readm != NULL) && strchr(user_ch_readm,c))
1670  return((*user_readm)(c,f));}
1671  *p++ = c;
1672  for(j = 1; j<TKBUFFERN; ++j)
1673  {c = GETC_FCN(f);
1674  if (c == EOF) return(lreadtk(j));
1675  if (isspace(c)) return(lreadtk(j));
1676  if (strchr("()'`,;\"",c) || strchr(user_te_readm,c))
1677  {UNGETC_FCN(c,f);return(lreadtk(j));}
1678  *p++ = c;}
1679  return(err("symbol larger than maxsize (can you use a string instead?)",NIL));}
1680 
1681 #if 0
1682 LISP lreadparen(struct gen_readio *f)
1683 {int c;
1684  LISP tmp;
1685  c = flush_ws(f,"end of file inside list");
1686  if (c == ')') return(NIL);
1687  UNGETC_FCN(c,f);
1688  tmp = lreadr(f);
1689  if EQ(tmp,sym_dot)
1690  {tmp = lreadr(f);
1691  c = flush_ws(f,"end of file inside list");
1692  if (c != ')') err("missing close paren",NIL);
1693  return(tmp);}
1694  return(cons(tmp,lreadparen(f)));}
1695 #endif
1696 
1697 /* Iterative version of the above */
1698 static LISP lreadparen(struct gen_readio *f)
1699 {
1700  int c;
1701  LISP tmp,l=NIL;
1702  LISP last=l;
1703 
1704  while ((c = flush_ws(f,"end of file inside list")) != ')')
1705  {
1706  UNGETC_FCN(c,f);
1707  tmp = lreadr(f);
1708  if EQ(tmp,sym_dot)
1709  {
1710  tmp = lreadr(f);
1711  c = flush_ws(f,"end of file inside list");
1712  if (c != ')') err("missing close paren",NIL);
1713  if (l == NIL) err("no car for dotted pair",NIL);
1714  CDR(last) = tmp;
1715  break;
1716  }
1717  if (l == NIL)
1718  {
1719  l = cons(tmp,NIL);
1720  last = l;
1721  }
1722  else
1723  {
1724  CDR(last) = cons(tmp,NIL);
1725  last = cdr(last);
1726  }
1727  }
1728  return l;
1729 }
1730 
1731 static LISP lreadstring(struct gen_readio *f)
1732 {
1733  int j,c,n;
1734  static int len=TKBUFFERN;
1735  static char *str = 0;
1736  char *q;
1737  LISP qq;
1738  j = 0;
1739  if (str == 0)
1740  str = (char *)must_malloc(len * sizeof(char));
1741  while(((c = GETC_FCN(f)) != '"') && (c != EOF))
1742  {
1743  if (c == '\\')
1744  {c = GETC_FCN(f);
1745  if (c == EOF) err("eof after \\",NIL);
1746  switch(c)
1747  {case 'n':
1748  c = '\n';
1749  break;
1750  case 't':
1751  c = '\t';
1752  break;
1753  case 'r':
1754  c = '\r';
1755  break;
1756  case 'd':
1757  c = 0x04;
1758  break;
1759  case 'N':
1760  c = 0;
1761  break;
1762  case 's':
1763  c = ' ';
1764  break;
1765  case '0':
1766  n = 0;
1767  while(1)
1768  {c = GETC_FCN(f);
1769  if (c == EOF) err("eof after \\0",NIL);
1770  if (isdigit(c))
1771  n = n * 8 + c - '0';
1772  else
1773  {UNGETC_FCN(c,f);
1774  break;}}
1775  c = n;}}
1776  if ((j + 1) >= len)
1777  {
1778  /* EST_String full so double the buffer, copy and continue */
1779  q = (char *)must_malloc(len*2*sizeof(char));
1780  strncpy(q,str,len);
1781  wfree(str);
1782  str = q;
1783  len = len*2;
1784  }
1785  str[j] = c;
1786  ++j;
1787  }
1788  str[j] = 0;
1789  qq = strcons(j,str);
1790  return qq;
1791 }
1792 
1793 LISP lreadtk(long j)
1794 {int flag;
1795  unsigned char *p;
1796  LISP tmp;
1797  int adigit;
1798  p = (unsigned char *)tkbuffer;
1799  p[j] = 0;
1800  if (user_readt != NULL)
1801  {tmp = (*user_readt)((char *)p,j,&flag);
1802  if (flag) return(tmp);}
1803  if (strcmp("nil",tkbuffer) == 0)
1804  return NIL;
1805  if (*p == '-') p+=1;
1806  adigit = 0;
1807  while((*p < 128) && (isdigit(*p))) {p+=1; adigit=1;}
1808  if (*p=='.')
1809  {p += 1;
1810  while((*p < 128) && (isdigit(*p))) {p+=1; adigit=1;}}
1811  if (!adigit) goto a_symbol;
1812  if (*p=='e')
1813  {p+=1;
1814  if (*p=='-'||*p=='+') p+=1;
1815  if ((!isdigit(*p) || (*p > 127))) goto a_symbol; else p+=1;
1816  while((*p < 128) && (isdigit(*p))) p+=1;}
1817  if (*p) goto a_symbol;
1818  return(flocons(atof(tkbuffer)));
1819  a_symbol:
1820  return(rintern(tkbuffer));}
1821 
1822 LISP siod_quit(void)
1823 {open_files = NIL; // will be closed on exit with no warnings
1824  if (errjmp_ok) longjmp(*est_errjmp,2);
1825  else exit(0);
1826  return(NIL);}
1827 
1828 LISP l_exit(LISP arg)
1829 {
1830  if (arg == NIL)
1831  exit(0);
1832  else
1833  exit((int)FLONM(arg));
1834 
1835  // never happens
1836  return NULL;
1837 }
1838 
1839 LISP lfwarning(LISP mode)
1840 {
1841  /* if mode is non-nil switch warnings on */
1842  if (mode == NIL)
1843  fwarn = NULL;
1844  else
1845  fwarn = stdout;
1846  return NIL;
1847 }
1848 
1849 LISP closure_code(LISP exp)
1850 {return(exp->storage_as.closure.code);}
1851 
1852 LISP closure_env(LISP exp)
1853 {return(exp->storage_as.closure.env);}
1854 
1855 int get_c_int(LISP x)
1856 {if NFLONUMP(x) err("not a number",x);
1857  return((int)FLONM(x));}
1858 
1859 double get_c_double(LISP x)
1860 {if NFLONUMP(x) err("not a number",x);
1861  return(FLONM(x));}
1862 
1863 float get_c_float(LISP x)
1864 {if NFLONUMP(x) err("not a number",x);
1865  return((float)FLONM(x));}
1866 
1867 
1868 void init_subrs_base(void)
1869 {
1870  init_subr_2("eval",leval,
1871  "(eval DATA)\n\
1872  Evaluate DATA and return result.");
1873  init_lsubr("gc-status",gc_status,
1874  "(gc-status OPTION)\n\
1875  Control summary information during garbage collection. If OPTION is t,\n\
1876  output information at each garbage collection, if nil do gc silently.");
1877  init_lsubr("gc",user_gc,
1878  "(gc)\n\
1879  Collect garbage now, where gc method supports it.");
1880  init_subr_2("error",lerr,
1881  "(error MESSAGE DATA)\n\
1882  Prints MESSAGE about DATA and throws an error.");
1883  init_subr_0("quit",siod_quit,
1884  "(quit)\n\
1885  Exit from program, does not return.");
1886  init_subr_1("exit",l_exit,
1887  "(exit [RCODE])\n\
1888  Exit from program, if RCODE is given it is given as an argument to\n\
1889  the system call exit.");
1890  init_subr_2("env-lookup",envlookup,
1891  "(env-lookup VARNAME ENVIRONMENT)\n\
1892  Return value of VARNAME in ENVIRONMENT.");
1893  init_subr_1("fwarning",lfwarning,
1894  "(fwarning MODE)\n\
1895  For controlling various levels of warning messages. If MODE is nil, or\n\
1896  not specified stop all warning messages from being displayed. If MODE\n\
1897  display warning messages.");
1898  init_subr_2("%%stack-limit",stack_limit,
1899  "(%%stack-limit AMOUNT SILENT)\n\
1900  Set stacksize to AMOUNT, if SILENT is non nil do it silently.");
1901  init_subr_1("intern",intern,
1902  "(intern ATOM)\n\
1903  Intern ATOM on the oblist.");
1904  init_subr_2("%%closure",closure,
1905  "(%%closure ENVIRONMENT CODE)\n\
1906  Make a closure from given environment and code.");
1907  init_subr_1("%%closure-code",closure_code,
1908  "(%%closure-code CLOSURE)\n\
1909  Return code part of closure.");
1910  init_subr_1("%%closure-env",closure_env,
1911  "(%%closure-env CLOSURE)\n\
1912  Return environment part of closure.");
1913  init_subr_1("set_backtrace",set_backtrace,
1914  "(set_backtrace arg)\n\
1915  If arg is non-nil a backtrace will be display automatically after errors\n\
1916  if arg is nil, a backtrace will not automatically be displayed (use\n\
1917  (:backtrace) for display explicitly.");
1918  init_subr_1("set_server_safe_functions",set_restricted,
1919  "(set_server_safe_functions LIST)\n\
1920  Sets restricted list to LIST. When restricted list is non-nil only\n\
1921  functions whose names appear in this list may be executed. This\n\
1922  is used so that clients in server mode may be restricted to a small\n\
1923  number of safe commands. [see Server/client API]");
1924 
1925 }
1926 
1927 void init_subrs(void)
1928 {
1929  init_subrs_base();
1930  init_subrs_core();
1931  init_subrs_doc();
1932  init_subrs_file();
1933  init_subrs_format();
1934  init_subrs_list();
1935  init_subrs_math();
1936  init_subrs_str();
1937  init_subrs_sys();
1938  init_subrs_xtr(); // arrays and hash tables
1939 }
1940 
1941 /* err0,pr,prp are convenient to call from the C-language debugger */
1942 
1943 void err0(void)
1944 {err("0",NIL);}
1945 
1946 void pr(LISP p)
1947 {if ((p >= heap_org) &&
1948  (p < heap_end) &&
1949  (((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0))
1950  pprint(p);
1951  else
1952  put_st("invalid\n");}
1953 
1954 void prp(LISP *p)
1955 {if (!p) return;
1956  pr(*p);}
1957 
1958 LISP siod_make_typed_cell(long type, void *s)
1959 {
1960  LISP ptr;
1961 
1962  NEWCELL(ptr,type);
1963  USERVAL(ptr) = s;
1964 
1965  return ptr;
1966 }
1967 
1968 static LISP set_restricted(LISP l)
1969 {
1970  // Set restricted list
1971 
1972  if (restricted == NIL)
1973  gc_protect(&restricted);
1974 
1975  restricted = l;
1976  return NIL;
1977 }
1978 
1979 static int restricted_function_call(LISP l)
1980 {
1981  // Checks l recursively to ensure all function calls
1982  // are in the restricted list
1983  LISP p;
1984 
1985  if (l == NIL)
1986  return TRUE;
1987  else if (!consp(l))
1988  return TRUE;
1989  else if (TYPE(car(l)) == tc_symbol)
1990  {
1991  if (streq("quote",get_c_string(car(l))))
1992  return TRUE;
1993  else if (siod_member_str(get_c_string(car(l)),restricted) == NIL)
1994  return FALSE;
1995  }
1996  else if (restricted_function_call(car(l)) == FALSE)
1997  return FALSE;
1998 
1999  // As its some type of list with a valid car, check the cdr
2000  for (p=cdr(l); consp(p); p=cdr(p))
2001  if (restricted_function_call(car(p)) == FALSE)
2002  return FALSE;
2003  return TRUE;
2004 }
2005