Edinburgh Speech Tools 2.4-release
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
7Permission to use, copy, modify, distribute and sell this software
8and its documentation for any purpose and without fee is hereby
9granted, provided that the above copyright notice appear in all copies
10and that both that copyright notice and this permission notice appear
11in supporting documentation, and that the name of Paradigm Associates
12Inc not be used in advertising or publicity pertaining to distribution
13of the software without specific, written prior permission.
14
15PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
16ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
17PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
18ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
19WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
20ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
21SOFTWARE.
22
23*/
24
25/*
26
27gjc@paradigm.com, gjc@mitech.com
28
29Paradigm Associates Inc Phone: 617-492-6079
3029 Putnam Ave, Suite 6
31Cambridge, 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
96static int restricted_function_call(LISP l);
97static long repl(struct repl_hooks *h);
98static void gc_mark_and_sweep(void);
99static void gc_ms_stats_start(void);
100static void gc_ms_stats_end(void);
101static void mark_protected_registers(void);
102static void mark_locations(LISP *start,LISP *end);
103static void gc_sweep(void);
104static void mark_locations_array(LISP *x,long n);
105static LISP lreadr(struct gen_readio *f);
106static LISP lreadparen(struct gen_readio *f);
107static LISP lreadstring(struct gen_readio *f);
108
109const char *siod_version(void)
110{return("3.0 FIELD TEST");}
111
112LISP heap_1,heap_2;
113LISP heap,heap_end,heap_org;
114long heap_size = DEFAULT_HEAP_SIZE;
115long old_heap_used;
116long which_heap;
117long gc_status_flag = 0;
118long show_backtrace = 0;
119char *init_file = (char *) NULL;
120char *tkbuffer = NULL;
121long gc_kind_copying = 0;
122long gc_cells_allocated = 0;
123double gc_time_taken;
124LISP *stack_start_ptr;
125LISP freelist;
126
127long nointerrupt = 1;
128long interrupt_differed = 0;
129LISP oblistvar = NIL;
130LISP current_env = NIL;
131static LISP siod_backtrace = NIL;
132LISP restricted = NIL;
133LISP truth = NIL;
134LISP eof_val = NIL;
135LISP sym_errobj = NIL;
136LISP sym_quote = NIL;
137LISP sym_dot = NIL;
138LISP unbound_marker = NIL;
139LISP *obarray;
140long obarray_dim = 100;
141struct catch_frame *catch_framep = (struct catch_frame *) NULL;
142void (*repl_puts)(char *) = NULL;
143LISP (*repl_read)(void) = NULL;
144LISP (*repl_eval)(LISP) = NULL;
145void (*repl_print)(LISP) = NULL;
146repl_getc_fn siod_fancy_getc = f_getc;
147repl_ungetc_fn siod_fancy_ungetc = f_ungetc;
148LISP *inums;
149LISP siod_docstrings = NIL; /* for builtin functions */
150long inums_dim = 100;
151struct user_type_hooks *user_types = NULL;
152struct gc_protected *protected_registers = NULL;
153jmp_buf save_regs_gc_mark;
154double gc_rt;
155long gc_cells_collected;
156static const char *user_ch_readm = "";
157static const char *user_te_readm = "";
158LISP (*user_readm)(int, struct gen_readio *) = NULL;
159LISP (*user_readt)(char *,long, int *) = NULL;
160void (*fatal_exit_hook)(void) = NULL;
161#ifdef THINK_C
162int ipoll_counter = 0;
163#endif
164FILE *fwarn=NULL;
165int siod_interactive = 1;
166
167extern "C" {
168int el_pos = -1; // actually used by readline
169}
170const char *repl_prompt = "siod>";
171const char *siod_prog_name = "siod";
172const char *siod_primary_prompt = "siod> ";
173const 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.
177void **dead_pointers = NULL;
178int size_dead_pointers = 0;
179int num_dead_pointers = 0;
180#define DEAD_POINTER_GROWTH (10)
181
182static LISP set_restricted(LISP l);
183
184char *stack_limit_ptr = NULL;
185long stack_size =
186#ifdef THINK_C
187 10000;
188#else
189 500000;
190#endif
191
192void 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
205void 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
217static void start_rememberring_dead(void)
218{
219 num_dead_pointers=0;
220}
221
222static 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
231static 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
244void 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
252void siod_print_welcome(void)
253{
254 siod_print_welcome("");
255}
256
257void 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
263void 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. */
271int audsp_mode = FALSE;
272int siod_ctrl_c = FALSE;
273
274static void err_ctrl_c(void)
275{
276 audsp_mode = FALSE;
277 siod_ctrl_c = TRUE;
278 err("control-c interrupt",NIL);}
279
280long 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
289extern "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
306extern "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
326void 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
334long 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
371static void ignore_puts(char *st)
372{(void)st;}
373
374static void noprompt_puts(char *st)
375{if (strcmp(st,"> ") != 0)
376 put_st(st);}
377
378static char *repl_c_string_arg = NULL;
379static long repl_c_string_flag = 0;
380
381static 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
389static void ignore_print(LISP x)
390{(void)x;
391 repl_c_string_flag = 1;}
392
393static void not_ignore_print(LISP x)
394{repl_c_string_flag = 1;
395 pprint(x);}
396
397long 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>
424double 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
436double myruntime(void)
437{return(((double) clock()) / ((double) CLOCKS_PER_SEC));}
438#else
439double myruntime(void)
440{time_t x;
441 time(&x);
442 return((double) x);}
443#endif
444#endif
445
446void 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
455void 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
465void put_st(const char *st)
466{fput_st(stdout,st);}
467
468void 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
475static 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
506static 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
575void set_fatal_exit_hook(void (*fcn)(void))
576{fatal_exit_hook = fcn;}
577
578static 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
613LISP err(const char *message, LISP x)
614{
615 return err(message, x, NULL);
616}
617
618LISP err(const char *message, const char *x)
619{
620 return err(message, NULL, x);
621}
622
623LISP errswitch(void)
624{return(err("BUG. Reached impossible case",NIL));}
625
626void 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 exceeded",NIL);}
630
631LISP 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
643const 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
666LISP lerr(LISP message, LISP x)
667{err(get_c_string(message),x);
668 return(NIL);}
669
670void gc_fatal_error(void)
671{err("ran out of storage",NIL);}
672
673LISP newcell(long type)
674{LISP z;
675 NEWCELL(z,type);
676 return(z);}
677
678LISP 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
691LISP 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
698char *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
704LISP 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
733LISP cintern(const char *name)
734{
735 char *dname = (char *)(void *)name;
736 return(gen_intern(dname,FALSE));
737}
738
739LISP 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
747LISP intern(LISP name)
748{return(rintern(get_c_string(name)));}
749
750LISP 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
757LISP 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
764void 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
796void 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
808void 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
816void gc_protect_sym(LISP *location,const char *st)
817{*location = cintern(st);
818 gc_protect(location);}
819
820void 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
830static 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
885void 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
893void init_subr(const char *name, long type, SUBR_FUNC fcn)
894{setvar(cintern(name),subrcons(type,name,fcn),NIL);}
895void 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 */
901void init_subr_0(const char *name, LISP (*fcn)(void),const char *doc)
902{init_subr(name,tc_subr_0,(SUBR_FUNC)fcn,doc);}
903void init_subr_1(const char *name, LISP (*fcn)(LISP),const char *doc)
904{init_subr(name,tc_subr_1,(SUBR_FUNC)fcn,doc);}
905void init_subr_2(const char *name, LISP (*fcn)(LISP,LISP),const char *doc)
906{init_subr(name,tc_subr_2,(SUBR_FUNC)fcn,doc);}
907void 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);}
909void 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);}
911void init_lsubr(const char *name, LISP (*fcn)(LISP),const char *doc)
912{init_subr(name,tc_lsubr,(SUBR_FUNC)fcn,doc);}
913void init_fsubr(const char *name, LISP (*fcn)(LISP,LISP),const char *doc)
914{init_subr(name,tc_fsubr,(SUBR_FUNC)fcn,doc);}
915void init_msubr(const char *name, LISP (*fcn)(LISP *,LISP *),const char *doc)
916{init_subr(name,tc_msubr,(SUBR_FUNC)fcn,doc);}
917
918struct 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
930int 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
951void 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
969LISP 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
1006LISP 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
1019void 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
1046void 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
1080void 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
1098void 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
1110static 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
1126static 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
1132static 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
1140void 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
1178static 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
1189static 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
1199static 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
1210static 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
1274LISP 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
1298LISP set_backtrace(LISP n)
1299{
1300 if (n)
1301 show_backtrace = 1;
1302 else
1303 show_backtrace = 0;
1304 return n;
1305}
1306
1307LISP 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
1333LISP 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
1346LISP 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
1355LISP global_var = NIL;
1356LISP global_env = NIL;
1357
1358LISP 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
1378void 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
1383LISP 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
1491void 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
1501void 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
1511void 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
1522int 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
1535void f_ungetc(int c, FILE *f)
1536{ungetc(c,f);}
1537
1538#ifdef WIN32
1539int winsock_unget_buffer;
1540bool winsock_unget_buffer_unused=true;
1541bool use_winsock_unget_buffer;
1542
1543int 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
1568void 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 }
1574use_winsock_unget_buffer = true;}
1575#endif
1576
1577int 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
1587LISP 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
1604LISP 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
1613LISP 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
1620void 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
1628static 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
1682LISP 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 */
1698static 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
1731static 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
1793LISP 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
1822LISP 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
1828LISP 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
1839LISP 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
1849LISP closure_code(LISP exp)
1850{return(exp->storage_as.closure.code);}
1851
1852LISP closure_env(LISP exp)
1853{return(exp->storage_as.closure.env);}
1854
1855int get_c_int(LISP x)
1856{if NFLONUMP(x) err("not a number",x);
1857 return((int)FLONM(x));}
1858
1859double get_c_double(LISP x)
1860{if NFLONUMP(x) err("not a number",x);
1861 return(FLONM(x));}
1862
1863float get_c_float(LISP x)
1864{if NFLONUMP(x) err("not a number",x);
1865 return((float)FLONM(x));}
1866
1867
1868void 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
1927void 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
1943void err0(void)
1944{err("0",NIL);}
1945
1946void 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
1954void prp(LISP *p)
1955{if (!p) return;
1956 pr(*p);}
1957
1958LISP 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
1968static 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
1979static 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
Definition: siod_defs.h:31