88#include "EST_cutils.h"
96static int restricted_function_call(
LISP l);
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);
109const char *siod_version(
void)
110{
return(
"3.0 FIELD TEST");}
113LISP heap,heap_end,heap_org;
114long heap_size = DEFAULT_HEAP_SIZE;
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;
124LISP *stack_start_ptr;
128long interrupt_differed = 0;
130LISP current_env = NIL;
131static LISP siod_backtrace = NIL;
132LISP restricted = NIL;
135LISP sym_errobj = NIL;
138LISP unbound_marker = NIL;
140long obarray_dim = 100;
142void (*repl_puts)(
char *) = NULL;
146repl_getc_fn siod_fancy_getc = f_getc;
147repl_ungetc_fn siod_fancy_ungetc = f_ungetc;
149LISP siod_docstrings = NIL;
155long gc_cells_collected;
156static const char *user_ch_readm =
"";
157static const char *user_te_readm =
"";
159LISP (*user_readt)(
char *,
long,
int *) = NULL;
160void (*fatal_exit_hook)(
void) = NULL;
165int siod_interactive = 1;
170const char *repl_prompt =
"siod>";
171const char *siod_prog_name =
"siod";
172const char *siod_primary_prompt =
"siod> ";
173const char *siod_secondary_prompt =
"> ";
177void **dead_pointers = NULL;
178int size_dead_pointers = 0;
179int num_dead_pointers = 0;
180#define DEAD_POINTER_GROWTH (10)
184char *stack_limit_ptr = NULL;
198 freelist = CDR(freelist);
199 ++gc_cells_allocated;
201 (*_into)->gc_mark = 0;
205void need_n_cells(
int n)
217static void start_rememberring_dead(
void)
222static int is_dead(
void *ptr)
225 for(i=0; i<num_dead_pointers; i++)
226 if (dead_pointers[i] == ptr)
231static 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;
245{
printf(
"Welcome to SIOD, Scheme In One Defun, Version %s\n",
247 printf(
"(C) Copyright 1988-1994 Paradigm Associates Inc.\n");
252void siod_print_welcome(
void)
254 siod_print_welcome(
"");
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");}
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);}
271int audsp_mode = FALSE;
272int siod_ctrl_c = FALSE;
274static void err_ctrl_c(
void)
278 err(
"control-c interrupt",NIL);}
280long no_interrupt(
long n)
284 if ((nointerrupt == 0) && (interrupt_differed == 1))
285 {interrupt_differed = 0;
289extern "C" void handle_sigfpe(
int sig SIG_restargs)
304 err(
"floating point exception",NIL);}
306extern "C" void handle_sigint(
int sig SIG_restargs)
321 if (nointerrupt == 1)
322 interrupt_differed = 1;
326void siod_reset_prompt(
void)
329 repl_prompt = siod_primary_prompt;
330 interrupt_differed = 0;
339 stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
340 est_errjmp = walloc(
jmp_buf,1);
344 sock_acknowledge_error();
347 if (k == 2)
return(2);
353 interrupt_differed = 0;
355 if (
want_init && init_file && (k == 0)) vload(init_file,0);
357 if ((siod_interactive) && (!
isatty(0)))
363 {
hd.repl_puts = repl_puts;
364 hd.repl_read = repl_read;
365 hd.repl_eval = repl_eval;
366 hd.repl_print = repl_print;
371static void ignore_puts(
char *
st)
374static void noprompt_puts(
char *
st)
378static char *repl_c_string_arg = NULL;
379static long repl_c_string_flag = 0;
381static 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)));}
389static void ignore_print(
LISP x)
391 repl_c_string_flag = 1;}
393static void not_ignore_print(
LISP x)
394{repl_c_string_flag = 1;
397long repl_c_string(
char *str,
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;
416 else if (repl_c_string_flag == 1)
422#include <sys/types.h>
423#include <sys/times.h>
424double 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
436double myruntime(
void)
439double myruntime(
void)
446void set_repl_hooks(
void (*
puts_f)(
char *),
455void fput_st(
FILE *f,
const char *
st)
459 flag = no_interrupt(1);
465void put_st(
const char *
st)
475static void display_backtrace(
LISP args)
483 if (cdr(args) == NIL)
486 for (i=0,l=siod_backtrace; l != NIL; l=cdr(l),i++)
489 pprintf(
stdout,car(l),3,72,2,2);
493 else if (FLONUMP(car(cdr(args))))
496 int nth = (int)FLONM(car(cdr(args)));
497 LISP frame = siod_nth(nth,siod_backtrace);
499 pprintf(
stdout,frame,3,72,-1,-1);
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);}
575void set_fatal_exit_hook(
void (*
fcn)(
void))
576{fatal_exit_hook =
fcn;}
600 if (show_backtrace == 1)
601 display_backtrace(NIL);
603 if (errjmp_ok == 1) {setvar(sym_errobj,
x,NIL);
longjmp(*est_errjmp,1);}
607 (*fatal_exit_hook)();
624{
return(err(
"BUG. Reached impossible case",NIL));}
626void err_stack(
char *ptr)
629 err(
"the currently assigned stack limit has been exceeded",NIL);}
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));}
643const 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)
655 FLONMPNAME(
x) = (
char *)must_malloc(
strlen(b)+1);
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);
670void gc_fatal_error(
void)
671{err(
"ran out of storage",NIL);}
673LISP newcell(
long type)
678LISP flocons(
double x)
681 if ((inums_dim > 0) &&
682 ((
x - (n = (
long)
x)) == 0) &&
686 NEWCELL(z,tc_flonum);
687 FLONMPNAME(z) = NULL;
693 NEWCELL(z,tc_symbol);
698char *must_malloc(
unsigned long size)
700 tmp = walloc(
char,size);
701 if (
tmp == (
char *)NULL) err(
"failed to allocate storage from system",NIL);
706 const unsigned char *
cname;
708 flag = no_interrupt(1);
711 else if (obarray_dim > 1)
714 cname = (
unsigned char *)name;
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);
733LISP cintern(
const char *name)
735 char *
dname = (
char *)(
void *)name;
736 return(gen_intern(
dname,FALSE));
739LISP rintern(
const char *name)
743 char *
dname = (
char *)(
void *)name;
744 return gen_intern(
dname,TRUE);
748{
return(rintern(get_c_string(name)));}
750LISP subrcons(
long type,
const char *name, SUBR_FUNC f)
753 (*z).storage_as.subr.name = name;
754 (*z).storage_as.subr0.f = f;
759 NEWCELL(z,tc_closure);
760 (*z).storage_as.closure.env = env;
761 (*z).storage_as.closure.code = code;
764void gc_unprotect(
LISP *location)
768 for(l=0,reg = protected_registers; reg; reg = reg->next)
770 if (reg->location == location)
777 (
unsigned long)*location);
782 reg = protected_registers;
783 protected_registers = reg->next;
796void gc_protect(
LISP *location)
799 for(reg = protected_registers; reg; reg = reg->next)
801 if (reg->location == location)
805 gc_protect_n(location,1);
808void gc_protect_n(
LISP *location,
long n)
811 (*reg).location = location;
813 (*reg).next = protected_registers;
814 protected_registers = reg;}
816void gc_protect_sym(
LISP *location,
const char *
st)
817{*location = cintern(
st);
818 gc_protect(location);}
820void scan_registers(
void)
824 for(reg = protected_registers; reg; reg = (*reg).next)
825 {location = (*reg).location;
828 location[
j] = gc_relocate(location[
j]);}}
833 tkbuffer = (
char *) must_malloc(TKBUFFERN+1);
839 if (gc_kind_copying == 1)
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);}}
890 stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
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)
897 setvar(
lname,subrcons(type,name,
fcn),NIL);
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);}
906{init_subr(name,tc_subr_2,(SUBR_FUNC)
fcn,
doc);}
908{init_subr(name,tc_subr_3,(SUBR_FUNC)
fcn,
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);}
914{init_subr(name,tc_fsubr,(SUBR_FUNC)
fcn,
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);
930int siod_register_user_type(
const char *name)
939 cerr <<
"SIOD: no more new types allowed, tc_table_dim needs increased"
941 return tc_table_dim-1;
947 th->name = wstrdup(name);
951void 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;}
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));}}
1006LISP get_newspace(
void)
1008 if (which_heap == 1)
1016 heap_end = heap + heap_size;
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);}}}
1046void 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));
1080void gc_stop_and_copy(
void)
1084 flag = no_interrupt(1);
1096 no_interrupt(
flag);}
1098void gc_for_newcell(
void)
1102 flag = no_interrupt(1);
1105 gc_mark_and_sweep();
1108 if NULLP(freelist) gc_fatal_error();}
1110static 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,
1120 mark_locations((
LISP *) ((
char *) stack_start_ptr + 2),
1126static void gc_ms_stats_start(
void)
1127{gc_rt = myruntime();
1128 gc_cells_collected = 0;
1132static 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);}
1140void 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);}}
1178static void mark_protected_registers(
void)
1182 for(reg = protected_registers; reg; reg = (*reg).next)
1184 location = (*reg).location;
1187 gc_mark(location[
j]);}}
1189static void mark_locations(
LISP *start,
LISP *end)
1197 mark_locations_array(start,n);}
1199static 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))
1210static void gc_sweep(
void)
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;
1266 p = get_user_type_hooks(TYPE(ptr));
1268 (*p->gc_clear)(ptr);
1270 gc_cells_collected = n;
1277 if (gc_kind_copying == 1)
1278 err(
"implementation cannot GC at will with stop-and-copy\n",
1280 flag = no_interrupt(1);
1291 gc_mark_and_sweep();
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);}}
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);
1341 {
tmp = cons(leval(CAR(
v2),env),NIL);
1343 if NNULLP(
v2) err(
"bad syntax argument list",l);
1354#define ENVLOOKUP_TRICK 1
1355LISP global_var = NIL;
1356LISP global_env = NIL;
1362 for(frame=env;CONSP(frame);frame=CDR(frame))
1364 if NCONSP(
tmp) err(
"damaged frame",
tmp);
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);
1380 p = get_user_type_hooks(type);
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));
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);
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);
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);
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);
1491void set_print_hooks(
long type,
1493 void (*print_string)(
LISP,
char *)
1496 p = get_user_type_hooks(type);
1498 p->print_string = print_string;
1501void set_io_hooks(
long type,
1506 p = get_user_type_hooks(type);
1507 p->fast_print = fast_print;
1508 p->fast_read = fast_read;
1511void set_type_hooks(
long type,
1512 long (*c_sxhash)(
LISP,
long),
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))
1532 no_interrupt(
iflag);
1535void f_ungetc(
int c,
FILE *f)
1547 iflag = no_interrupt(1);
1559 cerr <<
"f_getc_winsock(): error reading from socket\n";
1565 no_interrupt(
iflag);
1572 cerr <<
"f_ungetc_winsock: tried to unget before reading socket\n";
1585 else if (!
isspace(c))
return(c);}}
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));}
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);
1635 c = flush_ws(f,
"end of file inside read");
1639 repl_prompt = siod_secondary_prompt;
1640 rval = lreadparen(f);
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)));
1664 repl_prompt = siod_secondary_prompt;
1665 rval = lreadstring(f);
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));
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);
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);
1798 p = (
unsigned char *)tkbuffer;
1800 if (user_readt != NULL)
1801 {
tmp = (*user_readt)((
char *)p,
j,&
flag);
1803 if (
strcmp(
"nil",tkbuffer) == 0)
1805 if (*p ==
'-') p+=1;
1814 if (*p==
'-'||*p==
'+') p+=1;
1816 while((*p < 128) && (
isdigit(*p))) p+=1;}
1818 return(flocons(
atof(tkbuffer)));
1820 return(rintern(tkbuffer));}
1824 if (errjmp_ok)
longjmp(*est_errjmp,2);
1850{
return(
exp->storage_as.closure.code);}
1853{
return(
exp->storage_as.closure.env);}
1855int get_c_int(
LISP x)
1856{
if NFLONUMP(
x) err(
"not a number",
x);
1857 return((
int)FLONM(
x));}
1859double get_c_double(
LISP x)
1860{
if NFLONUMP(
x) err(
"not a number",
x);
1863float get_c_float(
LISP x)
1864{
if NFLONUMP(
x) err(
"not a number",
x);
1865 return((
float)FLONM(
x));}
1868void 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]");
1927void 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");}
1958LISP siod_make_typed_cell(
long type,
void *s)
1972 if (restricted == NIL)
1973 gc_protect(&restricted);
1979static 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)