Import Upstream version 5c3upstream/5c3

1 files changed, 142 insertions, 56 deletions

diff --git a/scm.h b/scm.h
index 55be55a..1af22f1 100644
--- a/scm.h
+++ b/scm.h
@@ -100,6 +100,11 @@ typedef struct {
   long inc;
 } array_dim;
 
+#ifndef INUMS_ONLY
+# define NUM_HP_MAX_REQ 4*sizeof(double)
+
+#endif
+
 #ifdef FLOATS
 typedef struct {char *string;double (*cproc)P((double));} dblproc;
 # ifdef SINGLES
@@ -137,7 +142,9 @@ typedef struct {SCM type;double *real;} dbl;
 #define ISYMP(n) ((0x187 & (int)(n))==4)
 /* IFLAGP tests for ISPCSYM, ISYM and IFLAG */
 #define IFLAGP(n) ((0x87 & (int)(n))==4)
-#define ISYMNUM(n) ((int)((n)>>9))
+#define ISYMNUM(n) (((int)((n)>>9)) & 0x7f)
+#define ISYMVAL(n) ((int)((n)>>16))
+#define ISYMSETVAL(isym, val) ((isym) | ((long)(val) <<16))
 #define ISYMCHARS(n) (isymnames[ISYMNUM(n)])
 #define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
 #define MAKISYM(n) (((n)<<9)+0x74L)
@@ -183,17 +190,16 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
 /* each symbol defined here must have a unique number which */
  /* corresponds to it's position in isymnames[] in sys.c */
 #define IM_APPLY MAKISYM(14)
-#define IM_CONT MAKISYM(15)
-#define IM_FARLOC_CAR MAKISYM(16)
-#define IM_FARLOC_CDR MAKISYM(17)
-#define IM_DELAY MAKISYM(18)
-#define IM_QUASIQUOTE MAKISYM(19)
-#define IM_UNQUOTE MAKISYM(20)
-#define IM_UQ_SPLICING MAKISYM(21)
-#define IM_ELSE MAKISYM(22)
-#define IM_ARROW MAKISYM(23)
-
-#define NUM_ISYMS 24
+#define IM_FARLOC_CAR MAKISYM(15)
+#define IM_FARLOC_CDR MAKISYM(16)
+#define IM_DELAY MAKISYM(17)
+#define IM_QUASIQUOTE MAKISYM(18)
+#define IM_UNQUOTE MAKISYM(19)
+#define IM_UQ_SPLICING MAKISYM(20)
+#define IM_ELSE MAKISYM(21)
+#define IM_ARROW MAKISYM(22)
+
+#define NUM_ISYMS 23
 
 #define BOOL_F MAKIFLAG(NUM_ISYMS+0)
 #define BOOL_T MAKIFLAG(NUM_ISYMS+1)
@@ -253,7 +259,16 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
 #define CLOSUREP(x) (TYP3(x)==tc3_closure)
 #define CODE(x) (CAR(x)-tc3_closure)
 #define SETCODE(x, e) CAR(x) = (e)+tc3_closure
-#define ENV(x) CDR(x)
+#define ENV(x) ((~7L & CDR(x)) ? (~7L & CDR(x)) : EOL)
+#define GCENV ENV
+#define ARGC(x) ((6L & CDR(x))>>1)
+#ifdef CAUTIOUS
+# define SCM_ESTK_FRLEN 3
+#else
+# define SCM_ESTK_FRLEN 2
+#endif
+#define SCM_ESTK_BASE (2*SCM_ESTK_FRLEN)
+extern long tc16_env;
 
 #define PORTP(x) (TYP7(x)==tc7_port)
 #define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN))
@@ -273,7 +288,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
 #define SETSTREAM SETCDR
 #define CRDYP(port) (CAR(port) & CRDY)
 #define CLRDY(port) {CAR(port) &= CUC;}
-#define CGETUN(port) ((int)SRS(CAR(port), 22))
+#define CGETUN(port) ((unsigned char)SRS(CAR(port), 22))
 #define CUNGET(c, port) {CAR(port) += ((long)c<<22) + CRDY;}
 
 #define tc_socket (tc7_port | OPN)
@@ -320,6 +335,7 @@ extern SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
 #define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc)
 #define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc)
 #define CCLO_SUBR(x) (VELTS(x)[0])
+#define CCLO_LENGTH NUMDIGS
 
 #define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol)
 #define STRINGP(x) (TYP7(x)==tc7_string)
@@ -387,7 +403,8 @@ extern long tc16_array;
 #define tcs_symbols tc7_ssymbol:case tc7_msymbol
 #define tcs_bignums tc16_bigpos:case tc16_bigneg
 
-#define tc3_cons	0
+#define tc3_cons_nimcar 0
+#define tc3_cons_imcar  2:case 4:case 6
 #define tc3_cons_gloc	1
 #define tc3_closure	3
 
@@ -405,7 +422,7 @@ extern long tc16_array;
 #define tc7_cvect	53
 #define tc7_port	55
 #define tc7_contin	61
-#define tc7_cclo	63
+#define tc7_specfun	63
 
 /* spare 69 71 77 79 */
 #define tc7_subr_0	85
@@ -422,6 +439,11 @@ extern long tc16_array;
 
 #define tc7_smob	127
 #define tc_free_cell	127
+#define tc_broken_heart (tc_free_cell+0x10000)
+
+#define tc16_apply	(tc7_specfun | (0L<<8))
+#define tc16_call_cc	(tc7_specfun | (1L<<8))
+#define tc16_cclo	(tc7_specfun | (2L<<8))
 
 #define tc16_flo	0x017f
 #define tc_flo		0x017fL
@@ -458,15 +480,15 @@ extern SCM sys_protects[];
 #define def_inp sys_protects[3]
 #define def_outp sys_protects[4]
 #define def_errp sys_protects[5]
-#define listofnull sys_protects[6]
-#define undefineds sys_protects[7]
-#define nullvect sys_protects[8]
-#define nullstr sys_protects[9]
-#define progargs sys_protects[10]
-#define transcript sys_protects[11]
-#define rootcont sys_protects[12]
-#define dynwinds sys_protects[13]
-#define stacktrace sys_protects[14]
+#define sys_errp sys_protects[6]
+#define listofnull sys_protects[7]
+#define undefineds sys_protects[8]
+#define nullvect sys_protects[9]
+#define nullstr sys_protects[10]
+#define progargs sys_protects[11]
+#define transcript sys_protects[12]
+#define rootcont sys_protects[13]
+#define dynwinds sys_protects[14]
 #ifdef FLOATS
 # define flo0 sys_protects[15]
 # define NUM_PROTECTS 16
@@ -481,9 +503,9 @@ extern void (**finals)P((void));
 extern unsigned char upcase[], downcase[];
 extern SCM symhash;
 extern int symhash_dim;
-extern long heap_size;
+extern long heap_cells;
 extern CELLPTR heap_org;
-extern SCM freelist;
+extern VOLATILE SCM freelist;
 extern long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
 extern long gc_syms_collected;
 extern long cells_allocated, lcells_allocated, mallocated, lmallocated;
@@ -492,12 +514,15 @@ extern SCM *loc_loadpath;
 extern SCM *loc_errobj;
 extern SCM loadport;
 extern long linum;
-extern int errjmp_bad, ints_disabled, sig_deferred, alrm_deferred;
+extern int errjmp_bad, ints_disabled, output_deferred;
+extern unsigned long SIG_deferred;
 extern SCM exitval;
 extern int cursinit;
 extern unsigned int poll_count, tick_count;
 extern int dumped;
 extern char *execpath;
+extern int scm_verbose;
+#define verbose (scm_verbose+0)
 
 /* strings used in several source files */
 
@@ -512,15 +537,20 @@ extern char s_ccl[];
 #define s_limit (s_ccl+10)
 extern char s_close_port[];
 #define s_port_type (s_close_port+6)
+extern char s_call_cc[];
+#define s_cont (s_call_cc+18)
 
 /* function prototypes */
 
-void	gc_mark P((SCM p));
-void	han_sig P((void));
-void	han_alrm P((void));
+extern void (* deferred_proc) P((void));
+void	process_signals P((void));
+int	handle_it P((int i));
+SCM	must_malloc_cell P((long len, char *what));
+void	must_realloc_cell P((SCM z, long olen, long len, char *what));
 char	*must_malloc P((long len, char *what));
 char	*must_realloc P((char *where, long olen, long len, char *what));
-void	must_free P((char *obj));
+void	must_free P((char *obj, sizet len));
+void	scm_protect_temp P((SCM *ptr));
 long	ilength P((SCM sx));
 SCM	hash P((SCM obj, SCM n));
 SCM	hashv P((SCM obj, SCM n));
@@ -535,9 +565,12 @@ long	newsmob P((smobfuns *smob));
 long	newptob P((ptobfuns *ptob));
 void	prinport P((SCM exp, SCM port, char *type));
 void	repl P((void));
-void	growth_mon P((char *obj, long size, char *units));
+void	growth_mon P((char *obj, long size, char *units, int grewp));
 void	gc_start P((char *what));
 void	gc_end P((void));
+void	gc_mark P((SCM p));
+void    scm_egc_start P((void));
+void    scm_egc_end P((void));
 void	heap_report P((void));
 void	exit_report P((void));
 void	stack_report P((void));
@@ -570,11 +603,11 @@ void	warn P((char *str1, char *str2));
 void	everr P((SCM exp, SCM env, SCM arg, char *pos, char *s_subr));
 void	wta P((SCM arg, char *pos, char *s_subr));
 SCM	intern P((char *name, sizet len));
-SCM	sysintern P((char *name, SCM val));
+SCM	sysintern P((const char *name, SCM val));
 SCM	sym2vcell P((SCM sym));
 SCM	makstr P((long len));
-SCM	make_subr P((char *name, int type, SCM (*fcn)()));
-SCM	closure P((SCM code, SCM env));
+SCM	make_subr P((const char *name, int type, SCM (*fcn)()));
+SCM	closure P((SCM code, int nargs));
 SCM	makprom P((SCM code));
 SCM	force P((SCM x));
 SCM	makarb P((SCM name));
@@ -583,7 +616,7 @@ SCM	relarb P((SCM arb));
 SCM	ceval P((SCM x, SCM env));
 SCM	prolixity P((SCM arg));
 SCM	gc_for_newcell P((void));
-SCM	gc P((void));
+SCM	gc P((SCM arg));
 SCM	tryload P((SCM filename));
 SCM	acons P((SCM w, SCM x, SCM y));
 SCM	cons2 P((SCM w, SCM x, SCM y));
@@ -652,6 +685,7 @@ int     rafill P((SCM ra, SCM fill, SCM ignore));
 SCM	uve_fill P((SCM uve, SCM fill));
 SCM	array_fill P((SCM ra, SCM fill));
 SCM	array_prot P((SCM ra));
+SCM     array_rank P((SCM ra));
 int	bigprint P((SCM exp, SCM port, int writing));
 int	floprint P((SCM sexp, SCM port, int writing));
 SCM	istr2int P((char *str, long len, long radix));
@@ -698,6 +732,7 @@ SCM	scm_make_cont P((void));
 SCM	copytree P((SCM obj));
 SCM	eval P((SCM obj));
 SCM 	identp P((SCM obj));
+SCM	ident2sym P((SCM id));
 SCM 	ident_eqp P((SCM id1, SCM id2, SCM env));
 SCM 	renamed_ident P((SCM id, SCM env));
 SCM	input_portp P((SCM x));
@@ -705,6 +740,7 @@ SCM	output_portp P((SCM x));
 SCM	cur_input_port P((void));
 SCM	cur_output_port P((void));
 SCM	i_setbuf0 P((SCM port));
+SCM	try_open_file P((SCM filename, SCM modes));
 SCM	open_file P((SCM filename, SCM modes));
 SCM	open_pipe P((SCM pipestr, SCM modes));
 SCM	close_port P((SCM port));
@@ -737,9 +773,13 @@ SCM     ura_read P((SCM v, SCM port));
 SCM     ura_write P((SCM v, SCM port));
 SCM	aset P((SCM v, SCM obj, SCM args));
 SCM	aref P((SCM v, SCM args));
+SCM     scm_array_ref P((SCM args));
 SCM	cvref P((SCM v, sizet pos, SCM last));
 SCM	quit P((SCM n));
-void	ints_viol P((int sense));
+#ifdef CAREFUL_INTS
+void	ints_viol P((ints_infot *info, int sense));
+void    ints_warn P((char *s1, char* s2, char *fname, int linum));
+#endif
 void	add_final P((void (*final)(void)));
 SCM	makcclo P((SCM proc, long len));
 SCM	make_uve P((long k, SCM prot));
@@ -751,7 +791,25 @@ SCM	scm_eval_string P((SCM str));
 SCM	scm_load_string P((SCM str));
 void	scm_print_stack P((SCM stk));
 char *	dld_find_executable P((const char* command));
+char *  scm_find_executable P((void));
+SCM     scm_find_impl P((SCM execpath));
 SCM	scm_unexec P((const SCM pathname));
+SCM     scm_log_aref P((SCM args));
+SCM     scm_log_aset P((SCM ra, SCM obj, SCM args));
+SCM     scm_logbitp  P((SCM index, SCM j1));
+SCM     scm_logtest  P((SCM x, SCM y));
+SCM     scm_logxor P((SCM x, SCM y));
+SCM     scm_logand P((SCM x, SCM y));
+SCM     scm_logior P((SCM x, SCM y));
+SCM     scm_lognot P((SCM n));
+SCM     scm_intexpt P((SCM z1, SCM z2));
+SCM     scm_ash P((SCM n, SCM cnt));
+SCM     scm_bitfield P((SCM n, SCM start, SCM end));
+SCM     scm_logcount P((SCM n));
+SCM     scm_intlength P((SCM n));
+SCM     scm_copybit P((SCM index, SCM j1, SCM bit));
+SCM 	scm_bitif P((SCM mask, SCM n0, SCM n1));
+SCM 	scm_copybitfield P((SCM to, SCM start, SCM rest));
 
 				/* Defined in "rope.c" */
 SCM	 long2num P((long n));
@@ -781,7 +839,7 @@ double	lasinh P((double x));
 double	lacosh P((double x));
 double	latanh P((double x));
 double	ltrunc P((double x));
-double	round P((double x));
+double	scm_round P((double x));
 double	floident P((double x));
 #endif
 
@@ -810,6 +868,25 @@ int	script_count_argv P((char **argv));
 char *	scm_find_impl_file P((char *exec_path, const char *generic_name,
 			      const char *initname, const char *sep));
 
+/* environment cache functions */
+void scm_ecache_report P((void));
+void scm_estk_reset P((void));
+void scm_estk_grow P((sizet inc));
+void scm_env_cons P((SCM x, SCM y));
+void scm_env_cons2 P((SCM w, SCM x, SCM y));
+void scm_env_cons_tmp P((SCM x));
+void scm_extend_env P((SCM names));
+void scm_egc P((void));
+
+/* Global state for environment cache */
+extern CELLPTR scm_ecache;
+extern VOLATILE long scm_ecache_index, scm_ecache_len;
+extern SCM scm_env, scm_env_tmp;
+extern SCM scm_egc_roots[];
+extern long scm_egc_root_index;
+extern SCM scm_estk;
+extern  SCM *scm_estk_v, *scm_estk_ptr;
+
 #ifdef RECKLESS
 # define ASSERT(_cond, _arg, _pos, _subr) ;
 # define ASRTGO(_cond, _label) ;
@@ -818,30 +895,39 @@ char *	scm_find_impl_file P((char *exec_path, const char *generic_name,
 # define ASRTGO(_cond, _label) if(!(_cond)) goto _label;
 #endif
 
-#define ARGn 0
-#define ARG1 1
-#define ARG2 2
-#define ARG3 3
-#define ARG4 4
-#define ARG5 5
+#define ARGn		0
+#define ARG1		1
+#define ARG2		2
+#define ARG3		3
+#define ARG4		4
+#define ARG5		5
   /* following must match entry indexes in errmsgs[] */
-#define WNA 6
-#define OVFLOW 7
-#define OUTOFRANGE 8
-#define NALLOC 9
-#define EXIT 10
-#define HUP_SIGNAL 11
-#define INT_SIGNAL 12
-#define FPE_SIGNAL 13
-#define BUS_SIGNAL 14
-#define SEGV_SIGNAL 15
-#define ALRM_SIGNAL 16
+#define WNA		6
+#define OVFLOW		7
+#define OUTOFRANGE	8
+#define NALLOC		9
+#define THRASH		10
+#define EXIT		11
+#define HUP_SIGNAL	12
+#define INT_SIGNAL	13
+#define FPE_SIGNAL	14
+#define BUS_SIGNAL	15
+#define SEGV_SIGNAL	16
+#define ALRM_SIGNAL	17
+#define PROF_SIGNAL	18
 
 #define EVAL(x, env) (IMP(x)?(x):ceval((x), (env)))
 #define SIDEVAL(x, env) if NIMP(x) ceval((x), (env))
 
 #define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\
 	else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}}
+/*
+#define NEWCELL(_into) {DEFER_INTS;if IMP(freelist) _into = gc_for_newcell();\
+	else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}\
+        ALLOW_INTS;}
+*/
+
+int run_scm P((int argc, char **argv, int iverbose, int buf0stdin, char *initpath));
 
 #ifdef __cplusplus
 }