88 #include "EST_cutils.h"
96 static int restricted_function_call(LISP l);
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);
107 static LISP lreadstring(
struct gen_readio *f);
109 const char *siod_version(
void)
110 {
return(
"3.0 FIELD TEST");}
113 LISP heap,heap_end,heap_org;
114 long heap_size = DEFAULT_HEAP_SIZE;
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;
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;
135 LISP sym_errobj = NIL;
136 LISP sym_quote = NIL;
138 LISP unbound_marker = NIL;
140 long obarray_dim = 100;
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;
149 LISP siod_docstrings = NIL;
150 long inums_dim = 100;
153 jmp_buf save_regs_gc_mark;
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;
162 int ipoll_counter = 0;
165 int siod_interactive = 1;
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 =
"> ";
177 void **dead_pointers = NULL;
178 int size_dead_pointers = 0;
179 int num_dead_pointers = 0;
180 #define DEAD_POINTER_GROWTH (10)
182 static LISP set_restricted(LISP l);
184 char *stack_limit_ptr = NULL;
192 void NNEWCELL(LISP *_into,
long _type)
198 freelist = CDR(freelist);
199 ++gc_cells_allocated;
201 (*_into)->gc_mark = 0;
202 (*_into)->type = (short) _type;
205 void need_n_cells(
int n)
217 static void start_rememberring_dead(
void)
222 static int is_dead(
void *ptr)
225 for(i=0; i<num_dead_pointers; i++)
226 if (dead_pointers[i] == ptr)
231 static void mark_as_dead(
void *ptr)
234 if (num_dead_pointers == size_dead_pointers)
235 dead_pointers = wrealloc(dead_pointers,
void *, size_dead_pointers += DEAD_POINTER_GROWTH);
237 for(i=0; i<num_dead_pointers; i++)
238 if (dead_pointers[i] == ptr)
241 dead_pointers[num_dead_pointers++] = ptr;
244 void siod_print_welcome(
EST_String extra_info)
245 {printf(
"Welcome to SIOD, Scheme In One Defun, Version %s\n",
247 printf(
"(C) Copyright 1988-1994 Paradigm Associates Inc.\n");
248 if (extra_info !=
"")
249 printf(
"%s\n", (
const char *)extra_info);
252 void siod_print_welcome(
void)
254 siod_print_welcome(
"");
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)),
261 (gc_kind_copying == 1) ?
"stop and copy" :
"mark and sweep");}
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);
267 printf(
"heap_1 at %p\n",(
void *)heap_1);}
271 int audsp_mode = FALSE;
272 int siod_ctrl_c = FALSE;
274 static void err_ctrl_c(
void)
278 err(
"control-c interrupt",NIL);}
280 long no_interrupt(
long n)
284 if ((nointerrupt == 0) && (interrupt_differed == 1))
285 {interrupt_differed = 0;
289 extern "C" void handle_sigfpe(
int sig SIG_restargs)
291 signal(SIGFPE,handle_sigfpe);
300 sigaddset(&set1,SIGFPE);
301 sigprocmask(SIG_UNBLOCK,&set1,NULL);
303 signal(SIGFPE,handle_sigfpe);
304 err(
"floating point exception",NIL);}
306 extern "C" void handle_sigint(
int sig SIG_restargs)
308 signal(SIGINT,handle_sigint);
317 sigaddset(&set1,SIGINT);
318 sigprocmask(SIG_UNBLOCK,&set1,NULL);
320 signal(SIGINT,handle_sigint);
321 if (nointerrupt == 1)
322 interrupt_differed = 1;
326 void siod_reset_prompt(
void)
329 repl_prompt = siod_primary_prompt;
330 interrupt_differed = 0;
334 long repl_driver(
long want_sigint,
long want_init,
struct repl_hooks *h)
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);
344 sock_acknowledge_error();
347 if (k == 2)
return(2);
349 if (want_sigint) signal(SIGINT,handle_sigint);
353 interrupt_differed = 0;
355 if (want_init && init_file && (k == 0)) vload(init_file,0);
357 if ((siod_interactive) && (!isatty(0)))
359 fprintf(stdout,
"%s",repl_prompt);
363 {hd.repl_puts = repl_puts;
364 hd.repl_read = repl_read;
365 hd.repl_eval = repl_eval;
366 hd.repl_print = repl_print;
371 static void ignore_puts(
char *st)
374 static void noprompt_puts(
char *st)
375 {
if (strcmp(st,
"> ") != 0)
378 static char *repl_c_string_arg = NULL;
379 static long repl_c_string_flag = 0;
381 static LISP repl_c_string_read(
void)
383 if (repl_c_string_arg == NULL)
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)));}
389 static void ignore_print(LISP x)
391 repl_c_string_flag = 1;}
393 static void not_ignore_print(LISP x)
394 {repl_c_string_flag = 1;
397 long repl_c_string(
char *str,
398 long want_sigint,
long want_init,
long want_print)
402 h.repl_puts = noprompt_puts;
404 h.repl_puts = ignore_puts;
405 h.repl_read = repl_c_string_read;
408 h.repl_print = not_ignore_print;
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);
416 else if (repl_c_string_flag == 1)
422 #include <sys/types.h>
423 #include <sys/times.h>
424 double myruntime(
void)
429 total += b.tms_stime;
430 return(total / 60.0);}
432 #if defined(THINK_C) | defined(WIN32) | defined(VMS)
433 #ifndef CLOCKS_PER_SEC
434 #define CLOCKS_PER_SEC CLK_TCK
436 double myruntime(
void)
437 {
return(((
double) clock()) / ((
double) CLOCKS_PER_SEC));}
439 double myruntime(
void)
446 void set_repl_hooks(
void (*puts_f)(
char *),
447 LISP (*read_f)(
void),
448 LISP (*eval_f)(LISP),
449 void (*print_f)(LISP))
453 repl_print = print_f;}
455 void fput_st(FILE *f,
const char *st)
459 flag = no_interrupt(1);
465 void put_st(
const char *st)
466 {fput_st(stdout,st);}
468 void grepl_puts(
char *st,
void (*repl_putss)(
char *))
469 {
if (repl_putss == NULL)
471 if (fwarn != NULL) fflush(stdout);}
475 static void display_backtrace(LISP args)
480 int local_show_backtrace = show_backtrace;
483 if (cdr(args) == NIL)
485 printf(
"BACKTRACE:\n");
486 for (i=0,l=siod_backtrace; l != NIL; l=cdr(l),i++)
488 fprintf(stdout,
"%4d: ",i);
489 pprintf(stdout,car(l),3,72,2,2);
490 fprintf(stdout,
"\n");
493 else if (FLONUMP(car(cdr(args))))
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");
503 show_backtrace = local_show_backtrace;
513 if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
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);}
523 if (h->repl_read == NULL)
526 x = (*h->repl_read)();
527 if EQ(x,eof_val) break;
529 if (gc_kind_copying == 1)
532 {gc_cells_allocated = 0;
533 gc_time_taken = 0.0;}
535 if ((TYPE(x) == tc_cons) &&
536 (TYPE(car(x)) == tc_symbol) &&
537 (streq(
":backtrace",get_c_string(car(x)))))
539 display_backtrace(x);
542 else if ((restricted != NIL) &&
543 (restricted_function_call(x) == FALSE))
544 err(
"Expression contains functions not in restricted list",x);
547 siod_backtrace = NIL;
548 if (h->repl_eval == NULL)
551 x = (*h->repl_eval)(x);
553 if (gc_kind_copying == 1)
555 "Evaluation took %g seconds %ld cons work\n",
560 "Evaluation took %g seconds (%g in gc) %ld cons work\n",
564 grepl_puts(tkbuffer,h->repl_puts);
565 setvar(rintern(
"!"),x,NIL);
566 if (h->repl_print == NULL)
568 if (siod_interactive)
572 (*h->repl_print)(x);}
575 void set_fatal_exit_hook(
void (*fcn)(
void))
576 {fatal_exit_hook = fcn;}
578 static LISP err(
const char *message, LISP x,
const char *s)
583 fprintf(stderr,
"SIOD ERROR: %s %s: ",
584 (message) ? message :
"?",
588 fprintf(stderr,
"\n");
593 fprintf(stderr,
"SIOD ERROR: %s %s\n",
594 (message) ? message :
"?",
600 if (show_backtrace == 1)
601 display_backtrace(NIL);
603 if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(*est_errjmp,1);}
605 fprintf(stderr,
"%s: fatal error exiting.\n",siod_prog_name);
607 (*fatal_exit_hook)();
613 LISP err(
const char *message, LISP x)
615 return err(message, x, NULL);
618 LISP err(
const char *message,
const char *x)
620 return err(message, NULL, x);
624 {
return(err(
"BUG. Reached impossible case",NIL));}
626 void err_stack(
char *ptr)
629 err(
"the currently assigned stack limit has been exceded",NIL);}
631 LISP stack_limit(LISP amount,LISP silent)
633 {stack_size = get_c_int(amount);
634 stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);}
636 {sprintf(tkbuffer,
"Stack_size = %ld bytes, [%p,%p]\n",
637 stack_size,(
void *)stack_start_ptr,(
void *)stack_limit_ptr);
641 return(flocons(stack_size));}
643 const char *get_c_string(LISP x)
647 else if TYPEP(x,tc_symbol)
649 else if TYPEP(x,tc_flonum)
651 if (FLONMPNAME(x) == NULL)
654 sprintf(b,
"%.8g",FLONM(x));
655 FLONMPNAME(x) = (
char *)must_malloc(strlen(b)+1);
656 sprintf(FLONMPNAME(x),
"%s",b);
658 return FLONMPNAME(x);
660 else if TYPEP(x,tc_string)
661 return(x->storage_as.
string.data);
663 err("not a symbol or
string",x);
666 LISP lerr(LISP message, LISP x)
667 {err(get_c_string(message),x);
670 void gc_fatal_error(
void)
671 {err(
"ran out of storage",NIL);}
673 LISP newcell(
long type)
678 LISP flocons(
double x)
681 if ((inums_dim > 0) &&
682 ((x - (n = (
long)x)) == 0) &&
686 NEWCELL(z,tc_flonum);
687 FLONMPNAME(z) = NULL;
691 LISP symcons(
char *pname,LISP vcell)
693 NEWCELL(z,tc_symbol);
698 char *must_malloc(
unsigned long size)
700 tmp = walloc(
char,size);
701 if (tmp == (
char *)NULL) err(
"failed to allocate storage from system",NIL);
704 LISP gen_intern(
char *name,
int require_copy)
706 const unsigned char *cname;
707 long hash=0,n,c,flag;
708 flag = no_interrupt(1);
711 else if (obarray_dim > 1)
714 cname = (
unsigned char *)name;
715 while((c = *cname++)) hash = ((hash * 17) ^ c) % n;
719 for(l=sl;NNULLP(l);l=CDR(l))
720 if (strcmp(name,PNAME(CAR(l))) == 0)
725 sym = symcons(wstrdup(name),unbound_marker);
727 sym = symcons(name,unbound_marker);
728 if (obarray_dim > 1) obarray[hash] = cons(sym,sl);
729 oblistvar = cons(sym,oblistvar);
733 LISP cintern(
const char *name)
735 char *dname = (
char *)(
void *)name;
736 return(gen_intern(dname,FALSE));
739 LISP rintern(
const char *name)
743 char *dname = (
char *)(
void *)name;
744 return gen_intern(dname,TRUE);
747 LISP intern(LISP name)
748 {
return(rintern(get_c_string(name)));}
750 LISP subrcons(
long type,
const char *name, SUBR_FUNC f)
753 (*z).storage_as.subr.name = name;
754 (*z).storage_as.subr0.f = f;
757 LISP closure(LISP env,LISP code)
759 NEWCELL(z,tc_closure);
760 (*z).storage_as.closure.env = env;
761 (*z).storage_as.closure.code = code;
764 void gc_unprotect(LISP *location)
768 for(l=0,reg = protected_registers; reg; reg = reg->next)
770 if (reg->location == location)
776 fprintf(stderr,
"Cannot unprotected %lx: never protected\n",
777 (
unsigned long)*location);
782 reg = protected_registers;
783 protected_registers = reg->next;
796 void gc_protect(LISP *location)
799 for(reg = protected_registers; reg; reg = reg->next)
801 if (reg->location == location)
805 gc_protect_n(location,1);
808 void gc_protect_n(LISP *location,
long n)
811 (*reg).location = location;
813 (*reg).next = protected_registers;
814 protected_registers = reg;}
816 void gc_protect_sym(LISP *location,
const char *st)
817 {*location = cintern(st);
818 gc_protect(location);}
820 void scan_registers(
void)
824 for(reg = protected_registers; reg; reg = (*reg).next)
825 {location = (*reg).location;
828 location[j] = gc_relocate(location[j]);}}
830 static void init_storage_1(
int init_heap_size)
833 tkbuffer = (
char *) must_malloc(TKBUFFERN+1);
834 heap_1 = (LISP) must_malloc(
sizeof(
struct obj)*init_heap_size);
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);
845 {(*ptr).type = tc_free_cell;
853 freelist = heap_org;}
854 gc_protect(&oblistvar);
855 gc_protect(&siod_backtrace);
856 gc_protect(¤t_env);
858 {obarray = (LISP *) must_malloc(
sizeof(LISP) * obarray_dim);
859 for(j=0;j<obarray_dim;++j)
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);
877 {inums = (LISP *) must_malloc(
sizeof(LISP) * inums_dim);
878 for(j=0;j<inums_dim;++j)
879 {NEWCELL(ptr,tc_flonum);
881 FLONMPNAME(ptr) = NULL;
883 gc_protect_n(inums,inums_dim);}}
885 void init_storage(
int init_heap_size)
887 init_storage_1(init_heap_size);
889 stack_start_ptr = &stack_start;
890 stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
893 void init_subr(
const char *name,
long type, SUBR_FUNC fcn)
894 {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
895 void init_subr(
const char *name,
long type, SUBR_FUNC fcn,
const char *doc)
896 {LISP lname = cintern(name);
897 setvar(lname,subrcons(type,name,fcn),NIL);
898 setdoc(lname,cstrcons(doc));}
901 void init_subr_0(
const char *name, LISP (*fcn)(
void),
const char *doc)
902 {init_subr(name,tc_subr_0,(SUBR_FUNC)fcn,doc);}
903 void init_subr_1(
const char *name, LISP (*fcn)(LISP),
const char *doc)
904 {init_subr(name,tc_subr_1,(SUBR_FUNC)fcn,doc);}
905 void init_subr_2(
const char *name, LISP (*fcn)(LISP,LISP),
const char *doc)
906 {init_subr(name,tc_subr_2,(SUBR_FUNC)fcn,doc);}
907 void init_subr_3(
const char *name, LISP (*fcn)(LISP,LISP,LISP),
const char *doc)
908 {init_subr(name,tc_subr_3,(SUBR_FUNC)fcn,doc);}
909 void init_subr_4(
const char *name, LISP (*fcn)(LISP,LISP,LISP,LISP),
const char *doc)
910 {init_subr(name,tc_subr_4,(SUBR_FUNC)fcn,doc);}
911 void init_lsubr(
const char *name, LISP (*fcn)(LISP),
const char *doc)
912 {init_subr(name,tc_lsubr,(SUBR_FUNC)fcn,doc);}
913 void init_fsubr(
const char *name, LISP (*fcn)(LISP,LISP),
const char *doc)
914 {init_subr(name,tc_fsubr,(SUBR_FUNC)fcn,doc);}
915 void init_msubr(
const char *name, LISP (*fcn)(LISP *,LISP *),
const char *doc)
916 {init_subr(name,tc_msubr,(SUBR_FUNC)fcn,doc);}
920 if (user_types == NULL)
923 memset(user_types,0,n);}
924 if ((type >= 0) && (type < tc_table_dim))
925 return(&user_types[type]);
927 err(
"type number out of range",NIL);
930 int siod_register_user_type(
const char *name)
933 static int siod_user_type = tc_first_user_type;
934 int new_type = siod_user_type;
937 if (new_type == tc_table_dim)
939 cerr <<
"SIOD: no more new types allowed, tc_table_dim needs increased"
941 return tc_table_dim-1;
946 th=get_user_type_hooks(new_type);
947 th->name = wstrdup(name);
951 void set_gc_hooks(
long type,
960 p = get_user_type_hooks(type);
961 p->gc_free_once = gc_free_once;
962 p->gc_relocate = rel;
967 *kind = gc_kind_copying;}
969 LISP gc_relocate(LISP x)
972 if EQ(x,NIL) return(NIL);
973 if ((*x).gc_mark == 1) return(CAR(x));
976 if (FLONMPNAME(x) != NULL)
977 wfree(FLONMPNAME(x));
978 FLONMPNAME(x) = NULL;
990 if ((nw = heap) >= heap_end) gc_fatal_error();
992 memcpy(nw,x,
sizeof(
struct obj));
995 p = get_user_type_hooks(TYPE(x));
997 nw = (*p->gc_relocate)(x);
999 {
if ((nw = heap) >= heap_end) gc_fatal_error();
1001 memcpy(nw,x,
sizeof(
struct obj));}}
1006 LISP get_newspace(
void)
1008 if (which_heap == 1)
1016 heap_end = heap + heap_size;
1019 void scan_newspace(LISP newspace)
1022 for(ptr=newspace; ptr < heap; ++ptr)
1026 CAR(ptr) = gc_relocate(CAR(ptr));
1027 CDR(ptr) = gc_relocate(CDR(ptr));
1030 VCELL(ptr) = gc_relocate(VCELL(ptr));
1043 p = get_user_type_hooks(TYPE(ptr));
1044 if (p->gc_scan) (*p->gc_scan)(ptr);}}}
1046 void free_oldspace(LISP space,LISP end)
1049 for(ptr=space; ptr < end; ++ptr)
1050 if (ptr->gc_mark == 0)
1057 if (FLONMPNAME(ptr) != NULL)
1058 wfree(FLONMPNAME(ptr));
1059 FLONMPNAME(ptr) = NULL;
1062 wfree(ptr->storage_as.string.data);
1074 p = get_user_type_hooks(TYPE(ptr));
1080 void gc_stop_and_copy(
void)
1081 {LISP newspace,oldspace,end;
1084 flag = no_interrupt(1);
1085 fprintf(stderr,
"GC ing \n");
1088 oldspace = heap_org;
1090 old_heap_used = end - oldspace;
1091 newspace = get_newspace();
1093 scan_newspace(newspace);
1094 free_oldspace(oldspace,end);
1096 no_interrupt(flag);}
1098 void gc_for_newcell(
void)
1102 flag = no_interrupt(1);
1105 gc_mark_and_sweep();
1108 if NULLP(freelist) gc_fatal_error();}
1110 static
void gc_mark_and_sweep(
void)
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);
1120 mark_locations((LISP *) ((
char *) stack_start_ptr + 2),
1121 (LISP *) ((
char *) &stack_end + 2));
1126 static void gc_ms_stats_start(
void)
1127 {gc_rt = myruntime();
1128 gc_cells_collected = 0;
1130 fprintf(stderr,
"[starting GC]\n");}
1132 static void gc_ms_stats_end(
void)
1133 {gc_rt = myruntime() - gc_rt;
1134 gc_time_taken = gc_time_taken + gc_rt;
1136 fprintf(stderr,
"[GC took %g cpu seconds, %ld cells collected]\n",
1138 gc_cells_collected);}
1140 void gc_mark(LISP ptr)
1144 if NULLP(ptr) return;
1145 if ((*ptr).gc_mark) return;
1147 switch ((*ptr).type)
1158 gc_mark((*ptr).storage_as.closure.code);
1159 ptr = (*ptr).storage_as.closure.env;
1174 p = get_user_type_hooks(TYPE(ptr));
1176 ptr = (*p->gc_mark)(ptr);}}
1178 static void mark_protected_registers(
void)
1182 for(reg = protected_registers; reg; reg = (*reg).next)
1184 location = (*reg).location;
1187 gc_mark(location[j]);}}
1189 static void mark_locations(LISP *start,LISP *end)
1197 mark_locations_array(start,n);}
1199 static void mark_locations_array(LISP *x,
long n)
1204 if ((p >= heap_org) &&
1206 (((((
char *)p) - ((
char *)heap_org)) %
sizeof(
struct obj)) == 0) &&
1207 NTYPEP(p,tc_free_cell))
1210 static void gc_sweep(
void)
1211 {LISP ptr,end,nfreelist;
1217 start_rememberring_dead();
1218 for(ptr=heap_org; ptr < end; ++ptr)
1219 if (((*ptr).gc_mark) == 0)
1220 {
switch((*ptr).type)
1222 if (FLONMPNAME(ptr) != NULL)
1223 wfree(FLONMPNAME(ptr));
1224 FLONMPNAME(ptr) = NULL;
1227 wfree(ptr->storage_as.string.data);
1243 p = get_user_type_hooks(TYPE(ptr));
1246 if (p->gc_free_once)
1248 if (!is_dead(USERVAL(ptr)))
1251 mark_as_dead(USERVAL(ptr));
1259 (*ptr).type = tc_free_cell;
1260 CDR(ptr) = nfreelist;
1266 p = get_user_type_hooks(TYPE(ptr));
1268 (*p->gc_clear)(ptr);
1270 gc_cells_collected = n;
1271 freelist = nfreelist;
1274 LISP user_gc(LISP args)
1275 {
long old_status_flag,flag;
1277 if (gc_kind_copying == 1)
1278 err(
"implementation cannot GC at will with stop-and-copy\n",
1280 flag = no_interrupt(1);
1283 old_status_flag = gc_status_flag;
1291 gc_mark_and_sweep();
1292 gc_status_flag = old_status_flag;
1298 LISP set_backtrace(LISP n)
1307 LISP gc_status(LISP args)
1312 if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
1314 if (gc_kind_copying == 1)
1315 {
if (gc_status_flag)
1316 fput_st(fwarn,
"garbage collection is on\n");
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);}
1323 {
if (gc_status_flag)
1324 fput_st(fwarn,
"garbage collection verbose\n");
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);}}
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);
1340 v1 = tmp, v2 = CDR(v2))
1341 {tmp = cons(leval(CAR(v2),env),NIL);
1343 if NNULLP(v2) err("bad syntax argument list",l);
1346 LISP extend_env(LISP actuals,LISP formals,LISP env)
1349 return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
1351 return(cons(cons(formals,actuals),env));
1354 #define ENVLOOKUP_TRICK 1
1355 LISP global_var = NIL;
1356 LISP global_env = NIL;
1358 LISP envlookup(LISP var,LISP env)
1359 {LISP frame,al,fl,tmp;
1362 for(frame=env;CONSP(frame);frame=CDR(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);}
1370 #if (ENVLOOKUP_TRICK)
1371 if (SYMBOLP(fl) && EQ(fl, var))
return(cons(al, NIL));
1375 err("damaged env",env);
1378 void set_eval_hooks(
long type,LISP (*fcn)(LISP, LISP *,LISP *))
1380 p = get_user_type_hooks(type);
1383 LISP leval(LISP x,LISP qenv)
1384 {LISP tmp,arg1,rval;
1389 siod_backtrace = cons(x,siod_backtrace);
1395 tmp = envlookup(x,env);
1398 siod_backtrace = cdr(siod_backtrace);
1402 if EQ(tmp,unbound_marker) err("unbound variable",x);
1403 siod_backtrace = cdr(siod_backtrace);
1409 tmp = envlookup(tmp,env);
1413 tmp = VCELL(CAR(x));
1414 if EQ(tmp,unbound_marker) err("unbound variable",CAR(x));
1417 tmp = leval(tmp,env);
1421 rval = SUBR0(tmp)();
1422 siod_backtrace = cdr(siod_backtrace);
1425 rval = SUBR1(tmp)(leval(car(CDR(x)),env));
1426 siod_backtrace = cdr(siod_backtrace);
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);
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);
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);
1452 rval = SUBR1(tmp)(leval_args(CDR(x),env));
1453 siod_backtrace = cdr(siod_backtrace);
1456 rval = SUBR2(tmp)(CDR(x),env);
1457 siod_backtrace = cdr(siod_backtrace);
1460 if NULLP(SUBRM(tmp)(&x,&env))
1462 siod_backtrace = cdr(siod_backtrace);
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);
1473 x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
1477 p = get_user_type_hooks(TYPE(tmp));
1479 {
if NULLP((*p->leval)(tmp,&x,&env))
1481 siod_backtrace = cdr(siod_backtrace);
1486 err(
"bad function",tmp);}
1488 siod_backtrace = cdr(siod_backtrace);
1491 void set_print_hooks(
long type,
1492 void (*prin1)(LISP, FILE *),
1493 void (*print_string)(LISP,
char *)
1496 p = get_user_type_hooks(type);
1498 p->print_string = print_string;
1501 void set_io_hooks(
long type,
1502 LISP (*fast_print)(LISP,LISP),
1503 LISP (*fast_read)(
int,LISP))
1506 p = get_user_type_hooks(type);
1507 p->fast_print = fast_print;
1508 p->fast_read = fast_read;
1511 void set_type_hooks(
long type,
1512 long (*c_sxhash)(LISP,
long),
1513 LISP (*equal)(LISP,LISP))
1517 p = get_user_type_hooks(type);
1518 p->c_sxhash = c_sxhash;
1525 iflag = no_interrupt(1);
1527 if ((c ==
'\n') && (f == stdin) && (siod_interactive))
1529 fprintf(stdout,
"%s",repl_prompt);
1532 no_interrupt(iflag);
1535 void f_ungetc(
int c, FILE *f)
1539 int winsock_unget_buffer;
1540 bool winsock_unget_buffer_unused=
true;
1541 bool use_winsock_unget_buffer;
1543 int f_getc_winsock(HANDLE h)
1546 DWORD lpNumberOfBytesRead;
1547 iflag = no_interrupt(1);
1548 if (use_winsock_unget_buffer)
1550 use_winsock_unget_buffer =
false;
1551 return winsock_unget_buffer;
1554 if (SOCKET_ERROR == recv((SOCKET)h,&c,1,0))
1556 if (WSAECONNRESET == GetLastError())
1559 cerr <<
"f_getc_winsock(): error reading from socket\n";
1562 winsock_unget_buffer=c;
1563 winsock_unget_buffer_unused =
false;
1565 no_interrupt(iflag);
1568 void f_ungetc_winsock(
int c, HANDLE h)
1570 if (winsock_unget_buffer_unused)
1572 cerr <<
"f_ungetc_winsock: tried to unget before reading socket\n";
1574 use_winsock_unget_buffer =
true;}
1577 int flush_ws(
struct gen_readio *f,
const char *eoferr)
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);}}
1587 LISP lreadf(FILE *f)
1589 if ((f == stdin) && (isatty(0)) && (siod_interactive))
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;
1597 s.getc_fcn = (int (*)(
char *))f_getc;
1598 s.ungetc_fcn = (void (*)(int,
char *))f_ungetc;
1599 s.cb_argument = (
char *) f;
1601 return(readtl(&s));}
1604 LISP lreadwinsock(
void)
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));}
1615 c = flush_ws(f,(
char *)NULL);
1616 if (c == EOF)
return(eof_val);
1620 void set_read_hooks(
char *all_set,
char *end_set,
1622 LISP (*fcn2)(
char *,
long,
int *))
1623 {user_ch_readm = all_set;
1624 user_te_readm = end_set;
1631 const char *pp, *last_prompt;
1635 c = flush_ws(f,
"end of file inside read");
1638 last_prompt = repl_prompt;
1639 repl_prompt = siod_secondary_prompt;
1640 rval = lreadparen(f);
1641 repl_prompt = last_prompt;
1644 err(
"unexpected close paren",NIL);
1646 return(cons(sym_quote,cons(lreadr(f),NIL)));
1648 return(cons(cintern(
"+internal-backquote"),lreadr(f)));
1653 pp =
"+internal-comma-atsign";
1656 pp =
"+internal-comma-dot";
1659 pp =
"+internal-comma";
1661 return(cons(cintern(pp),lreadr(f)));
1663 last_prompt = repl_prompt;
1664 repl_prompt = siod_secondary_prompt;
1665 rval = lreadstring(f);
1666 repl_prompt = last_prompt;
1669 if ((user_readm != NULL) && strchr(user_ch_readm,c))
1670 return((*user_readm)(c,f));}
1672 for(j = 1; j<TKBUFFERN; ++j)
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));}
1679 return(err(
"symbol larger than maxsize (can you use a string instead?)",NIL));}
1685 c = flush_ws(f,
"end of file inside list");
1686 if (c ==
')')
return(NIL);
1691 c = flush_ws(f,
"end of file inside list");
1692 if (c !=
')') err(
"missing close paren",NIL);
1694 return(cons(tmp,lreadparen(f)));}
1704 while ((c = flush_ws(f,
"end of file inside list")) !=
')')
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);
1724 CDR(last) = cons(tmp,NIL);
1731 static LISP lreadstring(
struct gen_readio *f)
1734 static int len=TKBUFFERN;
1735 static char *str = 0;
1740 str = (
char *)must_malloc(len *
sizeof(
char));
1741 while(((c = GETC_FCN(f)) !=
'"') && (c != EOF))
1745 if (c == EOF) err(
"eof after \\",NIL);
1769 if (c == EOF) err(
"eof after \\0",NIL);
1771 n = n * 8 + c -
'0';
1779 q = (
char *)must_malloc(len*2*
sizeof(
char));
1789 qq = strcons(j,str);
1793 LISP lreadtk(
long j)
1798 p = (
unsigned char *)tkbuffer;
1800 if (user_readt != NULL)
1801 {tmp = (*user_readt)((
char *)p,j,&flag);
1802 if (flag)
return(tmp);}
1803 if (strcmp(
"nil",tkbuffer) == 0)
1805 if (*p ==
'-') p+=1;
1807 while((*p < 128) && (isdigit(*p))) {p+=1; adigit=1;}
1810 while((*p < 128) && (isdigit(*p))) {p+=1; adigit=1;}}
1811 if (!adigit)
goto a_symbol;
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)));
1820 return(rintern(tkbuffer));}
1822 LISP siod_quit(
void)
1824 if (errjmp_ok) longjmp(*est_errjmp,2);
1828 LISP l_exit(LISP arg)
1833 exit((
int)FLONM(arg));
1839 LISP lfwarning(LISP mode)
1849 LISP closure_code(LISP exp)
1850 {
return(exp->storage_as.closure.code);}
1852 LISP closure_env(LISP exp)
1853 {
return(exp->storage_as.closure.env);}
1855 int get_c_int(LISP x)
1856 {
if NFLONUMP(x) err("not a number",x);
1857 return((
int)FLONM(x));}
1859 double get_c_double(LISP x)
1860 {
if NFLONUMP(x) err("not a number",x);
1863 float get_c_float(LISP x)
1864 {
if NFLONUMP(x) err("not a number",x);
1865 return((
float)FLONM(x));}
1868 void init_subrs_base(
void)
1870 init_subr_2(
"eval",leval,
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,
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,
1885 Exit from program, does not return.");
1886 init_subr_1(
"exit",l_exit,
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,
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,
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]");
1927 void init_subrs(
void)
1933 init_subrs_format();
1947 {
if ((p >= heap_org) &&
1949 (((((
char *)p) - ((
char *)heap_org)) %
sizeof(
struct obj)) == 0))
1952 put_st(
"invalid\n");}
1958 LISP siod_make_typed_cell(
long type,
void *s)
1968 static LISP set_restricted(LISP l)
1972 if (restricted == NIL)
1973 gc_protect(&restricted);
1979 static int restricted_function_call(LISP l)
1989 else if (TYPE(car(l)) == tc_symbol)
1991 if (streq(
"quote",get_c_string(car(l))))
1993 else if (siod_member_str(get_c_string(car(l)),restricted) == NIL)
1996 else if (restricted_function_call(car(l)) == FALSE)
2000 for (p=cdr(l); consp(p); p=cdr(p))
2001 if (restricted_function_call(car(p)) == FALSE)