[llvm-commits] CVS: llvm/test/Programs/MultiSource/Applications/siod/Makefile README-LLVM.txt siod.c siod.h siodp.h slib.c sliba.c slibu.c test.scm trace.c
Brian Gaeke
gaeke at cs.uiuc.edu
Fri Oct 17 13:49:02 PDT 2003
Changes in directory llvm/test/Programs/MultiSource/Applications/siod:
Makefile added (r1.1)
README-LLVM.txt added (r1.1)
siod.c added (r1.1)
siod.h added (r1.1)
siodp.h added (r1.1)
slib.c added (r1.1)
sliba.c added (r1.1)
slibu.c added (r1.1)
test.scm added (r1.1)
trace.c added (r1.1)
---
Log message:
benchmarkified version of SIOD
---
Diffs of the changes: (+8021 -0)
Index: llvm/test/Programs/MultiSource/Applications/siod/Makefile
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/Makefile:1.1
*** /dev/null Fri Oct 17 13:48:55 2003
--- llvm/test/Programs/MultiSource/Applications/siod/Makefile Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,10 ----
+
+ LEVEL = ../../../../..
+ PROG = siod
+ CPPFLAGS = -D__USE_MISC -D__USE_GNU -D__USE_SVID -D__USE_XOPEN_EXTENDED -D__USE_XOPEN
+ LDFLAGS = -lm -ldl -lcrypt
+
+ RUN_OPTIONS = $(BUILD_SRC_DIR)/test.scm
+
+ include ../../Makefile.multisrc
+
Index: llvm/test/Programs/MultiSource/Applications/siod/README-LLVM.txt
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/README-LLVM.txt:1.1
*** /dev/null Fri Oct 17 13:48:55 2003
--- llvm/test/Programs/MultiSource/Applications/siod/README-LLVM.txt Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,43 ----
+
+ WHAT IS THIS?
+ =============
+
+ This is SIOD ("Scheme in One Defun, but in C this time") by George
+ J. Carrette, retrieved from the freebsd distfiles collection
+ on 1-Oct-2003.
+
+
+ WHERE IS THE DOCUMENTATION?
+ ===========================
+
+ http://people.delphiforums.com/gjc/siod.html
+
+
+ WHAT CHANGES HAVE BEEN MADE?
+ ============================
+
+ I removed all the files except for those that need to be compiled to get
+ the thing to work, and gave it a small MultiSource-friendly Makefile. I
+ also #ifdefed out the "Evaluation took ... seconds" message that gets
+ printed out after every top-level REPL expression, in slib.c (search for
+ "ifdef STATISTICS"). I also renamed lchmod to l_chmod to allow it to
+ compile natively under Redhat 8...
+
+
+ WHAT ELSE NEEDS TO BE DONE?
+ ===========================
+
+ Add some interesting test code to test.scm. Right now it's really
+ boring stuff.
+
+ Once invoke is better supported we should exercise it, e.g.,
+ we would want to add a test that tries something like this:
+
+ > (*catch 'foo (*throw 'foo 1))
+ 1
+ > (*catch 'foo (*throw 'bar 1))
+ ERROR: no *catch found with this tag (errobj bar)
+
+
+ -Brian
+ Wed Oct 1 19:19:00 CDT 2003
Index: llvm/test/Programs/MultiSource/Applications/siod/siod.c
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/siod.c:1.1
*** /dev/null Fri Oct 17 13:48:55 2003
--- llvm/test/Programs/MultiSource/Applications/siod/siod.c Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,50 ----
+ /* 23-DEC-94 George J. Carrette.
+
+ This is a SIOD main program with additional command-line processing
+ functionality. See slib.c and siod.html for more information.
+
+ $Id: siod.c,v 1.1 2003/10/17 18:48:45 gaeke Exp $
+
+ */
+
+ #include <stdio.h>
+ #include <stdlib.h>
+ #include <string.h>
+ #include "siod.h"
+
+ static char *siod_argv[] = {
+ "siod",
+ "-h100000:10",
+ "-g0",
+ "-o1000",
+ "-s200000",
+ "-n2048"};
+
+ int main(int argc,char **argv
+ #if defined(unix) || defined(vms) || defined(WIN32)
+ ,char **env
+ #endif
+ )
+ {int nargc = argc;
+ char **nargv = argv;
+ #if defined(WIN32) || defined(vms)
+ if (nargc > 0)
+ siod_shuffle_args(&nargc,&nargv);
+ #endif
+ process_cla(sizeof(siod_argv)/sizeof(char *),siod_argv,1);
+ return(siod_main(nargc,nargv,
+ #if defined(unix) || defined(vms) || defined(WIN32)
+ env
+ #else
+ NULL
+ #endif
+ ));}
+
+
+
+
+
+
+
+
+
Index: llvm/test/Programs/MultiSource/Applications/siod/siod.h
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/siod.h:1.1
*** /dev/null Fri Oct 17 13:48:55 2003
--- llvm/test/Programs/MultiSource/Applications/siod/siod.h Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,353 ----
+ /* Scheme In One Defun, but in C this time.
+
+ * COPYRIGHT (c) 1988-1994 BY *
+ * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
+ * See the source file SLIB.C for more information. *
+
+ $Id: siod.h,v 1.1 2003/10/17 18:48:45 gaeke Exp $
+
+ */
+
+ struct obj
+ {short gc_mark;
+ short type;
+ union {struct {struct obj * car;
+ struct obj * cdr;} cons;
+ struct {double data;} flonum;
+ struct {char *pname;
+ struct obj * vcell;} symbol;
+ struct {char *name;
+ struct obj * (*f)(void);} subr0;
+ struct {char *name;
+ struct obj * (*f)(struct obj *);} subr1;
+ struct {char *name;
+ struct obj * (*f)(struct obj *, struct obj *);} subr2;
+ struct {char *name;
+ struct obj * (*f)(struct obj *, struct obj *, struct obj *);
+ } subr3;
+ struct {char *name;
+ struct obj * (*f)(struct obj *, struct obj *, struct obj *,
+ struct obj *);
+ } subr4;
+ struct {char *name;
+ struct obj * (*f)(struct obj *, struct obj *, struct obj *,
+ struct obj *,struct obj *);
+ } subr5;
+ struct {char *name;
+ struct obj * (*f)(struct obj **, struct obj **);} subrm;
+ struct {char *name;
+ struct obj * (*f)(void *,...);} subr;
+ struct {struct obj *env;
+ struct obj *code;} closure;
+ struct {long dim;
+ long *data;} long_array;
+ struct {long dim;
+ double *data;} double_array;
+ struct {long dim;
+ char *data;} string;
+ struct {long dim;
+ unsigned char *data;} u_string;
+ struct {long dim;
+ signed char *data;} s_string;
+ struct {long dim;
+ struct obj **data;} lisp_array;
+ struct {FILE *f;
+ char *name;} c_file;}
+ storage_as;};
+
+ #define CAR(x) ((*x).storage_as.cons.car)
+ #define CDR(x) ((*x).storage_as.cons.cdr)
+ #define PNAME(x) ((*x).storage_as.symbol.pname)
+ #define VCELL(x) ((*x).storage_as.symbol.vcell)
+ #define SUBR0(x) (*((*x).storage_as.subr0.f))
+ #define SUBR1(x) (*((*x).storage_as.subr1.f))
+ #define SUBR2(x) (*((*x).storage_as.subr2.f))
+ #define SUBR3(x) (*((*x).storage_as.subr3.f))
+ #define SUBR4(x) (*((*x).storage_as.subr4.f))
+ #define SUBR5(x) (*((*x).storage_as.subr5.f))
+ #define SUBRM(x) (*((*x).storage_as.subrm.f))
+ #define SUBRF(x) (*((*x).storage_as.subr.f))
+ #define FLONM(x) ((*x).storage_as.flonum.data)
+
+ #define NIL ((struct obj *) 0)
+ #define EQ(x,y) ((x) == (y))
+ #define NEQ(x,y) ((x) != (y))
+ #define NULLP(x) EQ(x,NIL)
+ #define NNULLP(x) NEQ(x,NIL)
+
+ #define TYPE(x) (((x) == NIL) ? 0 : ((*(x)).type))
+
+ #define TYPEP(x,y) (TYPE(x) == (y))
+ #define NTYPEP(x,y) (TYPE(x) != (y))
+
+ #define tc_nil 0
+ #define tc_cons 1
+ #define tc_flonum 2
+ #define tc_symbol 3
+ #define tc_subr_0 4
+ #define tc_subr_1 5
+ #define tc_subr_2 6
+ #define tc_subr_3 7
+ #define tc_lsubr 8
+ #define tc_fsubr 9
+ #define tc_msubr 10
+ #define tc_closure 11
+ #define tc_free_cell 12
+ #define tc_string 13
+ #define tc_double_array 14
+ #define tc_long_array 15
+ #define tc_lisp_array 16
+ #define tc_c_file 17
+ #define tc_byte_array 18
+ #define tc_subr_4 19
+ #define tc_subr_5 20
+ #define tc_subr_2n 21
+ #define FO_comment 35
+ #define tc_user_min 50
+ #define tc_user_max 100
+
+ #define FO_fetch 127
+ #define FO_store 126
+ #define FO_list 125
+ #define FO_listd 124
+
+ #define tc_table_dim 100
+
+ typedef struct obj* LISP;
+ typedef LISP (*SUBR_FUNC)(void);
+
+ #define CONSP(x) TYPEP(x,tc_cons)
+ #define FLONUMP(x) TYPEP(x,tc_flonum)
+ #define SYMBOLP(x) TYPEP(x,tc_symbol)
+
+ #define NCONSP(x) NTYPEP(x,tc_cons)
+ #define NFLONUMP(x) NTYPEP(x,tc_flonum)
+ #define NSYMBOLP(x) NTYPEP(x,tc_symbol)
+
+ #define TKBUFFERN 5120
+
+ #ifndef WIN32
+ #define __stdcall
+ #endif
+
+
+ struct gen_readio
+ {int (*getc_fcn)(void *);
+ void (*ungetc_fcn)(int,void *);
+ void *cb_argument;};
+
+ struct gen_printio
+ {int (*putc_fcn)(int,void *);
+ int (*puts_fcn)(char *,void *);
+ void *cb_argument;};
+
+ #define GETC_FCN(x) (*((*x).getc_fcn))((*x).cb_argument)
+ #define UNGETC_FCN(c,x) (*((*x).ungetc_fcn))(c,(*x).cb_argument)
+ #define PUTC_FCN(c,x) (*((*x).putc_fcn))(c,(*x).cb_argument)
+ #define PUTS_FCN(c,x) (*((*x).puts_fcn))(c,(*x).cb_argument)
+
+ struct repl_hooks
+ {void (*repl_puts)(char *);
+ LISP (*repl_read)(void);
+ LISP (*repl_eval)(LISP);
+ void (*repl_print)(LISP);};
+
+ void __stdcall process_cla(int argc,char **argv,int warnflag);
+ void __stdcall print_welcome(void);
+ void __stdcall print_hs_1(void);
+ void __stdcall print_hs_2(void);
+ long no_interrupt(long n);
+ LISP get_eof_val(void);
+ long repl_driver(long want_sigint,long want_init,struct repl_hooks *);
+ void set_repl_hooks(void (*puts_f)(char *),
+ LISP (*read_f)(void),
+ LISP (*eval_f)(LISP),
+ void (*print_f)(LISP));
+ long repl(struct repl_hooks *);
+ LISP err(const char *message, LISP x);
+ LISP errswitch(void);
+ char *get_c_string(LISP x);
+ char *get_c_string_dim(LISP x,long *);
+ char *try_get_c_string(LISP x);
+ long get_c_long(LISP x);
+ double get_c_double(LISP x);
+ LISP lerr(LISP message, LISP x);
+
+ LISP newcell(long type);
+ LISP cons(LISP x,LISP y);
+ LISP consp(LISP x);
+ LISP car(LISP x);
+ LISP cdr(LISP x);
+ LISP setcar(LISP cell, LISP value);
+ LISP setcdr(LISP cell, LISP value);
+ LISP flocons(double x);
+ LISP numberp(LISP x);
+ LISP plus(LISP x,LISP y);
+ LISP ltimes(LISP x,LISP y);
+ LISP difference(LISP x,LISP y);
+ LISP Quotient(LISP x,LISP y);
+ LISP greaterp(LISP x,LISP y);
+ LISP lessp(LISP x,LISP y);
+ LISP eq(LISP x,LISP y);
+ LISP eql(LISP x,LISP y);
+ LISP symcons(char *pname,LISP vcell);
+ LISP symbolp(LISP x);
+ LISP symbol_boundp(LISP x,LISP env);
+ LISP symbol_value(LISP x,LISP env);
+ LISP cintern(char *name);
+ LISP rintern(char *name);
+ LISP subrcons(long type, char *name, SUBR_FUNC f);
+ LISP closure(LISP env,LISP code);
+ void gc_protect(LISP *location);
+ void gc_protect_n(LISP *location,long n);
+ void gc_protect_sym(LISP *location,char *st);
+
+ void __stdcall init_storage(void);
+ void __stdcall init_slibu(void);
+
+ void init_subr(char *name, long type, SUBR_FUNC fcn);
+ void init_subr_0(char *name, LISP (*fcn)(void));
+ void init_subr_1(char *name, LISP (*fcn)(LISP));
+ void init_subr_2(char *name, LISP (*fcn)(LISP,LISP));
+ void init_subr_2n(char *name, LISP (*fcn)(LISP,LISP));
+ void init_subr_3(char *name, LISP (*fcn)(LISP,LISP,LISP));
+ void init_subr_4(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP));
+ void init_subr_5(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP,LISP));
+ void init_lsubr(char *name, LISP (*fcn)(LISP));
+ void init_fsubr(char *name, LISP (*fcn)(LISP,LISP));
+ void init_msubr(char *name, LISP (*fcn)(LISP *,LISP *));
+
+ LISP assq(LISP x,LISP alist);
+ LISP delq(LISP elem,LISP l);
+ void set_gc_hooks(long type,
+ LISP (*rel)(LISP),
+ LISP (*mark)(LISP),
+ void (*scan)(LISP),
+ void (*free)(LISP),
+ long *kind);
+ LISP gc_relocate(LISP x);
+ LISP user_gc(LISP args);
+ LISP gc_status(LISP args);
+ void set_eval_hooks(long type,LISP (*fcn)(LISP, LISP *, LISP *));
+ LISP leval(LISP x,LISP env);
+ LISP symbolconc(LISP args);
+ void set_print_hooks(long type,void (*fcn)(LISP, struct gen_printio *));
+ LISP lprin1g(LISP exp,struct gen_printio *f);
+ LISP lprin1f(LISP exp,FILE *f);
+ LISP lprint(LISP exp,LISP);
+ LISP lread(LISP);
+ LISP lreadtk(char *,long j);
+ LISP lreadf(FILE *f);
+ void set_read_hooks(char *all_set,char *end_set,
+ LISP (*fcn1)(int, struct gen_readio *),
+ LISP (*fcn2)(char *,long, int *));
+ LISP apropos(LISP);
+ LISP vload(char *fname,long cflag,long rflag);
+ LISP load(LISP fname,LISP cflag,LISP rflag);
+ LISP require(LISP fname);
+ LISP save_forms(LISP fname,LISP forms,LISP how);
+ LISP quit(void);
+ LISP nullp(LISP x);
+ LISP strcons(long length,const char *data);
+ LISP read_from_string(LISP x);
+ LISP aref1(LISP a,LISP i);
+ LISP aset1(LISP a,LISP i,LISP v);
+ LISP cons_array(LISP dim,LISP kind);
+ LISP arcons(long typecode,long n,long initp);
+ LISP string_append(LISP args);
+ LISP string_length(LISP string);
+ LISP string_search(LISP,LISP);
+ LISP substring(LISP,LISP,LISP);
+ LISP string_trim(LISP);
+ LISP string_trim_left(LISP);
+ LISP string_trim_right(LISP);
+ LISP string_upcase(LISP);
+ LISP string_downcase(LISP);
+ void __stdcall init_subrs(void);
+ LISP copy_list(LISP);
+ long c_sxhash(LISP,long);
+ LISP sxhash(LISP,LISP);
+ LISP href(LISP,LISP);
+ LISP hset(LISP,LISP,LISP);
+ LISP fast_print(LISP,LISP);
+ LISP fast_read(LISP);
+ LISP equal(LISP,LISP);
+ LISP assoc(LISP x,LISP alist);
+ LISP make_list(LISP x,LISP v);
+ void set_fatal_exit_hook(void (*fcn)(void));
+ LISP parse_number(LISP x);
+ LISP intern(LISP x);
+ void __stdcall init_trace(void);
+ long __stdcall repl_c_string(char *,long want_sigint,long want_init,long want_print);
+ char * __stdcall siod_version(void);
+ LISP nreverse(LISP);
+ LISP number2string(LISP,LISP,LISP,LISP);
+ LISP string2number(LISP,LISP);
+ LISP siod_verbose(LISP);
+ int __stdcall siod_verbose_check(int);
+ LISP setvar(LISP,LISP,LISP);
+ long allocate_user_tc(void);
+ LISP cadr(LISP);
+ LISP caar(LISP);
+ LISP cddr(LISP);
+ LISP caaar(LISP);
+ LISP caadr(LISP);
+ LISP cadar(LISP);
+ LISP caddr(LISP);
+ LISP cdaar(LISP);
+ LISP cdadr(LISP);
+ LISP cddar(LISP);
+ LISP cdddr(LISP);
+ void chk_string(LISP,char **,long *);
+ LISP a_true_value(void);
+ LISP lapply(LISP fcn,LISP args);
+ LISP mallocl(void *lplace,long size);
+ void gput_st(struct gen_printio *,char *);
+ void put_st(char *st);
+ LISP listn(long n, ...);
+ char *must_malloc(unsigned long size);
+ LISP lstrbreakup(LISP str,LISP lmarker);
+ LISP lstrunbreakup(LISP elems,LISP lmarker);
+ LISP nconc(LISP,LISP);
+ LISP poparg(LISP *,LISP);
+ FILE *get_c_file(LISP p,FILE *deflt);
+ char *last_c_errmsg(int);
+ LISP llast_c_errmsg(int);
+
+ #define SAFE_STRCPY(_to,_from) safe_strcpy((_to),sizeof(_to),(_from))
+ #define SAFE_STRCAT(_to,_from) safe_strcat((_to),sizeof(_to),(_from))
+ #define SAFE_STRLEN(_buff) safe_strlen((_buff),sizeof(_buff))
+
+ char *safe_strcpy(char *s1,size_t size1,const char *s2);
+ char *safe_strcat(char *s1,size_t size1,const char *s2);
+
+ size_t safe_strlen(const char *s,size_t size);
+ LISP memq(LISP x,LISP il);
+ LISP lstrbreakup(LISP,LISP);
+ LISP lstrbreakup(LISP,LISP);
+ LISP nth(LISP,LISP);
+ LISP butlast(LISP);
+ LISP last(LISP);
+ LISP readtl(struct gen_readio *f);
+ LISP funcall1(LISP,LISP);
+ LISP funcall2(LISP,LISP,LISP);
+ LISP apply1(LISP,LISP,LISP);
+ LISP lgetc(LISP p);
+ LISP lungetc(LISP i,LISP p);
+ LISP lputc(LISP c,LISP p);
+ LISP lputs(LISP str,LISP p);
+
+ int assemble_options(LISP, ...);
+ LISP ccall_catch(LISP tag,LISP (*fcn)(void *),void *);
+ LISP lref_default(LISP li,LISP x,LISP fcn);
+
+
+ LISP symalist(char *item,...);
+
+ LISP encode_st_mode(LISP l);
+ LISP encode_open_flags(LISP l);
+ long nlength(LISP obj);
+ int __stdcall siod_main(int argc,char **argv, char **env);
+ void __stdcall siod_shuffle_args(int *pargc,char ***pargv);
+ void __stdcall siod_init(int argc,char **argv);
+
Index: llvm/test/Programs/MultiSource/Applications/siod/siodp.h
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/siodp.h:1.1
*** /dev/null Fri Oct 17 13:48:55 2003
--- llvm/test/Programs/MultiSource/Applications/siod/siodp.h Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,208 ----
+ /* Scheme In One Defun, but in C this time.
+
+ * COPYRIGHT (c) 1988-1992 BY *
+ * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
+ * See the source file SLIB.C for more information. *
+
+ Declarations which are private to SLIB.C internals.
+ However, some of these should be moved to siod.h
+
+ $Id: siodp.h,v 1.1 2003/10/17 18:48:45 gaeke Exp $
+
+ */
+
+
+ extern char *tkbuffer;
+ extern LISP heap,heap_end,heap_org;
+ extern LISP sym_t;
+
+ extern long siod_verbose_level;
+ extern char *siod_lib;
+ extern long nointerrupt;
+ extern long interrupt_differed;
+ extern long errjmp_ok;
+ extern LISP unbound_marker;
+
+ struct user_type_hooks
+ {LISP (*gc_relocate)(LISP);
+ void (*gc_scan)(LISP);
+ LISP (*gc_mark)(LISP);
+ void (*gc_free)(LISP);
+ void (*prin1)(LISP,struct gen_printio *);
+ LISP (*leval)(LISP, LISP *, LISP *);
+ long (*c_sxhash)(LISP,long);
+ LISP (*fast_print)(LISP,LISP);
+ LISP (*fast_read)(int,LISP);
+ LISP (*equal)(LISP,LISP);};
+
+ struct catch_frame
+ {LISP tag;
+ LISP retval;
+ jmp_buf cframe;
+ struct catch_frame *next;};
+
+ extern struct catch_frame *catch_framep;
+
+ struct gc_protected
+ {LISP *location;
+ long length;
+ struct gc_protected *next;};
+
+ #define NEWCELL(_into,_type) \
+ {if (gc_kind_copying == 1) \
+ {if ((_into = heap) >= heap_end) \
+ gc_fatal_error(); \
+ heap = _into+1;} \
+ else \
+ {if NULLP(freelist) \
+ gc_for_newcell(); \
+ _into = freelist; \
+ freelist = CDR(freelist); \
+ ++gc_cells_allocated;} \
+ (*_into).gc_mark = 0; \
+ (*_into).type = (short) _type;}
+
+ #if defined(THINK_C)
+ extern int ipoll_counter;
+ void full_interrupt_poll(int *counter);
+ #define INTERRUPT_CHECK() if (--ipoll_counter < 0) full_interrupt_poll(&ipoll_counter)
+ #else
+ #if defined(WIN32)
+ void handle_interrupt_differed(void);
+ #define INTERRUPT_CHECK() if (interrupt_differed) handle_interrupt_differed()
+ #else
+ #define INTERRUPT_CHECK()
+ #endif
+ #endif
+
+ extern char *stack_limit_ptr;
+
+ #define STACK_LIMIT(_ptr,_amt) (((char *)_ptr) - (_amt))
+
+ #define STACK_CHECK(_ptr) \
+ if (((char *) (_ptr)) < stack_limit_ptr) err_stack((char *) _ptr);
+
+ void err_stack(char *);
+
+ #if defined(VMS) && defined(VAX)
+ #define SIG_restargs ,...
+ #else
+ #define SIG_restargs
+ #endif
+
+ void handle_sigfpe(int sig SIG_restargs);
+ void handle_sigint(int sig SIG_restargs);
+ void err_ctrl_c(void);
+ double myruntime(void);
+ void fput_st(FILE *f,char *st);
+ void put_st(char *st);
+ void grepl_puts(char *,void (*)(char *));
+ void gc_fatal_error(void);
+ LISP gen_intern(char *name,long copyp);
+ void scan_registers(void);
+ void init_storage_1(void);
+ struct user_type_hooks *get_user_type_hooks(long type);
+ LISP get_newspace(void);
+ void scan_newspace(LISP newspace);
+ void free_oldspace(LISP space,LISP end);
+ void gc_stop_and_copy(void);
+ void gc_for_newcell(void);
+ void gc_mark_and_sweep(void);
+ void gc_ms_stats_start(void);
+ void gc_ms_stats_end(void);
+ void gc_mark(LISP ptr);
+ void mark_protected_registers(void);
+ void mark_locations(LISP *start,LISP *end);
+ void mark_locations_array(LISP *x,long n);
+ void gc_sweep(void);
+ LISP leval_args(LISP l,LISP env);
+ LISP extend_env(LISP actuals,LISP formals,LISP env);
+ LISP envlookup(LISP var,LISP env);
+ LISP setvar(LISP var,LISP val,LISP env);
+ LISP leval_setq(LISP args,LISP env);
+ LISP syntax_define(LISP args);
+ LISP leval_define(LISP args,LISP env);
+ LISP leval_if(LISP *pform,LISP *penv);
+ LISP leval_lambda(LISP args,LISP env);
+ LISP leval_progn(LISP *pform,LISP *penv);
+ LISP leval_or(LISP *pform,LISP *penv);
+ LISP leval_and(LISP *pform,LISP *penv);
+ LISP leval_catch_1(LISP forms,LISP env);
+ LISP leval_catch(LISP args,LISP env);
+ LISP lthrow(LISP tag,LISP value);
+ LISP leval_let(LISP *pform,LISP *penv);
+ LISP reverse(LISP l);
+ LISP let_macro(LISP form);
+ LISP leval_quote(LISP args,LISP env);
+ LISP leval_tenv(LISP args,LISP env);
+ int flush_ws(struct gen_readio *f,char *eoferr);
+ int f_getc(FILE *f);
+ void f_ungetc(int c, FILE *f);
+ LISP lreadr(struct gen_readio *f);
+ LISP lreadparen(struct gen_readio *f);
+ LISP arglchk(LISP x);
+ void init_storage_a1(long type);
+ void init_storage_a(void);
+ LISP array_gc_relocate(LISP ptr);
+ void array_gc_scan(LISP ptr);
+ LISP array_gc_mark(LISP ptr);
+ void array_gc_free(LISP ptr);
+ void array_prin1(LISP ptr,struct gen_printio *f);
+ long array_sxhaxh(LISP,long);
+ LISP array_fast_print(LISP,LISP);
+ LISP array_fast_read(int,LISP);
+ LISP array_equal(LISP,LISP);
+ long array_sxhash(LISP,long);
+
+ int rfs_getc(unsigned char **p);
+ void rfs_ungetc(unsigned char c,unsigned char **p);
+ void err1_aset1(LISP i);
+ void err2_aset1(LISP v);
+ LISP lreadstring(struct gen_readio *f);
+ LISP lreadsharp(struct gen_readio *f);
+
+ void file_gc_free(LISP ptr);
+ void file_prin1(LISP ptr,struct gen_printio *f);
+ LISP fopen_c(char *name,char *how);
+ LISP fopen_cg(FILE *(*)(const char *,const char *),char *,char *);
+ LISP fopen_l(LISP name,LISP how);
+ LISP fclose_l(LISP p);
+ LISP lftell(LISP file);
+ LISP lfseek(LISP file,LISP offset,LISP direction);
+ LISP lfread(LISP size,LISP file);
+ LISP lfwrite(LISP string,LISP file);
+
+
+ LISP leval_while(LISP args,LISP env);
+
+ void init_subrs_a(void);
+ void init_subrs_1(void);
+
+ long href_index(LISP table,LISP key);
+
+ void put_long(long,FILE *);
+ long get_long(FILE *);
+
+ long fast_print_table(LISP obj,LISP table);
+
+ LISP stack_limit(LISP,LISP);
+
+
+ void err0(void);
+ void pr(LISP);
+ void prp(LISP *);
+
+ LISP closure_code(LISP exp);
+ LISP closure_env(LISP exp);
+ LISP lwhile(LISP form,LISP env);
+ LISP llength(LISP obj);
+ void gc_kind_check(void);
+ LISP allocate_aheap(void);
+ long looks_pointerp(LISP);
+ long nactive_heaps(void);
+ long freelist_length(void);
+ LISP gc_info(LISP);
+ LISP err_closure_code(LISP tmp);
+
+ #define VLOAD_OFFSET_HACK_CHAR '|'
+
Index: llvm/test/Programs/MultiSource/Applications/siod/slib.c
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/slib.c:1.1
*** /dev/null Fri Oct 17 13:48:55 2003
--- llvm/test/Programs/MultiSource/Applications/siod/slib.c Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,2682 ----
+ /* Scheme In One Defun, but in C this time.
+
+ * COPYRIGHT (c) 1988-1997 BY *
+ * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
+ * ALL RIGHTS RESERVED *
+
+ Permission to use, copy, modify, distribute and sell this software
+ and its documentation for any purpose and without fee is hereby
+ granted, provided that the above copyright notice appear in all copies
+ and that both that copyright notice and this permission notice appear
+ in supporting documentation, and that the name of Paradigm Associates
+ Inc not be used in advertising or publicity pertaining to distribution
+ of the software without specific, written prior permission.
+
+ PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+ ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+ PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+ ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+ SOFTWARE.
+
+ */
+
+ /*
+
+ gjc at world.std.com
+
+ Release 1.0: 24-APR-88
+ Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
+ Barak.Pearlmutter at DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
+ cleaned up uses of NULL/0. Now distributed with siod.scm.
+ Release 1.2: 28-APR-88, name changes as requested by JAR at AI.AI.MIT.EDU,
+ plus some bug fixes.
+ Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
+ define now works properly. vms specific function edit.
+ Release 1.4 20-NOV-89. Minor Cleanup and remodularization.
+ Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your
+ own main loops. Some short-int changes for lightspeed C included.
+ Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy
+ or mark-and-sweep garbage collection, which assumes that the stack/register
+ marking code is correct for your architecture.
+ Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly
+ different enough (from 1.3) now that I'm calling it a major release.
+ Release 2.1 4-DEC-89. Small reader features, dot, backquote, comma.
+ Release 2.2 5-DEC-89. gc,read,print,eval, hooks for user defined datatypes.
+ Release 2.3 6-DEC-89. save_forms, obarray intern mechanism. comment char.
+ Release 2.3a......... minor speed-ups. i/o interrupt considerations.
+ Release 2.4 27-APR-90 gen_readr, for read-from-string.
+ Release 2.5 18-SEP-90 arrays added to SIOD.C by popular demand. inums.
+ Release 2.6 11-MAR-92 function prototypes, some remodularization.
+ Release 2.7 20-MAR-92 hash tables, fasload. Stack check.
+ Release 2.8 3-APR-92 Bug fixes, \n syntax in string reading.
+ Release 2.9 28-AUG-92 gc sweep bug fix. fseek, ftell, etc. Change to
+ envlookup to allow (a . rest) suggested by bowles at is.s.u-tokyo.ac.jp.
+ Release 2.9a 10-AUG-93. Minor changes for Windows NT.
+ Release 3.0 1-MAY-94. Release it, include changes/cleanup recommended by
+ andreasg at nynexst.com for the OS2 C++ compiler. Compilation and running
+ tested using DEC C, VAX C. WINDOWS NT. GNU C on SPARC. Storage
+ management improvements, more string functions. SQL support.
+ Release 3.1? -JUN-95 verbose flag, other integration improvements for htqs.c
+ hpux by denson at sdd.hp.com, solaris by pgw9 at columbia.edu.
+ Release 3.2X MAR-96. dynamic linking, subr closures, other improvements.
+ Release 3.2 12-JUN-96. Bug fixes. Call it a release.
+ Release 3.3x cleanup for gcc -Wall.
+ Release 3.4 win95 cleanup.
+ Release 3.5 5-MAY-97 fixes, plus win95 "compiler" to create exe files.
+ */
+
+ #include <stdio.h>
+ #include <string.h>
+ #include <ctype.h>
+ #include <setjmp.h>
+ #include <signal.h>
+ #include <math.h>
+ #include <stdlib.h>
+ #include <time.h>
+ #include <errno.h>
+
+ #include "siod.h"
+ #include "siodp.h"
+
+ static void init_slib_version(void)
+ {setvar(cintern("*slib-version*"),
+ cintern("$Id: slib.c,v 1.1 2003/10/17 18:48:45 gaeke Exp $"),
+ NIL);}
+
+ char * __stdcall siod_version(void)
+ {return("3.5 5-MAY-97");}
+
+ long nheaps = 2;
+ LISP *heaps;
+ LISP heap,heap_end,heap_org;
+ long heap_size = 5000;
+ long old_heap_used;
+ long gc_status_flag = 1;
+ char *init_file = (char *) NULL;
+ char *tkbuffer = NULL;
+ long gc_kind_copying = 0;
+ long gc_cells_allocated = 0;
+ double gc_time_taken;
+ LISP *stack_start_ptr = NULL;
+ LISP freelist;
+ jmp_buf errjmp;
+ long errjmp_ok = 0;
+ long nointerrupt = 1;
+ long interrupt_differed = 0;
+ LISP oblistvar = NIL;
+ LISP sym_t = NIL;
+ LISP eof_val = NIL;
+ LISP sym_errobj = NIL;
+ LISP sym_catchall = NIL;
+ LISP sym_progn = NIL;
+ LISP sym_lambda = NIL;
+ LISP sym_quote = NIL;
+ LISP sym_dot = NIL;
+ LISP sym_after_gc = NIL;
+ LISP sym_eval_history_ptr = NIL;
+ LISP unbound_marker = NIL;
+ LISP *obarray;
+ long obarray_dim = 100;
+ struct catch_frame *catch_framep = (struct catch_frame *) NULL;
+ void (*repl_puts)(char *) = NULL;
+ LISP (*repl_read)(void) = NULL;
+ LISP (*repl_eval)(LISP) = NULL;
+ void (*repl_print)(LISP) = NULL;
+ LISP *inums;
+ long inums_dim = 256;
+ struct user_type_hooks *user_types = NULL;
+ long user_tc_next = tc_user_min;
+ struct gc_protected *protected_registers = NULL;
+ jmp_buf save_regs_gc_mark;
+ double gc_rt;
+ long gc_cells_collected;
+ char *user_ch_readm = "";
+ char *user_te_readm = "";
+ LISP (*user_readm)(int, struct gen_readio *) = NULL;
+ LISP (*user_readt)(char *,long, int *) = NULL;
+ void (*fatal_exit_hook)(void) = NULL;
+ #ifdef THINK_C
+ int ipoll_counter = 0;
+ #endif
+
+ char *stack_limit_ptr = NULL;
+ long stack_size =
+ #ifdef THINK_C
+ 10000;
+ #else
+ 50000;
+ #endif
+
+ long siod_verbose_level = 4;
+
+ #ifndef SIOD_LIB_DEFAULT
+ #ifdef unix
+ #define SIOD_LIB_DEFAULT "/usr/local/lib/siod"
+ #endif
+ #ifdef vms
+ #define SIOD_LIB_DEFAULT "SIOD_LIB:"
+ #endif
+ #ifdef WIN32
+ #define SIOD_LIB_DEFAULT "c:\\siod\\"
+ #include <float.h>
+ #endif
+ #endif
+
+ char *siod_lib = SIOD_LIB_DEFAULT;
+
+ void __stdcall process_cla(int argc,char **argv,int warnflag)
+ {int k;
+ char *ptr;
+ static siod_lib_set = 0;
+ #if !defined(vms)
+ if (!siod_lib_set)
+ {
+ #ifdef WIN32
+ if (argc > 0)
+ {siod_lib = strdup(argv[0]);
+ siod_lib_set = 1;
+ if ((ptr = strrchr(siod_lib,'\\')))
+ ptr[1] = 0;}
+ #endif
+ if (getenv("SIOD_LIB"))
+ {siod_lib = getenv("SIOD_LIB");
+ siod_lib_set = 1;}}
+ #endif
+ for(k=1;k<argc;++k)
+ {if (strlen(argv[k])<2) continue;
+ if (argv[k][0] != '-')
+ {if (warnflag) printf("bad arg: %s\n",argv[k]);continue;}
+ switch(argv[k][1])
+ {case 'l':
+ siod_lib = &argv[k][2];
+ break;
+ case 'h':
+ heap_size = atol(&(argv[k][2]));
+ if ((ptr = strchr(&(argv[k][2]),':')))
+ nheaps = atol(&ptr[1]);
+ break;
+ case 'o':
+ obarray_dim = atol(&(argv[k][2]));
+ break;
+ case 'i':
+ init_file = &(argv[k][2]);
+ break;
+ case 'n':
+ inums_dim = atol(&(argv[k][2]));
+ break;
+ case 'g':
+ gc_kind_copying = atol(&(argv[k][2]));
+ break;
+ case 's':
+ stack_size = atol(&(argv[k][2]));
+ break;
+ case 'v':
+ siod_verbose_level = atol(&(argv[k][2]));
+ break;
+ default:
+ if (warnflag) printf("bad arg: %s\n",argv[k]);}}}
+
+ void __stdcall print_welcome(void)
+ {if (siod_verbose_level >= 2)
+ {printf("Welcome to SIOD, Scheme In One Defun, Version %s\n",
+ siod_version());
+ printf("(C) Copyright 1988-1994 Paradigm Associates Inc.\n");}}
+
+ void __stdcall print_hs_1(void)
+ {if (siod_verbose_level >= 2)
+ {printf("%ld heaps. size = %ld cells, %ld bytes. %ld inums. GC is %s\n",
+ nheaps,
+ heap_size,heap_size*sizeof(struct obj),
+ inums_dim,
+ (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");}}
+
+
+ void __stdcall print_hs_2(void)
+ {if (siod_verbose_level >= 2)
+ {if (gc_kind_copying == 1)
+ printf("heaps[0] at %p, heaps[1] at %p\n",heaps[0],heaps[1]);
+ else
+ printf("heaps[0] at %p\n",heaps[0]);}}
+
+ long no_interrupt(long n)
+ {long x;
+ x = nointerrupt;
+ nointerrupt = n;
+ if ((nointerrupt == 0) && (interrupt_differed == 1))
+ {interrupt_differed = 0;
+ err_ctrl_c();}
+ return(x);}
+
+ void handle_sigfpe(int sig SIG_restargs)
+ {
+ #ifdef WIN32
+ _fpreset();
+ #endif
+ signal(SIGFPE,handle_sigfpe);
+ err("floating point exception",NIL);}
+
+ void handle_sigint(int sig SIG_restargs)
+ {signal(SIGINT,handle_sigint);
+ #if defined(WIN32)
+ interrupt_differed = 1;
+ #else
+ if (nointerrupt == 1)
+ interrupt_differed = 1;
+ else
+ err_ctrl_c();
+ #endif
+ }
+
+ #if defined(WIN32)
+ void handle_interrupt_differed(void)
+ {interrupt_differed = 0;
+ err_ctrl_c();}
+ #endif
+
+ void err_ctrl_c(void)
+ {err("control-c interrupt",NIL);}
+
+ LISP get_eof_val(void)
+ {return(eof_val);}
+
+ long repl_driver(long want_sigint,long want_init,struct repl_hooks *h)
+ {int k;
+ long rv;
+ struct repl_hooks hd;
+ LISP stack_start;
+ static void (*osigint)(int);
+ static void (*osigfpe)(int);
+ stack_start_ptr = &stack_start;
+ stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
+ k = setjmp(errjmp);
+ if (k == 2)
+ {if (want_sigint) signal(SIGINT,osigint);
+ signal(SIGFPE,osigfpe);
+ stack_start_ptr = NULL;
+ stack_limit_ptr = NULL;
+ return(2);}
+ if (want_sigint) osigint = signal(SIGINT,handle_sigint);
+ #ifdef WIN32_X
+ /* doesn't work, because library functions like atof
+ depend on default setting, or some other reason I didn't
+ have time to investigate. */
+ _controlfp(_EM_INVALID,
+ _MCW_EM);
+ #endif
+ osigfpe = signal(SIGFPE,handle_sigfpe);
+ catch_framep = (struct catch_frame *) NULL;
+ errjmp_ok = 1;
+ interrupt_differed = 0;
+ nointerrupt = 0;
+ if (want_init && init_file && (k == 0)) vload(init_file,0,1);
+ if (!h)
+ {hd.repl_puts = repl_puts;
+ hd.repl_read = repl_read;
+ hd.repl_eval = repl_eval;
+ hd.repl_print = repl_print;
+ rv = repl(&hd);}
+ else
+ rv = repl(h);
+ if (want_sigint) signal(SIGINT,osigint);
+ signal(SIGFPE,osigfpe);
+ stack_start_ptr = NULL;
+ stack_limit_ptr = NULL;
+ return(rv);}
+
+ static void ignore_puts(char *st)
+ {}
+
+ static void noprompt_puts(char *st)
+ {if (strcmp(st,"> ") != 0)
+ put_st(st);}
+
+ static char *repl_c_string_arg = NULL;
+ static char *repl_c_string_out = NULL;
+ static long repl_c_string_flag = 0;
+ static long repl_c_string_print_len = 0;
+
+
+ static LISP repl_c_string_read(void)
+ {LISP s;
+ if (repl_c_string_arg == NULL)
+ return(get_eof_val());
+ s = strcons(strlen(repl_c_string_arg),repl_c_string_arg);
+ repl_c_string_arg = NULL;
+ if (repl_c_string_out) repl_c_string_out[0] = 0;
+ return(read_from_string(s));}
+
+ static void ignore_print(LISP x)
+ {repl_c_string_flag = 1;}
+
+ static void not_ignore_print(LISP x)
+ {repl_c_string_flag = 1;
+ lprint(x,NIL);}
+
+ struct rcsp_puts
+ {char *ptr;
+ char *end;};
+
+ static int rcsp_puts(char *from,void *cb)
+ {long fromlen,intolen,cplen;
+ struct rcsp_puts *p = (struct rcsp_puts *) cb;
+ fromlen = strlen(from);
+ intolen = p->end - p->ptr;
+ cplen = (fromlen > intolen) ? intolen : fromlen;
+ memcpy(p->ptr,from,cplen);
+ p->ptr = &p->ptr[cplen];
+ *p->ptr = 0;
+ if (cplen != fromlen)
+ err("repl_c_string_print overflow",NIL);
+ return(1);}
+
+ static void repl_c_string_print(LISP x)
+ {struct gen_printio s;
+ struct rcsp_puts p;
+ s.putc_fcn = NULL;
+ s.puts_fcn = rcsp_puts;
+ p.ptr = repl_c_string_out;
+ p.end = &repl_c_string_out[repl_c_string_print_len - 1];
+ s.cb_argument = &p;
+ lprin1g(x,&s);
+ repl_c_string_flag = 1;}
+
+ long __stdcall repl_c_string(char *str,
+ long want_sigint,long want_init,long want_print)
+ {struct repl_hooks h;
+ long retval;
+ h.repl_read = repl_c_string_read;
+ h.repl_eval = NULL;
+ if (want_print > 1)
+ {h.repl_puts = ignore_puts;
+ h.repl_print = repl_c_string_print;
+ repl_c_string_print_len = want_print;
+ repl_c_string_out = str;}
+ else if (want_print)
+ {h.repl_puts = noprompt_puts;
+ h.repl_print = not_ignore_print;
+ repl_c_string_print_len = 0;
+ repl_c_string_out = NULL;}
+ else
+ {h.repl_puts = ignore_puts;
+ h.repl_print = ignore_print;
+ repl_c_string_print_len = 0;
+ repl_c_string_out = NULL;}
+ repl_c_string_arg = str;
+ repl_c_string_flag = 0;
+ retval = repl_driver(want_sigint,want_init,&h);
+ if (retval != 0)
+ return(retval);
+ else if (repl_c_string_flag == 1)
+ return(0);
+ else
+ return(2);}
+
+ #ifdef unix
+ #include <sys/types.h>
+ #include <sys/times.h>
+ #ifdef sun
+ #include <limits.h>
+ #endif
+ #ifndef CLK_TCK
+ #define CLK_TCK 60
+ #endif
+ double myruntime(void)
+ {double total;
+ struct tms b;
+ times(&b);
+ total = b.tms_utime;
+ total += b.tms_stime;
+ return(total / (double)CLK_TCK);}
+ #else
+ #if defined(THINK_C) | defined(WIN32) | defined(VMS)
+ #ifndef CLOCKS_PER_SEC
+ #define CLOCKS_PER_SEC CLK_TCK
+ #endif
+ double myruntime(void)
+ {return(((double) clock()) / ((double) CLOCKS_PER_SEC));}
+ #else
+ double myruntime(void)
+ {time_t x;
+ time(&x);
+ return((double) x);}
+ #endif
+ #endif
+
+ #if defined(__osf__)
+ #include <sys/timers.h>
+ #ifndef TIMEOFDAY
+ #define TIMEOFDAY 1
+ #endif
+ double myrealtime(void)
+ {struct timespec x;
+ if (!getclock(TIMEOFDAY,&x))
+ return(x.tv_sec + (((double) x.tv_nsec) * 1.0e-9));
+ else
+ return(0.0);}
+ #endif
+
+ #if defined(VMS)
+ #include <ssdef.h>
+ #include <starlet.h>
+
+ double myrealtime(void)
+ {unsigned long x[2];
+ static double c = 0.0;
+ if (sys$gettim(&x) == SS$_NORMAL)
+ {if (c == 0.0) c = pow((double) 2,(double) 31) * 100.0e-9;
+ return(x[0] * 100.0e-9 + x[1] * c);}
+ else
+ return(0.0);}
+
+ #endif
+
+ #if defined(SUN5) || defined(linux)
+
+ #if defined(linux)
+ #include <sys/time.h>
+ #endif
+
+ double myrealtime(void)
+ {struct timeval x;
+ if (gettimeofday(&x,NULL))
+ return(0.0);
+ return(((double) x.tv_sec) + ((double) x.tv_usec) * 1.0E-6);}
+ #endif
+
+ #if defined(WIN32)
+ #include <sys/timeb.h>
+ double myrealtime(void)
+ {struct _timeb x;
+ _ftime(&x);
+ return(x.time + ((double) x.millitm) * 0.001);}
+ #endif
+
+ #if !defined(__osf__) & !defined(VMS) & !defined(SUN5) & !defined(WIN32) &!defined(linux)
+ double myrealtime(void)
+ {time_t x;
+ time(&x);
+ return((double) x);}
+ #endif
+
+ void set_repl_hooks(void (*puts_f)(char *),
+ LISP (*read_f)(void),
+ LISP (*eval_f)(LISP),
+ void (*print_f)(LISP))
+ {repl_puts = puts_f;
+ repl_read = read_f;
+ repl_eval = eval_f;
+ repl_print = print_f;}
+
+ void gput_st(struct gen_printio *f,char *st)
+ {PUTS_FCN(st,f);}
+
+ void fput_st(FILE *f,char *st)
+ {long flag;
+ flag = no_interrupt(1);
+ fprintf(f,"%s",st);
+ no_interrupt(flag);}
+
+ int fputs_fcn(char *st,void *cb)
+ {fput_st((FILE *)cb,st);
+ return(1);}
+
+ void put_st(char *st)
+ {fput_st(stdout,st);}
+
+ void grepl_puts(char *st,void (*repl_puts)(char *))
+ {if (repl_puts == NULL)
+ {put_st(st);
+ fflush(stdout);}
+ else
+ (*repl_puts)(st);}
+
+ long repl(struct repl_hooks *h)
+ {LISP x,cw = 0;
+ double rt,ct;
+ while(1)
+ {if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
+ {rt = myruntime();
+ gc_stop_and_copy();
+ if (siod_verbose_level >= 2)
+ {sprintf(tkbuffer,
+ "GC took %g seconds, %ld compressed to %ld, %ld free\n",
+ myruntime()-rt,old_heap_used,(long)(heap-heap_org),(long)(heap_end-heap));
+ grepl_puts(tkbuffer,h->repl_puts);}}
+ if (siod_verbose_level >= 2)
+ grepl_puts("> ",h->repl_puts);
+ if (h->repl_read == NULL)
+ x = lread(NIL);
+ else
+ x = (*h->repl_read)();
+ if EQ(x,eof_val) break;
+ rt = myruntime();
+ ct = myrealtime();
+ if (gc_kind_copying == 1)
+ cw = heap;
+ else
+ {gc_cells_allocated = 0;
+ gc_time_taken = 0.0;}
+ if (h->repl_eval == NULL)
+ x = leval(x,NIL);
+ else
+ x = (*h->repl_eval)(x);
+ #ifdef STATISTICS
+ if (gc_kind_copying == 1)
+ sprintf(tkbuffer,
+ "Evaluation took %g seconds %ld cons work, %g real.\n",
+ myruntime()-rt,
+ (long)(heap-cw),
+ myrealtime()-ct);
+ else
+ sprintf(tkbuffer,
+ "Evaluation took %g seconds (%g in gc) %ld cons work, %g real.\n",
+ myruntime()-rt,
+ gc_time_taken,
+ gc_cells_allocated,
+ myrealtime()-ct);
+ if (siod_verbose_level >= 2)
+ grepl_puts(tkbuffer,h->repl_puts);
+ #endif /* STATISTICS */
+ if (h->repl_print == NULL)
+ {if (siod_verbose_level >= 2)
+ lprint(x,NIL);}
+ else
+ (*h->repl_print)(x);}
+ return(0);}
+
+ void set_fatal_exit_hook(void (*fcn)(void))
+ {fatal_exit_hook = fcn;}
+
+ static long inside_err = 0;
+
+ LISP err(const char *message, LISP x)
+ {struct catch_frame *l;
+ long was_inside = inside_err;
+ LISP retval,nx;
+ const char *msg,*eobj;
+ nointerrupt = 1;
+ if ((!message) && CONSP(x) && TYPEP(CAR(x),tc_string))
+ {msg = get_c_string(CAR(x));
+ nx = CDR(x);
+ retval = x;}
+ else
+ {msg = message;
+ nx = x;
+ retval = NIL;}
+ if ((eobj = try_get_c_string(nx)) && !memchr(eobj,0,80 ))
+ eobj = NULL;
+ if ((siod_verbose_level >= 1) && msg)
+ {if NULLP(nx)
+ printf("ERROR: %s\n",msg);
+ else if (eobj)
+ printf("ERROR: %s (errobj %s)\n",msg,eobj);
+ else
+ printf("ERROR: %s (see errobj)\n",msg);}
+ if (errjmp_ok == 1)
+ {inside_err = 1;
+ setvar(sym_errobj,nx,NIL);
+ for(l=catch_framep; l; l = (*l).next)
+ if (EQ((*l).tag,sym_errobj) ||
+ EQ((*l).tag,sym_catchall))
+ {if (!msg) msg = "quit";
+ (*l).retval = (NNULLP(retval) ? retval :
+ (was_inside) ? NIL :
+ cons(strcons(strlen(msg),msg),nx));
+ nointerrupt = 0;
+ inside_err = 0;
+ longjmp((*l).cframe,2);}
+ inside_err = 0;
+ longjmp(errjmp,(msg) ? 1 : 2);}
+ if (siod_verbose_level >= 1)
+ printf("FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n");
+ if (fatal_exit_hook)
+ (*fatal_exit_hook)();
+ else
+ exit(10);
+ return(NIL);}
+
+ LISP errswitch(void)
+ {return(err("BUG. Reached impossible case",NIL));}
+
+ void err_stack(char *ptr)
+ /* The user could be given an option to continue here */
+ {err("the currently assigned stack limit has been exceded",NIL);}
+
+ LISP stack_limit(LISP amount,LISP silent)
+ {if NNULLP(amount)
+ {stack_size = get_c_long(amount);
+ stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);}
+ if NULLP(silent)
+ {sprintf(tkbuffer,"Stack_size = %ld bytes, [%p,%p]\n",
+ stack_size,stack_start_ptr,stack_limit_ptr);
+ put_st(tkbuffer);
+ return(NIL);}
+ else
+ return(flocons(stack_size));}
+
+ char *try_get_c_string(LISP x)
+ {if TYPEP(x,tc_symbol)
+ return(PNAME(x));
+ else if TYPEP(x,tc_string)
+ return(x->storage_as.string.data);
+ else
+ return(NULL);}
+
+ char *get_c_string(LISP x)
+ {if TYPEP(x,tc_symbol)
+ return(PNAME(x));
+ else if TYPEP(x,tc_string)
+ return(x->storage_as.string.data);
+ else
+ err("not a symbol or string",x);
+ return(NULL);}
+
+ char *get_c_string_dim(LISP x,long *len)
+ {switch(TYPE(x))
+ {case tc_symbol:
+ *len = strlen(PNAME(x));
+ return(PNAME(x));
+ case tc_string:
+ case tc_byte_array:
+ *len = x->storage_as.string.dim;
+ return(x->storage_as.string.data);
+ case tc_long_array:
+ *len = x->storage_as.long_array.dim * sizeof(long);
+ return((char *)x->storage_as.long_array.data);
+ default:
+ err("not a symbol or string",x);
+ return(NULL);}}
+
+ LISP lerr(LISP message, LISP x)
+ {if (CONSP(message) && TYPEP(CAR(message),tc_string))
+ err(NULL,message);
+ else
+ err(get_c_string(message),x);
+ return(NIL);}
+
+ void gc_fatal_error(void)
+ {err("ran out of storage",NIL);}
+
+ LISP newcell(long type)
+ {LISP z;
+ NEWCELL(z,type);
+ return(z);}
+
+ LISP cons(LISP x,LISP y)
+ {LISP z;
+ NEWCELL(z,tc_cons);
+ CAR(z) = x;
+ CDR(z) = y;
+ return(z);}
+
+ LISP consp(LISP x)
+ {if CONSP(x) return(sym_t); else return(NIL);}
+
+ LISP car(LISP x)
+ {switch TYPE(x)
+ {case tc_nil:
+ return(NIL);
+ case tc_cons:
+ return(CAR(x));
+ default:
+ return(err("wta to car",x));}}
+
+ LISP cdr(LISP x)
+ {switch TYPE(x)
+ {case tc_nil:
+ return(NIL);
+ case tc_cons:
+ return(CDR(x));
+ default:
+ return(err("wta to cdr",x));}}
+
+ LISP setcar(LISP cell, LISP value)
+ {if NCONSP(cell) err("wta to setcar",cell);
+ return(CAR(cell) = value);}
+
+ LISP setcdr(LISP cell, LISP value)
+ {if NCONSP(cell) err("wta to setcdr",cell);
+ return(CDR(cell) = value);}
+
+ LISP flocons(double x)
+ {LISP z;
+ long n;
+ if ((inums_dim > 0) &&
+ ((x - (n = (long)x)) == 0) &&
+ (x >= 0) &&
+ (n < inums_dim))
+ return(inums[n]);
+ NEWCELL(z,tc_flonum);
+ FLONM(z) = x;
+ return(z);}
+
+ LISP numberp(LISP x)
+ {if FLONUMP(x) return(sym_t); else return(NIL);}
+
+ LISP plus(LISP x,LISP y)
+ {if NULLP(y)
+ return(NULLP(x) ? flocons(0) : x);
+ if NFLONUMP(x) err("wta(1st) to plus",x);
+ if NFLONUMP(y) err("wta(2nd) to plus",y);
+ return(flocons(FLONM(x) + FLONM(y)));}
+
+ LISP ltimes(LISP x,LISP y)
+ {if NULLP(y)
+ return(NULLP(x) ? flocons(1) : x);
+ if NFLONUMP(x) err("wta(1st) to times",x);
+ if NFLONUMP(y) err("wta(2nd) to times",y);
+ return(flocons(FLONM(x)*FLONM(y)));}
+
+ LISP difference(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to difference",x);
+ if NULLP(y)
+ return(flocons(-FLONM(x)));
+ else
+ {if NFLONUMP(y) err("wta(2nd) to difference",y);
+ return(flocons(FLONM(x) - FLONM(y)));}}
+
+ LISP Quotient(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to quotient",x);
+ if NULLP(y)
+ return(flocons(1/FLONM(x)));
+ else
+ {if NFLONUMP(y) err("wta(2nd) to quotient",y);
+ return(flocons(FLONM(x)/FLONM(y)));}}
+
+ LISP lllabs(LISP x)
+ {double v;
+ if NFLONUMP(x) err("wta to abs",x);
+ v = FLONM(x);
+ if (v < 0)
+ return(flocons(-v));
+ else
+ return(x);}
+
+ LISP lsqrt(LISP x)
+ {if NFLONUMP(x) err("wta to sqrt",x);
+ return(flocons(sqrt(FLONM(x))));}
+
+ LISP greaterp(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to greaterp",x);
+ if NFLONUMP(y) err("wta(2nd) to greaterp",y);
+ if (FLONM(x)>FLONM(y)) return(sym_t);
+ return(NIL);}
+
+ LISP lessp(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to lessp",x);
+ if NFLONUMP(y) err("wta(2nd) to lessp",y);
+ if (FLONM(x)<FLONM(y)) return(sym_t);
+ return(NIL);}
+
+ LISP greaterEp(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to greaterp",x);
+ if NFLONUMP(y) err("wta(2nd) to greaterp",y);
+ if (FLONM(x)>=FLONM(y)) return(sym_t);
+ return(NIL);}
+
+ LISP lessEp(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to lessp",x);
+ if NFLONUMP(y) err("wta(2nd) to lessp",y);
+ if (FLONM(x)<=FLONM(y)) return(sym_t);
+ return(NIL);}
+
+ LISP lmax(LISP x,LISP y)
+ {if NULLP(y) return(x);
+ if NFLONUMP(x) err("wta(1st) to max",x);
+ if NFLONUMP(y) err("wta(2nd) to max",y);
+ return((FLONM(x) > FLONM(y)) ? x : y);}
+
+ LISP lmin(LISP x,LISP y)
+ {if NULLP(y) return(x);
+ if NFLONUMP(x) err("wta(1st) to min",x);
+ if NFLONUMP(y) err("wta(2nd) to min",y);
+ return((FLONM(x) < FLONM(y)) ? x : y);}
+
+ LISP eq(LISP x,LISP y)
+ {if EQ(x,y) return(sym_t); else return(NIL);}
+
+ LISP eql(LISP x,LISP y)
+ {if EQ(x,y) return(sym_t); else
+ if NFLONUMP(x) return(NIL); else
+ if NFLONUMP(y) return(NIL); else
+ if (FLONM(x) == FLONM(y)) return(sym_t);
+ return(NIL);}
+
+ LISP symcons(char *pname,LISP vcell)
+ {LISP z;
+ NEWCELL(z,tc_symbol);
+ PNAME(z) = pname;
+ VCELL(z) = vcell;
+ return(z);}
+
+ LISP symbolp(LISP x)
+ {if SYMBOLP(x) return(sym_t); else return(NIL);}
+
+ LISP err_ubv(LISP v)
+ {return(err("unbound variable",v));}
+
+ LISP symbol_boundp(LISP x,LISP env)
+ {LISP tmp;
+ if NSYMBOLP(x) err("not a symbol",x);
+ tmp = envlookup(x,env);
+ if NNULLP(tmp) return(sym_t);
+ if EQ(VCELL(x),unbound_marker) return(NIL); else return(sym_t);}
+
+ LISP symbol_value(LISP x,LISP env)
+ {LISP tmp;
+ if NSYMBOLP(x) err("not a symbol",x);
+ tmp = envlookup(x,env);
+ if NNULLP(tmp) return(CAR(tmp));
+ tmp = VCELL(x);
+ if EQ(tmp,unbound_marker) err_ubv(x);
+ return(tmp);}
+
+
+
+ char *must_malloc(unsigned long size)
+ {char *tmp;
+ tmp = (char *) malloc((size) ? size : 1);
+ if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
+ return(tmp);}
+
+ LISP gen_intern(char *name,long copyp)
+ {LISP l,sym,sl;
+ char *cname;
+ long hash=0,n,c,flag;
+ flag = no_interrupt(1);
+ if (obarray_dim > 1)
+ {hash = 0;
+ n = obarray_dim;
+ cname = name;
+ while((c = *cname++)) hash = ((hash * 17) ^ c) % n;
+ sl = obarray[hash];}
+ else
+ sl = oblistvar;
+ for(l=sl;NNULLP(l);l=CDR(l))
+ if (strcmp(name,PNAME(CAR(l))) == 0)
+ {no_interrupt(flag);
+ return(CAR(l));}
+ if (copyp == 1)
+ {cname = (char *) must_malloc(strlen(name)+1);
+ strcpy(cname,name);}
+ else
+ cname = name;
+ sym = symcons(cname,unbound_marker);
+ if (obarray_dim > 1) obarray[hash] = cons(sym,sl);
+ oblistvar = cons(sym,oblistvar);
+ no_interrupt(flag);
+ return(sym);}
+
+ LISP cintern(char *name)
+ {return(gen_intern(name,0));}
+
+ LISP rintern(char *name)
+ {return(gen_intern(name,1));}
+
+ LISP intern(LISP name)
+ {return(rintern(get_c_string(name)));}
+
+ LISP subrcons(long type, char *name, SUBR_FUNC f)
+ {LISP z;
+ NEWCELL(z,type);
+ (*z).storage_as.subr.name = name;
+ (*z).storage_as.subr0.f = f;
+ return(z);}
+
+ LISP closure(LISP env,LISP code)
+ {LISP z;
+ NEWCELL(z,tc_closure);
+ (*z).storage_as.closure.env = env;
+ (*z).storage_as.closure.code = code;
+ return(z);}
+
+ void gc_protect(LISP *location)
+ {gc_protect_n(location,1);}
+
+ void gc_protect_n(LISP *location,long n)
+ {struct gc_protected *reg;
+ reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
+ (*reg).location = location;
+ (*reg).length = n;
+ (*reg).next = protected_registers;
+ protected_registers = reg;}
+
+ void gc_protect_sym(LISP *location,char *st)
+ {*location = cintern(st);
+ gc_protect(location);}
+
+ void scan_registers(void)
+ {struct gc_protected *reg;
+ LISP *location;
+ long j,n;
+ for(reg = protected_registers; reg; reg = (*reg).next)
+ {location = (*reg).location;
+ n = (*reg).length;
+ for(j=0;j<n;++j)
+ location[j] = gc_relocate(location[j]);}}
+
+ void __stdcall init_storage(void)
+ {long j;
+ LISP stack_start;
+ if (stack_start_ptr == NULL)
+ stack_start_ptr = &stack_start;
+ init_storage_1();
+ init_storage_a();
+ set_gc_hooks(tc_c_file,0,0,0,file_gc_free,&j);
+ set_print_hooks(tc_c_file,file_prin1);}
+
+ void init_storage_1(void)
+ {LISP ptr;
+ long j;
+ tkbuffer = (char *) must_malloc(TKBUFFERN+1);
+ if (((gc_kind_copying == 1) && (nheaps != 2)) || (nheaps < 1))
+ err("invalid number of heaps",NIL);
+ heaps = (LISP *) must_malloc(sizeof(LISP) * nheaps);
+ for(j=0;j<nheaps;++j) heaps[j] = NULL;
+ heaps[0] = (LISP) must_malloc(sizeof(struct obj)*heap_size);
+ heap = heaps[0];
+ heap_org = heap;
+ heap_end = heap + heap_size;
+ if (gc_kind_copying == 1)
+ heaps[1] = (LISP) must_malloc(sizeof(struct obj)*heap_size);
+ else
+ freelist = NIL;
+ gc_protect(&oblistvar);
+ if (obarray_dim > 1)
+ {obarray = (LISP *) must_malloc(sizeof(LISP) * obarray_dim);
+ for(j=0;j<obarray_dim;++j)
+ obarray[j] = NIL;
+ gc_protect_n(obarray,obarray_dim);}
+ unbound_marker = cons(cintern("**unbound-marker**"),NIL);
+ gc_protect(&unbound_marker);
+ eof_val = cons(cintern("eof"),NIL);
+ gc_protect(&eof_val);
+ gc_protect_sym(&sym_t,"t");
+ setvar(sym_t,sym_t,NIL);
+ setvar(cintern("nil"),NIL,NIL);
+ setvar(cintern("let"),cintern("let-internal-macro"),NIL);
+ setvar(cintern("let*"),cintern("let*-macro"),NIL);
+ setvar(cintern("letrec"),cintern("letrec-macro"),NIL);
+ gc_protect_sym(&sym_errobj,"errobj");
+ setvar(sym_errobj,NIL,NIL);
+ gc_protect_sym(&sym_catchall,"all");
+ gc_protect_sym(&sym_progn,"begin");
+ gc_protect_sym(&sym_lambda,"lambda");
+ gc_protect_sym(&sym_quote,"quote");
+ gc_protect_sym(&sym_dot,".");
+ gc_protect_sym(&sym_after_gc,"*after-gc*");
+ setvar(sym_after_gc,NIL,NIL);
+ gc_protect_sym(&sym_eval_history_ptr,"*eval-history-ptr*");
+ setvar(sym_eval_history_ptr,NIL,NIL);
+ if (inums_dim > 0)
+ {inums = (LISP *) must_malloc(sizeof(LISP) * inums_dim);
+ for(j=0;j<inums_dim;++j)
+ {NEWCELL(ptr,tc_flonum);
+ FLONM(ptr) = j;
+ inums[j] = ptr;}
+ gc_protect_n(inums,inums_dim);}}
+
+ void init_subr(char *name, long type, SUBR_FUNC fcn)
+ {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
+
+ void init_subr_0(char *name, LISP (*fcn)(void))
+ {init_subr(name,tc_subr_0,(SUBR_FUNC)fcn);}
+
+ void init_subr_1(char *name, LISP (*fcn)(LISP))
+ {init_subr(name,tc_subr_1,(SUBR_FUNC)fcn);}
+
+ void init_subr_2(char *name, LISP (*fcn)(LISP,LISP))
+ {init_subr(name,tc_subr_2,(SUBR_FUNC)fcn);}
+
+ void init_subr_2n(char *name, LISP (*fcn)(LISP,LISP))
+ {init_subr(name,tc_subr_2n,(SUBR_FUNC)fcn);}
+
+ void init_subr_3(char *name, LISP (*fcn)(LISP,LISP,LISP))
+ {init_subr(name,tc_subr_3,(SUBR_FUNC)fcn);}
+
+ void init_subr_4(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP))
+ {init_subr(name,tc_subr_4,(SUBR_FUNC)fcn);}
+
+ void init_subr_5(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP,LISP))
+ {init_subr(name,tc_subr_5,(SUBR_FUNC)fcn);}
+
+ void init_lsubr(char *name, LISP (*fcn)(LISP))
+ {init_subr(name,tc_lsubr,(SUBR_FUNC)fcn);}
+
+ void init_fsubr(char *name, LISP (*fcn)(LISP,LISP))
+ {init_subr(name,tc_fsubr,(SUBR_FUNC)fcn);}
+
+ void init_msubr(char *name, LISP (*fcn)(LISP *,LISP *))
+ {init_subr(name,tc_msubr,(SUBR_FUNC)fcn);}
+
+ LISP assq(LISP x,LISP alist)
+ {LISP l,tmp;
+ for(l=alist;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to assq",alist));}
+
+
+ struct user_type_hooks *get_user_type_hooks(long type)
+ {long n;
+ if (user_types == NULL)
+ {n = sizeof(struct user_type_hooks) * tc_table_dim;
+ user_types = (struct user_type_hooks *) must_malloc(n);
+ memset(user_types,0,n);}
+ if ((type >= 0) && (type < tc_table_dim))
+ return(&user_types[type]);
+ else
+ err("type number out of range",NIL);
+ return(NULL);}
+
+ long allocate_user_tc(void)
+ {long x = user_tc_next;
+ if (x > tc_user_max)
+ err("ran out of user type codes",NIL);
+ ++user_tc_next;
+ return(x);}
+
+ void set_gc_hooks(long type,
+ LISP (*rel)(LISP),
+ LISP (*mark)(LISP),
+ void (*scan)(LISP),
+ void (*free)(LISP),
+ long *kind)
+ {struct user_type_hooks *p;
+ p = get_user_type_hooks(type);
+ p->gc_relocate = rel;
+ p->gc_scan = scan;
+ p->gc_mark = mark;
+ p->gc_free = free;
+ *kind = gc_kind_copying;}
+
+ LISP gc_relocate(LISP x)
+ {LISP nw;
+ struct user_type_hooks *p;
+ if EQ(x,NIL) return(NIL);
+ if ((*x).gc_mark == 1) return(CAR(x));
+ switch TYPE(x)
+ {case tc_flonum:
+ case tc_cons:
+ case tc_symbol:
+ case tc_closure:
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_2n:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ if ((nw = heap) >= heap_end) gc_fatal_error();
+ heap = nw+1;
+ memcpy(nw,x,sizeof(struct obj));
+ break;
+ default:
+ p = get_user_type_hooks(TYPE(x));
+ if (p->gc_relocate)
+ nw = (*p->gc_relocate)(x);
+ else
+ {if ((nw = heap) >= heap_end) gc_fatal_error();
+ heap = nw+1;
+ memcpy(nw,x,sizeof(struct obj));}}
+ (*x).gc_mark = 1;
+ CAR(x) = nw;
+ return(nw);}
+
+ LISP get_newspace(void)
+ {LISP newspace;
+ if (heap_org == heaps[0])
+ newspace = heaps[1];
+ else
+ newspace = heaps[0];
+ heap = newspace;
+ heap_org = heap;
+ heap_end = heap + heap_size;
+ return(newspace);}
+
+ void scan_newspace(LISP newspace)
+ {LISP ptr;
+ struct user_type_hooks *p;
+ for(ptr=newspace; ptr < heap; ++ptr)
+ {switch TYPE(ptr)
+ {case tc_cons:
+ case tc_closure:
+ CAR(ptr) = gc_relocate(CAR(ptr));
+ CDR(ptr) = gc_relocate(CDR(ptr));
+ break;
+ case tc_symbol:
+ VCELL(ptr) = gc_relocate(VCELL(ptr));
+ break;
+ case tc_flonum:
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_2n:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ break;
+ default:
+ p = get_user_type_hooks(TYPE(ptr));
+ if (p->gc_scan) (*p->gc_scan)(ptr);}}}
+
+ void free_oldspace(LISP space,LISP end)
+ {LISP ptr;
+ struct user_type_hooks *p;
+ for(ptr=space; ptr < end; ++ptr)
+ if (ptr->gc_mark == 0)
+ switch TYPE(ptr)
+ {case tc_cons:
+ case tc_closure:
+ case tc_symbol:
+ case tc_flonum:
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_2n:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ break;
+ default:
+ p = get_user_type_hooks(TYPE(ptr));
+ if (p->gc_free) (*p->gc_free)(ptr);}}
+
+ void gc_stop_and_copy(void)
+ {LISP newspace,oldspace,end;
+ long flag;
+ flag = no_interrupt(1);
+ errjmp_ok = 0;
+ oldspace = heap_org;
+ end = heap;
+ old_heap_used = end - oldspace;
+ newspace = get_newspace();
+ scan_registers();
+ scan_newspace(newspace);
+ free_oldspace(oldspace,end);
+ errjmp_ok = 1;
+ no_interrupt(flag);}
+
+ LISP allocate_aheap(void)
+ {long j,flag;
+ LISP ptr,end,next;
+ gc_kind_check();
+ for(j=0;j<nheaps;++j)
+ if (!heaps[j])
+ {flag = no_interrupt(1);
+ if (gc_status_flag && (siod_verbose_level >= 4))
+ printf("[allocating heap %ld]\n",j);
+ heaps[j] = (LISP) must_malloc(sizeof(struct obj)*heap_size);
+ ptr = heaps[j];
+ end = heaps[j] + heap_size;
+ while(1)
+ {(*ptr).type = tc_free_cell;
+ next = ptr + 1;
+ if (next < end)
+ {CDR(ptr) = next;
+ ptr = next;}
+ else
+ {CDR(ptr) = freelist;
+ break;}}
+ freelist = heaps[j];
+ flag = no_interrupt(flag);
+ return(sym_t);}
+ return(NIL);}
+
+ void gc_for_newcell(void)
+ {long flag,n;
+ LISP l;
+ if (heap < heap_end)
+ {freelist = heap;
+ CDR(freelist) = NIL;
+ ++heap;
+ return;}
+ if (errjmp_ok == 0) gc_fatal_error();
+ flag = no_interrupt(1);
+ errjmp_ok = 0;
+ gc_mark_and_sweep();
+ errjmp_ok = 1;
+ no_interrupt(flag);
+ for(n=0,l=freelist;(n < 100) && NNULLP(l); ++n) l = CDR(l);
+ if (n == 0)
+ {if NULLP(allocate_aheap())
+ gc_fatal_error();}
+ else if ((n == 100) && NNULLP(sym_after_gc))
+ leval(leval(sym_after_gc,NIL),NIL);
+ else
+ allocate_aheap();}
+
+ void gc_mark_and_sweep(void)
+ {LISP stack_end;
+ gc_ms_stats_start();
+ while(heap < heap_end)
+ {heap->type = tc_free_cell;
+ heap->gc_mark = 0;
+ ++heap;}
+ setjmp(save_regs_gc_mark);
+ mark_locations((LISP *) save_regs_gc_mark,
+ (LISP *) (((char *) save_regs_gc_mark) + sizeof(save_regs_gc_mark)));
+ mark_protected_registers();
+ mark_locations((LISP *) stack_start_ptr,
+ (LISP *) &stack_end);
+ #ifdef THINK_C
+ mark_locations((LISP *) ((char *) stack_start_ptr + 2),
+ (LISP *) ((char *) &stack_end + 2));
+ #endif
+ gc_sweep();
+ gc_ms_stats_end();}
+
+ void gc_ms_stats_start(void)
+ {gc_rt = myruntime();
+ gc_cells_collected = 0;
+ if (gc_status_flag && (siod_verbose_level >= 4))
+ printf("[starting GC]\n");}
+
+ void gc_ms_stats_end(void)
+ {gc_rt = myruntime() - gc_rt;
+ gc_time_taken = gc_time_taken + gc_rt;
+ if (gc_status_flag && (siod_verbose_level >= 4))
+ printf("[GC took %g cpu seconds, %ld cells collected]\n",
+ gc_rt,
+ gc_cells_collected);}
+
+ void gc_mark(LISP ptr)
+ {struct user_type_hooks *p;
+ gc_mark_loop:
+ if NULLP(ptr) return;
+ if ((*ptr).gc_mark) return;
+ (*ptr).gc_mark = 1;
+ switch ((*ptr).type)
+ {case tc_flonum:
+ break;
+ case tc_cons:
+ gc_mark(CAR(ptr));
+ ptr = CDR(ptr);
+ goto gc_mark_loop;
+ case tc_symbol:
+ ptr = VCELL(ptr);
+ goto gc_mark_loop;
+ case tc_closure:
+ gc_mark((*ptr).storage_as.closure.code);
+ ptr = (*ptr).storage_as.closure.env;
+ goto gc_mark_loop;
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_2n:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ break;
+ default:
+ p = get_user_type_hooks(TYPE(ptr));
+ if (p->gc_mark)
+ ptr = (*p->gc_mark)(ptr);}}
+
+ void mark_protected_registers(void)
+ {struct gc_protected *reg;
+ LISP *location;
+ long j,n;
+ for(reg = protected_registers; reg; reg = (*reg).next)
+ {location = (*reg).location;
+ n = (*reg).length;
+ for(j=0;j<n;++j)
+ gc_mark(location[j]);}}
+
+ void mark_locations(LISP *start,LISP *end)
+ {LISP *tmp;
+ long n;
+ if (start > end)
+ {tmp = start;
+ start = end;
+ end = tmp;}
+ n = end - start;
+ mark_locations_array(start,n);}
+
+ long looks_pointerp(LISP p)
+ {long j;
+ LISP h;
+ for(j=0;j<nheaps;++j)
+ if ((h = heaps[j]) &&
+ (p >= h) &&
+ (p < (h + heap_size)) &&
+ (((((char *)p) - ((char *)h)) % sizeof(struct obj)) == 0) &&
+ NTYPEP(p,tc_free_cell))
+ return(1);
+ return(0);}
+
+ void mark_locations_array(LISP *x,long n)
+ {int j;
+ LISP p;
+ for(j=0;j<n;++j)
+ {p = x[j];
+ if (looks_pointerp(p))
+ gc_mark(p);}}
+
+ void gc_sweep(void)
+ {LISP ptr,end,nfreelist,org;
+ long n,k;
+ struct user_type_hooks *p;
+ end = heap_end;
+ n = 0;
+ nfreelist = NIL;
+ for(k=0;k<nheaps;++k)
+ if (heaps[k])
+ {org = heaps[k];
+ end = org + heap_size;
+ for(ptr=org; ptr < end; ++ptr)
+ if (((*ptr).gc_mark == 0))
+ {switch((*ptr).type)
+ {case tc_free_cell:
+ case tc_cons:
+ case tc_closure:
+ case tc_symbol:
+ case tc_flonum:
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_2n:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ break;
+ default:
+ p = get_user_type_hooks(TYPE(ptr));
+ if (p->gc_free)
+ (*p->gc_free)(ptr);}
+ ++n;
+ (*ptr).type = tc_free_cell;
+ CDR(ptr) = nfreelist;
+ nfreelist = ptr;}
+ else
+ (*ptr).gc_mark = 0;}
+ gc_cells_collected = n;
+ freelist = nfreelist;}
+
+ void gc_kind_check(void)
+ {if (gc_kind_copying == 1)
+ err("cannot perform operation with stop-and-copy GC mode. Use -g0\n",
+ NIL);}
+
+ LISP user_gc(LISP args)
+ {long old_status_flag,flag;
+ gc_kind_check();
+ flag = no_interrupt(1);
+ errjmp_ok = 0;
+ old_status_flag = gc_status_flag;
+ if NNULLP(args)
+ if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
+ gc_mark_and_sweep();
+ gc_status_flag = old_status_flag;
+ errjmp_ok = 1;
+ no_interrupt(flag);
+ return(NIL);}
+
+ long nactive_heaps(void)
+ {long m;
+ for(m=0;(m < nheaps) && heaps[m];++m);
+ return(m);}
+
+ long freelist_length(void)
+ {long n;
+ LISP l;
+ for(n=0,l=freelist;NNULLP(l); ++n) l = CDR(l);
+ n += (heap_end - heap);
+ return(n);}
+
+ LISP gc_status(LISP args)
+ {long n,m;
+ if NNULLP(args)
+ if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
+ if (gc_kind_copying == 1)
+ {if (gc_status_flag)
+ put_st("garbage collection is on\n");
+ else
+ put_st("garbage collection is off\n");
+ sprintf(tkbuffer,"%ld allocated %ld free\n",
+ (long)(heap - heap_org), (long)(heap_end - heap));
+ put_st(tkbuffer);}
+ else
+ {if (gc_status_flag)
+ put_st("garbage collection verbose\n");
+ else
+ put_st("garbage collection silent\n");
+ {m = nactive_heaps();
+ n = freelist_length();
+ sprintf(tkbuffer,"%ld/%ld heaps, %ld allocated %ld free\n",
+ m,nheaps,m*heap_size - n,n);
+ put_st(tkbuffer);}}
+ return(NIL);}
+
+ LISP gc_info(LISP arg)
+ {switch(get_c_long(arg))
+ {case 0:
+ return((gc_kind_copying == 1) ? sym_t : NIL);
+ case 1:
+ return(flocons(nactive_heaps()));
+ case 2:
+ return(flocons(nheaps));
+ case 3:
+ return(flocons(heap_size));
+ case 4:
+ return(flocons((gc_kind_copying == 1)
+ ? (long) (heap_end - heap)
+ : freelist_length()));
+ default:
+ return(NIL);}}
+
+ LISP leval_args(LISP l,LISP env)
+ {LISP result,v1,v2,tmp;
+ if NULLP(l) return(NIL);
+ if NCONSP(l) err("bad syntax argument list",l);
+ result = cons(leval(CAR(l),env),NIL);
+ for(v1=result,v2=CDR(l);
+ CONSP(v2);
+ v1 = tmp, v2 = CDR(v2))
+ {tmp = cons(leval(CAR(v2),env),NIL);
+ CDR(v1) = tmp;}
+ if NNULLP(v2) err("bad syntax argument list",l);
+ return(result);}
+
+ LISP extend_env(LISP actuals,LISP formals,LISP env)
+ {if SYMBOLP(formals)
+ return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
+ return(cons(cons(formals,actuals),env));}
+
+ #define ENVLOOKUP_TRICK 1
+
+ LISP envlookup(LISP var,LISP env)
+ {LISP frame,al,fl,tmp;
+ for(frame=env;CONSP(frame);frame=CDR(frame))
+ {tmp = CAR(frame);
+ if NCONSP(tmp) err("damaged frame",tmp);
+ for(fl=CAR(tmp),al=CDR(tmp);CONSP(fl);fl=CDR(fl),al=CDR(al))
+ {if NCONSP(al) err("too few arguments",tmp);
+ if EQ(CAR(fl),var) return(al);}
+ /* suggested by a user. It works for reference (although conses)
+ but doesn't allow for set! to work properly... */
+ #if (ENVLOOKUP_TRICK)
+ if (SYMBOLP(fl) && EQ(fl, var)) return(cons(al, NIL));
+ #endif
+ }
+ if NNULLP(frame) err("damaged env",env);
+ return(NIL);}
+
+ void set_eval_hooks(long type,LISP (*fcn)(LISP, LISP *,LISP *))
+ {struct user_type_hooks *p;
+ p = get_user_type_hooks(type);
+ p->leval = fcn;}
+
+ LISP err_closure_code(LISP tmp)
+ {return(err("closure code type not valid",tmp));}
+
+ LISP leval(LISP x,LISP env)
+ {LISP tmp,arg1;
+ struct user_type_hooks *p;
+ STACK_CHECK(&x);
+ loop:
+ INTERRUPT_CHECK();
+ tmp = VCELL(sym_eval_history_ptr);
+ if TYPEP(tmp,tc_cons)
+ {CAR(tmp) = x;
+ VCELL(sym_eval_history_ptr) = CDR(tmp);}
+ switch TYPE(x)
+ {case tc_symbol:
+ tmp = envlookup(x,env);
+ if NNULLP(tmp) return(CAR(tmp));
+ tmp = VCELL(x);
+ if EQ(tmp,unbound_marker) err_ubv(x);
+ return(tmp);
+ case tc_cons:
+ tmp = CAR(x);
+ switch TYPE(tmp)
+ {case tc_symbol:
+ tmp = envlookup(tmp,env);
+ if NNULLP(tmp)
+ {tmp = CAR(tmp);
+ break;}
+ tmp = VCELL(CAR(x));
+ if EQ(tmp,unbound_marker) err_ubv(CAR(x));
+ break;
+ case tc_cons:
+ tmp = leval(tmp,env);
+ break;}
+ switch TYPE(tmp)
+ {case tc_subr_0:
+ return(SUBR0(tmp)());
+ case tc_subr_1:
+ return(SUBR1(tmp)(leval(car(CDR(x)),env)));
+ case tc_subr_2:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR2(tmp)(arg1,
+ leval(car(x),env)));
+ case tc_subr_2n:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ arg1 = SUBR2(tmp)(arg1,
+ leval(car(x),env));
+ for(x=cdr(x);CONSP(x);x=CDR(x))
+ arg1 = SUBR2(tmp)(arg1,leval(CAR(x),env));
+ return(arg1);
+ case tc_subr_3:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR3(tmp)(arg1,
+ leval(car(x),env),
+ leval(car(cdr(x)),env)));
+
+ case tc_subr_4:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR4(tmp)(arg1,
+ leval(car(x),env),
+ leval(car(cdr(x)),env),
+ leval(car(cdr(cdr(x))),env)));
+
+ case tc_subr_5:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR5(tmp)(arg1,
+ leval(car(x),env),
+ leval(car(cdr(x)),env),
+ leval(car(cdr(cdr(x))),env),
+ leval(car(cdr(cdr(cdr(x)))),env)));
+
+ case tc_lsubr:
+ return(SUBR1(tmp)(leval_args(CDR(x),env)));
+ case tc_fsubr:
+ return(SUBR2(tmp)(CDR(x),env));
+ case tc_msubr:
+ if NULLP(SUBRM(tmp)(&x,&env)) return(x);
+ goto loop;
+ case tc_closure:
+ switch TYPE((*tmp).storage_as.closure.code)
+ {case tc_cons:
+ env = extend_env(leval_args(CDR(x),env),
+ CAR((*tmp).storage_as.closure.code),
+ (*tmp).storage_as.closure.env);
+ x = CDR((*tmp).storage_as.closure.code);
+ goto loop;
+ case tc_subr_1:
+ return(SUBR1(tmp->storage_as.closure.code)
+ (tmp->storage_as.closure.env));
+ case tc_subr_2:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ return(SUBR2(tmp->storage_as.closure.code)
+ (tmp->storage_as.closure.env,arg1));
+ case tc_subr_3:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR3(tmp->storage_as.closure.code)
+ (tmp->storage_as.closure.env,
+ arg1,
+ leval(car(x),env)));
+ case tc_subr_4:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR4(tmp->storage_as.closure.code)
+ (tmp->storage_as.closure.env,
+ arg1,
+ leval(car(x),env),
+ leval(car(cdr(x)),env)));
+ case tc_subr_5:
+ x = CDR(x);
+ arg1 = leval(car(x),env);
+ x = NULLP(x) ? NIL : CDR(x);
+ return(SUBR5(tmp->storage_as.closure.code)
+ (tmp->storage_as.closure.env,
+ arg1,
+ leval(car(x),env),
+ leval(car(cdr(x)),env),
+ leval(car(cdr(cdr(x))),env)));
+
+ case tc_lsubr:
+ return(SUBR1(tmp->storage_as.closure.code)
+ (cons(tmp->storage_as.closure.env,
+ leval_args(CDR(x),env))));
+ default:
+ err_closure_code(tmp);}
+ break;
+ case tc_symbol:
+ x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
+ x = leval(x,NIL);
+ goto loop;
+ default:
+ p = get_user_type_hooks(TYPE(tmp));
+ if (p->leval)
+ {if NULLP((*p->leval)(tmp,&x,&env)) return(x); else goto loop;}
+ err("bad function",tmp);}
+ default:
+ return(x);}}
+
+ LISP lapply(LISP fcn,LISP args)
+ {struct user_type_hooks *p;
+ LISP acc;
+ STACK_CHECK(&fcn);
+ INTERRUPT_CHECK();
+ switch TYPE(fcn)
+ {case tc_subr_0:
+ return(SUBR0(fcn)());
+ case tc_subr_1:
+ return(SUBR1(fcn)(car(args)));
+ case tc_subr_2:
+ return(SUBR2(fcn)(car(args),car(cdr(args))));
+ case tc_subr_2n:
+ acc = SUBR2(fcn)(car(args),car(cdr(args)));
+ for(args=cdr(cdr(args));CONSP(args);args=CDR(args))
+ acc = SUBR2(fcn)(acc,CAR(args));
+ return(acc);
+ case tc_subr_3:
+ return(SUBR3(fcn)(car(args),car(cdr(args)),car(cdr(cdr(args)))));
+ case tc_subr_4:
+ return(SUBR4(fcn)(car(args),car(cdr(args)),car(cdr(cdr(args))),
+ car(cdr(cdr(cdr(args))))));
+ case tc_subr_5:
+ return(SUBR5(fcn)(car(args),car(cdr(args)),car(cdr(cdr(args))),
+ car(cdr(cdr(cdr(args)))),
+ car(cdr(cdr(cdr(cdr(args)))))));
+ case tc_lsubr:
+ return(SUBR1(fcn)(args));
+ case tc_fsubr:
+ case tc_msubr:
+ case tc_symbol:
+ return(err("cannot be applied",fcn));
+ case tc_closure:
+ switch TYPE(fcn->storage_as.closure.code)
+ {case tc_cons:
+ return(leval(cdr(fcn->storage_as.closure.code),
+ extend_env(args,
+ car(fcn->storage_as.closure.code),
+ fcn->storage_as.closure.env)));
+ case tc_subr_1:
+ return(SUBR1(fcn->storage_as.closure.code)
+ (fcn->storage_as.closure.env));
+ case tc_subr_2:
+ return(SUBR2(fcn->storage_as.closure.code)
+ (fcn->storage_as.closure.env,
+ car(args)));
+ case tc_subr_3:
+ return(SUBR3(fcn->storage_as.closure.code)
+ (fcn->storage_as.closure.env,
+ car(args),car(cdr(args))));
+ case tc_subr_4:
+ return(SUBR4(fcn->storage_as.closure.code)
+ (fcn->storage_as.closure.env,
+ car(args),car(cdr(args)),car(cdr(cdr(args)))));
+ case tc_subr_5:
+ return(SUBR5(fcn->storage_as.closure.code)
+ (fcn->storage_as.closure.env,
+ car(args),car(cdr(args)),car(cdr(cdr(args))),
+ car(cdr(cdr(cdr(args))))));
+ case tc_lsubr:
+ return(SUBR1(fcn->storage_as.closure.code)
+ (cons(fcn->storage_as.closure.env,args)));
+ default:
+ return(err_closure_code(fcn));}
+ default:
+ p = get_user_type_hooks(TYPE(fcn));
+ if (p->leval)
+ return(err("have eval, dont know apply",fcn));
+ else
+ return(err("cannot be applied",fcn));}}
+
+ LISP setvar(LISP var,LISP val,LISP env)
+ {LISP tmp;
+ if NSYMBOLP(var) err("wta(non-symbol) to setvar",var);
+ tmp = envlookup(var,env);
+ if NULLP(tmp) return(VCELL(var) = val);
+ return(CAR(tmp)=val);}
+
+ LISP leval_setq(LISP args,LISP env)
+ {return(setvar(car(args),leval(car(cdr(args)),env),env));}
+
+ LISP syntax_define(LISP args)
+ {if SYMBOLP(car(args)) return(args);
+ return(syntax_define(
+ cons(car(car(args)),
+ cons(cons(sym_lambda,
+ cons(cdr(car(args)),
+ cdr(args))),
+ NIL))));}
+
+ LISP leval_define(LISP args,LISP env)
+ {LISP tmp,var,val;
+ tmp = syntax_define(args);
+ var = car(tmp);
+ if NSYMBOLP(var) err("wta(non-symbol) to define",var);
+ val = leval(car(cdr(tmp)),env);
+ tmp = envlookup(var,env);
+ if NNULLP(tmp) return(CAR(tmp) = val);
+ if NULLP(env) return(VCELL(var) = val);
+ tmp = car(env);
+ setcar(tmp,cons(var,car(tmp)));
+ setcdr(tmp,cons(val,cdr(tmp)));
+ return(val);}
+
+ LISP leval_if(LISP *pform,LISP *penv)
+ {LISP args,env;
+ args = cdr(*pform);
+ env = *penv;
+ if NNULLP(leval(car(args),env))
+ *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
+ return(sym_t);}
+
+ LISP leval_lambda(LISP args,LISP env)
+ {LISP body;
+ if NULLP(cdr(cdr(args)))
+ body = car(cdr(args));
+ else body = cons(sym_progn,cdr(args));
+ return(closure(env,cons(arglchk(car(args)),body)));}
+
+ LISP leval_progn(LISP *pform,LISP *penv)
+ {LISP env,l,next;
+ env = *penv;
+ l = cdr(*pform);
+ next = cdr(l);
+ while(NNULLP(next)) {leval(car(l),env);l=next;next=cdr(next);}
+ *pform = car(l);
+ return(sym_t);}
+
+ LISP leval_or(LISP *pform,LISP *penv)
+ {LISP env,l,next,val;
+ env = *penv;
+ l = cdr(*pform);
+ next = cdr(l);
+ while(NNULLP(next))
+ {val = leval(car(l),env);
+ if NNULLP(val) {*pform = val; return(NIL);}
+ l=next;next=cdr(next);}
+ *pform = car(l);
+ return(sym_t);}
+
+ LISP leval_and(LISP *pform,LISP *penv)
+ {LISP env,l,next;
+ env = *penv;
+ l = cdr(*pform);
+ if NULLP(l) {*pform = sym_t; return(NIL);}
+ next = cdr(l);
+ while(NNULLP(next))
+ {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
+ l=next;next=cdr(next);}
+ *pform = car(l);
+ return(sym_t);}
+
+ LISP leval_catch_1(LISP forms,LISP env)
+ {LISP l,val = NIL;
+ for(l=forms; NNULLP(l); l = cdr(l))
+ val = leval(car(l),env);
+ catch_framep = catch_framep->next;
+ return(val);}
+
+ LISP leval_catch(LISP args,LISP env)
+ {struct catch_frame frame;
+ int k;
+ frame.tag = leval(car(args),env);
+ frame.next = catch_framep;
+ k = setjmp(frame.cframe);
+ catch_framep = &frame;
+ if (k == 2)
+ {catch_framep = frame.next;
+ return(frame.retval);}
+ return(leval_catch_1(cdr(args),env));}
+
+ LISP lthrow(LISP tag,LISP value)
+ {struct catch_frame *l;
+ for(l=catch_framep; l; l = (*l).next)
+ if (EQ((*l).tag,tag) ||
+ EQ((*l).tag,sym_catchall))
+ {(*l).retval = value;
+ longjmp((*l).cframe,2);}
+ err("no *catch found with this tag",tag);
+ return(NIL);}
+
+ LISP leval_let(LISP *pform,LISP *penv)
+ {LISP env,l;
+ l = cdr(*pform);
+ env = *penv;
+ *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
+ *pform = car(cdr(cdr(l)));
+ return(sym_t);}
+
+ LISP letstar_macro(LISP form)
+ {LISP bindings = cadr(form);
+ if (NNULLP(bindings) && NNULLP(cdr(bindings)))
+ setcdr(form,cons(cons(car(bindings),NIL),
+ cons(cons(cintern("let*"),
+ cons(cdr(bindings),
+ cddr(form))),
+ NIL)));
+ setcar(form,cintern("let"));
+ return(form);}
+
+ LISP letrec_macro(LISP form)
+ {LISP letb,setb,l;
+ for(letb=NIL,setb=cddr(form),l=cadr(form);NNULLP(l);l=cdr(l))
+ {letb = cons(cons(caar(l),NIL),letb);
+ setb = cons(listn(3,cintern("set!"),caar(l),cadar(l)),setb);}
+ setcdr(form,cons(letb,setb));
+ setcar(form,cintern("let"));
+ return(form);}
+
+ LISP reverse(LISP l)
+ {LISP n,p;
+ n = NIL;
+ for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
+ return(n);}
+
+ LISP let_macro(LISP form)
+ {LISP p,fl,al,tmp;
+ fl = NIL;
+ al = NIL;
+ for(p=car(cdr(form));NNULLP(p);p=cdr(p))
+ {tmp = car(p);
+ if SYMBOLP(tmp) {fl = cons(tmp,fl); al = cons(NIL,al);}
+ else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
+ p = cdr(cdr(form));
+ if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
+ setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
+ setcar(form,cintern("let-internal"));
+ return(form);}
+
+ LISP leval_quote(LISP args,LISP env)
+ {return(car(args));}
+
+ LISP leval_tenv(LISP args,LISP env)
+ {return(env);}
+
+ LISP leval_while(LISP args,LISP env)
+ {LISP l;
+ while NNULLP(leval(car(args),env))
+ for(l=cdr(args);NNULLP(l);l=cdr(l))
+ leval(car(l),env);
+ return(NIL);}
+
+ LISP symbolconc(LISP args)
+ {long size;
+ LISP l,s;
+ size = 0;
+ tkbuffer[0] = 0;
+ for(l=args;NNULLP(l);l=cdr(l))
+ {s = car(l);
+ if NSYMBOLP(s) err("wta(non-symbol) to symbolconc",s);
+ size = size + strlen(PNAME(s));
+ if (size > TKBUFFERN) err("symbolconc buffer overflow",NIL);
+ strcat(tkbuffer,PNAME(s));}
+ return(rintern(tkbuffer));}
+
+ void set_print_hooks(long type,void (*fcn)(LISP,struct gen_printio *))
+ {struct user_type_hooks *p;
+ p = get_user_type_hooks(type);
+ p->prin1 = fcn;}
+
+ char *subr_kind_str(long n)
+ {switch(n)
+ {case tc_subr_0: return("subr_0");
+ case tc_subr_1: return("subr_1");
+ case tc_subr_2: return("subr_2");
+ case tc_subr_2n: return("subr_2n");
+ case tc_subr_3: return("subr_3");
+ case tc_subr_4: return("subr_4");
+ case tc_subr_5: return("subr_5");
+ case tc_lsubr: return("lsubr");
+ case tc_fsubr: return("fsubr");
+ case tc_msubr: return("msubr");
+ default: return("???");}}
+
+ LISP lprin1g(LISP exp,struct gen_printio *f)
+ {LISP tmp;
+ long n;
+ struct user_type_hooks *p;
+ STACK_CHECK(&exp);
+ INTERRUPT_CHECK();
+ switch TYPE(exp)
+ {case tc_nil:
+ gput_st(f,"()");
+ break;
+ case tc_cons:
+ gput_st(f,"(");
+ lprin1g(car(exp),f);
+ for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
+ {gput_st(f," ");lprin1g(car(tmp),f);}
+ if NNULLP(tmp) {gput_st(f," . ");lprin1g(tmp,f);}
+ gput_st(f,")");
+ break;
+ case tc_flonum:
+ n = (long) FLONM(exp);
+ if (((double) n) == FLONM(exp))
+ sprintf(tkbuffer,"%ld",n);
+ else
+ sprintf(tkbuffer,"%g",FLONM(exp));
+ gput_st(f,tkbuffer);
+ break;
+ case tc_symbol:
+ gput_st(f,PNAME(exp));
+ break;
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_2n:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ sprintf(tkbuffer,"#<%s ",subr_kind_str(TYPE(exp)));
+ gput_st(f,tkbuffer);
+ gput_st(f,(*exp).storage_as.subr.name);
+ gput_st(f,">");
+ break;
+ case tc_closure:
+ gput_st(f,"#<CLOSURE ");
+ if CONSP((*exp).storage_as.closure.code)
+ {lprin1g(car((*exp).storage_as.closure.code),f);
+ gput_st(f," ");
+ lprin1g(cdr((*exp).storage_as.closure.code),f);}
+ else
+ lprin1g((*exp).storage_as.closure.code,f);
+ gput_st(f,">");
+ break;
+ default:
+ p = get_user_type_hooks(TYPE(exp));
+ if (p->prin1)
+ (*p->prin1)(exp,f);
+ else
+ {sprintf(tkbuffer,"#<UNKNOWN %d %p>",TYPE(exp),exp);
+ gput_st(f,tkbuffer);}}
+ return(NIL);}
+
+ LISP lprint(LISP exp,LISP lf)
+ {FILE *f = get_c_file(lf,stdout);
+ lprin1f(exp,f);
+ fput_st(f,"\n");
+ return(NIL);}
+
+ LISP lprin1(LISP exp,LISP lf)
+ {FILE *f = get_c_file(lf,stdout);
+ lprin1f(exp,f);
+ return(NIL);}
+
+ LISP lprin1f(LISP exp,FILE *f)
+ {struct gen_printio s;
+ s.putc_fcn = NULL;
+ s.puts_fcn = fputs_fcn;
+ s.cb_argument = f;
+ lprin1g(exp,&s);
+ return(NIL);}
+
+ LISP lread(LISP f)
+ {return(lreadf(get_c_file(f,stdin)));}
+
+ int f_getc(FILE *f)
+ {long iflag,dflag;
+ int c;
+ iflag = no_interrupt(1);
+ dflag = interrupt_differed;
+ c = getc(f);
+ #ifdef VMS
+ if ((dflag == 0) & interrupt_differed & (f == stdin))
+ while((c != 0) & (c != EOF)) c = getc(f);
+ #endif
+ no_interrupt(iflag);
+ return(c);}
+
+ void f_ungetc(int c, FILE *f)
+ {ungetc(c,f);}
+
+ int flush_ws(struct gen_readio *f,char *eoferr)
+ {int c,commentp;
+ commentp = 0;
+ while(1)
+ {c = GETC_FCN(f);
+ if (c == EOF) if (eoferr) err(eoferr,NIL); else return(c);
+ if (commentp) {if (c == '\n') commentp = 0;}
+ else if (c == ';') commentp = 1;
+ else if (!isspace(c)) return(c);}}
+
+ LISP lreadf(FILE *f)
+ {struct gen_readio s;
+ s.getc_fcn = (int (*)(void *)) f_getc;
+ s.ungetc_fcn = (void (*)(int,void *)) f_ungetc;
+ s.cb_argument = (char *) f;
+ return(readtl(&s));}
+
+ LISP readtl(struct gen_readio *f)
+ {int c;
+ c = flush_ws(f,(char *)NULL);
+ if (c == EOF) return(eof_val);
+ UNGETC_FCN(c,f);
+ return(lreadr(f));}
+
+ void set_read_hooks(char *all_set,char *end_set,
+ LISP (*fcn1)(int, struct gen_readio *),
+ LISP (*fcn2)(char *,long, int *))
+ {user_ch_readm = all_set;
+ user_te_readm = end_set;
+ user_readm = fcn1;
+ user_readt = fcn2;}
+
+ LISP lreadr(struct gen_readio *f)
+ {int c,j;
+ char *p,*buffer=tkbuffer;
+ STACK_CHECK(&f);
+ p = buffer;
+ c = flush_ws(f,"end of file inside read");
+ switch (c)
+ {case '(':
+ return(lreadparen(f));
+ case ')':
+ err("unexpected close paren",NIL);
+ case '\'':
+ return(cons(sym_quote,cons(lreadr(f),NIL)));
+ case '`':
+ return(cons(cintern("+internal-backquote"),lreadr(f)));
+ case ',':
+ c = GETC_FCN(f);
+ switch(c)
+ {case '@':
+ p = "+internal-comma-atsign";
+ break;
+ case '.':
+ p = "+internal-comma-dot";
+ break;
+ default:
+ p = "+internal-comma";
+ UNGETC_FCN(c,f);}
+ return(cons(cintern(p),lreadr(f)));
+ case '"':
+ return(lreadstring(f));
+ case '#':
+ return(lreadsharp(f));
+ default:
+ if ((user_readm != NULL) && strchr(user_ch_readm,c))
+ return((*user_readm)(c,f));}
+ *p++ = c;
+ for(j = 1; j<TKBUFFERN; ++j)
+ {c = GETC_FCN(f);
+ if (c == EOF) return(lreadtk(buffer,j));
+ if (isspace(c)) return(lreadtk(buffer,j));
+ if (strchr("()'`,;\"",c) || strchr(user_te_readm,c))
+ {UNGETC_FCN(c,f);return(lreadtk(buffer,j));}
+ *p++ = c;}
+ return(err("token larger than TKBUFFERN",NIL));}
+
+ LISP lreadparen(struct gen_readio *f)
+ {int c;
+ LISP tmp;
+ c = flush_ws(f,"end of file inside list");
+ if (c == ')') return(NIL);
+ UNGETC_FCN(c,f);
+ tmp = lreadr(f);
+ if EQ(tmp,sym_dot)
+ {tmp = lreadr(f);
+ c = flush_ws(f,"end of file inside list");
+ if (c != ')') err("missing close paren",NIL);
+ return(tmp);}
+ return(cons(tmp,lreadparen(f)));}
+
+ LISP lreadtk(char *buffer,long j)
+ {int flag;
+ LISP tmp;
+ int adigit;
+ char *p = buffer;
+ p[j] = 0;
+ if (user_readt != NULL)
+ {tmp = (*user_readt)(p,j,&flag);
+ if (flag) return(tmp);}
+ if (*p == '-') p+=1;
+ adigit = 0;
+ while(isdigit(*p)) {p+=1; adigit=1;}
+ if (*p=='.')
+ {p += 1;
+ while(isdigit(*p)) {p+=1; adigit=1;}}
+ if (!adigit) goto a_symbol;
+ if (*p=='e')
+ {p+=1;
+ if (*p=='-'||*p=='+') p+=1;
+ if (!isdigit(*p)) goto a_symbol; else p+=1;
+ while(isdigit(*p)) p+=1;}
+ if (*p) goto a_symbol;
+ return(flocons(atof(buffer)));
+ a_symbol:
+ return(rintern(buffer));}
+
+ LISP copy_list(LISP x)
+ {if NULLP(x) return(NIL);
+ STACK_CHECK(&x);
+ return(cons(car(x),copy_list(cdr(x))));}
+
+ LISP apropos(LISP matchl)
+ {LISP result = NIL,l,ml;
+ char *pname;
+ for(l=oblistvar;CONSP(l);l=CDR(l))
+ {pname = get_c_string(CAR(l));
+ ml=matchl;
+ while(CONSP(ml) && strstr(pname,get_c_string(CAR(ml))))
+ ml=CDR(ml);
+ if NULLP(ml)
+ result = cons(CAR(l),result);}
+ return(result);}
+
+ LISP fopen_cg(FILE *(*fcn)(const char *,const char *),char *name,char *how)
+ {LISP sym;
+ long flag;
+ char errmsg[256];
+ flag = no_interrupt(1);
+ sym = newcell(tc_c_file);
+ sym->storage_as.c_file.f = (FILE *)NULL;
+ sym->storage_as.c_file.name = (char *)NULL;
+ if (!(sym->storage_as.c_file.f = (*fcn)(name,how)))
+ {SAFE_STRCPY(errmsg,"could not open ");
+ SAFE_STRCAT(errmsg,name);
+ err(errmsg,llast_c_errmsg(-1));}
+ sym->storage_as.c_file.name = (char *) must_malloc(strlen(name)+1);
+ strcpy(sym->storage_as.c_file.name,name);
+ no_interrupt(flag);
+ return(sym);}
+
+ LISP fopen_c(char *name,char *how)
+ {return(fopen_cg(fopen,name,how));}
+
+ LISP fopen_l(LISP name,LISP how)
+ {return(fopen_c(get_c_string(name),NULLP(how) ? "r" : get_c_string(how)));}
+
+ LISP delq(LISP elem,LISP l)
+ {if NULLP(l) return(l);
+ STACK_CHECK(&elem);
+ if EQ(elem,car(l)) return(delq(elem,cdr(l)));
+ setcdr(l,delq(elem,cdr(l)));
+ return(l);}
+
+ LISP fclose_l(LISP p)
+ {long flag;
+ flag = no_interrupt(1);
+ if NTYPEP(p,tc_c_file) err("not a file",p);
+ file_gc_free(p);
+ no_interrupt(flag);
+ return(NIL);}
+
+ LISP vload(char *ofname,long cflag,long rflag)
+ {LISP form,result,tail,lf,reader = NIL;
+ FILE *f;
+ int c;
+ long j,len;
+ char buffer[512],*key = "parser:",*start,*end,*ftype=".scm",*fname;
+ if ((start = strchr(ofname,VLOAD_OFFSET_HACK_CHAR)))
+ {len = atol(ofname);
+ fname = &start[1];}
+ else
+ {len = 0;
+ fname = ofname;}
+ if (rflag)
+ {int iflag;
+ iflag = no_interrupt(1);
+ if ((f = fopen(fname,"r")))
+ fclose(f);
+ else if ((fname[0] != '/') &&
+ ((strlen(siod_lib) + strlen(fname) + 1)
+ < sizeof(buffer)))
+ {strcpy(buffer,siod_lib);
+ #ifdef unix
+ strcat(buffer,"/");
+ #endif
+ strcat(buffer,fname);
+ if ((f = fopen(buffer,"r")))
+ {fname = buffer;
+ fclose(f);}}
+ no_interrupt(iflag);}
+ if (siod_verbose_level >= 3)
+ {put_st("loading ");
+ put_st(fname);
+ put_st("\n");}
+ lf = fopen_c(fname,(len) ? "rb" : "r");
+ f = lf->storage_as.c_file.f;
+ result = NIL;
+ tail = NIL;
+ for(j=0;j<len;++j) getc(f);
+ j = 0;
+ buffer[0] = 0;
+ c = getc(f);
+ while((c == '#') || (c == ';'))
+ {while(((c = getc(f)) != EOF) && (c != '\n'))
+ if ((j+1)<sizeof(buffer))
+ {buffer[j] = c;
+ buffer[++j] = 0;}
+ if (c == '\n')
+ c = getc(f);}
+ if (c != EOF)
+ ungetc(c,f);
+ if ((start = strstr(buffer,key)))
+ {for(end = &start[strlen(key)];
+ *end && isalnum(*end);
+ ++end);
+ j = end - start;
+ memmove(buffer,start,j);
+ buffer[strlen(key)-1] = '_';
+ buffer[j] = 0;
+ strcat(buffer,ftype);
+ require(strcons(-1,buffer));
+ buffer[j] = 0;
+ reader = rintern(buffer);
+ reader = funcall1(leval(reader,NIL),reader);
+ if (siod_verbose_level >= 5)
+ {put_st("parser:");
+ lprin1(reader,NIL);
+ put_st("\n");}}
+ while(1)
+ {form = NULLP(reader) ? lread(lf) : funcall1(reader,lf);
+ if EQ(form,eof_val) break;
+ if (siod_verbose_level >= 5)
+ lprint(form,NIL);
+ if (cflag)
+ {form = cons(form,NIL);
+ if NULLP(result)
+ result = tail = form;
+ else
+ tail = setcdr(tail,form);}
+ else
+ leval(form,NIL);}
+ fclose_l(lf);
+ if (siod_verbose_level >= 3)
+ put_st("done.\n");
+ return(result);}
+
+ LISP load(LISP fname,LISP cflag,LISP rflag)
+ {return(vload(get_c_string(fname),NULLP(cflag) ? 0 : 1,NULLP(rflag) ? 0 : 1));}
+
+ LISP require(LISP fname)
+ {LISP sym;
+ sym = intern(string_append(cons(cintern("*"),
+ cons(fname,
+ cons(cintern("-loaded*"),NIL)))));
+ if (NULLP(symbol_boundp(sym,NIL)) ||
+ NULLP(symbol_value(sym,NIL)))
+ {load(fname,NIL,sym_t);
+ setvar(sym,sym_t,NIL);}
+ return(sym);}
+
+ LISP save_forms(LISP fname,LISP forms,LISP how)
+ {char *cname,*chow = NULL;
+ LISP l,lf;
+ FILE *f;
+ cname = get_c_string(fname);
+ if EQ(how,NIL) chow = "w";
+ else if EQ(how,cintern("a")) chow = "a";
+ else err("bad argument to save-forms",how);
+ if (siod_verbose_level >= 3)
+ {put_st((*chow == 'a') ? "appending" : "saving");
+ put_st(" forms to ");
+ put_st(cname);
+ put_st("\n");}
+ lf = fopen_c(cname,chow);
+ f = lf->storage_as.c_file.f;
+ for(l=forms;NNULLP(l);l=cdr(l))
+ {lprin1f(car(l),f);
+ putc('\n',f);}
+ fclose_l(lf);
+ if (siod_verbose_level >= 3)
+ put_st("done.\n");
+ return(sym_t);}
+
+ LISP quit(void)
+ {return(err(NULL,NIL));}
+
+ LISP nullp(LISP x)
+ {if EQ(x,NIL) return(sym_t); else return(NIL);}
+
+ LISP arglchk(LISP x)
+ {
+ #if (!ENVLOOKUP_TRICK)
+ LISP l;
+ if SYMBOLP(x) return(x);
+ for(l=x;CONSP(l);l=CDR(l));
+ if NNULLP(l) err("improper formal argument list",x);
+ #endif
+ return(x);}
+
+ void file_gc_free(LISP ptr)
+ {if (ptr->storage_as.c_file.f)
+ {fclose(ptr->storage_as.c_file.f);
+ ptr->storage_as.c_file.f = (FILE *) NULL;}
+ if (ptr->storage_as.c_file.name)
+ {free(ptr->storage_as.c_file.name);
+ ptr->storage_as.c_file.name = NULL;}}
+
+ void file_prin1(LISP ptr,struct gen_printio *f)
+ {char *name;
+ name = ptr->storage_as.c_file.name;
+ gput_st(f,"#<FILE ");
+ sprintf(tkbuffer," %p",ptr->storage_as.c_file.f);
+ gput_st(f,tkbuffer);
+ if (name)
+ {gput_st(f," ");
+ gput_st(f,name);}
+ gput_st(f,">");}
+
+ FILE *get_c_file(LISP p,FILE *deflt)
+ {if (NULLP(p) && deflt) return(deflt);
+ if NTYPEP(p,tc_c_file) err("not a file",p);
+ if (!p->storage_as.c_file.f) err("file is closed",p);
+ return(p->storage_as.c_file.f);}
+
+ LISP lgetc(LISP p)
+ {int i;
+ i = f_getc(get_c_file(p,stdin));
+ return((i == EOF) ? NIL : flocons((double)i));}
+
+ LISP lungetc(LISP ii,LISP p)
+ {int i;
+ if NNULLP(ii)
+ {i = get_c_long(ii);
+ f_ungetc(i,get_c_file(p,stdin));}
+ return(NIL);}
+
+ LISP lputc(LISP c,LISP p)
+ {long flag;
+ int i;
+ FILE *f;
+ f = get_c_file(p,stdout);
+ if FLONUMP(c)
+ i = (int)FLONM(c);
+ else
+ i = *get_c_string(c);
+ flag = no_interrupt(1);
+ putc(i,f);
+ no_interrupt(flag);
+ return(NIL);}
+
+ LISP lputs(LISP str,LISP p)
+ {fput_st(get_c_file(p,stdout),get_c_string(str));
+ return(NIL);}
+
+ LISP lftell(LISP file)
+ {return(flocons((double)ftell(get_c_file(file,NULL))));}
+
+ LISP lfseek(LISP file,LISP offset,LISP direction)
+ {return((fseek(get_c_file(file,NULL),get_c_long(offset),get_c_long(direction)))
+ ? NIL : sym_t);}
+
+ LISP parse_number(LISP x)
+ {char *c;
+ c = get_c_string(x);
+ return(flocons(atof(c)));}
+
+ void __stdcall init_subrs(void)
+ {init_subrs_1();
+ init_subrs_a();}
+
+ LISP closure_code(LISP exp)
+ {return(exp->storage_as.closure.code);}
+
+ LISP closure_env(LISP exp)
+ {return(exp->storage_as.closure.env);}
+
+ LISP lwhile(LISP form,LISP env)
+ {LISP l;
+ while(NNULLP(leval(car(form),env)))
+ for(l=cdr(form);NNULLP(l);l=cdr(l))
+ leval(car(l),env);
+ return(NIL);}
+
+ LISP nreverse(LISP x)
+ {LISP newp,oldp,nextp;
+ newp = NIL;
+ for(oldp=x;CONSP(oldp);oldp=nextp)
+ {nextp=CDR(oldp);
+ CDR(oldp) = newp;
+ newp = oldp;}
+ return(newp);}
+
+ LISP siod_verbose(LISP arg)
+ {if NNULLP(arg)
+ siod_verbose_level = get_c_long(car(arg));
+ return(flocons(siod_verbose_level));}
+
+ int __stdcall siod_verbose_check(int level)
+ {return((siod_verbose_level >= level) ? 1 : 0);}
+
+ LISP lruntime(void)
+ {return(cons(flocons(myruntime()),
+ cons(flocons(gc_time_taken),NIL)));}
+
+ LISP lrealtime(void)
+ {return(flocons(myrealtime()));}
+
+ LISP caar(LISP x)
+ {return(car(car(x)));}
+
+ LISP cadr(LISP x)
+ {return(car(cdr(x)));}
+
+ LISP cdar(LISP x)
+ {return(cdr(car(x)));}
+
+ LISP cddr(LISP x)
+ {return(cdr(cdr(x)));}
+
+ LISP lrand(LISP m)
+ {long res;
+ res = rand();
+ if NULLP(m)
+ return(flocons(res));
+ else
+ return(flocons(res % get_c_long(m)));}
+
+ LISP lsrand(LISP s)
+ {srand(get_c_long(s));
+ return(NIL);}
+
+ LISP a_true_value(void)
+ {return(sym_t);}
+
+ LISP poparg(LISP *ptr,LISP defaultv)
+ {LISP value;
+ if NULLP(*ptr)
+ return(defaultv);
+ value = car(*ptr);
+ *ptr = cdr(*ptr);
+ return(value);}
+
+ char *last_c_errmsg(int num)
+ {int xerrno = (num < 0) ? errno : num;
+ static char serrmsg[100];
+ char *errmsg;
+ errmsg = strerror(xerrno);
+ if (!errmsg)
+ {sprintf(serrmsg,"errno %d",xerrno);
+ errmsg = serrmsg;}
+ return(errmsg);}
+
+ LISP llast_c_errmsg(int num)
+ {int xerrno = (num < 0) ? errno : num;
+ char *errmsg = strerror(xerrno);
+ if (!errmsg) return(flocons(xerrno));
+ return(cintern(errmsg));}
+
+ LISP lllast_c_errmsg(void)
+ {return(llast_c_errmsg(-1));}
+
+ size_t safe_strlen(const char *s,size_t size)
+ {char *end;
+ if ((end = (char *)memchr(s,0,size)))
+ return(end - s);
+ else
+ return(size);}
+
+ char *safe_strcpy(char *s1,size_t size1,const char *s2)
+ {size_t len2;
+ if (size1 == 0) return(s1);
+ len2 = strlen(s2);
+ if (len2 < size1)
+ {if (len2) memcpy(s1,s2,len2);
+ s1[len2] = 0;}
+ else
+ {memcpy(s1,s2,size1);
+ s1[size1-1] = 0;}
+ return(s1);}
+
+ char *safe_strcat(char *s1,size_t size1,const char *s2)
+ {size_t len1;
+ len1 = safe_strlen(s1,size1);
+ safe_strcpy(&s1[len1],size1 - len1,s2);
+ return(s1);}
+
+ static LISP parser_read(LISP ignore)
+ {return(leval(cintern("read"),NIL));}
+
+ static LISP os_classification(void)
+ {
+ #ifdef unix
+ return(cintern("unix"));
+ #endif
+ #ifdef WIN32
+ return(cintern("win32"));
+ #endif
+ #ifdef VMS
+ return(cintern("vms"));
+ #endif
+ return(NIL);}
+
+ void init_subrs_1(void)
+ {init_subr_2("cons",cons);
+ init_subr_1("car",car);
+ init_subr_1("cdr",cdr);
+ init_subr_2("set-car!",setcar);
+ init_subr_2("set-cdr!",setcdr);
+ init_subr_2n("+",plus);
+ init_subr_2n("-",difference);
+ init_subr_2n("*",ltimes);
+ init_subr_2n("/",Quotient);
+ init_subr_2n("min",lmin);
+ init_subr_2n("max",lmax);
+ init_subr_1("abs",lllabs);
+ init_subr_1("sqrt",lsqrt);
+ init_subr_2(">",greaterp);
+ init_subr_2("<",lessp);
+ init_subr_2(">=",greaterEp);
+ init_subr_2("<=",lessEp);
+ init_subr_2("eq?",eq);
+ init_subr_2("eqv?",eql);
+ init_subr_2("=",eql);
+ init_subr_2("assq",assq);
+ init_subr_2("delq",delq);
+ init_subr_1("read",lread);
+ init_subr_1("parser_read",parser_read);
+ setvar(cintern("*parser_read.scm-loaded*"),sym_t,NIL);
+ init_subr_0("eof-val",get_eof_val);
+ init_subr_2("print",lprint);
+ init_subr_2("prin1",lprin1);
+ init_subr_2("eval",leval);
+ init_subr_2("apply",lapply);
+ init_fsubr("define",leval_define);
+ init_fsubr("lambda",leval_lambda);
+ init_msubr("if",leval_if);
+ init_fsubr("while",leval_while);
+ init_msubr("begin",leval_progn);
+ init_fsubr("set!",leval_setq);
+ init_msubr("or",leval_or);
+ init_msubr("and",leval_and);
+ init_fsubr("*catch",leval_catch);
+ init_subr_2("*throw",lthrow);
+ init_fsubr("quote",leval_quote);
+ init_lsubr("apropos",apropos);
+ init_lsubr("verbose",siod_verbose);
+ init_subr_1("copy-list",copy_list);
+ init_lsubr("gc-status",gc_status);
+ init_lsubr("gc",user_gc);
+ init_subr_3("load",load);
+ init_subr_1("require",require);
+ init_subr_1("pair?",consp);
+ init_subr_1("symbol?",symbolp);
+ init_subr_1("number?",numberp);
+ init_msubr("let-internal",leval_let);
+ init_subr_1("let-internal-macro",let_macro);
+ init_subr_1("let*-macro",letstar_macro);
+ init_subr_1("letrec-macro",letrec_macro);
+ init_subr_2("symbol-bound?",symbol_boundp);
+ init_subr_2("symbol-value",symbol_value);
+ init_subr_3("set-symbol-value!",setvar);
+ init_fsubr("the-environment",leval_tenv);
+ init_subr_2("error",lerr);
+ init_subr_0("quit",quit);
+ init_subr_1("not",nullp);
+ init_subr_1("null?",nullp);
+ init_subr_2("env-lookup",envlookup);
+ init_subr_1("reverse",reverse);
+ init_lsubr("symbolconc",symbolconc);
+ init_subr_3("save-forms",save_forms);
+ init_subr_2("fopen",fopen_l);
+ init_subr_1("fclose",fclose_l);
+ init_subr_1("getc",lgetc);
+ init_subr_2("ungetc",lungetc);
+ init_subr_2("putc",lputc);
+ init_subr_2("puts",lputs);
+ init_subr_1("ftell",lftell);
+ init_subr_3("fseek",lfseek);
+ init_subr_1("parse-number",parse_number);
+ init_subr_2("%%stack-limit",stack_limit);
+ init_subr_1("intern",intern);
+ init_subr_2("%%closure",closure);
+ init_subr_1("%%closure-code",closure_code);
+ init_subr_1("%%closure-env",closure_env);
+ init_fsubr("while",lwhile);
+ init_subr_1("nreverse",nreverse);
+ init_subr_0("allocate-heap",allocate_aheap);
+ init_subr_1("gc-info",gc_info);
+ init_subr_0("runtime",lruntime);
+ init_subr_0("realtime",lrealtime);
+ init_subr_1("caar",caar);
+ init_subr_1("cadr",cadr);
+ init_subr_1("cdar",cdar);
+ init_subr_1("cddr",cddr);
+ init_subr_1("rand",lrand);
+ init_subr_1("srand",lsrand);
+ init_subr_0("last-c-error",lllast_c_errmsg);
+ init_subr_0("os-classification",os_classification);
+ init_slib_version();}
+
+
+ /* err0,pr,prp are convenient to call from the C-language debugger */
+
+ void err0(void)
+ {err("0",NIL);}
+
+ void pr(LISP p)
+ {if (looks_pointerp(p))
+ lprint(p,NIL);
+ else
+ put_st("invalid\n");}
+
+ void prp(LISP *p)
+ {if (!p) return;
+ pr(*p);}
+
+
Index: llvm/test/Programs/MultiSource/Applications/siod/sliba.c
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/sliba.c:1.1
*** /dev/null Fri Oct 17 13:48:56 2003
--- llvm/test/Programs/MultiSource/Applications/siod/sliba.c Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,2120 ----
+ /*
+ * COPYRIGHT (c) 1988-1996 BY *
+ * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
+ * See the source file SLIB.C for more information. *
+
+ Array-hacking code moved to another source file.
+
+ */
+
+ #include <stdio.h>
+ #include <string.h>
+ #include <setjmp.h>
+ #include <stdlib.h>
+ #include <stdarg.h>
+ #include <ctype.h>
+ #include <math.h>
+
+ #include "siod.h"
+ #include "siodp.h"
+
+ static void init_sliba_version(void)
+ {setvar(cintern("*sliba-version*"),
+ cintern("$Id: sliba.c,v 1.1 2003/10/17 18:48:45 gaeke Exp $"),
+ NIL);}
+
+ static LISP sym_plists = NIL;
+ static LISP bashnum = NIL;
+ static LISP sym_e = NIL;
+ static LISP sym_f = NIL;
+
+ void init_storage_a1(long type)
+ {long j;
+ struct user_type_hooks *p;
+ set_gc_hooks(type,
+ array_gc_relocate,
+ array_gc_mark,
+ array_gc_scan,
+ array_gc_free,
+ &j);
+ set_print_hooks(type,array_prin1);
+ p = get_user_type_hooks(type);
+ p->fast_print = array_fast_print;
+ p->fast_read = array_fast_read;
+ p->equal = array_equal;
+ p->c_sxhash = array_sxhash;}
+
+ void init_storage_a(void)
+ {gc_protect(&bashnum);
+ bashnum = newcell(tc_flonum);
+ init_storage_a1(tc_string);
+ init_storage_a1(tc_double_array);
+ init_storage_a1(tc_long_array);
+ init_storage_a1(tc_lisp_array);
+ init_storage_a1(tc_byte_array);}
+
+ LISP array_gc_relocate(LISP ptr)
+ {LISP nw;
+ if ((nw = heap) >= heap_end) gc_fatal_error();
+ heap = nw+1;
+ memcpy(nw,ptr,sizeof(struct obj));
+ return(nw);}
+
+ void array_gc_scan(LISP ptr)
+ {long j;
+ if TYPEP(ptr,tc_lisp_array)
+ for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
+ ptr->storage_as.lisp_array.data[j] =
+ gc_relocate(ptr->storage_as.lisp_array.data[j]);}
+
+ LISP array_gc_mark(LISP ptr)
+ {long j;
+ if TYPEP(ptr,tc_lisp_array)
+ for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
+ gc_mark(ptr->storage_as.lisp_array.data[j]);
+ return(NIL);}
+
+ void array_gc_free(LISP ptr)
+ {switch (ptr->type)
+ {case tc_string:
+ case tc_byte_array:
+ free(ptr->storage_as.string.data);
+ break;
+ case tc_double_array:
+ free(ptr->storage_as.double_array.data);
+ break;
+ case tc_long_array:
+ free(ptr->storage_as.long_array.data);
+ break;
+ case tc_lisp_array:
+ free(ptr->storage_as.lisp_array.data);
+ break;}}
+
+ void array_prin1(LISP ptr,struct gen_printio *f)
+ {int j;
+ switch (ptr->type)
+ {case tc_string:
+ gput_st(f,"\"");
+ if (strcspn(ptr->storage_as.string.data,"\"\\\n\r\t") ==
+ strlen(ptr->storage_as.string.data))
+ gput_st(f,ptr->storage_as.string.data);
+ else
+ {int n,c;
+ char cbuff[3];
+ n = strlen(ptr->storage_as.string.data);
+ for(j=0;j<n;++j)
+ switch(c = ptr->storage_as.string.data[j])
+ {case '\\':
+ case '"':
+ cbuff[0] = '\\';
+ cbuff[1] = c;
+ cbuff[2] = 0;
+ gput_st(f,cbuff);
+ break;
+ case '\n':
+ gput_st(f,"\\n");
+ break;
+ case '\r':
+ gput_st(f,"\\r");
+ break;
+ case '\t':
+ gput_st(f,"\\t");
+ break;
+ default:
+ cbuff[0] = c;
+ cbuff[1] = 0;
+ gput_st(f,cbuff);
+ break;}}
+ gput_st(f,"\"");
+ break;
+ case tc_double_array:
+ gput_st(f,"#(");
+ for(j=0; j < ptr->storage_as.double_array.dim; ++j)
+ {sprintf(tkbuffer,"%g",ptr->storage_as.double_array.data[j]);
+ gput_st(f,tkbuffer);
+ if ((j + 1) < ptr->storage_as.double_array.dim)
+ gput_st(f," ");}
+ gput_st(f,")");
+ break;
+ case tc_long_array:
+ gput_st(f,"#(");
+ for(j=0; j < ptr->storage_as.long_array.dim; ++j)
+ {sprintf(tkbuffer,"%ld",ptr->storage_as.long_array.data[j]);
+ gput_st(f,tkbuffer);
+ if ((j + 1) < ptr->storage_as.long_array.dim)
+ gput_st(f," ");}
+ gput_st(f,")");
+ case tc_byte_array:
+ sprintf(tkbuffer,"#%ld\"",ptr->storage_as.string.dim);
+ gput_st(f,tkbuffer);
+ for(j=0; j < ptr->storage_as.string.dim; ++j)
+ {sprintf(tkbuffer,"%02x",ptr->storage_as.string.data[j] & 0xFF);
+ gput_st(f,tkbuffer);}
+ gput_st(f,"\"");
+ break;
+ case tc_lisp_array:
+ gput_st(f,"#(");
+ for(j=0; j < ptr->storage_as.lisp_array.dim; ++j)
+ {lprin1g(ptr->storage_as.lisp_array.data[j],f);
+ if ((j + 1) < ptr->storage_as.lisp_array.dim)
+ gput_st(f," ");}
+ gput_st(f,")");
+ break;}}
+
+ LISP strcons(long length,const char *data)
+ {long flag;
+ LISP s;
+ flag = no_interrupt(1);
+ s = cons(NIL,NIL);
+ s->type = tc_string;
+ if (length == -1) length = strlen(data);
+ s->storage_as.string.data = must_malloc(length+1);
+ s->storage_as.string.dim = length;
+ if (data)
+ memcpy(s->storage_as.string.data,data,length);
+ s->storage_as.string.data[length] = 0;
+ no_interrupt(flag);
+ return(s);}
+
+ int rfs_getc(unsigned char **p)
+ {int i;
+ i = **p;
+ if (!i) return(EOF);
+ *p = *p + 1;
+ return(i);}
+
+ void rfs_ungetc(unsigned char c,unsigned char **p)
+ {*p = *p - 1;}
+
+ LISP read_from_string(LISP x)
+ {char *p;
+ struct gen_readio s;
+ p = get_c_string(x);
+ s.getc_fcn = (int (*)(void *))rfs_getc;
+ s.ungetc_fcn = (void (*)(int,void *))rfs_ungetc;
+ s.cb_argument = (char *) &p;
+ return(readtl(&s));}
+
+ int pts_puts(char *from,void *cb)
+ {LISP into;
+ size_t fromlen,intolen,intosize,fitsize;
+ into = (LISP) cb;
+ fromlen = strlen(from);
+ intolen = strlen(into->storage_as.string.data);
+ intosize = into->storage_as.string.dim - intolen;
+ fitsize = (fromlen < intosize) ? fromlen : intosize;
+ memcpy(&into->storage_as.string.data[intolen],from,fitsize);
+ into->storage_as.string.data[intolen+fitsize] = 0;
+ if (fitsize < fromlen)
+ err("print to string overflow",NIL);
+ return(1);}
+
+ LISP err_wta_str(LISP exp)
+ {return(err("not a string",exp));}
+
+ LISP print_to_string(LISP exp,LISP str,LISP nostart)
+ {struct gen_printio s;
+ if NTYPEP(str,tc_string) err_wta_str(str);
+ s.putc_fcn = NULL;
+ s.puts_fcn = pts_puts;
+ s.cb_argument = str;
+ if NULLP(nostart)
+ str->storage_as.string.data[0] = 0;
+ lprin1g(exp,&s);
+ return(str);}
+
+ LISP aref1(LISP a,LISP i)
+ {long k;
+ if NFLONUMP(i) err("bad index to aref",i);
+ k = (long) FLONM(i);
+ if (k < 0) err("negative index to aref",i);
+ switch TYPE(a)
+ {case tc_string:
+ if (k >= a->storage_as.string.dim) err("index too large",i);
+ return(flocons((double) a->storage_as.u_string.data[k]));
+ case tc_byte_array:
+ if (k >= a->storage_as.string.dim) err("index too large",i);
+ return(flocons((double) a->storage_as.string.data[k]));
+ case tc_double_array:
+ if (k >= a->storage_as.double_array.dim) err("index too large",i);
+ return(flocons(a->storage_as.double_array.data[k]));
+ case tc_long_array:
+ if (k >= a->storage_as.long_array.dim) err("index too large",i);
+ return(flocons(a->storage_as.long_array.data[k]));
+ case tc_lisp_array:
+ if (k >= a->storage_as.lisp_array.dim) err("index too large",i);
+ return(a->storage_as.lisp_array.data[k]);
+ default:
+ return(err("invalid argument to aref",a));}}
+
+ void err1_aset1(LISP i)
+ {err("index to aset too large",i);}
+
+ void err2_aset1(LISP v)
+ {err("bad value to store in array",v);}
+
+ LISP aset1(LISP a,LISP i,LISP v)
+ {long k;
+ if NFLONUMP(i) err("bad index to aset",i);
+ k = (long) FLONM(i);
+ if (k < 0) err("negative index to aset",i);
+ switch TYPE(a)
+ {case tc_string:
+ case tc_byte_array:
+ if NFLONUMP(v) err2_aset1(v);
+ if (k >= a->storage_as.string.dim) err1_aset1(i);
+ a->storage_as.string.data[k] = (char) FLONM(v);
+ return(v);
+ case tc_double_array:
+ if NFLONUMP(v) err2_aset1(v);
+ if (k >= a->storage_as.double_array.dim) err1_aset1(i);
+ a->storage_as.double_array.data[k] = FLONM(v);
+ return(v);
+ case tc_long_array:
+ if NFLONUMP(v) err2_aset1(v);
+ if (k >= a->storage_as.long_array.dim) err1_aset1(i);
+ a->storage_as.long_array.data[k] = (long) FLONM(v);
+ return(v);
+ case tc_lisp_array:
+ if (k >= a->storage_as.lisp_array.dim) err1_aset1(i);
+ a->storage_as.lisp_array.data[k] = v;
+ return(v);
+ default:
+ return(err("invalid argument to aset",a));}}
+
+ LISP arcons(long typecode,long n,long initp)
+ {LISP a;
+ long flag,j;
+ flag = no_interrupt(1);
+ a = cons(NIL,NIL);
+ switch(typecode)
+ {case tc_double_array:
+ a->storage_as.double_array.dim = n;
+ a->storage_as.double_array.data = (double *) must_malloc(n *
+ sizeof(double));
+ if (initp)
+ for(j=0;j<n;++j) a->storage_as.double_array.data[j] = 0.0;
+ break;
+ case tc_long_array:
+ a->storage_as.long_array.dim = n;
+ a->storage_as.long_array.data = (long *) must_malloc(n * sizeof(long));
+ if (initp)
+ for(j=0;j<n;++j) a->storage_as.long_array.data[j] = 0;
+ break;
+ case tc_string:
+ a->storage_as.string.dim = n;
+ a->storage_as.string.data = (char *) must_malloc(n+1);
+ a->storage_as.string.data[n] = 0;
+ if (initp)
+ for(j=0;j<n;++j) a->storage_as.string.data[j] = ' ';
+ case tc_byte_array:
+ a->storage_as.string.dim = n;
+ a->storage_as.string.data = (char *) must_malloc(n);
+ if (initp)
+ for(j=0;j<n;++j) a->storage_as.string.data[j] = 0;
+ break;
+ case tc_lisp_array:
+ a->storage_as.lisp_array.dim = n;
+ a->storage_as.lisp_array.data = (LISP *) must_malloc(n * sizeof(LISP));
+ for(j=0;j<n;++j) a->storage_as.lisp_array.data[j] = NIL;
+ break;
+ default:
+ errswitch();}
+ a->type = (short) typecode;
+ no_interrupt(flag);
+ return(a);}
+
+ LISP mallocl(void *place,long size)
+ {long n,r;
+ LISP retval;
+ n = size / sizeof(long);
+ r = size % sizeof(long);
+ if (r) ++n;
+ retval = arcons(tc_long_array,n,0);
+ *(long **)place = retval->storage_as.long_array.data;
+ return(retval);}
+
+ LISP cons_array(LISP dim,LISP kind)
+ {LISP a;
+ long flag,n,j;
+ if (NFLONUMP(dim) || (FLONM(dim) < 0))
+ return(err("bad dimension to cons-array",dim));
+ else
+ n = (long) FLONM(dim);
+ flag = no_interrupt(1);
+ a = cons(NIL,NIL);
+ if EQ(cintern("double"),kind)
+ {a->type = tc_double_array;
+ a->storage_as.double_array.dim = n;
+ a->storage_as.double_array.data = (double *) must_malloc(n *
+ sizeof(double));
+ for(j=0;j<n;++j) a->storage_as.double_array.data[j] = 0.0;}
+ else if EQ(cintern("long"),kind)
+ {a->type = tc_long_array;
+ a->storage_as.long_array.dim = n;
+ a->storage_as.long_array.data = (long *) must_malloc(n * sizeof(long));
+ for(j=0;j<n;++j) a->storage_as.long_array.data[j] = 0;}
+ else if EQ(cintern("string"),kind)
+ {a->type = tc_string;
+ a->storage_as.string.dim = n;
+ a->storage_as.string.data = (char *) must_malloc(n+1);
+ a->storage_as.string.data[n] = 0;
+ for(j=0;j<n;++j) a->storage_as.string.data[j] = ' ';}
+ else if EQ(cintern("byte"),kind)
+ {a->type = tc_byte_array;
+ a->storage_as.string.dim = n;
+ a->storage_as.string.data = (char *) must_malloc(n);
+ for(j=0;j<n;++j) a->storage_as.string.data[j] = 0;}
+ else if (EQ(cintern("lisp"),kind) || NULLP(kind))
+ {a->type = tc_lisp_array;
+ a->storage_as.lisp_array.dim = n;
+ a->storage_as.lisp_array.data = (LISP *) must_malloc(n * sizeof(LISP));
+ for(j=0;j<n;++j) a->storage_as.lisp_array.data[j] = NIL;}
+ else
+ err("bad type of array",kind);
+ no_interrupt(flag);
+ return(a);}
+
+ LISP string_append(LISP args)
+ {long size;
+ LISP l,s;
+ char *data;
+ size = 0;
+ for(l=args;NNULLP(l);l=cdr(l))
+ size += strlen(get_c_string(car(l)));
+ s = strcons(size,NULL);
+ data = s->storage_as.string.data;
+ data[0] = 0;
+ for(l=args;NNULLP(l);l=cdr(l))
+ strcat(data,get_c_string(car(l)));
+ return(s);}
+
+ LISP bytes_append(LISP args)
+ {long size,n,j;
+ LISP l,s;
+ char *data,*ptr;
+ size = 0;
+ for(l=args;NNULLP(l);l=cdr(l))
+ {get_c_string_dim(car(l),&n);
+ size += n;}
+ s = arcons(tc_byte_array,size,0);
+ data = s->storage_as.string.data;
+ for(j=0,l=args;NNULLP(l);l=cdr(l))
+ {ptr = get_c_string_dim(car(l),&n);
+ memcpy(&data[j],ptr,n);
+ j += n;}
+ return(s);}
+
+ LISP substring(LISP str,LISP start,LISP end)
+ {long s,e,n;
+ char *data;
+ data = get_c_string_dim(str,&n);
+ s = get_c_long(start);
+ if NULLP(end)
+ e = n;
+ else
+ e = get_c_long(end);
+ if ((s < 0) || (s > e)) err("bad start index",start);
+ if ((e < 0) || (e > n)) err("bad end index",end);
+ return(strcons(e-s,&data[s]));}
+
+ LISP string_search(LISP token,LISP str)
+ {char *s1,*s2,*ptr;
+ s1 = get_c_string(str);
+ s2 = get_c_string(token);
+ ptr = strstr(s1,s2);
+ if (ptr)
+ return(flocons(ptr - s1));
+ else
+ return(NIL);}
+
+ #define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x)))
+
+ LISP string_trim(LISP str)
+ {char *start,*end;
+ start = get_c_string(str);
+ while(*start && IS_TRIM_SPACE(*start)) ++start;
+ end = &start[strlen(start)];
+ while((end > start) && IS_TRIM_SPACE(*(end-1))) --end;
+ return(strcons(end-start,start));}
+
+ LISP string_trim_left(LISP str)
+ {char *start,*end;
+ start = get_c_string(str);
+ while(*start && IS_TRIM_SPACE(*start)) ++start;
+ end = &start[strlen(start)];
+ return(strcons(end-start,start));}
+
+ LISP string_trim_right(LISP str)
+ {char *start,*end;
+ start = get_c_string(str);
+ end = &start[strlen(start)];
+ while((end > start) && IS_TRIM_SPACE(*(end-1))) --end;
+ return(strcons(end-start,start));}
+
+ LISP string_upcase(LISP str)
+ {LISP result;
+ char *s1,*s2;
+ long j,n;
+ s1 = get_c_string(str);
+ n = strlen(s1);
+ result = strcons(n,s1);
+ s2 = get_c_string(result);
+ for(j=0;j<n;++j) s2[j] = toupper(s2[j]);
+ return(result);}
+
+ LISP string_downcase(LISP str)
+ {LISP result;
+ char *s1,*s2;
+ long j,n;
+ s1 = get_c_string(str);
+ n = strlen(s1);
+ result = strcons(n,s1);
+ s2 = get_c_string(result);
+ for(j=0;j<n;++j) s2[j] = tolower(s2[j]);
+ return(result);}
+
+ LISP lreadstring(struct gen_readio *f)
+ {int j,c,n;
+ char *p;
+ j = 0;
+ p = tkbuffer;
+ while(((c = GETC_FCN(f)) != '"') && (c != EOF))
+ {if (c == '\\')
+ {c = GETC_FCN(f);
+ if (c == EOF) err("eof after \\",NIL);
+ switch(c)
+ {case 'n':
+ c = '\n';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 'd':
+ c = 0x04;
+ break;
+ case 'N':
+ c = 0;
+ break;
+ case 's':
+ c = ' ';
+ break;
+ case '0':
+ n = 0;
+ while(1)
+ {c = GETC_FCN(f);
+ if (c == EOF) err("eof after \\0",NIL);
+ if (isdigit(c))
+ n = n * 8 + c - '0';
+ else
+ {UNGETC_FCN(c,f);
+ break;}}
+ c = n;}}
+ if ((j + 1) >= TKBUFFERN) err("read string overflow",NIL);
+ ++j;
+ *p++ = c;}
+ *p = 0;
+ return(strcons(j,tkbuffer));}
+
+
+ LISP lreadsharp(struct gen_readio *f)
+ {LISP obj,l,result;
+ long j,n;
+ int c;
+ c = GETC_FCN(f);
+ switch(c)
+ {case '(':
+ UNGETC_FCN(c,f);
+ obj = lreadr(f);
+ n = nlength(obj);
+ result = arcons(tc_lisp_array,n,1);
+ for(l=obj,j=0;j<n;l=cdr(l),++j)
+ result->storage_as.lisp_array.data[j] = car(l);
+ return(result);
+ case '.':
+ obj = lreadr(f);
+ return(leval(obj,NIL));
+ case 'f':
+ return(NIL);
+ case 't':
+ return(flocons(1));
+ default:
+ return(err("readsharp syntax not handled",NIL));}}
+
+ #define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
+
+ long c_sxhash(LISP obj,long n)
+ {long hash;
+ unsigned char *s;
+ LISP tmp;
+ struct user_type_hooks *p;
+ STACK_CHECK(&obj);
+ INTERRUPT_CHECK();
+ switch TYPE(obj)
+ {case tc_nil:
+ return(0);
+ case tc_cons:
+ hash = c_sxhash(CAR(obj),n);
+ for(tmp=CDR(obj);CONSP(tmp);tmp=CDR(tmp))
+ hash = HASH_COMBINE(hash,c_sxhash(CAR(tmp),n),n);
+ hash = HASH_COMBINE(hash,c_sxhash(tmp,n),n);
+ return(hash);
+ case tc_symbol:
+ for(hash=0,s=(unsigned char *)PNAME(obj);*s;++s)
+ hash = HASH_COMBINE(hash,*s,n);
+ return(hash);
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_3:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ for(hash=0,s=(unsigned char *) obj->storage_as.subr.name;*s;++s)
+ hash = HASH_COMBINE(hash,*s,n);
+ return(hash);
+ case tc_flonum:
+ return(((unsigned long)FLONM(obj)) % n);
+ default:
+ p = get_user_type_hooks(TYPE(obj));
+ if (p->c_sxhash)
+ return((*p->c_sxhash)(obj,n));
+ else
+ return(0);}}
+
+ LISP sxhash(LISP obj,LISP n)
+ {return(flocons(c_sxhash(obj,FLONUMP(n) ? (long) FLONM(n) : 10000)));}
+
+ LISP equal(LISP a,LISP b)
+ {struct user_type_hooks *p;
+ long atype;
+ STACK_CHECK(&a);
+ loop:
+ INTERRUPT_CHECK();
+ if EQ(a,b) return(sym_t);
+ atype = TYPE(a);
+ if (atype != TYPE(b)) return(NIL);
+ switch(atype)
+ {case tc_cons:
+ if NULLP(equal(car(a),car(b))) return(NIL);
+ a = cdr(a);
+ b = cdr(b);
+ goto loop;
+ case tc_flonum:
+ return((FLONM(a) == FLONM(b)) ? sym_t : NIL);
+ case tc_symbol:
+ return(NIL);
+ default:
+ p = get_user_type_hooks(atype);
+ if (p->equal)
+ return((*p->equal)(a,b));
+ else
+ return(NIL);}}
+
+ LISP array_equal(LISP a,LISP b)
+ {long j,len;
+ switch(TYPE(a))
+ {case tc_string:
+ case tc_byte_array:
+ len = a->storage_as.string.dim;
+ if (len != b->storage_as.string.dim) return(NIL);
+ if (memcmp(a->storage_as.string.data,b->storage_as.string.data,len) == 0)
+ return(sym_t);
+ else
+ return(NIL);
+ case tc_long_array:
+ len = a->storage_as.long_array.dim;
+ if (len != b->storage_as.long_array.dim) return(NIL);
+ if (memcmp(a->storage_as.long_array.data,
+ b->storage_as.long_array.data,
+ len * sizeof(long)) == 0)
+ return(sym_t);
+ else
+ return(NIL);
+ case tc_double_array:
+ len = a->storage_as.double_array.dim;
+ if (len != b->storage_as.double_array.dim) return(NIL);
+ for(j=0;j<len;++j)
+ if (a->storage_as.double_array.data[j] !=
+ b->storage_as.double_array.data[j])
+ return(NIL);
+ return(sym_t);
+ case tc_lisp_array:
+ len = a->storage_as.lisp_array.dim;
+ if (len != b->storage_as.lisp_array.dim) return(NIL);
+ for(j=0;j<len;++j)
+ if NULLP(equal(a->storage_as.lisp_array.data[j],
+ b->storage_as.lisp_array.data[j]))
+ return(NIL);
+ return(sym_t);
+ default:
+ return(errswitch());}}
+
+ long array_sxhash(LISP a,long n)
+ {long j,len,hash;
+ unsigned char *char_data;
+ unsigned long *long_data;
+ double *double_data;
+ switch(TYPE(a))
+ {case tc_string:
+ case tc_byte_array:
+ len = a->storage_as.string.dim;
+ for(j=0,hash=0,char_data=(unsigned char *)a->storage_as.string.data;
+ j < len;
+ ++j,++char_data)
+ hash = HASH_COMBINE(hash,*char_data,n);
+ return(hash);
+ case tc_long_array:
+ len = a->storage_as.long_array.dim;
+ for(j=0,hash=0,long_data=(unsigned long *)a->storage_as.long_array.data;
+ j < len;
+ ++j,++long_data)
+ hash = HASH_COMBINE(hash,*long_data % n,n);
+ return(hash);
+ case tc_double_array:
+ len = a->storage_as.double_array.dim;
+ for(j=0,hash=0,double_data=a->storage_as.double_array.data;
+ j < len;
+ ++j,++double_data)
+ hash = HASH_COMBINE(hash,(unsigned long)*double_data % n,n);
+ return(hash);
+ case tc_lisp_array:
+ len = a->storage_as.lisp_array.dim;
+ for(j=0,hash=0; j < len; ++j)
+ hash = HASH_COMBINE(hash,
+ c_sxhash(a->storage_as.lisp_array.data[j],n),
+ n);
+ return(hash);
+ default:
+ errswitch();
+ return(0);}}
+
+ long href_index(LISP table,LISP key)
+ {long index;
+ if NTYPEP(table,tc_lisp_array) err("not a hash table",table);
+ index = c_sxhash(key,table->storage_as.lisp_array.dim);
+ if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
+ {err("sxhash inconsistency",table);
+ return(0);}
+ else
+ return(index);}
+
+ LISP href(LISP table,LISP key)
+ {return(cdr(assoc(key,
+ table->storage_as.lisp_array.data[href_index(table,key)])));}
+
+ LISP hset(LISP table,LISP key,LISP value)
+ {long index;
+ LISP cell,l;
+ index = href_index(table,key);
+ l = table->storage_as.lisp_array.data[index];
+ if NNULLP(cell = assoc(key,l))
+ return(setcdr(cell,value));
+ cell = cons(key,value);
+ table->storage_as.lisp_array.data[index] = cons(cell,l);
+ return(value);}
+
+ LISP assoc(LISP x,LISP alist)
+ {LISP l,tmp;
+ for(l=alist;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if (CONSP(tmp) && equal(CAR(tmp),x)) return(tmp);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to assoc",alist));}
+
+ LISP assv(LISP x,LISP alist)
+ {LISP l,tmp;
+ for(l=alist;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if (CONSP(tmp) && NNULLP(eql(CAR(tmp),x))) return(tmp);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to assv",alist));}
+
+ void put_long(long i,FILE *f)
+ {fwrite(&i,sizeof(long),1,f);}
+
+ long get_long(FILE *f)
+ {long i;
+ fread(&i,sizeof(long),1,f);
+ return(i);}
+
+ long fast_print_table(LISP obj,LISP table)
+ {FILE *f;
+ LISP ht,index;
+ f = get_c_file(car(table),(FILE *) NULL);
+ if NULLP(ht = car(cdr(table)))
+ return(1);
+ index = href(ht,obj);
+ if NNULLP(index)
+ {putc(FO_fetch,f);
+ put_long(get_c_long(index),f);
+ return(0);}
+ if NULLP(index = car(cdr(cdr(table))))
+ return(1);
+ hset(ht,obj,index);
+ FLONM(bashnum) = 1.0;
+ setcar(cdr(cdr(table)),plus(index,bashnum));
+ putc(FO_store,f);
+ put_long(get_c_long(index),f);
+ return(1);}
+
+ LISP fast_print(LISP obj,LISP table)
+ {FILE *f;
+ long len;
+ LISP tmp;
+ struct user_type_hooks *p;
+ STACK_CHECK(&obj);
+ f = get_c_file(car(table),(FILE *) NULL);
+ switch(TYPE(obj))
+ {case tc_nil:
+ putc(tc_nil,f);
+ return(NIL);
+ case tc_cons:
+ for(len=0,tmp=obj;CONSP(tmp);tmp=CDR(tmp)) {INTERRUPT_CHECK();++len;}
+ if (len == 1)
+ {putc(tc_cons,f);
+ fast_print(car(obj),table);
+ fast_print(cdr(obj),table);}
+ else if NULLP(tmp)
+ {putc(FO_list,f);
+ put_long(len,f);
+ for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
+ fast_print(CAR(tmp),table);}
+ else
+ {putc(FO_listd,f);
+ put_long(len,f);
+ for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
+ fast_print(CAR(tmp),table);
+ fast_print(tmp,table);}
+ return(NIL);
+ case tc_flonum:
+ putc(tc_flonum,f);
+ fwrite(&obj->storage_as.flonum.data,
+ sizeof(obj->storage_as.flonum.data),
+ 1,
+ f);
+ return(NIL);
+ case tc_symbol:
+ if (fast_print_table(obj,table))
+ {putc(tc_symbol,f);
+ len = strlen(PNAME(obj));
+ if (len >= TKBUFFERN)
+ err("symbol name too long",obj);
+ put_long(len,f);
+ fwrite(PNAME(obj),len,1,f);
+ return(sym_t);}
+ else
+ return(NIL);
+ default:
+ p = get_user_type_hooks(TYPE(obj));
+ if (p->fast_print)
+ return((*p->fast_print)(obj,table));
+ else
+ return(err("cannot fast-print",obj));}}
+
+ LISP fast_read(LISP table)
+ {FILE *f;
+ LISP tmp,l;
+ struct user_type_hooks *p;
+ int c;
+ long len;
+ f = get_c_file(car(table),(FILE *) NULL);
+ c = getc(f);
+ if (c == EOF) return(table);
+ switch(c)
+ {case FO_comment:
+ while((c = getc(f)))
+ switch(c)
+ {case EOF:
+ return(table);
+ case '\n':
+ return(fast_read(table));}
+ case FO_fetch:
+ len = get_long(f);
+ FLONM(bashnum) = len;
+ return(href(car(cdr(table)),bashnum));
+ case FO_store:
+ len = get_long(f);
+ tmp = fast_read(table);
+ hset(car(cdr(table)),flocons(len),tmp);
+ return(tmp);
+ case tc_nil:
+ return(NIL);
+ case tc_cons:
+ tmp = fast_read(table);
+ return(cons(tmp,fast_read(table)));
+ case FO_list:
+ case FO_listd:
+ len = get_long(f);
+ FLONM(bashnum) = len;
+ l = make_list(bashnum,NIL);
+ tmp = l;
+ while(len > 1)
+ {CAR(tmp) = fast_read(table);
+ tmp = CDR(tmp);
+ --len;}
+ CAR(tmp) = fast_read(table);
+ if (c == FO_listd)
+ CDR(tmp) = fast_read(table);
+ return(l);
+ case tc_flonum:
+ tmp = newcell(tc_flonum);
+ fread(&tmp->storage_as.flonum.data,
+ sizeof(tmp->storage_as.flonum.data),
+ 1,
+ f);
+ return(tmp);
+ case tc_symbol:
+ len = get_long(f);
+ if (len >= TKBUFFERN)
+ err("symbol name too long",NIL);
+ fread(tkbuffer,len,1,f);
+ tkbuffer[len] = 0;
+ return(rintern(tkbuffer));
+ default:
+ p = get_user_type_hooks(c);
+ if (p->fast_read)
+ return(*p->fast_read)(c,table);
+ else
+ return(err("unknown fast-read opcode",flocons(c)));}}
+
+ LISP array_fast_print(LISP ptr,LISP table)
+ {int j,len;
+ FILE *f;
+ f = get_c_file(car(table),(FILE *) NULL);
+ switch (ptr->type)
+ {case tc_string:
+ case tc_byte_array:
+ putc(ptr->type,f);
+ len = ptr->storage_as.string.dim;
+ put_long(len,f);
+ fwrite(ptr->storage_as.string.data,len,1,f);
+ return(NIL);
+ case tc_double_array:
+ putc(tc_double_array,f);
+ len = ptr->storage_as.double_array.dim * sizeof(double);
+ put_long(len,f);
+ fwrite(ptr->storage_as.double_array.data,len,1,f);
+ return(NIL);
+ case tc_long_array:
+ putc(tc_long_array,f);
+ len = ptr->storage_as.long_array.dim * sizeof(long);
+ put_long(len,f);
+ fwrite(ptr->storage_as.long_array.data,len,1,f);
+ return(NIL);
+ case tc_lisp_array:
+ putc(tc_lisp_array,f);
+ len = ptr->storage_as.lisp_array.dim;
+ put_long(len,f);
+ for(j=0; j < len; ++j)
+ fast_print(ptr->storage_as.lisp_array.data[j],table);
+ return(NIL);
+ default:
+ return(errswitch());}}
+
+ LISP array_fast_read(int code,LISP table)
+ {long j,len,iflag;
+ FILE *f;
+ LISP ptr;
+ f = get_c_file(car(table),(FILE *) NULL);
+ switch (code)
+ {case tc_string:
+ len = get_long(f);
+ ptr = strcons(len,NULL);
+ fread(ptr->storage_as.string.data,len,1,f);
+ ptr->storage_as.string.data[len] = 0;
+ return(ptr);
+ case tc_byte_array:
+ len = get_long(f);
+ iflag = no_interrupt(1);
+ ptr = newcell(tc_byte_array);
+ ptr->storage_as.string.dim = len;
+ ptr->storage_as.string.data =
+ (char *) must_malloc(len);
+ fread(ptr->storage_as.string.data,len,1,f);
+ no_interrupt(iflag);
+ return(ptr);
+ case tc_double_array:
+ len = get_long(f);
+ iflag = no_interrupt(1);
+ ptr = newcell(tc_double_array);
+ ptr->storage_as.double_array.dim = len;
+ ptr->storage_as.double_array.data =
+ (double *) must_malloc(len * sizeof(double));
+ fread(ptr->storage_as.double_array.data,sizeof(double),len,f);
+ no_interrupt(iflag);
+ return(ptr);
+ case tc_long_array:
+ len = get_long(f);
+ iflag = no_interrupt(1);
+ ptr = newcell(tc_long_array);
+ ptr->storage_as.long_array.dim = len;
+ ptr->storage_as.long_array.data =
+ (long *) must_malloc(len * sizeof(long));
+ fread(ptr->storage_as.long_array.data,sizeof(long),len,f);
+ no_interrupt(iflag);
+ return(ptr);
+ case tc_lisp_array:
+ len = get_long(f);
+ FLONM(bashnum) = len;
+ ptr = cons_array(bashnum,NIL);
+ for(j=0; j < len; ++j)
+ ptr->storage_as.lisp_array.data[j] = fast_read(table);
+ return(ptr);
+ default:
+ return(errswitch());}}
+
+ long get_c_long(LISP x)
+ {if NFLONUMP(x) err("not a number",x);
+ return((long)FLONM(x));}
+
+ double get_c_double(LISP x)
+ {if NFLONUMP(x) err("not a number",x);
+ return(FLONM(x));}
+
+ LISP make_list(LISP x,LISP v)
+ {long n;
+ LISP l;
+ n = get_c_long(x);
+ l = NIL;
+ while(n > 0)
+ {l = cons(v,l); --n;}
+ return(l);}
+
+ LISP lfread(LISP size,LISP file)
+ {long flag,n,ret,m;
+ char *buffer;
+ LISP s;
+ FILE *f;
+ f = get_c_file(file,stdin);
+ flag = no_interrupt(1);
+ switch(TYPE(size))
+ {case tc_string:
+ case tc_byte_array:
+ s = size;
+ buffer = s->storage_as.string.data;
+ n = s->storage_as.string.dim;
+ m = 0;
+ break;
+ default:
+ n = get_c_long(size);
+ buffer = (char *) must_malloc(n+1);
+ buffer[n] = 0;
+ m = 1;}
+ ret = fread(buffer,1,n,f);
+ if (ret == 0)
+ {if (m)
+ free(buffer);
+ no_interrupt(flag);
+ return(NIL);}
+ if (m)
+ {if (ret == n)
+ {s = cons(NIL,NIL);
+ s->type = tc_string;
+ s->storage_as.string.data = buffer;
+ s->storage_as.string.dim = n;}
+ else
+ {s = strcons(ret,NULL);
+ memcpy(s->storage_as.string.data,buffer,ret);
+ free(buffer);}
+ no_interrupt(flag);
+ return(s);}
+ no_interrupt(flag);
+ return(flocons((double)ret));}
+
+ LISP lfwrite(LISP string,LISP file)
+ {FILE *f;
+ long flag;
+ char *data;
+ long dim,len;
+ f = get_c_file(file,stdout);
+ data = get_c_string_dim(CONSP(string) ? car(string) : string,&dim);
+ len = CONSP(string) ? get_c_long(cadr(string)) : dim;
+ if (len <= 0) return(NIL);
+ if (len > dim) err("write length too long",string);
+ flag = no_interrupt(1);
+ fwrite(data,1,len,f);
+ no_interrupt(flag);
+ return(NIL);}
+
+ LISP lfflush(LISP file)
+ {FILE *f;
+ long flag;
+ f = get_c_file(file,stdout);
+ flag = no_interrupt(1);
+ fflush(f);
+ no_interrupt(flag);
+ return(NIL);}
+
+ LISP string_length(LISP string)
+ {if NTYPEP(string,tc_string) err_wta_str(string);
+ return(flocons(strlen(string->storage_as.string.data)));}
+
+ LISP string_dim(LISP string)
+ {if NTYPEP(string,tc_string) err_wta_str(string);
+ return(flocons((double)string->storage_as.string.dim));}
+
+ long nlength(LISP obj)
+ {LISP l;
+ long n;
+ switch TYPE(obj)
+ {case tc_string:
+ return(strlen(obj->storage_as.string.data));
+ case tc_byte_array:
+ return(obj->storage_as.string.dim);
+ case tc_double_array:
+ return(obj->storage_as.double_array.dim);
+ case tc_long_array:
+ return(obj->storage_as.long_array.dim);
+ case tc_lisp_array:
+ return(obj->storage_as.lisp_array.dim);
+ case tc_nil:
+ return(0);
+ case tc_cons:
+ for(l=obj,n=0;CONSP(l);l=CDR(l),++n) INTERRUPT_CHECK();
+ if NNULLP(l) err("improper list to length",obj);
+ return(n);
+ default:
+ err("wta to length",obj);
+ return(0);}}
+
+ LISP llength(LISP obj)
+ {return(flocons(nlength(obj)));}
+
+ LISP number2string(LISP x,LISP b,LISP w,LISP p)
+ {char buffer[1000];
+ double y;
+ long base,width,prec;
+ if NFLONUMP(x) err("wta",x);
+ y = FLONM(x);
+ width = NNULLP(w) ? get_c_long(w) : -1;
+ if (width > 100) err("width too long",w);
+ prec = NNULLP(p) ? get_c_long(p) : -1;
+ if (prec > 100) err("precision too large",p);
+ if (NULLP(b) || EQ(sym_e,b) || EQ(sym_f,b))
+ {if ((width >= 0) && (prec >= 0))
+ sprintf(buffer,
+ NULLP(b) ? "% *.*g" : EQ(sym_e,b) ? "% *.*e" : "% *.*f",
+ width,
+ prec,
+ y);
+ else if (width >= 0)
+ sprintf(buffer,
+ NULLP(b) ? "% *g" : EQ(sym_e,b) ? "% *e" : "% *f",
+ width,
+ y);
+ else if (prec >= 0)
+ sprintf(buffer,
+ NULLP(b) ? "%.*g" : EQ(sym_e,b) ? "%.*e" : "%.*f",
+ prec,
+ y);
+ else
+ sprintf(buffer,
+ NULLP(b) ? "%g" : EQ(sym_e,b) ? "%e" : "%f",
+ y);}
+ else if (((base = get_c_long(b)) == 10) || (base == 8) || (base == 16))
+ {if (width >= 0)
+ sprintf(buffer,
+ (base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX",
+ width,
+ (long) y);
+ else
+ sprintf(buffer,
+ (base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX",
+ (long) y);}
+ else
+ err("number base not handled",b);
+ return(strcons(strlen(buffer),buffer));}
+
+ LISP string2number(LISP x,LISP b)
+ {char *str;
+ long base,value = 0;
+ double result;
+ str = get_c_string(x);
+ if NULLP(b)
+ result = atof(str);
+ else if ((base = get_c_long(b)) == 10)
+ {sscanf(str,"%ld",&value);
+ result = (double) value;}
+ else if (base == 8)
+ {sscanf(str,"%lo",&value);
+ result = (double) value;}
+ else if (base == 16)
+ {sscanf(str,"%lx",&value);
+ result = (double) value;}
+ else if ((base >= 1) && (base <= 16))
+ {for(result = 0.0;*str;++str)
+ if (isdigit(*str))
+ result = result * base + *str - '0';
+ else if (isxdigit(*str))
+ result = result * base + toupper(*str) - 'A' + 10;}
+ else
+ return(err("number base not handled",b));
+ return(flocons(result));}
+
+ LISP lstrcmp(LISP s1,LISP s2)
+ {return(flocons(strcmp(get_c_string(s1),get_c_string(s2))));}
+
+ void chk_string(LISP s,char **data,long *dim)
+ {if TYPEP(s,tc_string)
+ {*data = s->storage_as.string.data;
+ *dim = s->storage_as.string.dim;}
+ else
+ err_wta_str(s);}
+
+ LISP lstrcpy(LISP dest,LISP src)
+ {long ddim,slen;
+ char *d,*s;
+ chk_string(dest,&d,&ddim);
+ s = get_c_string(src);
+ slen = strlen(s);
+ if (slen > ddim)
+ err("string too long",src);
+ memcpy(d,s,slen);
+ d[slen] = 0;
+ return(NIL);}
+
+ LISP lstrcat(LISP dest,LISP src)
+ {long ddim,dlen,slen;
+ char *d,*s;
+ chk_string(dest,&d,&ddim);
+ s = get_c_string(src);
+ slen = strlen(s);
+ dlen = strlen(d);
+ if ((slen + dlen) > ddim)
+ err("string too long",src);
+ memcpy(&d[dlen],s,slen);
+ d[dlen+slen] = 0;
+ return(NIL);}
+
+ LISP lstrbreakup(LISP str,LISP lmarker)
+ {char *start,*end,*marker;
+ size_t k;
+ LISP result = NIL;
+ start = get_c_string(str);
+ marker = get_c_string(lmarker);
+ k = strlen(marker);
+ while(*start)
+ {if (!(end = strstr(start,marker))) end = &start[strlen(start)];
+ result = cons(strcons(end-start,start),result);
+ start = (*end) ? end+k : end;}
+ return(nreverse(result));}
+
+ LISP lstrunbreakup(LISP elems,LISP lmarker)
+ {LISP result,l;
+ for(l=elems,result=NIL;NNULLP(l);l=cdr(l))
+ if EQ(l,elems)
+ result = cons(car(l),result);
+ else
+ result = cons(car(l),cons(lmarker,result));
+ return(string_append(nreverse(result)));}
+
+ LISP stringp(LISP x)
+ {return(TYPEP(x,tc_string) ? sym_t : NIL);}
+
+ static char *base64_encode_table = "\
+ ABCDEFGHIJKLMNOPQRSTUVWXYZ\
+ abcdefghijklmnopqrstuvwxyz\
+ 0123456789+/=";
+
+ static char *base64_decode_table = NULL;
+
+ static void init_base64_table(void)
+ {int j;
+ base64_decode_table = (char *) malloc(256);
+ memset(base64_decode_table,-1,256);
+ for(j=0;j<65;++j)
+ base64_decode_table[base64_encode_table[j]] = j;}
+
+ #define BITMSK(N) ((1 << (N)) - 1)
+
+ #define ITEM1(X) (X >> 2) & BITMSK(6)
+ #define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4))
+ #define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2))
+ #define ITEM4(X) X & BITMSK(6)
+
+ LISP base64encode(LISP in)
+ {char *s,*t = base64_encode_table;
+ unsigned char *p1,*p2;
+ LISP out;
+ long j,m,n,chunks,leftover;
+ s = get_c_string_dim(in,&n);
+ chunks = n / 3;
+ leftover = n % 3;
+ m = (chunks + ((leftover) ? 1 : 0)) * 4;
+ out = strcons(m,NULL);
+ p2 = (unsigned char *) get_c_string(out);
+ for(j=0,p1=(unsigned char *)s;j<chunks;++j,p1 += 3)
+ {*p2++ = t[ITEM1(p1[0])];
+ *p2++ = t[ITEM2(p1[0],p1[1])];
+ *p2++ = t[ITEM3(p1[1],p1[2])];
+ *p2++ = t[ITEM4(p1[2])];}
+ switch(leftover)
+ {case 0:
+ break;
+ case 1:
+ *p2++ = t[ITEM1(p1[0])];
+ *p2++ = t[ITEM2(p1[0],0)];
+ *p2++ = base64_encode_table[64];
+ *p2++ = base64_encode_table[64];
+ break;
+ case 2:
+ *p2++ = t[ITEM1(p1[0])];
+ *p2++ = t[ITEM2(p1[0],p1[1])];
+ *p2++ = t[ITEM3(p1[1],0)];
+ *p2++ = base64_encode_table[64];
+ break;
+ default:
+ errswitch();}
+ return(out);}
+
+ LISP base64decode(LISP in)
+ {char *s,*t = base64_decode_table;
+ LISP out;
+ unsigned char *p1,*p2;
+ long j,m,n,chunks,leftover,item1,item2,item3,item4;
+ s = get_c_string(in);
+ n = strlen(s);
+ if (n == 0) return(strcons(0,NULL));
+ if (n % 4)
+ err("illegal base64 data length",in);
+ if (s[n-1] == base64_encode_table[64])
+ if (s[n-2] == base64_encode_table[64])
+ leftover = 1;
+ else
+ leftover = 2;
+ else
+ leftover = 0;
+ chunks = (n / 4 ) - ((leftover) ? 1 : 0);
+ m = (chunks * 3) + leftover;
+ out = strcons(m,NULL);
+ p2 = (unsigned char *) get_c_string(out);
+ for(j=0,p1=(unsigned char *)s;j<chunks;++j,p1 += 4)
+ {if ((item1 = t[p1[0]]) & ~BITMSK(6)) return(NIL);
+ if ((item2 = t[p1[1]]) & ~BITMSK(6)) return(NIL);
+ if ((item3 = t[p1[2]]) & ~BITMSK(6)) return(NIL);
+ if ((item4 = t[p1[3]]) & ~BITMSK(6)) return(NIL);
+ *p2++ = (unsigned char) ((item1 << 2) | (item2 >> 4));
+ *p2++ = (unsigned char) ((item2 << 4) | (item3 >> 2));
+ *p2++ = (unsigned char) ((item3 << 6) | item4);}
+ switch(leftover)
+ {case 0:
+ break;
+ case 1:
+ if ((item1 = t[p1[0]]) & ~BITMSK(6)) return(NIL);
+ if ((item2 = t[p1[1]]) & ~BITMSK(6)) return(NIL);
+ *p2++ = (unsigned char) ((item1 << 2) | (item2 >> 4));
+ break;
+ case 2:
+ if ((item1 = t[p1[0]]) & ~BITMSK(6)) return(NIL);
+ if ((item2 = t[p1[1]]) & ~BITMSK(6)) return(NIL);
+ if ((item3 = t[p1[2]]) & ~BITMSK(6)) return(NIL);
+ *p2++ = (unsigned char) ((item1 << 2) | (item2 >> 4));
+ *p2++ = (unsigned char) ((item2 << 4) | (item3 >> 2));
+ break;
+ default:
+ errswitch();}
+ return(out);}
+
+ LISP memq(LISP x,LISP il)
+ {LISP l,tmp;
+ for(l=il;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if EQ(x,tmp) return(l);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to memq",il));}
+
+ LISP member(LISP x,LISP il)
+ {LISP l,tmp;
+ for(l=il;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if NNULLP(equal(x,tmp)) return(l);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to member",il));}
+
+ LISP memv(LISP x,LISP il)
+ {LISP l,tmp;
+ for(l=il;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if NNULLP(eql(x,tmp)) return(l);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to memv",il));}
+
+
+ LISP nth(LISP x,LISP li)
+ {LISP l;
+ long j,n = get_c_long(x);
+ for(j = 0, l = li; (j < n) && CONSP(l); ++j) l = CDR(l);
+ if CONSP(l)
+ return(CAR(l));
+ else
+ return(err("bad arg to nth",x));}
+
+ /* these lxxx_default functions are convenient for manipulating
+ command-line argument lists */
+
+ LISP lref_default(LISP li,LISP x,LISP fcn)
+ {LISP l;
+ long j,n = get_c_long(x);
+ for(j = 0, l = li; (j < n) && CONSP(l); ++j) l = CDR(l);
+ if CONSP(l)
+ return(CAR(l));
+ else if NNULLP(fcn)
+ return(lapply(fcn,NIL));
+ else
+ return(NIL);}
+
+ LISP larg_default(LISP li,LISP x,LISP dval)
+ {LISP l = li,elem;
+ long j=0,n = get_c_long(x);
+ while NNULLP(l)
+ {elem = car(l);
+ if (TYPEP(elem,tc_string) && strchr("-:",*get_c_string(elem)))
+ l = cdr(l);
+ else if (j == n)
+ return(elem);
+ else
+ {l = cdr(l);
+ ++j;}}
+ return(dval);}
+
+ LISP lkey_default(LISP li,LISP key,LISP dval)
+ {LISP l = li,elem;
+ char *ckey,*celem;
+ long n;
+ ckey = get_c_string(key);
+ n = strlen(ckey);
+ while NNULLP(l)
+ {elem = car(l);
+ if (TYPEP(elem,tc_string) && (*(celem = get_c_string(elem)) == ':') &&
+ (strncmp(&celem[1],ckey,n) == 0) && (celem[n+1] == '='))
+ return(strcons(strlen(&celem[n+2]),&celem[n+2]));
+ l = cdr(l);}
+ return(dval);}
+
+
+ LISP llist(LISP l)
+ {return(l);}
+
+ LISP writes1(FILE *f,LISP l)
+ {LISP v;
+ STACK_CHECK(&v);
+ INTERRUPT_CHECK();
+ for(v=l;CONSP(v);v=CDR(v))
+ writes1(f,CAR(v));
+ switch TYPE(v)
+ {case tc_nil:
+ break;
+ case tc_symbol:
+ case tc_string:
+ fput_st(f,get_c_string(v));
+ break;
+ default:
+ lprin1f(v,f);
+ break;}
+ return(NIL);}
+
+ LISP writes(LISP args)
+ {return(writes1(get_c_file(car(args),stdout),cdr(args)));}
+
+ LISP last(LISP l)
+ {LISP v1,v2;
+ v1 = l;
+ v2 = CONSP(v1) ? CDR(v1) : err("bad arg to last",l);
+ while(CONSP(v2))
+ {INTERRUPT_CHECK();
+ v1 = v2;
+ v2 = CDR(v2);}
+ return(v1);}
+
+ LISP butlast(LISP l)
+ {INTERRUPT_CHECK();
+ STACK_CHECK(&l);
+ if NULLP(l) err("list is empty",l);
+ if CONSP(l)
+ if NULLP(CDR(l))
+ return(NIL);
+ else
+ return(cons(CAR(l),butlast(CDR(l))));
+ return(err("not a list",l));}
+
+ LISP nconc(LISP a,LISP b)
+ {if NULLP(a)
+ return(b);
+ setcdr(last(a),b);
+ return(a);}
+
+ LISP funcall1(LISP fcn,LISP a1)
+ {switch TYPE(fcn)
+ {case tc_subr_1:
+ STACK_CHECK(&fcn);
+ INTERRUPT_CHECK();
+ return(SUBR1(fcn)(a1));
+ case tc_closure:
+ if TYPEP(fcn->storage_as.closure.code,tc_subr_2)
+ {STACK_CHECK(&fcn);
+ INTERRUPT_CHECK();
+ return(SUBR2(fcn->storage_as.closure.code)
+ (fcn->storage_as.closure.env,a1));}
+ default:
+ return(lapply(fcn,cons(a1,NIL)));}}
+
+ LISP funcall2(LISP fcn,LISP a1,LISP a2)
+ {switch TYPE(fcn)
+ {case tc_subr_2:
+ case tc_subr_2n:
+ STACK_CHECK(&fcn);
+ INTERRUPT_CHECK();
+ return(SUBR2(fcn)(a1,a2));
+ default:
+ return(lapply(fcn,cons(a1,cons(a2,NIL))));}}
+
+ LISP lqsort(LISP l,LISP f,LISP g)
+ /* this is a stupid recursive qsort */
+ {int j,n;
+ LISP v,mark,less,notless;
+ for(v=l,n=0;CONSP(v);v=CDR(v),++n) INTERRUPT_CHECK();
+ if NNULLP(v) err("bad list to qsort",l);
+ if (n == 0)
+ return(NIL);
+ j = rand() % n;
+ for(v=l,n=0;n<j;++n) v=CDR(v);
+ mark = CAR(v);
+ for(less=NIL,notless=NIL,v=l,n=0;NNULLP(v);v=CDR(v),++n)
+ if (j != n)
+ {if NNULLP(funcall2(f,
+ NULLP(g) ? CAR(v) : funcall1(g,CAR(v)),
+ NULLP(g) ? mark : funcall1(g,mark)))
+ less = cons(CAR(v),less);
+ else
+ notless = cons(CAR(v),notless);}
+ return(nconc(lqsort(less,f,g),
+ cons(mark,
+ lqsort(notless,f,g))));}
+
+ LISP string_lessp(LISP s1,LISP s2)
+ {if (strcmp(get_c_string(s1),get_c_string(s2)) < 0)
+ return(sym_t);
+ else
+ return(NIL);}
+
+ LISP benchmark_funcall1(LISP ln,LISP f,LISP a1)
+ {long j,n;
+ LISP value = NIL;
+ n = get_c_long(ln);
+ for(j=0;j<n;++j)
+ value = funcall1(f,a1);
+ return(value);}
+
+ LISP benchmark_funcall2(LISP l)
+ {long j,n;
+ LISP ln = car(l);LISP f = car(cdr(l)); LISP a1 = car(cdr(cdr(l)));
+ LISP a2 = car(cdr(cdr(cdr(l))));
+ LISP value = NIL;
+ n = get_c_long(ln);
+ for(j=0;j<n;++j)
+ value = funcall2(f,a1,a2);
+ return(value);}
+
+ LISP benchmark_eval(LISP ln,LISP exp,LISP env)
+ {long j,n;
+ LISP value = NIL;
+ n = get_c_long(ln);
+ for(j=0;j<n;++j)
+ value = leval(exp,env);
+ return(value);}
+
+ LISP mapcar1(LISP fcn,LISP in)
+ {LISP res,ptr,l;
+ if NULLP(in) return(NIL);
+ res = ptr = cons(funcall1(fcn,car(in)),NIL);
+ for(l=cdr(in);CONSP(l);l=CDR(l))
+ ptr = CDR(ptr) = cons(funcall1(fcn,CAR(l)),CDR(ptr));
+ return(res);}
+
+ LISP mapcar2(LISP fcn,LISP in1,LISP in2)
+ {LISP res,ptr,l1,l2;
+ if (NULLP(in1) || NULLP(in2)) return(NIL);
+ res = ptr = cons(funcall2(fcn,car(in1),car(in2)),NIL);
+ for(l1=cdr(in1),l2=cdr(in2);CONSP(l1) && CONSP(l2);l1=CDR(l1),l2=CDR(l2))
+ ptr = CDR(ptr) = cons(funcall2(fcn,CAR(l1),CAR(l2)),CDR(ptr));
+ return(res);}
+
+ LISP mapcar(LISP l)
+ {LISP fcn = car(l);
+ switch(get_c_long(llength(l)))
+ {case 2:
+ return(mapcar1(fcn,car(cdr(l))));
+ case 3:
+ return(mapcar2(fcn,car(cdr(l)),car(cdr(cdr(l)))));
+ default:
+ return(err("mapcar case not handled",l));}}
+
+ LISP lfmod(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to fmod",x);
+ if NFLONUMP(y) err("wta(2nd) to fmod",y);
+ return(flocons(fmod(FLONM(x),FLONM(y))));}
+
+ LISP lsubset(LISP fcn,LISP l)
+ {LISP result = NIL,v;
+ for(v=l;CONSP(v);v=CDR(v))
+ if NNULLP(funcall1(fcn,CAR(v)))
+ result = cons(CAR(v),result);
+ return(nreverse(result));}
+
+ LISP ass(LISP x,LISP alist,LISP fcn)
+ {LISP l,tmp;
+ for(l=alist;CONSP(l);l=CDR(l))
+ {tmp = CAR(l);
+ if (CONSP(tmp) && NNULLP(funcall2(fcn,CAR(tmp),x))) return(tmp);
+ INTERRUPT_CHECK();}
+ if EQ(l,NIL) return(NIL);
+ return(err("improper list to ass",alist));}
+
+ LISP append2(LISP l1,LISP l2)
+ {long n;
+ LISP result = NIL,p1,p2;
+ n = nlength(l1) + nlength(l2);
+ while(n > 0) {result = cons(NIL,result); --n;}
+ for(p1=result,p2=l1;NNULLP(p2);p1=cdr(p1),p2=cdr(p2)) setcar(p1,car(p2));
+ for(p2=l2;NNULLP(p2);p1=cdr(p1),p2=cdr(p2)) setcar(p1,car(p2));
+ return(result);}
+
+ LISP append(LISP l)
+ {STACK_CHECK(&l);
+ INTERRUPT_CHECK();
+ if NULLP(l)
+ return(NIL);
+ else if NULLP(cdr(l))
+ return(car(l));
+ else if NULLP(cddr(l))
+ return(append2(car(l),cadr(l)));
+ else
+ return(append2(car(l),append(cdr(l))));}
+
+ LISP listn(long n, ...)
+ {LISP result,ptr;
+ long j;
+ va_list args;
+ for(j=0,result=NIL;j<n;++j) result = cons(NIL,result);
+ va_start(args,n);
+ for(j=0,ptr=result;j<n;ptr=cdr(ptr),++j)
+ setcar(ptr,va_arg(args,LISP));
+ va_end(args);
+ return(result);}
+
+
+ LISP fast_load(LISP lfname,LISP noeval)
+ {char *fname;
+ LISP stream;
+ LISP result = NIL,form;
+ fname = get_c_string(lfname);
+ if (siod_verbose_level >= 3)
+ {put_st("fast loading ");
+ put_st(fname);
+ put_st("\n");}
+ stream = listn(3,
+ fopen_c(fname,"rb"),
+ cons_array(flocons(100),NIL),
+ flocons(0));
+ while(NEQ(stream,form = fast_read(stream)))
+ {if (siod_verbose_level >= 5)
+ lprint(form,NIL);
+ if NULLP(noeval)
+ leval(form,NIL);
+ else
+ result = cons(form,result);}
+ fclose_l(car(stream));
+ if (siod_verbose_level >= 3)
+ put_st("done.\n");
+ return(nreverse(result));}
+
+ static void shexstr(char *outstr,void *buff,size_t len)
+ {unsigned char *data = buff;
+ size_t j;
+ for(j=0;j<len;++j)
+ sprintf(&outstr[j*2],"%02X",data[j]);}
+
+ LISP fast_save(LISP fname,LISP forms,LISP nohash,LISP comment,LISP fmode)
+ {char *cname,msgbuff[100],databuff[50];
+ LISP stream,l;
+ FILE *f;
+ long l_one = 1;
+ double d_one = 1.0;
+ cname = get_c_string(fname);
+ if (siod_verbose_level >= 3)
+ {put_st("fast saving forms to ");
+ put_st(cname);
+ put_st("\n");}
+ stream = listn(3,
+ fopen_c(cname,NNULLP(fmode) ? get_c_string(fmode) : "wb"),
+ NNULLP(nohash) ? NIL : cons_array(flocons(100),NIL),
+ flocons(0));
+ f = get_c_file(car(stream),NULL);
+ if NNULLP(comment)
+ fput_st(f,get_c_string(comment));
+ sprintf(msgbuff,"# Siod Binary Object Save File\n");
+ fput_st(f,msgbuff);
+ sprintf(msgbuff,"# sizeof(long) = %d\n# sizeof(double) = %d\n",
+ sizeof(long),sizeof(double));
+ fput_st(f,msgbuff);
+ shexstr(databuff,&l_one,sizeof(l_one));
+ sprintf(msgbuff,"# 1 = %s\n",databuff);
+ fput_st(f,msgbuff);
+ shexstr(databuff,&d_one,sizeof(d_one));
+ sprintf(msgbuff,"# 1.0 = %s\n",databuff);
+ fput_st(f,msgbuff);
+ for(l=forms;NNULLP(l);l=cdr(l))
+ fast_print(car(l),stream);
+ fclose_l(car(stream));
+ if (siod_verbose_level >= 3)
+ put_st("done.\n");
+ return(NIL);}
+
+ void swrite1(LISP stream,LISP data)
+ {FILE *f = get_c_file(stream,stdout);
+ switch TYPE(data)
+ {case tc_symbol:
+ case tc_string:
+ fput_st(f,get_c_string(data));
+ break;
+ default:
+ lprin1f(data,f);
+ break;}}
+
+ static LISP swrite2(LISP name,LISP table)
+ {LISP value,key;
+ if (SYMBOLP(name) && (PNAME(name)[0] == '.'))
+ key = rintern(&PNAME(name)[1]);
+ else
+ key = name;
+ value = href(table,key);
+ if (CONSP(value))
+ {if (CONSP(CDR(value)) && EQ(name,key))
+ hset(table,key,CDR(value));
+ return(CAR(value));}
+ else if (NULLP(value))
+ return(name);
+ else
+ return(value);}
+
+ LISP swrite(LISP stream,LISP table,LISP data)
+ {long j,k,m,n;
+ switch(TYPE(data))
+ {case tc_symbol:
+ swrite1(stream,swrite2(data,table));
+ break;
+ case tc_lisp_array:
+ n = data->storage_as.lisp_array.dim;
+ if (n < 1)
+ err("no object repeat count",data);
+ m = get_c_long(swrite2(data->storage_as.lisp_array.data[0],
+ table));
+ for(k=0;k<m;++k)
+ for(j=1;j<n;++j)
+ swrite(stream,table,data->storage_as.lisp_array.data[j]);
+ break;
+ case tc_cons:
+ /* this should be handled similar to the array case */
+ break;
+ default:
+ swrite1(stream,data);}
+ return(NIL);}
+
+ LISP lpow(LISP x,LISP y)
+ {if NFLONUMP(x) err("wta(1st) to pow",x);
+ if NFLONUMP(y) err("wta(2nd) to pow",y);
+ return(flocons(pow(FLONM(x),FLONM(y))));}
+
+ LISP lexp(LISP x)
+ {return(flocons(exp(get_c_double(x))));}
+
+ LISP llog(LISP x)
+ {return(flocons(log(get_c_double(x))));}
+
+ LISP lsin(LISP x)
+ {return(flocons(sin(get_c_double(x))));}
+
+ LISP lcos(LISP x)
+ {return(flocons(cos(get_c_double(x))));}
+
+ LISP ltan(LISP x)
+ {return(flocons(tan(get_c_double(x))));}
+
+ LISP lasin(LISP x)
+ {return(flocons(asin(get_c_double(x))));}
+
+ LISP lacos(LISP x)
+ {return(flocons(acos(get_c_double(x))));}
+
+ LISP latan(LISP x)
+ {return(flocons(atan(get_c_double(x))));}
+
+ LISP latan2(LISP x,LISP y)
+ {return(flocons(atan2(get_c_double(x),get_c_double(y))));}
+
+ LISP hexstr(LISP a)
+ {unsigned char *in;
+ char *out;
+ LISP result;
+ long j,dim;
+ in = (unsigned char *) get_c_string_dim(a,&dim);
+ result = strcons(dim*2,NULL);
+ for(out=get_c_string(result),j=0;j<dim;++j,out += 2)
+ sprintf(out,"%02x",in[j]);
+ return(result);}
+
+ static int xdigitvalue(int c)
+ {if (isdigit(c))
+ return(c - '0');
+ if (isxdigit(c))
+ return(toupper(c) - 'A' + 10);
+ return(0);}
+
+ LISP hexstr2bytes(LISP a)
+ {char *in;
+ unsigned char *out;
+ LISP result;
+ long j,dim;
+ in = get_c_string(a);
+ dim = strlen(in) / 2;
+ result = arcons(tc_byte_array,dim,0);
+ out = (unsigned char *) result->storage_as.string.data;
+ for(j=0;j<dim;++j)
+ out[j] = xdigitvalue(in[j*2]) * 16 + xdigitvalue(in[j*2+1]);
+ return(result);}
+
+ LISP getprop(LISP plist,LISP key)
+ {LISP l;
+ for(l=cdr(plist);NNULLP(l);l=cddr(l))
+ if EQ(car(l),key)
+ return(cadr(l));
+ else
+ INTERRUPT_CHECK();
+ return(NIL);}
+
+ LISP setprop(LISP plist,LISP key,LISP value)
+ {err("not implemented",NIL);
+ return(NIL);}
+
+ LISP putprop(LISP plist,LISP value,LISP key)
+ {return(setprop(plist,key,value));}
+
+ LISP ltypeof(LISP obj)
+ {long x;
+ x = TYPE(obj);
+ switch(x)
+ {case tc_nil: return(cintern("tc_nil"));
+ case tc_cons: return(cintern("tc_cons"));
+ case tc_flonum: return(cintern("tc_flonum"));
+ case tc_symbol: return(cintern("tc_symbol"));
+ case tc_subr_0: return(cintern("tc_subr_0"));
+ case tc_subr_1: return(cintern("tc_subr_1"));
+ case tc_subr_2: return(cintern("tc_subr_2"));
+ case tc_subr_2n: return(cintern("tc_subr_2n"));
+ case tc_subr_3: return(cintern("tc_subr_3"));
+ case tc_subr_4: return(cintern("tc_subr_4"));
+ case tc_subr_5: return(cintern("tc_subr_5"));
+ case tc_lsubr: return(cintern("tc_lsubr"));
+ case tc_fsubr: return(cintern("tc_fsubr"));
+ case tc_msubr: return(cintern("tc_msubr"));
+ case tc_closure: return(cintern("tc_closure"));
+ case tc_free_cell: return(cintern("tc_free_cell"));
+ case tc_string: return(cintern("tc_string"));
+ case tc_byte_array: return(cintern("tc_byte_array"));
+ case tc_double_array: return(cintern("tc_double_array"));
+ case tc_long_array: return(cintern("tc_long_array"));
+ case tc_lisp_array: return(cintern("tc_lisp_array"));
+ case tc_c_file: return(cintern("tc_c_file"));
+ default: return(flocons(x));}}
+
+ LISP caaar(LISP x)
+ {return(car(car(car(x))));}
+
+ LISP caadr(LISP x)
+ {return(car(car(cdr(x))));}
+
+ LISP cadar(LISP x)
+ {return(car(cdr(car(x))));}
+
+ LISP caddr(LISP x)
+ {return(car(cdr(cdr(x))));}
+
+ LISP cdaar(LISP x)
+ {return(cdr(car(car(x))));}
+
+ LISP cdadr(LISP x)
+ {return(cdr(car(cdr(x))));}
+
+ LISP cddar(LISP x)
+ {return(cdr(cdr(car(x))));}
+
+ LISP cdddr(LISP x)
+ {return(cdr(cdr(cdr(x))));}
+
+ LISP ash(LISP value,LISP n)
+ {long m,k;
+ m = get_c_long(value);
+ k = get_c_long(n);
+ if (k > 0)
+ m = m << k;
+ else
+ m = m >> (-k);
+ return(flocons(m));}
+
+ LISP bitand(LISP a,LISP b)
+ {return(flocons(get_c_long(a) & get_c_long(b)));}
+
+ LISP bitor(LISP a,LISP b)
+ {return(flocons(get_c_long(a) | get_c_long(b)));}
+
+ LISP bitxor(LISP a,LISP b)
+ {return(flocons(get_c_long(a) ^ get_c_long(b)));}
+
+ LISP bitnot(LISP a)
+ {return(flocons(~get_c_long(a)));}
+
+ LISP leval_prog1(LISP args,LISP env)
+ {LISP retval,l;
+ retval = leval(car(args),env);
+ for(l=cdr(args);NNULLP(l);l=cdr(l))
+ leval(car(l),env);
+ return(retval);}
+
+ LISP leval_cond(LISP *pform,LISP *penv)
+ {LISP args,env,clause,value,next;
+ args = cdr(*pform);
+ env = *penv;
+ if NULLP(args)
+ {*pform = NIL;
+ return(NIL);}
+ next = cdr(args);
+ while NNULLP(next)
+ {clause = car(args);
+ value = leval(car(clause),env);
+ if NNULLP(value)
+ {clause = cdr(clause);
+ if NULLP(clause)
+ {*pform = value;
+ return(NIL);}
+ else
+ {next = cdr(clause);
+ while(NNULLP(next))
+ {leval(car(clause),env);
+ clause=next;
+ next=cdr(next);}
+ *pform = car(clause);
+ return(sym_t);}}
+ args = next;
+ next = cdr(next);}
+ clause = car(args);
+ next = cdr(clause);
+ if NULLP(next)
+ {*pform = car(clause);
+ return(sym_t);}
+ value = leval(car(clause),env);
+ if NULLP(value)
+ {*pform = NIL;
+ return(NIL);}
+ clause = next;
+ next = cdr(next);
+ while(NNULLP(next))
+ {leval(car(clause),env);
+ clause=next;
+ next=cdr(next);}
+ *pform = car(clause);
+ return(sym_t);}
+
+ LISP lstrspn(LISP str1,LISP str2)
+ {return(flocons(strspn(get_c_string(str1),get_c_string(str2))));}
+
+ LISP lstrcspn(LISP str1,LISP str2)
+ {return(flocons(strcspn(get_c_string(str1),get_c_string(str2))));}
+
+ LISP substring_equal(LISP str1,LISP str2,LISP start,LISP end)
+ {char *cstr1,*cstr2;
+ long len1,n,s,e;
+ cstr1 = get_c_string_dim(str1,&len1);
+ cstr2 = get_c_string_dim(str2,&n);
+ s = NULLP(start) ? 0 : get_c_long(start);
+ e = NULLP(end) ? len1 : get_c_long(end);
+ if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
+ return(NIL);
+ return((memcmp(cstr1,&cstr2[s],e-s) == 0) ? a_true_value() : NIL);}
+
+ #ifdef vms
+ int strncasecmp(const char *s1, const char *s2, int n)
+ {int j,c1,c2;
+ for(j=0;j<n;++j)
+ {c1 = toupper(s1[j]);
+ c2 = toupper(s2[j]);
+ if ((c1 == 0) && (c2 == 0)) return(0);
+ if (c1 == 0) return(-1);
+ if (c2 == 0) return(1);
+ if (c1 < c2) return(-1);
+ if (c2 > c1) return(1);}
+ return(0);}
+ #endif
+
+ LISP substring_equalcase(LISP str1,LISP str2,LISP start,LISP end)
+ {char *cstr1,*cstr2;
+ long len1,n,s,e;
+ cstr1 = get_c_string_dim(str1,&len1);
+ cstr2 = get_c_string_dim(str2,&n);
+ s = NULLP(start) ? 0 : get_c_long(start);
+ e = NULLP(end) ? len1 : get_c_long(end);
+ if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
+ return(NIL);
+ return((strncasecmp(cstr1,&cstr2[s],e-s) == 0) ? a_true_value() : NIL);}
+
+ LISP set_eval_history(LISP len,LISP circ)
+ {LISP data;
+ data = NULLP(len) ? len : make_list(len,NIL);
+ if NNULLP(circ)
+ data = nconc(data,data);
+ setvar(cintern("*eval-history-ptr*"),data,NIL);
+ setvar(cintern("*eval-history*"),data,NIL);
+ return(len);}
+
+ static LISP parser_fasl(LISP ignore)
+ {return(closure(listn(3,
+ NIL,
+ cons_array(flocons(100),NIL),
+ flocons(0)),
+ leval(cintern("parser_fasl_hook"),NIL)));}
+
+ static LISP parser_fasl_hook(LISP env,LISP f)
+ {LISP result;
+ setcar(env,f);
+ result = fast_read(env);
+ if EQ(result,env)
+ return(get_eof_val());
+ else
+ return(result);}
+
+ void init_subrs_a(void)
+ {init_subr_2("aref",aref1);
+ init_subr_3("aset",aset1);
+ init_lsubr("string-append",string_append);
+ init_lsubr("bytes-append",bytes_append);
+ init_subr_1("string-length",string_length);
+ init_subr_1("string-dimension",string_dim);
+ init_subr_1("read-from-string",read_from_string);
+ init_subr_3("print-to-string",print_to_string);
+ init_subr_2("cons-array",cons_array);
+ init_subr_2("sxhash",sxhash);
+ init_subr_2("equal?",equal);
+ init_subr_2("href",href);
+ init_subr_3("hset",hset);
+ init_subr_2("assoc",assoc);
+ init_subr_2("assv",assv);
+ init_subr_1("fast-read",fast_read);
+ init_subr_2("fast-print",fast_print);
+ init_subr_2("make-list",make_list);
+ init_subr_2("fread",lfread);
+ init_subr_2("fwrite",lfwrite);
+ init_subr_1("fflush",lfflush);
+ init_subr_1("length",llength);
+ init_subr_4("number->string",number2string);
+ init_subr_2("string->number",string2number);
+ init_subr_3("substring",substring);
+ init_subr_2("string-search",string_search);
+ init_subr_1("string-trim",string_trim);
+ init_subr_1("string-trim-left",string_trim_left);
+ init_subr_1("string-trim-right",string_trim_right);
+ init_subr_1("string-upcase",string_upcase);
+ init_subr_1("string-downcase",string_downcase);
+ init_subr_2("strcmp",lstrcmp);
+ init_subr_2("strcat",lstrcat);
+ init_subr_2("strcpy",lstrcpy);
+ init_subr_2("strbreakup",lstrbreakup);
+ init_subr_2("unbreakupstr",lstrunbreakup);
+ init_subr_1("string?",stringp);
+ gc_protect_sym(&sym_e,"e");
+ gc_protect_sym(&sym_f,"f");
+ gc_protect_sym(&sym_plists,"*plists*");
+ setvar(sym_plists,arcons(tc_lisp_array,100,1),NIL);
+ init_subr_3("lref-default",lref_default);
+ init_subr_3("larg-default",larg_default);
+ init_subr_3("lkey-default",lkey_default);
+ init_lsubr("list",llist);
+ init_lsubr("writes",writes);
+ init_subr_3("qsort",lqsort);
+ init_subr_2("string-lessp",string_lessp);
+ init_lsubr("mapcar",mapcar);
+ init_subr_3("mapcar2",mapcar2);
+ init_subr_2("mapcar1",mapcar1);
+ init_subr_3("benchmark-funcall1",benchmark_funcall1);
+ init_lsubr("benchmark-funcall2",benchmark_funcall2);
+ init_subr_3("benchmark-eval",benchmark_eval);
+ init_subr_2("fmod",lfmod);
+ init_subr_2("subset",lsubset);
+ init_subr_1("base64encode",base64encode);
+ init_subr_1("base64decode",base64decode);
+ init_subr_3("ass",ass);
+ init_subr_2("append2",append2);
+ init_lsubr("append",append);
+ init_subr_5("fast-save",fast_save);
+ init_subr_2("fast-load",fast_load);
+ init_subr_3("swrite",swrite);
+ init_subr_2("pow",lpow);
+ init_subr_1("exp",lexp);
+ init_subr_1("log",llog);
+ init_subr_1("sin",lsin);
+ init_subr_1("cos",lcos);
+ init_subr_1("tan",ltan);
+ init_subr_1("asin",lasin);
+ init_subr_1("acos",lacos);
+ init_subr_1("atan",latan);
+ init_subr_2("atan2",latan2);
+ init_subr_1("typeof",ltypeof);
+ init_subr_1("caaar",caaar);
+ init_subr_1("caadr",caadr);
+ init_subr_1("cadar",cadar);
+ init_subr_1("caddr",caddr);
+ init_subr_1("cdaar",cdaar);
+ init_subr_1("cdadr",cdadr);
+ init_subr_1("cddar",cddar);
+ init_subr_1("cdddr",cdddr);
+ setvar(cintern("*pi*"),flocons(atan(1.0)*4),NIL);
+ init_base64_table();
+ init_subr_1("array->hexstr",hexstr);
+ init_subr_1("hexstr->bytes",hexstr2bytes);
+ init_subr_3("ass",ass);
+ init_subr_2("bit-and",bitand);
+ init_subr_2("bit-or",bitor);
+ init_subr_2("bit-xor",bitxor);
+ init_subr_1("bit-not",bitnot);
+ init_msubr("cond",leval_cond);
+ init_fsubr("prog1",leval_prog1);
+ init_subr_2("strspn",lstrspn);
+ init_subr_2("strcspn",lstrcspn);
+ init_subr_4("substring-equal?",substring_equal);
+ init_subr_4("substring-equalcase?",substring_equalcase);
+ init_subr_1("butlast",butlast);
+ init_subr_2("ash",ash);
+ init_subr_2("get",getprop);
+ init_subr_3("setprop",setprop);
+ init_subr_3("putprop",putprop);
+ init_subr_1("last",last);
+ init_subr_2("memq",memq);
+ init_subr_2("memv",memv);
+ init_subr_2("member",member);
+ init_subr_2("nth",nth);
+ init_subr_2("nconc",nconc);
+ init_subr_2("set-eval-history",set_eval_history);
+ init_subr_1("parser_fasl",parser_fasl);
+ setvar(cintern("*parser_fasl.scm-loaded*"),a_true_value(),NIL);
+ init_subr_2("parser_fasl_hook",parser_fasl_hook);
+ init_sliba_version();}
+
Index: llvm/test/Programs/MultiSource/Applications/siod/slibu.c
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/slibu.c:1.1
*** /dev/null Fri Oct 17 13:48:56 2003
--- llvm/test/Programs/MultiSource/Applications/siod/slibu.c Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,2337 ----
+ /*-*-mode:c-*-*/
+
+ /* DEC-94 George Carrette. Additional lisp util subrs,
+ many of them depending on operating system calls.
+ Note that I have avoided more than one nesting of conditional compilation,
+ and the use of the else clause, in hopes of preserving some readability.
+ For better or worse I avoided gnu autoconfigure because it was complex required
+ scripts nearly as big as this source file. Meanwhile there is some ANSI POSIX
+ convergence going on.
+ */
+
+ #include <stdio.h>
+ #include <string.h>
+ #include <ctype.h>
+ #include <setjmp.h>
+ #include <signal.h>
+ #include <math.h>
+ #include <stdlib.h>
+ #include <time.h>
+ #include <errno.h>
+ #include <stdarg.h>
+
+ #if defined(unix)
+ #include <unistd.h>
+ #include <dirent.h>
+ #include <sys/types.h>
+ #include <sys/wait.h>
+ #include <pwd.h>
+ #include <sys/stat.h>
+ #include <sys/time.h>
+ #include <sys/resource.h>
+ #include <grp.h>
+ #include <utime.h>
+ #include <sys/fcntl.h>
+ #endif
+
+ #if defined(__osf__) || defined(sun)
+ #include <sys/mode.h>
+ #endif
+
+ #if defined(__osf__) || defined(SUN5)
+ #include <fnmatch.h>
+ #endif
+
+ #if defined(__osf__)
+ #include <rld_interface.h>
+ #endif
+
+ #if defined(hpux)
+ #include <dl.h>
+ #endif
+
+ #if defined(__osf__) || defined(sun) || defined(linux) || defined(sgi)
+ #include <dlfcn.h>
+ #endif
+
+ #if defined(sun)
+ #include <crypt.h>
+ #include <limits.h>
+ #include <sys/mkdev.h>
+ #include <fcntl.h>
+ #endif
+
+ #if defined(linux) && defined(PPC)
+ /* I know, this should be defined(NEED_CRYPT_H) */
+ #include <crypt.h>
+ #endif
+
+ #if defined(sgi)
+ #include <limits.h>
+ #endif
+
+ #if defined(hpux)
+ #define PATH_MAX MAXPATHLEN
+ #endif
+
+ #if defined(VMS)
+ #include <unixlib.h>
+ #include <stat.h>
+ #include <ssdef.h>
+ #include <descrip.h>
+ #include <lib$routines.h>
+ #include <descrip.h>
+ #include <ssdef.h>
+ #include <iodef.h>
+ #include <lnmdef.h>
+ #endif
+
+ #ifdef WIN32
+ #include <windows.h>
+ #include <io.h>
+ #include <sys/types.h>
+ #include <sys/stat.h>
+ #include <process.h>
+ #include <direct.h>
+ #endif
+
+ #include "siod.h"
+ #include "siodp.h"
+
+ static void init_slibu_version(void)
+ {setvar(cintern("*slibu-version*"),
+ cintern("$Id: slibu.c,v 1.1 2003/10/17 18:48:45 gaeke Exp $"),
+ NIL);}
+
+
+ LISP sym_channels = NIL;
+ long tc_opendir = 0;
+
+ char *ld_library_path_env = "LD_LIBRARY_PATH";
+
+ #ifdef VMS
+ char *strdup(char *in)
+ {char *r;
+ r = (char *) malloc(strlen(in)+1);
+ strcpy(r,in);
+ return(r);}
+ #endif
+
+ LISP lsystem(LISP args)
+ {int retval;
+ long iflag;
+ iflag = no_interrupt(1);
+ retval = system(get_c_string(string_append(args)));
+ no_interrupt(iflag);
+ if (retval < 0)
+ return(cons(flocons(retval),llast_c_errmsg(-1)));
+ else
+ return(flocons(retval));}
+
+ #ifndef WIN32
+ LISP lgetuid(void)
+ {return(flocons(getuid()));}
+
+ LISP lgetgid(void)
+ {return(flocons(getgid()));}
+ #endif
+
+ #ifdef unix
+
+ LISP lcrypt(LISP key,LISP salt)
+ {char *result;
+ if ((result = crypt(get_c_string(key),get_c_string(salt))))
+ return(strcons(strlen(result),result));
+ else
+ return(NIL);}
+
+ #endif
+
+ #if defined(unix) || defined(WIN32)
+
+ #if defined(WIN32)
+ #define getcwd _getcwd
+ #define PATH_MAX _MAX_PATH
+ #endif
+
+ LISP lgetcwd(void)
+ {char path[PATH_MAX+1];
+ if (getcwd(path,sizeof(path)))
+ return(strcons(strlen(path),path));
+ else
+ return(err("getcwd",llast_c_errmsg(-1)));}
+
+ #endif
+
+ #ifdef unix
+
+
+ LISP ldecode_pwent(struct passwd *p)
+ {return(symalist(
+ "name",strcons(strlen(p->pw_name),p->pw_name),
+ "passwd",strcons(strlen(p->pw_passwd),p->pw_passwd),
+ "uid",flocons(p->pw_uid),
+ "gid",flocons(p->pw_gid),
+ "dir",strcons(strlen(p->pw_dir),p->pw_dir),
+ "gecos",strcons(strlen(p->pw_gecos),p->pw_gecos),
+ #if defined(__osf__) || defined(hpux) || defined(sun)
+ "comment",strcons(strlen(p->pw_comment),p->pw_comment),
+ #endif
+ #if defined(hpux) || defined(sun)
+ "age",strcons(strlen(p->pw_age),p->pw_age),
+ #endif
+ #if defined(__osf__)
+ "quota",flocons(p->pw_quota),
+ #endif
+ "shell",strcons(strlen(p->pw_shell),p->pw_shell),
+ NULL));}
+
+ static char *strfield(char *name,LISP alist)
+ {LISP value,key = rintern(name);
+ if NULLP(value = assq(key,alist))
+ return("");
+ return(get_c_string(cdr(value)));}
+
+ static long longfield(char *name,LISP alist)
+ {LISP value,key = rintern(name);
+ if NULLP(value = assq(key,alist))
+ return(0);
+ return(get_c_long(cdr(value)));}
+
+ void lencode_pwent(LISP alist,struct passwd *p)
+ {p->pw_name = strfield("name",alist);
+ p->pw_passwd = strfield("passwd",alist);
+ p->pw_uid = longfield("uid",alist);
+ p->pw_gid = longfield("gid",alist);
+ p->pw_dir = strfield("dir",alist);
+ p->pw_gecos = strfield("gecos",alist);
+ #if defined(__osf__) || defined(hpux) || defined(sun)
+ p->pw_comment = strfield("comment",alist);
+ #endif
+ #if defined(hpux) || defined(sun)
+ p->pw_age = strfield("age",alist);
+ #endif
+ #if defined(__osf__)
+ p->pw_quota = longfield("quota",alist);
+ #endif
+ p->pw_shell = strfield("shell",alist);}
+
+ LISP lgetpwuid(LISP luid)
+ {int iflag;
+ uid_t uid;
+ struct passwd *p;
+ LISP result = NIL;
+ uid = get_c_long(luid);
+ iflag = no_interrupt(1);
+ if ((p = getpwuid(uid)))
+ result = ldecode_pwent(p);
+ no_interrupt(iflag);
+ return(result);}
+
+ LISP lgetpwnam(LISP nam)
+ {int iflag;
+ struct passwd *p;
+ LISP result = NIL;
+ iflag = no_interrupt(1);
+ if ((p = getpwnam(get_c_string(nam))))
+ result = ldecode_pwent(p);
+ no_interrupt(iflag);
+ return(result);}
+
+ LISP lgetpwent(void)
+ {int iflag;
+ LISP result = NIL;
+ struct passwd *p;
+ iflag = no_interrupt(1);
+ if ((p = getpwent()))
+ result = ldecode_pwent(p);
+ no_interrupt(iflag);
+ return(result);}
+
+ LISP lsetpwent(void)
+ {int iflag = no_interrupt(1);
+ setpwent();
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP lendpwent(void)
+ {int iflag = no_interrupt(1);
+ endpwent();
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP lsetuid(LISP n)
+ {uid_t uid;
+ uid = (uid_t) get_c_long(n);
+ if (setuid(uid))
+ return(err("setuid",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+ LISP lseteuid(LISP n)
+ {uid_t uid;
+ uid = (uid_t) get_c_long(n);
+ if (seteuid(uid))
+ return(err("seteuid",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+ LISP lgeteuid(void)
+ {return(flocons(geteuid()));}
+
+ #if defined(__osf__)
+ LISP lsetpwfile(LISP fname)
+ {int iflag = no_interrupt(1);
+ setpwfile(get_c_string(fname));
+ no_interrupt(iflag);
+ return(NIL);}
+ #endif
+
+ LISP lputpwent(LISP alist,LISP file)
+ {int iflag = no_interrupt(1);
+ int status;
+ struct passwd p;
+ lencode_pwent(alist,&p);
+ status = putpwent(&p,get_c_file(file,NULL));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP laccess_problem(LISP lfname,LISP lacc)
+ {char *fname = get_c_string(lfname);
+ char *acc = get_c_string(lacc),*p;
+ int amode = 0,iflag = no_interrupt(1),retval;
+ for(p=acc;*p;++p)
+ switch(*p)
+ {case 'r':
+ amode |= R_OK;
+ break;
+ case 'w':
+ amode |= W_OK;
+ break;
+ case 'x':
+ amode |= X_OK;
+ break;
+ case 'f':
+ amode |= F_OK;
+ break;
+ default:
+ err("bad access mode",lacc);}
+ retval = access(fname,amode);
+ no_interrupt(iflag);
+ if (retval < 0)
+ return(llast_c_errmsg(-1));
+ else
+ return(NIL);}
+
+ LISP lsymlink(LISP p1,LISP p2)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (symlink(get_c_string(p1),get_c_string(p2)))
+ return(err("symlink",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP llink(LISP p1,LISP p2)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (link(get_c_string(p1),get_c_string(p2)))
+ return(err("link",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP lunlink(LISP p)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (unlink(get_c_string(p)))
+ return(err("unlink",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP lrmdir(LISP p)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (rmdir(get_c_string(p)))
+ return(err("rmdir",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP lmkdir(LISP p,LISP m)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (mkdir(get_c_string(p),get_c_long(m)))
+ return(err("mkdir",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP lreadlink(LISP p)
+ {long iflag;
+ char buff[PATH_MAX+1];
+ int size;
+ iflag = no_interrupt(1);
+ if ((size = readlink(get_c_string(p),buff,sizeof(buff))) < 0)
+ return(err("readlink",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(strcons(size,buff));}
+
+ LISP lrename(LISP p1,LISP p2)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (rename(get_c_string(p1),get_c_string(p2)))
+ return(err("rename",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ #endif
+
+ LISP lrandom(LISP n)
+ {int res;
+ #if defined(hpux) || defined(vms) || defined(sun) || defined(sgi) || defined(WIN32)
+ res = rand();
+ #endif
+ #if defined(__osf__) || defined(linux)
+ res = random();
+ #endif
+ return(flocons(NNULLP(n) ? res % get_c_long(n) : res));}
+
+ LISP lsrandom(LISP n)
+ {long seed;
+ seed = get_c_long(n);
+ #if defined(hpux) || defined(vms) || defined(sun) || defined(sgi) || defined(WIN32)
+ srand(seed);
+ #endif
+ #if defined(__osf__) || defined(linux)
+ srandom(seed);
+ #endif
+ return(NIL);}
+
+ #ifdef unix
+
+ LISP lfork(void)
+ {int iflag;
+ pid_t pid;
+ iflag = no_interrupt(1);
+ pid = fork();
+ if (pid == 0)
+ {no_interrupt(iflag);
+ return(NIL);}
+ if (pid == -1)
+ return(err("fork",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(flocons(pid));}
+
+ #endif
+
+ char **list2char(LISP *safe,LISP v)
+ {char **x,*tmp;
+ long j,n;
+ LISP l;
+ n = get_c_long(llength(v));
+ *safe = cons(mallocl(&x,sizeof(char *) * (n + 1)),*safe);
+ for(l=v,j=0;j<n;l=cdr(l),++j)
+ {tmp = get_c_string(car(l));
+ *safe = cons(mallocl(&x[j],strlen(tmp)+1),*safe);
+ strcpy(x[j],tmp);}
+ x[n] = NULL;
+ return(x);}
+
+ #ifdef unix
+
+ LISP lexec(LISP path,LISP args,LISP env)
+ {int iflag;
+ char **argv = NULL, **envp = NULL;
+ LISP gcsafe=NIL;
+ iflag = no_interrupt(1);
+ argv = list2char(&gcsafe,args);
+ if NNULLP(env)
+ envp = list2char(&gcsafe,env);
+ if (envp)
+ execve(get_c_string(path),argv,envp);
+ else
+ execv(get_c_string(path),argv);
+ no_interrupt(iflag);
+ return(err("exec",llast_c_errmsg(-1)));}
+
+ LISP lnice(LISP val)
+ {int iflag,n;
+ n = get_c_long(val);
+ iflag = no_interrupt(1);
+ n = nice(n);
+ if (n == -1)
+ err("nice",llast_c_errmsg(-1));
+ no_interrupt(iflag);
+ return(flocons(n));}
+
+ #endif
+
+ int assemble_options(LISP l, ...)
+ {int result = 0,val,noptions,nmask = 0;
+ LISP lsym,lp = NIL;
+ char *sym;
+ va_list syms;
+ if NULLP(l) return(0);
+ noptions = CONSP(l) ? get_c_long(llength(l)) : -1;
+ va_start(syms,l);
+ while((sym = va_arg(syms,char *)))
+ {val = va_arg(syms,int);
+ lsym = cintern(sym);
+ if (EQ(l,lsym) || (CONSP(l) && NNULLP(lp = memq(lsym,l))))
+ {result |= val;
+ if (noptions > 0)
+ nmask = nmask | (1 << (noptions - get_c_long(llength(lp))));
+ else
+ noptions = -2;}}
+ va_end(syms);
+ if ((noptions == -1) ||
+ ((noptions > 0) && (nmask != ((1 << noptions) - 1))))
+ err("contains undefined options",l);
+ return(result);}
+
+ #ifdef unix
+
+ LISP lwait(LISP lpid,LISP loptions)
+ {pid_t pid,ret;
+ int iflag,status = 0,options;
+ pid = NULLP(lpid) ? -1 : get_c_long(lpid);
+ options = assemble_options(loptions,
+ #ifdef WCONTINUED
+ "WCONTINUED",WCONTINUED,
+ #endif
+ #ifdef WNOWAIT
+ "WNOWAIT",WNOWAIT,
+ #endif
+ "WNOHANG",WNOHANG,
+ "WUNTRACED",WUNTRACED,
+ NULL);
+ iflag = no_interrupt(1);
+ ret = waitpid(pid,&status,options);
+ no_interrupt(iflag);
+ if (ret == 0)
+ return(NIL);
+ else if (ret == -1)
+ return(err("wait",llast_c_errmsg(-1)));
+ else
+ /* should do more decoding on the status */
+ return(cons(flocons(ret),cons(flocons(status),NIL)));}
+
+ LISP lkill(LISP pid,LISP sig)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (kill(get_c_long(pid),
+ NULLP(sig) ? SIGKILL : get_c_long(sig)))
+ err("kill",llast_c_errmsg(-1));
+ else
+ no_interrupt(iflag);
+ return(NIL);}
+
+ #endif
+
+ LISP lgetpid(void)
+ {return(flocons(getpid()));}
+
+ #ifdef unix
+ LISP lgetpgrp(void)
+ {return(flocons(getpgrp()));}
+
+ LISP lsetpgid(LISP pid,LISP pgid)
+ {if (setpgid(get_c_long(pid),get_c_long(pgid)))
+ return(err("setpgid",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+ LISP lgetgrgid(LISP n)
+ {gid_t gid;
+ struct group *gr;
+ long iflag,j;
+ LISP result = NIL;
+ gid = get_c_long(n);
+ iflag = no_interrupt(1);
+ if ((gr = getgrgid(gid)))
+ {result = cons(strcons(strlen(gr->gr_name),gr->gr_name),result);
+ for(j=0;gr->gr_mem[j];++j)
+ result = cons(strcons(strlen(gr->gr_mem[j]),gr->gr_mem[j]),result);
+ result = nreverse(result);}
+ no_interrupt(iflag);
+ return(result);}
+
+ #endif
+
+ #ifndef WIN32
+ LISP lgetppid(void)
+ {return(flocons(getppid()));}
+ #endif
+
+ LISP lmemref_byte(LISP addr)
+ {unsigned char *ptr = (unsigned char *) get_c_long(addr);
+ return(flocons(*ptr));}
+
+ LISP lexit(LISP val)
+ {int iflag = no_interrupt(1);
+ exit(get_c_long(val));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP ltrunc(LISP x)
+ {long i;
+ if NFLONUMP(x) err("wta to trunc",x);
+ i = (long) FLONM(x);
+ return(flocons((double) i));}
+
+ #ifdef unix
+ LISP lputenv(LISP lstr)
+ {char *orig,*cpy;
+ orig = get_c_string(lstr);
+ /* unix putenv keeps a pointer to the string we pass,
+ therefore we must make a fresh copy, which is memory leaky. */
+ cpy = (char *) must_malloc(strlen(orig)+1);
+ strcpy(cpy,orig);
+ if (putenv(cpy))
+ return(err("putenv",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+ #endif
+
+ #if defined(__osf__) || defined(sun)
+
+ void handle_sigxcpu(int sig)
+ {struct rlimit x;
+ if (getrlimit(RLIMIT_CPU,&x))
+ {errjmp_ok = 0;
+ err("getrlimit",llast_c_errmsg(-1));}
+ if (x.rlim_cur >= x.rlim_max)
+ {errjmp_ok = 0;
+ err("hard cpu limit exceded",NIL);}
+ if (nointerrupt == 1)
+ interrupt_differed = 1;
+ else
+ err("cpu limit exceded",NIL);}
+
+ LISP cpu_usage_limits(LISP soft,LISP hard)
+ {struct rlimit x;
+ if (NULLP(soft) && NULLP(hard))
+ {if (getrlimit(RLIMIT_CPU,&x))
+ return(err("getrlimit",llast_c_errmsg(-1)));
+ else
+ return(listn(2,flocons(x.rlim_cur),flocons(x.rlim_max)));}
+ else
+ {x.rlim_cur = get_c_long(soft);
+ x.rlim_max = get_c_long(hard);
+ signal(SIGXCPU,handle_sigxcpu);
+ if (setrlimit(RLIMIT_CPU,&x))
+ return(err("setrlimit",llast_c_errmsg(-1)));
+ else
+ return(NIL);}}
+
+ #endif
+
+ #if defined(unix)
+
+ static int handle_sigalrm_flag = 0;
+
+ void handle_sigalrm(int sig)
+ {if (nointerrupt == 1)
+ {if (handle_sigalrm_flag)
+ /* If we were inside a system call then it would be
+ interrupted even if we take no action here.
+ But sometimes we want to be really sure of signalling
+ an error, hence the flag. */
+ interrupt_differed = 1;}
+ else
+ err("alarm signal",NIL);}
+
+ LISP lalarm(LISP seconds,LISP flag)
+ {long iflag;
+ int retval;
+ iflag = no_interrupt(1);
+ signal(SIGALRM,handle_sigalrm);
+ handle_sigalrm_flag = NULLP(flag) ? 0 : 1;
+ retval = alarm(get_c_long(seconds));
+ no_interrupt(iflag);
+ return(flocons(retval));}
+
+ #endif
+
+
+ #if defined(__osf__) || defined(SUN5)
+
+ #define TV_FRAC(x) (((double)x.tv_usec) * 1.0e-6)
+
+ #ifdef SUN5
+ int getrusage(int,struct rusage *);
+ #endif
+
+ LISP current_resource_usage(LISP kind)
+ {struct rusage u;
+ int code;
+ if (NULLP(kind) || EQ(cintern("SELF"),kind))
+ code = RUSAGE_SELF;
+ else if EQ(cintern("CHILDREN"),kind)
+ code = RUSAGE_CHILDREN;
+ else
+ return(err("unknown rusage",kind));
+ if (getrusage(code,&u))
+ return(err("getrusage",llast_c_errmsg(-1)));
+ return(symalist("utime",flocons(((double)u.ru_utime.tv_sec) +
+ TV_FRAC(u.ru_utime)),
+ "stime",flocons(((double)u.ru_stime.tv_sec) +
+ TV_FRAC(u.ru_stime)),
+ "maxrss",flocons(u.ru_maxrss),
+ "ixrss",flocons(u.ru_ixrss),
+ "idrss",flocons(u.ru_idrss),
+ "isrss",flocons(u.ru_isrss),
+ "minflt",flocons(u.ru_minflt),
+ "majflt",flocons(u.ru_majflt),
+ "nswap",flocons(u.ru_nswap),
+ "inblock",flocons(u.ru_inblock),
+ "oublock",flocons(u.ru_oublock),
+ "msgsnd",flocons(u.ru_msgsnd),
+ "msgrcv",flocons(u.ru_msgrcv),
+ "nsignals",flocons(u.ru_nsignals),
+ "nvcsw",flocons(u.ru_nvcsw),
+ "nivcsw",flocons(u.ru_nivcsw),
+ NULL));}
+
+ #endif
+
+ #ifdef unix
+
+ LISP l_opendir(LISP name)
+ {long iflag;
+ LISP value;
+ DIR *d;
+ iflag = no_interrupt(1);
+ value = cons(NIL,NIL);
+ if (!(d = opendir(get_c_string(name))))
+ return(err("opendir",llast_c_errmsg(-1)));
+ value->type = tc_opendir;
+ CAR(value) = (LISP) d;
+ no_interrupt(iflag);
+ return(value);}
+
+ DIR *get_opendir(LISP v,long oflag)
+ {if NTYPEP(v,tc_opendir) err("not an opendir",v);
+ if NULLP(CAR(v))
+ {if (oflag) err("opendir not open",v);
+ return(NULL);}
+ return((DIR *)CAR(v));}
+
+ LISP l_closedir(LISP v)
+ {long iflag,old_errno;
+ DIR *d;
+ iflag = no_interrupt(1);
+ d = get_opendir(v,1);
+ old_errno = errno;
+ CAR(v) = NIL;
+ if (closedir(d))
+ return(err("closedir",llast_c_errmsg(old_errno)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ void opendir_gc_free(LISP v)
+ {DIR *d;
+ if ((d = get_opendir(v,0)))
+ closedir(d);}
+
+ LISP l_readdir(LISP v)
+ {long iflag,namlen;
+ DIR *d;
+ struct dirent *r;
+ d = get_opendir(v,1);
+ iflag = no_interrupt(1);
+ r = readdir(d);
+ no_interrupt(iflag);
+ if (!r) return(NIL);
+ #if defined(sun) || defined(sgi) || defined(linux)
+ namlen = safe_strlen(r->d_name,r->d_reclen);
+ #else
+ namlen = r->d_namlen;
+ #endif
+ return(strcons(namlen,r->d_name));}
+
+ void opendir_prin1(LISP ptr,struct gen_printio *f)
+ {char buffer[256];
+ sprintf(buffer,"#<OPENDIR %p>",get_opendir(ptr,0));
+ gput_st(f,buffer);}
+
+ #endif
+
+ #ifdef WIN32
+
+ typedef struct
+ {long count;
+ HANDLE h;
+ WIN32_FIND_DATA s;} DIR;
+
+ LISP llast_win32_errmsg(DWORD status)
+ {DWORD len,msgcode;
+ char buffer[256];
+ msgcode = (status == 0) ? GetLastError() : status;
+ len = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
+ FORMAT_MESSAGE_IGNORE_INSERTS |
+ FORMAT_MESSAGE_MAX_WIDTH_MASK,
+ 0,
+ msgcode,
+ 0, /* what language? */
+ buffer,
+ sizeof(buffer),
+ NULL);
+ if (len)
+ return(strcons(len,buffer));
+ else
+ return(flocons(msgcode));}
+
+ LISP l_opendir(LISP name)
+ {long iflag;
+ LISP value;
+ DIR *d;
+ iflag = no_interrupt(1);
+ value = cons(NIL,NIL);
+ d = (DIR *) must_malloc(sizeof(DIR));
+ d->h = INVALID_HANDLE_VALUE;
+ value->type = (short) tc_opendir;
+ d->count = 0;
+ CAR(value) = (LISP) d;
+ if ((d->h = FindFirstFile(get_c_string(name),&d->s)) == INVALID_HANDLE_VALUE)
+ return(err("FindFirstFile",llast_win32_errmsg(0)));
+ no_interrupt(iflag);
+ return(value);}
+
+ DIR *get_opendir(LISP v,long oflag)
+ {if NTYPEP(v,tc_opendir) err("not an opendir",v);
+ if NULLP(CAR(v))
+ {if (oflag) err("opendir not open",v);
+ return(NULL);}
+ return((DIR *)CAR(v));}
+
+ LISP l_closedir(LISP v)
+ {long iflag;
+ DIR *d;
+ HANDLE h;
+ iflag = no_interrupt(1);
+ d = get_opendir(v,1);
+ CAR(v) = NIL;
+ h = d->h;
+ free(d);
+ if ((h != INVALID_HANDLE_VALUE) && !FindClose(h))
+ return(err("closedir",llast_win32_errmsg(0)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ void opendir_gc_free(LISP v)
+ {DIR *d;
+ if ((d = get_opendir(v,0)))
+ {FindClose(d->h);
+ free(d);
+ CAR(v) = NIL;}}
+
+ LISP l_readdir(LISP v)
+ {long iflag;
+ DIR *d;
+ d = get_opendir(v,1);
+ iflag = no_interrupt(1);
+ if (d->count > 0)
+ if (!FindNextFile(d->h,&d->s))
+ if (GetLastError() == ERROR_NO_MORE_FILES)
+ {no_interrupt(1);
+ return(NIL);}
+ ++d->count;
+ no_interrupt(iflag);
+ return(strcons(-1,d->s.cFileName));}
+
+ void opendir_prin1(LISP ptr,struct gen_printio *f)
+ {char buffer[256];
+ sprintf(buffer,"#<OPENDIR %p>",get_opendir(ptr,0));
+ gput_st(f,buffer);}
+
+ #endif
+
+ LISP file_times(LISP fname)
+ {struct stat st;
+ int iflag,ret;
+ iflag = no_interrupt(1);
+ ret = stat(get_c_string(fname),&st);
+ no_interrupt(iflag);
+ if (ret)
+ return(NIL);
+ else
+ return(cons(flocons(st.st_ctime),
+ cons(flocons(st.st_mtime),NIL)));}
+
+ #if defined(unix) || defined(WIN32)
+
+ #if defined(unix)
+ LISP decode_st_moden(mode_t mode)
+ {LISP ret = NIL;
+ if (mode & S_ISUID) ret = cons(cintern("SUID"),ret);
+ if (mode & S_ISGID) ret = cons(cintern("SGID"),ret);
+ if (mode & S_IRUSR) ret = cons(cintern("RUSR"),ret);
+ if (mode & S_IWUSR) ret = cons(cintern("WUSR"),ret);
+ if (mode & S_IXUSR) ret = cons(cintern("XUSR"),ret);
+ if (mode & S_IRGRP) ret = cons(cintern("RGRP"),ret);
+ if (mode & S_IWGRP) ret = cons(cintern("WGRP"),ret);
+ if (mode & S_IXGRP) ret = cons(cintern("XGRP"),ret);
+ if (mode & S_IROTH) ret = cons(cintern("ROTH"),ret);
+ if (mode & S_IWOTH) ret = cons(cintern("WOTH"),ret);
+ if (mode & S_IXOTH) ret = cons(cintern("XOTH"),ret);
+ if (S_ISFIFO(mode)) ret = cons(cintern("FIFO"),ret);
+ if (S_ISDIR(mode)) ret = cons(cintern("DIR"),ret);
+ if (S_ISCHR(mode)) ret = cons(cintern("CHR"),ret);
+ if (S_ISBLK(mode)) ret = cons(cintern("BLK"),ret);
+ if (S_ISREG(mode)) ret = cons(cintern("REG"),ret);
+ if (S_ISLNK(mode)) ret = cons(cintern("LNK"),ret);
+ if (S_ISSOCK(mode)) ret = cons(cintern("SOCK"),ret);
+ return(ret);}
+
+ LISP encode_st_mode(LISP l)
+ {return(flocons(assemble_options(l,
+ "SUID",S_ISUID,
+ "SGID",S_ISGID,
+ "RUSR",S_IRUSR,
+ "WUSR",S_IWUSR,
+ "XUSR",S_IXUSR,
+ "RGRP",S_IRGRP,
+ "WGRP",S_IWGRP,
+ "XGRP",S_IXGRP,
+ "ROTH",S_IROTH,
+ "WOTH",S_IWOTH,
+ "XOTH",S_IXOTH,
+ NULL)));}
+ #endif
+
+ #ifdef WIN32
+
+ LISP decode_st_moden(int mode)
+ {LISP ret = NIL;
+ if (mode & _S_IREAD) ret = cons(cintern("RUSR"),ret);
+ if (mode & _S_IWRITE) ret = cons(cintern("WUSR"),ret);
+ if (mode & _S_IEXEC) ret = cons(cintern("XUSR"),ret);
+ if (mode & _S_IFDIR) ret = cons(cintern("DIR"),ret);
+ if (mode & _S_IFCHR) ret = cons(cintern("CHR"),ret);
+ if (mode & _S_IFREG) ret = cons(cintern("REG"),ret);
+ return(ret);}
+
+ LISP encode_st_mode(LISP l)
+ {return(flocons(assemble_options(l,
+ "RUSR",_S_IREAD,
+ "WUSR",_S_IWRITE,
+ "XUSR",_S_IEXEC,
+ NULL)));}
+ #endif
+
+ LISP decode_st_mode(LISP value)
+ {return(decode_st_moden(get_c_long(value)));}
+
+ LISP decode_stat(struct stat *s)
+ {return(symalist("dev",flocons(s->st_dev),
+ "ino",flocons(s->st_ino),
+ "mode",decode_st_moden(s->st_mode),
+ "nlink",flocons(s->st_nlink),
+ "uid",flocons(s->st_uid),
+ "gid",flocons(s->st_gid),
+ "rdev",flocons(s->st_rdev),
+ "size",flocons(s->st_size),
+ "atime",flocons(s->st_atime),
+ "mtime",flocons(s->st_mtime),
+ "ctime",flocons(s->st_ctime),
+ #if defined(unix)
+ "blksize",flocons(s->st_blksize),
+ "blocks",flocons(s->st_blocks),
+ #endif
+ #if defined(__osf__)
+ "flags",flocons(s->st_flags),
+ "gen",flocons(s->st_gen),
+ #endif
+ NULL));}
+
+
+ LISP g_stat(LISP fname,int (*fcn)(const char *,struct stat *))
+ {struct stat st;
+ int iflag,ret;
+ iflag = no_interrupt(1);
+ memset(&st,0,sizeof(struct stat));
+ ret = (*fcn)(get_c_string(fname),&st);
+ no_interrupt(iflag);
+ if (ret)
+ return(NIL);
+ else
+ return(decode_stat(&st));}
+
+ LISP l_stat(LISP fname)
+ {return(g_stat(fname,stat));}
+
+ LISP l_fstat(LISP f)
+ {struct stat st;
+ int iflag,ret;
+ iflag = no_interrupt(1);
+ ret = fstat(fileno(get_c_file(f,NULL)),&st);
+ no_interrupt(iflag);
+ if (ret)
+ return(NIL);
+ else
+ return(decode_stat(&st));}
+
+ #ifdef unix
+ LISP l_lstat(LISP fname)
+ {return(g_stat(fname,lstat));}
+ #endif
+
+ #if defined(__osf__) || defined(SUN5)
+
+ LISP l_fnmatch(LISP pat,LISP str,LISP flgs)
+ {if (fnmatch(get_c_string(pat),
+ get_c_string(str),
+ 0))
+ return(NIL);
+ else
+ return(a_true_value());}
+
+ #endif
+
+ #if defined(unix) || defined(WIN32)
+
+ LISP l_chmod(LISP path,LISP mode)
+ {if (chmod(get_c_string(path),get_c_long(mode)))
+ return(err("chmod",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+ #endif
+
+
+ #ifdef unix
+
+ LISP lutime(LISP fname,LISP mod,LISP ac)
+ {struct utimbuf x;
+ x.modtime = get_c_long(mod);
+ x.actime = NNULLP(ac) ? get_c_long(ac) : time(NULL);
+ if (utime(get_c_string(fname), &x))
+ return(err("utime",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+
+ LISP lfchmod(LISP file,LISP mode)
+ {if (fchmod(fileno(get_c_file(file,NULL)),get_c_long(mode)))
+ return(err("fchmod",llast_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+ LISP encode_open_flags(LISP l)
+ {return(flocons(assemble_options(l,
+ "NONBLOCK",O_NONBLOCK,
+ "APPEND",O_APPEND,
+ "RDONLY",O_RDONLY,
+ "WRONLY",O_WRONLY,
+ "RDWR",O_RDWR,
+ "CREAT",O_CREAT,
+ "TRUNC",O_TRUNC,
+ "EXCL",O_EXCL,
+ NULL)));}
+
+ int get_fd(LISP ptr)
+ {if TYPEP(ptr,tc_c_file)
+ return(fileno(get_c_file(ptr,NULL)));
+ else
+ return(get_c_long(ptr));}
+
+ LISP gsetlk(int op,LISP lfd,LISP ltype,LISP whence,LISP start,LISP len)
+ {struct flock f;
+ int fd = get_fd(lfd);
+ f.l_type = get_c_long(ltype);
+ f.l_whence = NNULLP(whence) ? get_c_long(whence) : SEEK_SET;
+ f.l_start = NNULLP(start) ? get_c_long(start) : 0;
+ f.l_len = NNULLP(len) ? get_c_long(len) : 0;
+ f.l_pid = 0;
+ if (fcntl(fd,op,&f) == -1)
+ return(llast_c_errmsg(-1));
+ else if (op != F_GETLK)
+ return(NIL);
+ else if (f.l_type == F_UNLCK)
+ return(NIL);
+ else
+ return(listn(2,flocons(f.l_type),flocons(f.l_pid)));}
+
+ LISP lF_SETLK(LISP fd,LISP ltype,LISP whence,LISP start,LISP len)
+ {return(gsetlk(F_SETLK,fd,ltype,whence,start,len));}
+
+ LISP lF_SETLKW(LISP fd,LISP ltype,LISP whence,LISP start,LISP len)
+ {return(gsetlk(F_SETLKW,fd,ltype,whence,start,len));}
+
+ LISP lF_GETLK(LISP fd,LISP ltype,LISP whence,LISP start,LISP len)
+ {return(gsetlk(F_GETLK,fd,ltype,whence,start,len));}
+
+ #endif
+
+ #endif
+
+ LISP delete_file(LISP fname)
+ {int iflag,ret;
+ iflag = no_interrupt(1);
+ #ifdef VMS
+ ret = delete(get_c_string(fname));
+ #else
+ ret = unlink(get_c_string(fname));
+ #endif
+ no_interrupt(iflag);
+ if (ret)
+ return(strcons(-1,last_c_errmsg(-1)));
+ else
+ return(NIL);}
+
+ LISP utime2str(LISP u)
+ {time_t bt;
+ struct tm *btm;
+ char sbuff[100];
+ bt = get_c_long(u);
+ if ((btm = localtime(&bt)))
+ {sprintf(sbuff,"%04d%02d%02d%02d%02d%02d%02d",
+ btm->tm_year+1900,btm->tm_mon + 1,btm->tm_mday,
+ btm->tm_hour,btm->tm_min,btm->tm_sec,0);
+ return(strcons(strlen(sbuff),sbuff));}
+ else
+ return(NIL);}
+
+ #ifdef WIN32
+ LISP win32_debug(void)
+ {DebugBreak();
+ return(NIL);}
+ #endif
+
+ #ifdef VMS
+
+ LISP vms_debug(arg)
+ LISP arg;
+ {unsigned char arg1[257];
+ char *data;
+ if NULLP(arg)
+ lib$signal(SS$_DEBUG,0);
+ else
+ {data = get_c_string(arg);
+ arg1[0] = strlen(data);
+ memcpy(&arg1[1],data,arg1[0]);
+ lib$signal(SS$_DEBUG,1,arg1);}
+ return(NIL);}
+
+ struct dsc$descriptor *set_dsc_cst(struct dsc$descriptor *d,char *s)
+ {d->dsc$w_length = strlen(s);
+ d->dsc$b_dtype = DSC$K_DTYPE_T;
+ d->dsc$b_class = DSC$K_CLASS_S;
+ d->dsc$a_pointer = s;
+ return(d);}
+
+
+ void err_vms(long retval)
+ {char *errmsg,buff[100];
+ if (errmsg = strerror(EVMSERR,retval))
+ err(errmsg,NIL);
+ else
+ {sprintf(buff,"VMS ERROR %d",retval);
+ err(buff,NIL);}}
+
+ LISP lcrembx(LISP l)
+ {LISP tmp;
+ short chan;
+ int prmflg,maxmsg,bufquo,promsk,acmode,iflag,retval;
+ struct dsc$descriptor lognam;
+ set_dsc_cst(&lognam,get_c_string(car(l)));
+ tmp = cadr(assq(cintern("prmflg"),l));
+ prmflg = NNULLP(tmp) ? 1 : 0;
+ tmp = cadr(assq(cintern("maxmsg"),l));
+ maxmsg = NNULLP(tmp) ? get_c_long(tmp) : 0;
+ tmp = cadr(assq(cintern("bufquo"),l));
+ bufquo = NNULLP(tmp) ? get_c_long(tmp) : 0;
+ tmp = cadr(assq(cintern("promsk"),l));
+ promsk = NNULLP(tmp) ? get_c_long(tmp) : 0;
+ tmp = cadr(assq(cintern("acmode"),l));
+ acmode = NNULLP(tmp) ? get_c_long(tmp) : 0;
+ tmp = cons(flocons(-1),leval(sym_channels,NIL));
+ iflag = no_interrupt(1);
+ retval = sys$crembx(prmflg,&chan,maxmsg,bufquo,promsk,acmode,&lognam);
+ if (retval != SS$_NORMAL)
+ {no_interrupt(iflag);
+ err_vms(retval);}
+ setvar(sym_channels,tmp,NIL);
+ tmp = car(tmp);
+ tmp->storage_as.flonum.data = chan;
+ no_interrupt(iflag);
+ return(tmp);}
+
+ LISP lset_logical(LISP name,LISP value,LISP table,LISP attributes)
+ {struct dsc$descriptor dname,dvalue,dtable;
+ long status,iflag;
+ iflag = no_interrupt(1);
+ status = lib$set_logical(set_dsc_cst(&dname,get_c_string(name)),
+ NULLP(value) ? 0 : set_dsc_cst(&dvalue,
+ get_c_string(value)),
+ NULLP(table) ? 0 : set_dsc_cst(&dtable,
+ get_c_string(table)),
+ assemble_options(attributes,
+ "NO_ALIAS",LNM$M_NO_ALIAS,
+ "CONFINE",LNM$M_CONFINE,
+ "CRELOG",LNM$M_CRELOG,
+ "TABLE",LNM$M_TABLE,
+ "CONCEALED",LNM$M_CONCEALED,
+ "TERMINAL",LNM$M_TERMINAL,
+ "EXISTS",LNM$M_EXISTS,
+ "SHAREABLE",LNM$M_SHAREABLE,
+ "CREATE_IF",LNM$M_CREATE_IF,
+ "CASE_BLIND",LNM$M_CASE_BLIND,
+ NULL),
+ 0);
+ if (status != SS$_NORMAL)
+ err_vms(status);
+ no_interrupt(iflag);
+ return(NIL);}
+
+ #endif
+
+ LISP lgetenv(LISP var)
+ {char *str;
+ if ((str = getenv(get_c_string(var))))
+ return(strcons(strlen(str),str));
+ else
+ return(NIL);}
+
+ LISP unix_time(void)
+ {return(flocons(time(NULL)));}
+
+ LISP unix_ctime(LISP value)
+ {time_t b;
+ char *buff,*p;
+ if NNULLP(value)
+ b = get_c_long(value);
+ else
+ time(&b);
+ if ((buff = ctime(&b)))
+ {if ((p = strchr(buff,'\n'))) *p = 0;
+ return(strcons(strlen(buff),buff));}
+ else
+ return(NIL);}
+
+ LISP http_date(LISP value)
+ /* returns the internet standard RFC 1123 format */
+ {time_t b;
+ char buff[256];
+ struct tm *t;
+ if NNULLP(value)
+ b = get_c_long(value);
+ else
+ time(&b);
+ if (!(t = gmtime(&b))) return(NIL);
+ (sprintf
+ (buff,"%s, %02d %s %04d %02d:%02d:%02d GMT",
+ &"Sun\0Mon\0Tue\0Wed\0Thu\0Fri\0Sat"[t->tm_wday*4],
+ t->tm_mday,
+ &"Jan\0Feb\0Mar\0Apr\0May\0Jun\0Jul\0Aug\0Sep\0Oct\0Nov\0Dec"[t->tm_mon*4],
+ t->tm_year+1900,
+ t->tm_hour,
+ t->tm_min,
+ t->tm_sec));
+ return(strcons(strlen(buff),buff));}
+
+ #if defined(__osf__)
+
+ LISP http_date_parse(LISP input)
+ /* handle RFC 822, RFC 850, RFC 1123 and the ANSI C ascitime() format */
+ {struct tm tm,*lc;
+ time_t t;
+ int gmtoff;
+ char *str = get_c_string(input),*format;
+ t = time(NULL);
+ if (lc = localtime(&t))
+ gmtoff = lc->tm_gmtoff;
+ if (strchr(str,',') && strchr(str,'-'))
+ /* rfc-850: Sunday, 06-Nov-94 08:49:37 GMT */
+ format = "%a, %d-%b-%y %H:%M:%S GMT";
+ else if (strchr(str,','))
+ /* rfc-1123: Sun, 06 Nov 1994 08:49:37 GMT */
+ format = "%a, %d %b %Y %H:%M:%S GMT";
+ else
+ /* ascitime: Sun Nov 6 08:49:37 1994 */
+ {format = "%c";
+ gmtoff = 0;}
+ if (strptime(str,format,&tm))
+ {t = mktime(&tm);
+ /* unfortunately there is no documented way to tell mktime
+ to assume GMT. Except for saving the value of the current
+ timezone, setting TZ to GMT, doing a tzset() then doing
+ our mktime() followed by setting the time zone back to the way
+ it was before. That is fairly horrible, so instead we work around
+ this by adding the gmtoff we computed above, which of course may
+ have changed since we computed it (if the system manager switched
+ daylight savings time modes, for example).
+ There is an executable /usr/lib/mh/dp which is presumably
+ doing the same sort of thing, although perhaps it uses tzset */
+ return(flocons(t + gmtoff));}
+ else
+ return(NIL);}
+
+ #endif
+
+
+ #ifdef hpux
+ long usleep(unsigned int winks) /* added, dcd */
+ {
+ struct timeval sleepytime;
+ sleepytime.tv_sec = winks / 1000000;
+ sleepytime.tv_usec = winks % 1000000;
+ return select(0,0,0,0,&sleepytime);
+ }
+ #endif
+
+ #if defined(sun_old) || defined(sgi)
+ long usleep(unsigned int winks)
+ {struct timespec x;
+ x.tv_sec = winks / 1000000;
+ x.tv_nsec = (winks % 1000000) * 1000;
+ return(nanosleep(&x,NULL));}
+ #endif
+
+ LISP lsleep(LISP ns)
+ {double val = get_c_double(ns);
+ #ifdef unix
+ usleep((unsigned int)(val * 1.0e6));
+ #else
+ #ifdef WIN32
+ Sleep((DWORD)(val * 1000));
+ #else
+ sleep((unsigned int)val);
+ #endif
+ #endif
+ return(NIL);}
+
+ LISP url_encode(LISP in)
+ {int spaces=0,specials=0,regulars=0,c;
+ char *str = get_c_string(in),*p,*r;
+ LISP out;
+ for(p=str,spaces=0,specials=0,regulars=0;(c = *p);++p)
+ if (c == ' ') ++spaces;
+ else if (!(isalnum(c) || strchr("*-._@",c))) ++specials;
+ else ++regulars;
+ if ((spaces == 0) && (specials == 0))
+ return(in);
+ out = strcons(spaces + regulars + specials * 3,NULL);
+ for(p=str,r=get_c_string(out);(c = *p);++p)
+ if (c == ' ')
+ *r++ = '+';
+ else if (!(isalnum(c) || strchr("*-._@",c)))
+ {sprintf(r,"%%%02X",c & 0xFF);
+ r += 3;}
+ else
+ *r++ = c;
+ *r = 0;
+ return(out);}
+
+ LISP url_decode(LISP in)
+ {int pluses=0,specials=0,regulars=0,c,j;
+ char *str = get_c_string(in),*p,*r;
+ LISP out;
+ for(p=str,pluses=0,specials=0,regulars=0;(c = *p);++p)
+ if (c == '+') ++pluses;
+ else if (c == '%')
+ {if (isxdigit(p[1]) && isxdigit(p[2]))
+ ++specials;
+ else
+ return(NIL);}
+ else
+ ++regulars;
+ if ((pluses == 0) && (specials == 0))
+ return(in);
+ out = strcons(regulars + pluses + specials,NULL);
+ for(p=str,r=get_c_string(out);(c = *p);++p)
+ if (c == '+')
+ *r++ = ' ';
+ else if (c == '%')
+ {for(*r = 0,j=1;j<3;++j)
+ *r = *r * 16 + ((isdigit(p[j]))
+ ? (p[j] - '0')
+ : (toupper(p[j]) - 'A' + 10));
+ p += 2;
+ ++r;}
+ else
+ *r++ = c;
+ *r = 0;
+ return(out);}
+
+ LISP html_encode(LISP in)
+ {long j,n,m;
+ char *str,*ptr;
+ LISP out;
+ switch(TYPE(in))
+ {case tc_string:
+ case tc_symbol:
+ break;
+ default:
+ return(in);}
+ str = get_c_string(in);
+ n = strlen(str);
+ for(j=0,m=0;j < n; ++j)
+ switch(str[j])
+ {case '>':
+ case '<':
+ m += 4;
+ break;
+ case '&':
+ m += 5;
+ break;
+ case '"':
+ m += 6;
+ break;
+ default:
+ ++m;}
+ if (n == m) return(in);
+ out = strcons(m,NULL);
+ for(j=0,ptr=get_c_string(out);j < n; ++j)
+ switch(str[j])
+ {case '>':
+ strcpy(ptr,">");
+ ptr += strlen(ptr);
+ break;
+ case '<':
+ strcpy(ptr,"<");
+ ptr += strlen(ptr);
+ break;
+ case '&':
+ strcpy(ptr,"&");
+ ptr += strlen(ptr);
+ break;
+ case '"':
+ strcpy(ptr,""");
+ ptr += strlen(ptr);
+ break;
+ default:
+ *ptr++ = str[j];}
+ return(out);}
+
+ LISP html_decode(LISP in)
+ {return(in);}
+
+ LISP lgets(LISP file,LISP buffn)
+ {FILE *f;
+ int iflag;
+ long n;
+ char buffer[2048],*ptr;
+ f = get_c_file(file,stdin);
+ if NULLP(buffn)
+ n = sizeof(buffer);
+ else if ((n = get_c_long(buffn)) < 0)
+ err("size must be >= 0",buffn);
+ else if (n > sizeof(buffer))
+ err("not handling buffer of size",listn(2,buffn,flocons(sizeof(buffer))));
+ iflag = no_interrupt(1);
+ if ((ptr = fgets(buffer,n,f)))
+ {no_interrupt(iflag);
+ return(strcons(strlen(buffer),buffer));}
+ no_interrupt(iflag);
+ return(NIL);}
+
+ LISP readline(LISP file)
+ {LISP result;
+ char *start,*ptr;
+ result = lgets(file,NIL);
+ if NULLP(result) return(NIL);
+ start = get_c_string(result);
+ if ((ptr = strchr(start,'\n')))
+ {*ptr = 0;
+ /* we also change the dim, because otherwise our equal? function
+ is confused. What we really need are arrays with fill pointers. */
+ result->storage_as.string.dim = ptr - start;
+ return(result);}
+ else
+ /* we should be doing lgets until we get a string with a newline or NIL,
+ and then append the results */
+ return(result);}
+
+ #ifndef WIN32
+
+ LISP l_chown(LISP path,LISP uid,LISP gid)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (chown(get_c_string(path),get_c_long(uid),get_c_long(gid)))
+ err("chown",cons(path,llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+
+ #endif
+
+ #if defined(unix) && !defined(linux)
+ LISP l_lchown(LISP path,LISP uid,LISP gid)
+ {long iflag;
+ iflag = no_interrupt(1);
+ if (lchown(get_c_string(path),get_c_long(uid),get_c_long(gid)))
+ err("lchown",cons(path,llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}
+ #endif
+
+
+ #ifdef unix
+
+ LISP popen_l(LISP name,LISP how)
+ {return(fopen_cg(popen,
+ get_c_string(name),
+ NULLP(how) ? "r" : get_c_string(how)));}
+
+ /* note: if the user fails to call pclose then the gc is going
+ to utilize fclose, which can result in a <defunct>
+ process laying around. However, we don't want to
+ modify file_gc_free nor add a new datatype.
+ So beware.
+ */
+ LISP pclose_l(LISP ptr)
+ {FILE *f = get_c_file(ptr,NULL);
+ long iflag = no_interrupt(1);
+ int retval,xerrno;
+ retval = pclose(f);
+ xerrno = errno;
+ ptr->storage_as.c_file.f = (FILE *) NULL;
+ free(ptr->storage_as.c_file.name);
+ ptr->storage_as.c_file.name = NULL;
+ no_interrupt(iflag);
+ if (retval < 0)
+ err("pclose",llast_c_errmsg(xerrno));
+ return(flocons(retval));}
+
+ #endif
+
+ LISP so_init_name(LISP fname,LISP iname)
+ {LISP init_name;
+ if NNULLP(iname)
+ init_name = iname;
+ else
+ {init_name = car(last(lstrbreakup(fname,cintern("/"))));
+ #if !defined(VMS)
+ init_name = lstrunbreakup(butlast(lstrbreakup(init_name,cintern("."))),
+ cintern("."));
+ #endif
+ init_name = string_append(listn(2,cintern("init_"),init_name));}
+ return(intern(init_name));}
+
+ LISP so_ext(LISP fname)
+ {char *ext = ".so";
+ LISP lext;
+ #if defined(hpux)
+ ext = ".sl";
+ #endif
+ #if defined(vms)
+ ext = "";
+ #endif
+ #if defined(WIN32)
+ ext = ".dll";
+ #endif
+ lext = strcons(strlen(ext),ext);
+ if NULLP(fname)
+ return(lext);
+ else
+ return(string_append(listn(2,fname,lext)));}
+
+ LISP load_so(LISP fname,LISP iname)
+ /* note: error cases can leak memory in this procedure. */
+ {LISP init_name;
+ void (*fcn)(void) = NULL;
+ #if defined(__osf__) || defined(sun) || defined(linux) || defined(sgi)
+ void *handle;
+ #endif
+ #if defined(hpux)
+ shl_t handle;
+ #endif
+ #if defined(VMS)
+ struct dsc$descriptor filename,symbol,defaultd;
+ long status;
+ LISP dsym;
+ #endif
+ #ifdef WIN32
+ HINSTANCE handle;
+ #endif
+ long iflag;
+ init_name = so_init_name(fname,iname);
+ iflag = no_interrupt(1);
+ if (siod_verbose_check(3))
+ {put_st("so-loading ");
+ put_st(get_c_string(fname));
+ put_st("\n");}
+ #if defined(__osf__) || defined(sun) || defined(linux) || defined(sgi)
+ #if !defined(__osf__)
+ /* Observed bug: values of LD_LIBRARY_PATH established with putenv
+ -after- a process has started are ignored. Work around follows. */
+ if (access(get_c_string(fname),F_OK))
+ fname = string_append(listn(3,
+ strcons(-1,siod_lib),
+ strcons(-1,"/"),
+ fname));
+ #endif
+ if (!(handle = dlopen(get_c_string(fname),RTLD_LAZY)))
+ err(dlerror(),fname);
+ if (!(fcn = dlsym(handle,get_c_string(init_name))))
+ err(dlerror(),init_name);
+ #endif
+ #if defined(hpux)
+ if (access(get_c_string(fname),F_OK))
+ fname = string_append(listn(3,
+ strcons(-1,siod_lib),
+ strcons(-1,"/"),
+ fname));
+ if (!(handle = shl_load(get_c_string(fname),BIND_DEFERRED,0L)))
+ err("shl_load",llast_c_errmsg(errno));
+ if (shl_findsym(&handle,get_c_string(init_name),TYPE_PROCEDURE,&fcn))
+ err("shl_findsym",llast_c_errmsg(errno));
+ #endif
+ #if defined(VMS)
+ dsym = cintern("*require-so-dir*");
+ if (NNULLP(symbol_boundp(dsym,NIL)) && NNULLP(symbol_value(dsym,NIL)))
+ set_dsc_cst(&defaultd,get_c_string(symbol_value(dsym,NIL)));
+ else
+ dsym = NIL;
+ status = lib$find_image_symbol(set_dsc_cst(&filename,
+ get_c_string(fname)),
+ set_dsc_cst(&symbol,
+ get_c_string(init_name)),
+ &fcn,
+ NULLP(dsym) ? 0 : &defaultd);
+ if (status != SS$_NORMAL)
+ err_vms(status);
+ #endif
+ #ifdef WIN32
+ if (!(handle = LoadLibrary(get_c_string(fname))))
+ err("LoadLibrary",fname);
+ if (!(fcn = (LPVOID)GetProcAddress(handle,get_c_string(init_name))))
+ err("GetProcAddress",init_name);
+ #endif
+ if (fcn)
+ (*fcn)();
+ else
+ err("did not load function",init_name);
+ no_interrupt(iflag);
+ if (siod_verbose_check(3))
+ put_st("done.\n");
+ return(init_name);}
+
+ LISP require_so(LISP fname)
+ {LISP init_name;
+ init_name = so_init_name(fname,NIL);
+ if (NULLP(symbol_boundp(init_name,NIL)) ||
+ NULLP(symbol_value(init_name,NIL)))
+ {load_so(fname,NIL);
+ return(setvar(init_name,a_true_value(),NIL));}
+ else
+ return(NIL);}
+
+ LISP siod_lib_l(void)
+ {return(rintern(siod_lib));}
+
+
+ LISP ccall_catch_1(LISP (*fcn)(void *),void *arg)
+ {LISP val;
+ val = (*fcn)(arg);
+ catch_framep = catch_framep->next;
+ return(val);}
+
+ LISP ccall_catch(LISP tag,LISP (*fcn)(void *),void *arg)
+ {struct catch_frame frame;
+ int k;
+ frame.tag = tag;
+ frame.next = catch_framep;
+ k = setjmp(frame.cframe);
+ catch_framep = &frame;
+ if (k == 2)
+ {catch_framep = frame.next;
+ return(frame.retval);}
+ return(ccall_catch_1(fcn,arg));}
+
+ LISP decode_tm(struct tm *t)
+ {return(symalist("sec",flocons(t->tm_sec),
+ "min",flocons(t->tm_min),
+ "hour",flocons(t->tm_hour),
+ "mday",flocons(t->tm_mday),
+ "mon",flocons(t->tm_mon),
+ "year",flocons(t->tm_year),
+ "wday",flocons(t->tm_wday),
+ "yday",flocons(t->tm_yday),
+ "isdst",flocons(t->tm_isdst),
+ #if defined(__osf__)
+ "gmtoff",flocons(t->__tm_gmtoff),
+ "tm_zone",(t->__tm_zone) ? rintern(t->__tm_zone) : NIL,
+ #endif
+ NULL));}
+
+ LISP symalist(char *arg,...)
+ {va_list args;
+ LISP result,l,val;
+ char *key;
+ if (!arg) return(NIL);
+ va_start(args,arg);
+ val = va_arg(args,LISP);
+ result = cons(cons(cintern(arg),val),NIL);
+ l = result;
+ while((key = va_arg(args,char *)))
+ {val = va_arg(args,LISP);
+ CDR(l) = cons(cons(cintern(key),val),NIL);
+ l = CDR(l);}
+ va_end(args);
+ return(result);}
+
+ void encode_tm(LISP alist,struct tm *t)
+ {LISP val;
+ val = cdr(assq(cintern("sec"),alist));
+ t->tm_sec = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("min"),alist));
+ t->tm_min = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("hour"),alist));
+ t->tm_hour = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("mday"),alist));
+ t->tm_mday = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("mon"),alist));
+ t->tm_mon = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("year"),alist));
+ t->tm_year = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("wday"),alist));
+ t->tm_wday = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("yday"),alist));
+ t->tm_yday = NULLP(val) ? 0 : get_c_long(val);
+ val = cdr(assq(cintern("isdst"),alist));
+ t->tm_isdst = NULLP(val) ? -1 : get_c_long(val);
+ #if defined(__osf__)
+ val = cdr(assq(cintern("gmtoff"),alist));
+ t->__tm_gmtoff = NULLP(val) ? 0 : get_c_long(val);
+ #endif
+ }
+
+ LISP llocaltime(LISP value)
+ {time_t b;
+ struct tm *t;
+ if NNULLP(value)
+ b = get_c_long(value);
+ else
+ time(&b);
+ if ((t = localtime(&b)))
+ return(decode_tm(t));
+ else
+ return(err("localtime",llast_c_errmsg(-1)));}
+
+ LISP lgmtime(LISP value)
+ {time_t b;
+ struct tm *t;
+ if NNULLP(value)
+ b = get_c_long(value);
+ else
+ time(&b);
+ if ((t = gmtime(&b)))
+ return(decode_tm(t));
+ else
+ return(err("gmtime",llast_c_errmsg(-1)));}
+
+ #if defined(unix) || defined(WIN32)
+ LISP ltzset(void)
+ {tzset();
+ return(NIL);}
+ #endif
+
+ LISP lmktime(LISP alist)
+ {struct tm tm;
+ time_t t;
+ encode_tm(alist,&tm);
+ t = mktime(&tm);
+ return(flocons(t));}
+
+ #if defined(__osf__) || defined(SUN5) || defined(linux)
+
+ LISP lstrptime(LISP str,LISP fmt,LISP in)
+ {struct tm tm;
+ encode_tm(in,&tm);
+ if (strptime(get_c_string(str),get_c_string(fmt),&tm))
+ {
+ #if defined(SUN5)
+ /* SUN software incorrectly sets this to 0, but until further
+ analysis (such as by mktime) it is too early to conclude */
+ tm.tm_isdst = -1;
+ #endif
+ return(decode_tm(&tm));
+ }
+ else
+ return(NIL);}
+
+ #endif
+
+ #ifdef unix
+
+ LISP lstrftime(LISP fmt,LISP in)
+ {struct tm tm;
+ time_t b;
+ struct tm *t;
+ size_t ret;
+ char buff[1024];
+ if NNULLP(in)
+ {encode_tm(in,&tm);
+ t = &tm;}
+ else
+ {time(&b);
+ if (!(t = gmtime(&b)))
+ return(NIL);}
+ if ((ret = strftime(buff,sizeof(buff),get_c_string(fmt),t)))
+ return(strcons(ret,buff));
+ else
+ return(NIL);}
+
+ #endif
+
+ LISP lchdir(LISP dir)
+ {long iflag;
+ #ifdef unix
+ FILE *f;
+ int fd;
+ #endif
+ char *path;
+ switch(TYPE(dir))
+ {case tc_c_file:
+ #ifdef unix
+ f = get_c_file(dir,NULL);
+ fd = fileno(f);
+ iflag = no_interrupt(1);
+ if (fchdir(fd))
+ return(err("fchdir",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ #else
+ err("fchdir not supported in os",NIL);
+ #endif
+ return(NIL);
+ default:
+ path = get_c_string(dir);
+ iflag = no_interrupt(1);
+ if (chdir(path))
+ return(err("chdir",llast_c_errmsg(-1)));
+ no_interrupt(iflag);
+ return(NIL);}}
+
+ #if defined(__osf__)
+ LISP rld_pathnames(void)
+ /* this is a quick diagnostic to know what images we are running */
+ {char *path;
+ LISP result = NIL;
+ for(path=_rld_first_pathname();path;path=_rld_next_pathname())
+ result = cons(strcons(strlen(path),path),result);
+ return(nreverse(result));}
+ #endif
+
+ #ifdef unix
+ LISP lgetpass(LISP lprompt)
+ {long iflag;
+ char *result;
+ iflag = no_interrupt(1);
+ result = getpass(NULLP(lprompt) ? "" : get_c_string(lprompt));
+ no_interrupt(iflag);
+ if (result)
+ return(strcons(strlen(result),result));
+ else
+ return(NIL);}
+ #endif
+
+ #ifdef unix
+ LISP lpipe(void)
+ {int filedes[2];
+ long iflag;
+ LISP f1,f2;
+ f1 = cons(NIL,NIL);
+ f2 = cons(NIL,NIL);
+ iflag = no_interrupt(1);
+ if (pipe(filedes) == 0)
+ {f1->type = tc_c_file;
+ f1->storage_as.c_file.f = fdopen(filedes[0],"r");
+ f2->type = tc_c_file;
+ f2->storage_as.c_file.f = fdopen(filedes[1],"w");
+ no_interrupt(iflag);
+ return(listn(2,f1,f2));}
+ else
+ return(err("pipe",llast_c_errmsg(-1)));}
+ #endif
+
+ #define CTYPE_FLOAT 1
+ #define CTYPE_DOUBLE 2
+ #define CTYPE_CHAR 3
+ #define CTYPE_UCHAR 4
+ #define CTYPE_SHORT 5
+ #define CTYPE_USHORT 6
+ #define CTYPE_INT 7
+ #define CTYPE_UINT 8
+ #define CTYPE_LONG 9
+ #define CTYPE_ULONG 10
+
+ LISP err_large_index(LISP ind)
+ {return(err("index too large",ind));}
+
+ LISP datref(LISP dat,LISP ctype,LISP ind)
+ {char *data;
+ long size,i;
+ data = get_c_string_dim(dat,&size);
+ i = get_c_long(ind);
+ if (i < 0) err("negative index",ind);
+ switch(get_c_long(ctype))
+ {case CTYPE_FLOAT:
+ if (((i+1) * (int) sizeof(float)) > size) err_large_index(ind);
+ return(flocons(((float *)data)[i]));
+ case CTYPE_DOUBLE:
+ if (((i+1) * (int) sizeof(double)) > size) err_large_index(ind);
+ return(flocons(((double *)data)[i]));
+ case CTYPE_LONG:
+ if (((i+1) * (int) sizeof(long)) > size) err_large_index(ind);
+ return(flocons(((long *)data)[i]));
+ case CTYPE_SHORT:
+ if (((i+1) * (int) sizeof(short)) > size) err_large_index(ind);
+ return(flocons(((short *)data)[i]));
+ case CTYPE_CHAR:
+ if (((i+1) * (int) sizeof(char)) > size) err_large_index(ind);
+ return(flocons(((char *)data)[i]));
+ case CTYPE_INT:
+ if (((i+1) * (int) sizeof(int)) > size) err_large_index(ind);
+ return(flocons(((int *)data)[i]));
+ case CTYPE_ULONG:
+ if (((i+1) * (int) sizeof(unsigned long)) > size) err_large_index(ind);
+ return(flocons(((unsigned long *)data)[i]));
+ case CTYPE_USHORT:
+ if (((i+1) * (int) sizeof(unsigned short)) > size) err_large_index(ind);
+ return(flocons(((unsigned short *)data)[i]));
+ case CTYPE_UCHAR:
+ if (((i+1) * (int) sizeof(unsigned char)) > size) err_large_index(ind);
+ return(flocons(((unsigned char *)data)[i]));
+ case CTYPE_UINT:
+ if (((i+1) * (int) sizeof(unsigned int)) > size) err_large_index(ind);
+ return(flocons(((unsigned int *)data)[i]));
+ default:
+ return(err("unknown CTYPE",ctype));}}
+
+ LISP sdatref(LISP spec,LISP dat)
+ {return(datref(dat,car(spec),cdr(spec)));}
+
+ LISP mkdatref(LISP ctype,LISP ind)
+ {return(closure(cons(ctype,ind),
+ leval(cintern("sdatref"),NIL)));}
+
+ LISP datlength(LISP dat,LISP ctype)
+ {char *data;
+ long size;
+ data = get_c_string_dim(dat,&size);
+ switch(get_c_long(ctype))
+ {case CTYPE_FLOAT:
+ return(flocons(size / sizeof(float)));
+ case CTYPE_DOUBLE:
+ return(flocons(size / sizeof(double)));
+ case CTYPE_LONG:
+ return(flocons(size / sizeof(long)));
+ case CTYPE_SHORT:
+ return(flocons(size / sizeof(short)));
+ case CTYPE_CHAR:
+ return(flocons(size / sizeof(char)));
+ case CTYPE_INT:
+ return(flocons(size / sizeof(int)));
+ case CTYPE_ULONG:
+ return(flocons(size / sizeof(unsigned long)));
+ case CTYPE_USHORT:
+ return(flocons(size / sizeof(unsigned short)));
+ case CTYPE_UCHAR:
+ return(flocons(size / sizeof(unsigned char)));
+ case CTYPE_UINT:
+ return(flocons(size / sizeof(unsigned int)));
+ default:
+ return(err("unknown CTYPE",ctype));}}
+
+ static LISP cgi_main(LISP result)
+ {if (CONSP(result) && TYPEP(car(result),tc_string))
+ {put_st("Status: 500 Server Error (Application)\n");
+ put_st("Content-type: text/html\n\n");
+ put_st("<HTML><HEAD><TITLE>Server Error (Application)</TITLE></HEAD>\n");
+ put_st("<BODY><H1>Server Error (Application)</H1>\n");
+ put_st("An application on this server has encountered an error\n");
+ put_st("which prevents it from fulfilling your request.");
+ put_st("<P><PRE><B>Error Message:</B> ");
+ lprint(car(result),NIL);
+ if NNULLP(cdr(result))
+ {put_st("\n");
+ lprint(cdr(result),NIL);}
+ put_st("</PRE></BODY></HTML>\n");
+ err("cgi-main",NIL);}
+ return(NIL);}
+
+
+ static int htqs_arg(char *value)
+ {char tmpbuff[1024],*p1,*p2;
+ if ((strcmp(value,"(repl)") == 0) ||
+ (strcmp(value,"repl") == 0))
+ return(repl_driver(1,1,NULL));
+ else if (!strchr(value,'('))
+ {strcpy(tmpbuff,"(require \"");
+ for(p1 = &tmpbuff[strlen(tmpbuff)],p2 = value;*p2;++p2)
+ {if (strchr("\\\"",*p2)) *p1++ = '\\';
+ *p1++ = *p2;}
+ *p1 = 0;
+ strcat(tmpbuff,"\")");
+ return(repl_c_string(tmpbuff,0,0,0));}
+ else
+ return(repl_c_string(value,0,0,0));}
+
+
+ int __stdcall siod_main(int argc,char **argv, char **env)
+ {int j,retval = 0,iargc,mainflag = 0,text_plain_flag = 0;
+ char *iargv[2],*start,*end;
+ LISP l;
+ iargv[0] = "";
+ for(iargc=0,j=1;j<argc; ++j)
+ if (*(start = argv[j]) == '-')
+ {while(*start)
+ {if (!(end = strstr(start,",-"))) end = &start[strlen(start)];
+ iargv[1] = (char *) malloc(end-start+1);
+ memcpy(iargv[1],start,end-start);
+ iargv[1][end-start] = 0;
+ if ((strncmp(iargv[1],"-v",2) == 0) &&
+ (atol(&iargv[1][2]) > 0) &&
+ (iargv[1][2] != '0'))
+ {printf("Content-type: text/plain\r\n\r\n");
+ text_plain_flag = 1;}
+ if ((strncmp(iargv[1],"-m",2) == 0))
+ mainflag = atol(&iargv[1][2]);
+ else
+ process_cla(2,iargv,1);
+ /* Note: Not doing free(iargv[1]); */
+ start = (*end) ? end+1 : end;}}
+ else
+ ++iargc;
+ print_welcome();
+ print_hs_1();
+ init_storage();
+ for(l=NIL,j=0;j<argc;++j)
+ l = cons(strcons(strlen(argv[j]),argv[j]),l);
+ setvar(cintern("*args*"),nreverse(l),NIL);
+ l = NIL;
+ for(l=NIL,j=0;env && env[j];++j)
+ l = cons(strcons(strlen(env[j]),env[j]),l);
+ setvar(cintern("*env*"),nreverse(l),NIL);
+ l = NIL;
+ init_subrs();
+ init_trace();
+ init_slibu();
+ init_subr_1("__cgi-main",cgi_main);
+ if (iargc == 0)
+ retval = repl_driver(1,1,NULL);
+ else
+ {for(j=1;j<(((mainflag >= 2) && (argc > 3)) ? 3 : argc);++j)
+ if (argv[j][0] != '-')
+ {retval = htqs_arg(argv[j]);
+ if (retval != 0) break;}
+ if (mainflag)
+ retval = htqs_arg(((mainflag > 2) && !text_plain_flag)
+ ? "(__cgi-main (*catch 'errobj (main))))"
+ : "(main)");}
+ if (siod_verbose_check(2))
+ printf("EXIT\n");
+ #ifdef VMS
+ if (retval == 0) retval = 1;
+ #endif
+ return(retval);}
+
+ long position_script(FILE *f,char *buff,size_t bufflen)
+ /* This recognizes #!/ sequence. Exersize: compute the probability
+ of the sequence showing up in a file of N random bytes. */
+ {int c,s = 0;
+ long pos = -1,offset;
+ size_t j;
+ buff[0] = 0;
+ for(offset=0;offset<250000;++offset)
+ {c = getc(f);
+ switch(c)
+ {case EOF:
+ return(-1);
+ case '#':
+ s = '#';
+ pos = offset;
+ break;
+ case '!':
+ s = (s == '#') ? '!' : 0;
+ break;
+ case '/':
+ if (s == '!')
+ {while((c = getc(f)) != EOF) if (c == ' ') break;
+ for(j=0;((c = getc(f)) != '\n') && (c != EOF) && (j+1 <= bufflen);++j)
+ {buff[j] = c; buff[j+1] = 0;}
+ if (strspn(buff," \t\r") == strlen(buff)) buff[0] = 0;
+ return(pos);}
+ s = 0;
+ break;
+ default:
+ s = 0;
+ break;}}
+ return(-1);}
+
+ #ifdef WIN32
+ char *find_exe_self(char *cmd)
+ /* This is for the benefit of WINDOWS NT, which is in fact
+ unix compatible in what it passes in as argv[0]. There
+ are other ways of getting a handle to the current executable. */
+ {DWORD retsize;
+ char exe_self[512];
+ retsize = SearchPath(NULL,cmd,".EXE",sizeof(exe_self),exe_self,NULL);
+ if (retsize > 0)
+ return(strdup(exe_self));
+ else
+ return(cmd);}
+ #endif
+
+ void __stdcall siod_shuffle_args(int *pargc,char ***pargv)
+ /* shuffle arguments in the same way that the unix exec loader
+ would do for a #!/xxx script execution. */
+ {FILE *f;
+ char flagbuff[100],**argv,**nargv,offbuff[10];
+ long pos;
+ int argc,nargc,j,k;
+ argc = *pargc;
+ argv = *pargv;
+ #ifdef WIN32
+ argv[0] = find_exe_self(argv[0]);
+ process_cla(1,argv,1);
+ #endif
+ if (!(f = fopen(argv[0],"rb")))
+ {/* perror(argv[0]); */
+ return;}
+ pos = position_script(f,flagbuff,sizeof(flagbuff));
+ fclose(f);
+ if (pos < 0) return;
+ nargc = argc + ((*flagbuff) ? 2 : 1);
+ nargv = (char **) malloc(sizeof(char *) * nargc);
+ j = 0;
+ nargv[j++] = "siod.exe";
+ if (*flagbuff) nargv[j++] = strdup(flagbuff);
+ sprintf(offbuff,"%ld",pos);
+ nargv[j] = (char *) malloc(strlen(offbuff)+strlen(argv[0])+2);
+ sprintf(nargv[j],"%s%c%s",offbuff,VLOAD_OFFSET_HACK_CHAR,argv[0]);
+ j++;
+ for(k=1;k<argc;++k) nargv[j++] = argv[k];
+ *pargc = nargc;
+ *pargv = nargv;
+ }
+
+ LISP lposition_script(LISP lfile)
+ {FILE *f;
+ long iflag,pos;
+ char flbuff[100];
+ f = get_c_file(lfile,stdin);
+ iflag = no_interrupt(1);
+ pos = position_script(f,flbuff,sizeof(flbuff));
+ no_interrupt(iflag);
+ if (pos < 0) return(NIL);
+ return(cons(flocons(pos),strcons(-1,flbuff)));}
+
+ void __stdcall siod_init(int argc,char **argv)
+ {process_cla(argc,argv,0);
+ init_storage();
+ init_subrs();
+ init_trace();
+ init_slibu();}
+
+ void __stdcall init_slibu(void)
+ {long j;
+ #if defined(unix)
+ char *tmp1,*tmp2;
+ #endif
+ #if defined(unix) || defined(WIN32)
+ tc_opendir = allocate_user_tc();
+ set_gc_hooks(tc_opendir,
+ NULL,
+ NULL,
+ NULL,
+ opendir_gc_free,
+ &j);
+ set_print_hooks(tc_opendir,opendir_prin1);
+ init_subr_2("chmod",l_chmod);
+ #endif
+
+ gc_protect_sym(&sym_channels,"*channels*");
+ setvar(sym_channels,NIL,NIL);
+ #ifdef WIN32
+ init_subr_0("win32-debug",win32_debug);
+ #endif
+ #ifdef VMS
+ init_subr_1("vms-debug",vms_debug);
+ init_lsubr("sys$crembx",lcrembx);
+ init_subr_4("lib$set_logical",lset_logical);
+ #endif
+ init_lsubr("system",lsystem);
+ #ifndef WIN32
+ init_subr_0("getgid",lgetgid);
+ init_subr_0("getuid",lgetuid);
+ #endif
+ #if defined(unix) || defined(WIN32)
+ init_subr_0("getcwd",lgetcwd);
+ #endif
+ #ifdef unix
+ init_subr_2("crypt",lcrypt);
+ init_subr_1("getpwuid",lgetpwuid);
+ init_subr_1("getpwnam",lgetpwnam);
+ init_subr_0("getpwent",lgetpwent);
+ init_subr_0("setpwent",lsetpwent);
+ init_subr_0("endpwent",lendpwent);
+ init_subr_1("setuid",lsetuid);
+ init_subr_1("seteuid",lseteuid);
+ init_subr_0("geteuid",lgeteuid);
+ #if defined(__osf__)
+ init_subr_1("setpwfile",lsetpwfile);
+ #endif
+ init_subr_2("putpwent",lputpwent);
+ init_subr_2("access-problem?",laccess_problem);
+ init_subr_3("utime",lutime);
+ init_subr_2("fchmod",lfchmod);
+ #endif
+ init_subr_1("random",lrandom);
+ init_subr_1("srandom",lsrandom);
+ init_subr_1("first",car);
+ init_subr_1("rest",cdr);
+ #ifdef unix
+ init_subr_0("fork",lfork);
+ init_subr_3("exec",lexec);
+ init_subr_1("nice",lnice);
+ init_subr_2("wait",lwait);
+ init_subr_0("getpgrp",lgetpgrp);
+ init_subr_1("getgrgid",lgetgrgid);
+ init_subr_2("setpgid",lsetpgid);
+ init_subr_2("kill",lkill);
+ #endif
+ init_subr_1("%%%memref",lmemref_byte);
+ init_subr_0("getpid",lgetpid);
+ #ifndef WIN32
+ init_subr_0("getppid",lgetppid);
+ #endif
+ init_subr_1("exit",lexit);
+ init_subr_1("trunc",ltrunc);
+ #ifdef unix
+ init_subr_1("putenv",lputenv);
+ #endif
+ #if defined(__osf__) || defined(sun)
+ init_subr_2("cpu-usage-limits",cpu_usage_limits);
+ #endif
+ #if defined(__osf__) || defined(SUN5)
+ init_subr_1("current-resource-usage",current_resource_usage);
+ #endif
+ #if defined(unix) || defined(WIN32)
+ init_subr_1("opendir",l_opendir);
+ init_subr_1("closedir",l_closedir);
+ init_subr_1("readdir",l_readdir);
+ #endif
+ init_subr_1("delete-file",delete_file);
+ init_subr_1("file-times",file_times);
+ init_subr_1("unix-time->strtime",utime2str);
+ init_subr_0("unix-time",unix_time);
+ init_subr_1("unix-ctime",unix_ctime);
+ init_subr_1("getenv",lgetenv);
+ init_subr_1("sleep",lsleep);
+ init_subr_1("url-encode",url_encode);
+ init_subr_1("url-decode",url_decode);
+ init_subr_2("gets",lgets);
+ init_subr_1("readline",readline);
+ init_subr_1("html-encode",html_encode);
+ init_subr_1("html-decode",html_decode);
+ #if defined(unix) || defined(WIN32)
+ init_subr_1("decode-file-mode",decode_st_mode);
+ init_subr_1("encode-file-mode",encode_st_mode);
+ init_subr_1("stat",l_stat);
+ init_subr_1("fstat",l_fstat);
+ #endif
+ #ifdef unix
+ init_subr_1("encode-open-flags",encode_open_flags);
+ init_subr_1("lstat",l_lstat);
+ #endif
+ #if defined(__osf__) || defined(SUN5)
+ init_subr_3("fnmatch",l_fnmatch);
+ #endif
+ #ifdef unix
+ init_subr_2("symlink",lsymlink);
+ init_subr_2("link",llink);
+ init_subr_1("unlink",lunlink);
+ init_subr_1("rmdir",lrmdir);
+ init_subr_2("mkdir",lmkdir);
+ init_subr_2("rename",lrename);
+ init_subr_1("readlink",lreadlink);
+ #endif
+ #ifndef WIN32
+ init_subr_3("chown",l_chown);
+ #endif
+ #if defined(unix) && !defined(linux)
+ init_subr_3("lchown",l_lchown);
+ #endif
+ init_subr_1("http-date",http_date);
+ #if defined(__osf__)
+ init_subr_1("http-date-parse",http_date_parse);
+ #endif
+ #ifdef unix
+ init_subr_2("popen",popen_l);
+ init_subr_1("pclose",pclose_l);
+ #endif
+ init_subr_2("load-so",load_so);
+ init_subr_1("require-so",require_so);
+ init_subr_1("so-ext",so_ext);
+ #ifdef unix
+ setvar(cintern("SEEK_SET"),flocons(SEEK_SET),NIL);
+ setvar(cintern("SEEK_CUR"),flocons(SEEK_CUR),NIL);
+ setvar(cintern("SEEK_END"),flocons(SEEK_END),NIL);
+ setvar(cintern("F_RDLCK"),flocons(F_RDLCK),NIL);
+ setvar(cintern("F_WRLCK"),flocons(F_WRLCK),NIL);
+ setvar(cintern("F_UNLCK"),flocons(F_UNLCK),NIL);
+ init_subr_5("F_SETLK",lF_SETLK);
+ init_subr_5("F_SETLKW",lF_SETLKW);
+ init_subr_5("F_GETLK",lF_GETLK);
+
+ #endif
+ init_subr_0("siod-lib",siod_lib_l);
+
+ #ifdef unix
+ if ((!(tmp1 = getenv(ld_library_path_env))) ||
+ (!strstr(tmp1,siod_lib)))
+ {tmp2 = (char *) must_malloc(strlen(ld_library_path_env) + 1 +
+ ((tmp1) ? strlen(tmp1) + 1 : 0) +
+ strlen(siod_lib) + 1);
+ sprintf(tmp2,"%s=%s%s%s",
+ ld_library_path_env,
+ (tmp1) ? tmp1 : "",
+ (tmp1) ? ":" : "",
+ siod_lib);
+ /* note that we cannot free the string afterwards. */
+ putenv(tmp2);}
+ #endif
+ #ifdef vms
+ setvar(cintern("*require-so-dir*"),
+ string_append(listn(2,
+ strcons(-1,siod_lib),
+ strcons(-1,".EXE"))),
+ NIL);
+ #endif
+ init_subr_1("localtime",llocaltime);
+ init_subr_1("gmtime",lgmtime);
+ #if defined(unix) || defined(WIN32)
+ init_subr_0("tzset",ltzset);
+ #endif
+ init_subr_1("mktime",lmktime);
+ init_subr_1("chdir",lchdir);
+ #if defined(__osf__)
+ init_subr_0("rld-pathnames",rld_pathnames);
+ #endif
+ #if defined(__osf__) || defined(SUN5) || defined(linux)
+ init_subr_3("strptime",lstrptime);
+ #endif
+ #ifdef unix
+ init_subr_2("strftime",lstrftime);
+ init_subr_1("getpass",lgetpass);
+ init_subr_0("pipe",lpipe);
+ init_subr_2("alarm",lalarm);
+ #endif
+
+ setvar(cintern("CTYPE_FLOAT"),flocons(CTYPE_FLOAT),NIL);
+ setvar(cintern("CTYPE_DOUBLE"),flocons(CTYPE_DOUBLE),NIL);
+ setvar(cintern("CTYPE_LONG"),flocons(CTYPE_LONG),NIL);
+ setvar(cintern("CTYPE_SHORT"),flocons(CTYPE_SHORT),NIL);
+ setvar(cintern("CTYPE_CHAR"),flocons(CTYPE_CHAR),NIL);
+ setvar(cintern("CTYPE_INT"),flocons(CTYPE_INT),NIL);
+ setvar(cintern("CTYPE_ULONG"),flocons(CTYPE_ULONG),NIL);
+ setvar(cintern("CTYPE_USHORT"),flocons(CTYPE_USHORT),NIL);
+ setvar(cintern("CTYPE_UCHAR"),flocons(CTYPE_UCHAR),NIL);
+ setvar(cintern("CTYPE_UINT"),flocons(CTYPE_UINT),NIL);
+ init_subr_3("datref",datref);
+ init_subr_2("sdatref",sdatref);
+ init_subr_2("mkdatref",mkdatref);
+ init_subr_2("datlength",datlength);
+ init_subr_1("position-script",lposition_script);
+
+ init_slibu_version();}
Index: llvm/test/Programs/MultiSource/Applications/siod/test.scm
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/test.scm:1.1
*** /dev/null Fri Oct 17 13:48:56 2003
--- llvm/test/Programs/MultiSource/Applications/siod/test.scm Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,72 ----
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; These are some really basic tests of SIOD that I wrote for the LLVM
+ ;; testsuite... later we should replace these with code that actually does
+ ;; something, I guess. -Brian
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Some standard-Scheme compatibility routines
+ (define else #t)
+ (define (display x)
+ (cond ((number? x) (puts (number->string x)))
+ ((string? x) (puts x))
+ ((symbol? x) (puts x))
+ (else (err "can't display errobj" x))))
+ (define (newline) (puts "\n"))
+ (define (cadddr x) (caddr (cdr x)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Property lists like in LISP.
+ (define *properties* '())
+ (define (get table key)
+ (let ((result (assoc (cons key table) *properties*)))
+ (if result
+ (cadr result)
+ #f)))
+ (define (put table key value)
+ (let* ((real-key (cons key table))
+ (result (assoc real-key *properties*)))
+ (if result
+ (set-car! (cdr result) value)
+ (set! *properties* (cons (list real-key value) *properties*)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; simple test code for proplist code, presented above
+ (define (simple-proplist-test)
+ (put 'answer 'value 42)
+ (display "the value of (get 'answer 'value) is ")
+ (display (get 'answer 'value))
+ (newline)
+ (put 'answer 'value 'xyzzy)
+ (display "the value of (get 'answer 'value) is ")
+ (display (get 'answer 'value))
+ (newline))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; recursively count down from COUNTER, printing out the numbers
+ (define (print-countdown counter)
+ (if (equal? counter 0)
+ #t
+ (begin
+ (display counter)
+ (newline)
+ (print-countdown (- counter 1)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; print out whether VALUE is positive, zero, or negative
+ (define (print-signum value)
+ (display value)
+ (display " is ")
+ (display (cond ((> value 0) "positive")
+ ((< value 0) "negative")
+ (else "zero")))
+ (newline))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Run some simple tests
+ (print-countdown 10)
+ (print-signum -42)
+ (print-signum 0)
+ (print-signum 42)
+ (simple-proplist-test)
+
Index: llvm/test/Programs/MultiSource/Applications/siod/trace.c
diff -c /dev/null llvm/test/Programs/MultiSource/Applications/siod/trace.c:1.1
*** /dev/null Fri Oct 17 13:48:56 2003
--- llvm/test/Programs/MultiSource/Applications/siod/trace.c Fri Oct 17 13:48:45 2003
***************
*** 0 ****
--- 1,146 ----
+ /* COPYRIGHT (c) 1992-1994 BY
+ * MITECH CORPORATION, ACTON, MASSACHUSETTS.
+ * See the source file SLIB.C for more information.
+
+ (trace procedure1 procedure2 ...)
+ (untrace procedure1 procedure2 ...)
+
+ Currently only user-defined procedures can be traced.
+ Fancy printing features such as indentation based on
+ recursion level will also have to wait for a future version.
+
+
+ */
+
+ #include <stdio.h>
+ #include <setjmp.h>
+ #include "siod.h"
+ #include "siodp.h"
+
+ static void init_trace_version(void)
+ {setvar(cintern("*trace-version*"),
+ cintern("$Id: trace.c,v 1.1 2003/10/17 18:48:45 gaeke Exp $"),
+ NIL);}
+
+
+ static long tc_closure_traced = 0;
+
+ static LISP sym_traced = NIL;
+ static LISP sym_quote = NIL;
+ static LISP sym_begin = NIL;
+
+ LISP ltrace_fcn_name(LISP body);
+ LISP ltrace_1(LISP fcn_name,LISP env);
+ LISP ltrace(LISP fcn_names,LISP env);
+ LISP luntrace_1(LISP fcn);
+ LISP luntrace(LISP fcns);
+ static void ct_gc_scan(LISP ptr);
+ static LISP ct_gc_mark(LISP ptr);
+ void ct_prin1(LISP ptr,struct gen_printio *f);
+ LISP ct_eval(LISP ct,LISP *px,LISP *penv);
+
+ LISP ltrace_fcn_name(LISP body)
+ {LISP tmp;
+ if NCONSP(body) return(NIL);
+ if NEQ(CAR(body),sym_begin) return(NIL);
+ tmp = CDR(body);
+ if NCONSP(tmp) return(NIL);
+ tmp = CAR(tmp);
+ if NCONSP(tmp) return(NIL);
+ if NEQ(CAR(tmp),sym_quote) return(NIL);
+ tmp = CDR(tmp);
+ if NCONSP(tmp) return(NIL);
+ return(CAR(tmp));}
+
+ LISP ltrace_1(LISP fcn_name,LISP env)
+ {LISP fcn,code;
+ fcn = leval(fcn_name,env);
+ if (TYPE(fcn) == tc_closure)
+ {code = fcn->storage_as.closure.code;
+ if NULLP(ltrace_fcn_name(cdr(code)))
+ setcdr(code,cons(sym_begin,
+ cons(cons(sym_quote,cons(fcn_name,NIL)),
+ cons(cdr(code),NIL))));
+ fcn->type = (short) tc_closure_traced;}
+ else if (TYPE(fcn) == tc_closure_traced)
+ ;
+ else
+ err("not a closure, cannot trace",fcn);
+ return(NIL);}
+
+ LISP ltrace(LISP fcn_names,LISP env)
+ {LISP l;
+ for(l=fcn_names;NNULLP(l);l=cdr(l))
+ ltrace_1(car(l),env);
+ return(NIL);}
+
+ LISP luntrace_1(LISP fcn)
+ {if (TYPE(fcn) == tc_closure)
+ ;
+ else if (TYPE(fcn) == tc_closure_traced)
+ fcn->type = tc_closure;
+ else
+ err("not a closure, cannot untrace",fcn);
+ return(NIL);}
+
+ LISP luntrace(LISP fcns)
+ {LISP l;
+ for(l=fcns;NNULLP(l);l=cdr(l))
+ luntrace_1(car(l));
+ return(NIL);}
+
+ static void ct_gc_scan(LISP ptr)
+ {CAR(ptr) = gc_relocate(CAR(ptr));
+ CDR(ptr) = gc_relocate(CDR(ptr));}
+
+ static LISP ct_gc_mark(LISP ptr)
+ {gc_mark(ptr->storage_as.closure.code);
+ return(ptr->storage_as.closure.env);}
+
+ void ct_prin1(LISP ptr,struct gen_printio *f)
+ {gput_st(f,"#<CLOSURE(TRACED) ");
+ lprin1g(car(ptr->storage_as.closure.code),f);
+ gput_st(f," ");
+ lprin1g(cdr(ptr->storage_as.closure.code),f);
+ gput_st(f,">");}
+
+ LISP ct_eval(LISP ct,LISP *px,LISP *penv)
+ {LISP fcn_name,args,env,result,l;
+ fcn_name = ltrace_fcn_name(cdr(ct->storage_as.closure.code));
+ args = leval_args(CDR(*px),*penv);
+ fput_st(stdout,"->");
+ lprin1f(fcn_name,stdout);
+ for(l=args;NNULLP(l);l=cdr(l))
+ {fput_st(stdout," ");
+ lprin1f(car(l),stdout);}
+ fput_st(stdout,"\n");
+ env = extend_env(args,
+ car(ct->storage_as.closure.code),
+ ct->storage_as.closure.env);
+ result = leval(cdr(ct->storage_as.closure.code),env);
+ fput_st(stdout,"<-");
+ lprin1f(fcn_name,stdout);
+ fput_st(stdout," ");
+ lprin1f(result,stdout);
+ fput_st(stdout,"\n");
+ *px = result;
+ return(NIL);}
+
+ void __stdcall init_trace(void)
+ {long j;
+ tc_closure_traced = allocate_user_tc();
+ set_gc_hooks(tc_closure_traced,
+ NULL,
+ ct_gc_mark,
+ ct_gc_scan,
+ NULL,
+ &j);
+ gc_protect_sym(&sym_traced,"*traced*");
+ setvar(sym_traced,NIL,NIL);
+ gc_protect_sym(&sym_begin,"begin");
+ gc_protect_sym(&sym_quote,"quote");
+ set_print_hooks(tc_closure_traced,ct_prin1);
+ set_eval_hooks(tc_closure_traced,ct_eval);
+ init_fsubr("trace",ltrace);
+ init_lsubr("untrace",luntrace);
+ init_trace_version();}
More information about the llvm-commits
mailing list