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
siod_version(void)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
NNEWCELL(LISP * _into,long _type)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
need_n_cells(int n)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
start_rememberring_dead(void)217 static void start_rememberring_dead(void)
218 {
219 num_dead_pointers=0;
220 }
221
is_dead(void * ptr)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
mark_as_dead(void * ptr)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
siod_print_welcome(EST_String extra_info)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
siod_print_welcome(void)252 void siod_print_welcome(void)
253 {
254 siod_print_welcome("");
255 }
256
print_hs_1(void)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
print_hs_2(void)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
err_ctrl_c(void)274 static void err_ctrl_c(void)
275 {
276 audsp_mode = FALSE;
277 siod_ctrl_c = TRUE;
278 err("control-c interrupt",NIL);}
279
no_interrupt(long n)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
handle_sigfpe(int sig SIG_restargs)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
handle_sigint(int sig SIG_restargs)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
siod_reset_prompt(void)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
repl_driver(long want_sigint,long want_init,struct repl_hooks * h)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
ignore_puts(char * st)371 static void ignore_puts(char *st)
372 {(void)st;}
373
noprompt_puts(char * st)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
repl_c_string_read(void)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
ignore_print(LISP x)389 static void ignore_print(LISP x)
390 {(void)x;
391 repl_c_string_flag = 1;}
392
not_ignore_print(LISP x)393 static void not_ignore_print(LISP x)
394 {repl_c_string_flag = 1;
395 pprint(x);}
396
repl_c_string(char * str,long want_sigint,long want_init,long want_print)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>
myruntime(void)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
myruntime(void)436 double myruntime(void)
437 {return(((double) clock()) / ((double) CLOCKS_PER_SEC));}
438 #else
myruntime(void)439 double myruntime(void)
440 {time_t x;
441 time(&x);
442 return((double) x);}
443 #endif
444 #endif
445
set_repl_hooks(void (* puts_f)(char *),LISP (* read_f)(void),LISP (* eval_f)(LISP),void (* print_f)(LISP))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
fput_st(FILE * f,const char * st)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
put_st(const char * st)465 void put_st(const char *st)
466 {fput_st(stdout,st);}
467
grepl_puts(char * st,void (* repl_putss)(char *))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
display_backtrace(LISP args)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
repl(struct repl_hooks * h)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
set_fatal_exit_hook(void (* fcn)(void))575 void set_fatal_exit_hook(void (*fcn)(void))
576 {fatal_exit_hook = fcn;}
577
err(const char * message,LISP x,const char * s)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
err(const char * message,LISP x)613 LISP err(const char *message, LISP x)
614 {
615 return err(message, x, NULL);
616 }
617
err(const char * message,const char * x)618 LISP err(const char *message, const char *x)
619 {
620 return err(message, NULL, x);
621 }
622
errswitch(void)623 LISP errswitch(void)
624 {return(err("BUG. Reached impossible case",NIL));}
625
err_stack(char * ptr)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
stack_limit(LISP amount,LISP silent)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
get_c_string(LISP x)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
lerr(LISP message,LISP x)666 LISP lerr(LISP message, LISP x)
667 {err(get_c_string(message),x);
668 return(NIL);}
669
gc_fatal_error(void)670 void gc_fatal_error(void)
671 {err("ran out of storage",NIL);}
672
newcell(long type)673 LISP newcell(long type)
674 {LISP z;
675 NEWCELL(z,type);
676 return(z);}
677
flocons(double x)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
symcons(char * pname,LISP vcell)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
must_malloc(unsigned long size)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
gen_intern(char * name,int require_copy)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
cintern(const char * name)733 LISP cintern(const char *name)
734 {
735 char *dname = (char *)(void *)name;
736 return(gen_intern(dname,FALSE));
737 }
738
rintern(const char * name)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
intern(LISP name)747 LISP intern(LISP name)
748 {return(rintern(get_c_string(name)));}
749
subrcons(long type,const char * name,SUBR_FUNC f)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
closure(LISP env,LISP code)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
gc_unprotect(LISP * location)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
gc_protect(LISP * location)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
gc_protect_n(LISP * location,long n)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
gc_protect_sym(LISP * location,const char * st)816 void gc_protect_sym(LISP *location,const char *st)
817 {*location = cintern(st);
818 gc_protect(location);}
819
scan_registers(void)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
init_storage_1(int init_heap_size)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(¤t_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
init_storage(int init_heap_size)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
init_subr(const char * name,long type,SUBR_FUNC fcn)893 void init_subr(const char *name, long type, SUBR_FUNC fcn)
894 {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
init_subr(const char * name,long type,SUBR_FUNC fcn,const char * doc)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 */
init_subr_0(const char * name,LISP (* fcn)(void),const char * doc)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);}
init_subr_1(const char * name,LISP (* fcn)(LISP),const char * 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);}
init_subr_2(const char * name,LISP (* fcn)(LISP,LISP),const char * 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);}
init_subr_3(const char * name,LISP (* fcn)(LISP,LISP,LISP),const char * 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);}
init_subr_4(const char * name,LISP (* fcn)(LISP,LISP,LISP,LISP),const char * 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);}
init_lsubr(const char * name,LISP (* fcn)(LISP),const char * doc)911 void init_lsubr(const char *name, LISP (*fcn)(LISP),const char *doc)
912 {init_subr(name,tc_lsubr,(SUBR_FUNC)fcn,doc);}
init_fsubr(const char * name,LISP (* fcn)(LISP,LISP),const char * 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);}
init_msubr(const char * name,LISP (* fcn)(LISP *,LISP *),const char * 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
get_user_type_hooks(long type)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
siod_register_user_type(const char * name)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
set_gc_hooks(long type,int gc_free_once,LISP (* rel)(LISP),LISP (* mark)(LISP),void (* scan)(LISP),void (* free)(LISP),void (* clear)(LISP),long * kind)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
gc_relocate(LISP x)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
get_newspace(void)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
scan_newspace(LISP newspace)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
free_oldspace(LISP space,LISP end)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
gc_stop_and_copy(void)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
gc_for_newcell(void)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
gc_mark_and_sweep(void)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
gc_ms_stats_start(void)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
gc_ms_stats_end(void)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
gc_mark(LISP ptr)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
mark_protected_registers(void)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
mark_locations(LISP * start,LISP * end)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
mark_locations_array(LISP * x,long n)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
gc_sweep(void)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
user_gc(LISP args)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
set_backtrace(LISP n)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
gc_status(LISP args)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
leval_args(LISP l,LISP env)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
extend_env(LISP actuals,LISP formals,LISP env)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
envlookup(LISP var,LISP env)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
set_eval_hooks(long type,LISP (* fcn)(LISP,LISP *,LISP *))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
leval(LISP x,LISP qenv)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
set_print_hooks(long type,void (* prin1)(LISP,FILE *),void (* print_string)(LISP,char *))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
set_io_hooks(long type,LISP (* fast_print)(LISP,LISP),LISP (* fast_read)(int,LISP))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
set_type_hooks(long type,long (* c_sxhash)(LISP,long),LISP (* equal)(LISP,LISP))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
f_getc(FILE * f)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
f_ungetc(int c,FILE * f)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
f_getc_winsock(HANDLE h)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
f_ungetc_winsock(int c,HANDLE h)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
flush_ws(struct gen_readio * f,const char * eoferr)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
lreadf(FILE * f)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
lreadwinsock(void)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
readtl(struct gen_readio * f)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
set_read_hooks(char * all_set,char * end_set,LISP (* fcn1)(int,struct gen_readio *),LISP (* fcn2)(char *,long,int *))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
lreadr(struct gen_readio * f)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 */
lreadparen(struct gen_readio * f)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
lreadstring(struct gen_readio * f)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
lreadtk(long j)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
siod_quit(void)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
l_exit(LISP arg)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
lfwarning(LISP mode)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
closure_code(LISP exp)1849 LISP closure_code(LISP exp)
1850 {return(exp->storage_as.closure.code);}
1851
closure_env(LISP exp)1852 LISP closure_env(LISP exp)
1853 {return(exp->storage_as.closure.env);}
1854
get_c_int(LISP x)1855 int get_c_int(LISP x)
1856 {if NFLONUMP(x) err("not a number",x);
1857 return((int)FLONM(x));}
1858
get_c_double(LISP x)1859 double get_c_double(LISP x)
1860 {if NFLONUMP(x) err("not a number",x);
1861 return(FLONM(x));}
1862
get_c_float(LISP x)1863 float get_c_float(LISP x)
1864 {if NFLONUMP(x) err("not a number",x);
1865 return((float)FLONM(x));}
1866
1867
init_subrs_base(void)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
init_subrs(void)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
err0(void)1943 void err0(void)
1944 {err("0",NIL);}
1945
pr(LISP p)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
prp(LISP * p)1954 void prp(LISP *p)
1955 {if (!p) return;
1956 pr(*p);}
1957
siod_make_typed_cell(long type,void * s)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
set_restricted(LISP l)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
restricted_function_call(LISP l)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
2006