Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log
Repository URL

runtime.c @ 12843

Last change on this file since 12843 was 12843, checked in by Ivan Raikov, 12 years ago
Added initial version of cmk.
File size: 220.1 KB

Line
1	/* runtime.c - Runtime code for compiler generated executables
2	;
3	; Copyright (c) 2000-2007, Felix L. Winkelmann
4	; Copyright (c) 2008, The Chicken Team
5	; All rights reserved.
6	;
7	; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8	; conditions are met:
9	;
10	; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11	; disclaimer.
12	; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13	; disclaimer in the documentation and/or other materials provided with the distribution.
14	; Neither the name of the author nor the names of its contributors may be used to endorse or promote
15	; products derived from this software without specific prior written permission.
16	;
17	; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18	; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19	; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20	; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21	; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22	; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23	; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24	; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25	; POSSIBILITY OF SUCH DAMAGE.
26	*/
27
28	#include "chicken.h"
29	#include <errno.h>
30	#include <signal.h>
31	#include <assert.h>
32	#include <limits.h>
33	#include <math.h>
34
35	#ifdef HAVE_SYSEXITS_H
36	# include <sysexits.h>
37	#endif
38
39	#if !defined(PIC)
40	# define NO_DLOAD2
41	#endif
42
43	#ifndef NO_DLOAD2
44	# ifdef HAVE_DLFCN_H
45	# include <dlfcn.h>
46	# endif
47
48	# ifdef HAVE_DL_H
49	# include <dl.h>
50	# endif
51	#endif
52
53	#ifndef EX_SOFTWARE
54	# define EX_SOFTWARE 70
55	#endif
56
57	#ifdef __WATCOMC__
58	# define NSIG (_SIGMAX - _SIGMIN + 1)
59	#endif
60
61	#if defined(__MWERKS__) && !defined(__INTEL__)
62
63	# include <stat.h>
64	# ifndef MACINTOSH_GUI
65	# include <console.h>
66	# include <SIOUX.h>
67	# endif
68
69	# define NSIG 32
70	# define EINVAL ERANGE
71	static C_TLS int timezone;
72
73	#elif !defined(C_NONUNIX)
74
75	# include <sys/types.h>
76	# include <sys/stat.h>
77	# include <sys/time.h>
78	# include <sys/resource.h>
79	# include <sys/wait.h>
80
81	#else
82
83	# include <sys/types.h>
84	# include <sys/stat.h>
85
86	#ifdef ECOS
87	#include <cyg/kernel/kapi.h>
88	static C_TLS int timezone;
89	#define NSIG 32
90	#endif
91
92	#endif
93
94	#ifndef RTLD_GLOBAL
95	# define RTLD_GLOBAL 0
96	#endif
97
98	#ifndef RTLD_NOW
99	# define RTLD_NOW 0
100	#endif
101
102	#ifndef RTLD_LOCAL
103	# define RTLD_LOCAL 0
104	#endif
105
106	#ifndef RTLD_LAZY
107	# define RTLD_LAZY 0
108	#endif
109
110	#ifdef HAVE_WINDOWS_H
111	# include <windows.h>
112	#endif
113
114	#ifdef HAVE_CONFIG_H
115	# ifdef PACKAGE
116	# undef PACKAGE
117	# endif
118	# ifdef VERSION
119	# undef VERSION
120	# endif
121	# include <chicken-config.h>
122
123	# ifndef HAVE_ALLOCA
124	# error this package requires "alloca()"
125	# endif
126	#endif
127
128	#ifdef _MSC_VER
129	# define S_IFMT _S_IFMT
130	# define S_IFDIR _S_IFDIR
131	# define timezone _timezone
132	# if defined(_M_IX86)
133	# ifndef C_HACKED_APPLY
134	# define C_HACKED_APPLY
135	# endif
136	# endif
137	#else
138	# ifdef C_HACKED_APPLY
139	# if defined(__MACH__) \|\| defined(__MINGW32__) \|\| defined(__CYGWIN__)
140	extern void C_do_apply_hack(void proc, C_word args, int count) C_noret;
141	# else
142	extern void _C_do_apply_hack(void proc, C_word args, int count) C_noret;
143	# define C_do_apply_hack _C_do_apply_hack
144	# endif
145	# endif
146	#endif
147
148	#if defined(C_NO_HACKED_APPLY) && defined(C_HACKED_APPLY)
149	# undef C_HACKED_APPLY
150	#endif
151
152	#ifdef C_LOCK_TOSPACE
153	#include <sys/mman.h>
154	#endif
155
156	#define BITWISE_UINT_ONLY
157
158	/* Parameters: */
159
160	#define RELAX_MULTIVAL_CHECK
161
162	#define DEFAULT_STACK_SIZE 64000
163	#define DEFAULT_SYMBOL_TABLE_SIZE 2999
164	#define DEFAULT_HEAP_SIZE 500000
165	#define MINIMAL_HEAP_SIZE 500000
166	#define DEFAULT_MAXIMAL_HEAP_SIZE 0x7ffffff0
167	#define DEFAULT_HEAP_GROWTH 200
168	#define DEFAULT_HEAP_SHRINKAGE 50
169	#define DEFAULT_HEAP_SHRINKAGE_USED 25
170	#define DEFAULT_FORWARDING_TABLE_SIZE 32
171	#define DEFAULT_LOCATIVE_TABLE_SIZE 32
172	#define DEFAULT_COLLECTIBLES_SIZE 1024
173	#define DEFAULT_TRACE_BUFFER_SIZE 8
174
175	#define MAX_HASH_PREFIX 64
176
177	#define WEAK_TABLE_SIZE 997
178	#define WEAK_HASH_ITERATIONS 4
179	#define WEAK_HASH_DISPLACEMENT 7
180	#define WEAK_COUNTER_MASK 3
181	#define WEAK_COUNTER_MAX 2
182
183	#define TEMPORARY_STACK_SIZE 2048
184	#define STRING_BUFFER_SIZE 4096
185	#define DEFAULT_MUTATION_STACK_SIZE 1024
186	#define MUTATION_STACK_GROWTH 1024
187
188	#define FILE_INFO_SIZE 7
189
190	#ifdef C_DOUBLE_IS_32_BITS
191	# define FLONUM_PRINT_PRECISION 7
192	#else
193	# define FLONUM_PRINT_PRECISION 15
194	#endif
195
196	#define WORDS_PER_FLONUM C_SIZEOF_FLONUM
197
198	#define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 32
199
200	#define INITIAL_TIMER_INTERRUPT_PERIOD 10000
201
202
203	/* Constants: */
204
205	#ifdef C_SIXTY_FOUR
206	# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffffffffffeL)
207	# define FORWARDING_BIT_SHIFT 63
208	# define UWORD_FORMAT_STRING "0x%lx"
209	# define UWORD_COUNT_FORMAT_STRING "%ld"
210	#else
211	# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffe)
212	# define FORWARDING_BIT_SHIFT 31
213	# define UWORD_FORMAT_STRING "0x%x"
214	# define UWORD_COUNT_FORMAT_STRING "%d"
215	#endif
216
217	#define GC_MINOR 0
218	#define GC_MAJOR 1
219	#define GC_REALLOC 2
220
221
222	/* Macros: */
223
224	#ifdef PARANOIA
225	# define check_alignment(p) assert(((C_word)(p) & 3) == 0)
226	#else
227	# ifndef NDEBUG
228	# define NDEBUG
229	# endif
230	# define check_alignment(p)
231	#endif
232
233	#define aligned8(n) ((((C_word)(n)) & 7) == 0)
234	#define nmax(x, y) ((x) > (y) ? (x) : (y))
235	#define nmin(x, y) ((x) < (y) ? (x) : (y))
236	#define percentage(n, p) ((long)(((double)(n) * (double)p) / 100))
237
238	#define is_fptr(x) (((x) & C_GC_FORWARDING_BIT) != 0)
239	#define ptr_to_fptr(x) ((((x) >> FORWARDING_BIT_SHIFT) & 1) \| C_GC_FORWARDING_BIT \| ((x) & ~1))
240	#define fptr_to_ptr(x) (((x) << FORWARDING_BIT_SHIFT) \| ((x) & ~(C_GC_FORWARDING_BIT \| 1)))
241
242	#ifdef C_UNSAFE_RUNTIME
243	# define C_check_flonum(x, w)
244	# define C_check_real(x, w, v) if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
245	else v = C_flonum_magnitude(x);
246	# define resolve_procedure(x, w) (x)
247	#else
248	# define C_check_flonum(x, w) if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) \
249	barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, w, x);
250	# define C_check_real(x, w, v) if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
251	else if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) \
252	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
253	else v = C_flonum_magnitude(x);
254	#endif
255
256	#define C_isnan(f) (!((f) == (f)))
257	#define C_isinf(f) ((f) == (f) + (f) && (f) != 0.0)
258
259
260	/* these could be shorter in unsafe mode: */
261	#define C_check_int(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
262	else if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) \
263	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
264	else { double _m; \
265	f = C_flonum_magnitude(x); \
266	if(modf(f, &_m) != 0.0 \|\| f < C_WORD_MIN \|\| f > C_WORD_MAX) \
267	barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, w, x); \
268	else n = (C_word)f; \
269	}
270
271	#define C_check_uint(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
272	else if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) \
273	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
274	else { double _m; \
275	f = C_flonum_magnitude(x); \
276	if(modf(f, &_m) != 0.0 \|\| f < 0 \|\| f > C_UWORD_MAX) \
277	barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
278	else n = (C_uword)f; \
279	}
280
281	#define C_check_uintX(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
282	else if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) \
283	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
284	else { double _m; \
285	f = C_flonum_magnitude(x); \
286	if(modf(f, &_m) != 0.0 \|\| f > C_UWORD_MAX) \
287	barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
288	else n = (C_uword)f; \
289	}
290
291	#define C_check_uintX(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
292	else if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) \
293	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
294	else { double _m; \
295	f = C_flonum_magnitude(x); \
296	if(modf(f, &_m) != 0.0 \|\| f > C_UWORD_MAX) \
297	barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
298	else n = (C_uword)f; \
299	}
300
301	#ifdef C_SIXTY_FOUR
302	#define C_limit_fixnum(n) ((n) & C_MOST_POSITIVE_FIXNUM)
303	#else
304	#define C_limit_fixnum(n) (n)
305	#endif
306
307	#define C_pte(name) pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;
308
309
310	/* Type definitions: */
311
312	typedef void (*TOPLEVEL)(C_word c, C_word self, C_word k) C_noret;
313	typedef void (C_fcall TRAMPOLINE)(void proc) C_regparm C_noret;
314
315	typedef struct lf_list_struct
316	{
317	C_word *lf;
318	int count;
319	struct lf_list_struct next, prev;
320	C_PTABLE_ENTRY *ptable;
321	void *module_handle;
322	char *module_name;
323	} LF_LIST;
324
325	typedef struct weak_table_entry_struct
326	{
327	C_word item,
328	container;
329	} WEAK_TABLE_ENTRY;
330
331	typedef struct finalizer_node_struct
332	{
333	struct finalizer_node_struct
334	*next,
335	*previous;
336	C_word
337	item,
338	finalizer;
339	} FINALIZER_NODE;
340
341	typedef struct trace_info_struct
342	{
343	C_char *raw;
344	C_word cooked1, cooked2, thread;
345	} TRACE_INFO;
346
347
348	/* Variables: */
349
350	C_TLS C_word
351	*C_temporary_stack,
352	*C_temporary_stack_bottom,
353	*C_temporary_stack_limit,
354	*C_stack_limit;
355	C_TLS long
356	C_timer_interrupt_counter,
357	C_initial_timer_interrupt_period;
358	C_TLS C_byte
359	*C_fromspace_top,
360	*C_fromspace_limit;
361	C_TLS double C_temporary_flonum;
362	C_TLS jmp_buf C_restart;
363	C_TLS void *C_restart_address;
364	C_TLS int C_entry_point_status;
365	C_TLS int (C_gc_mutation_hook)(C_word slot, C_word val);
366	C_TLS void (C_gc_trace_hook)(C_word var, int mode);
367	C_TLS C_word(*C_get_unbound_variable_value_hook)(C_word sym);
368	C_TLS void (C_panic_hook)(C_char msg) = NULL;
369	C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
370	C_TLS void (*C_post_gc_hook)(int mode, long ms) = NULL;
371	C_TLS void (C_fcall C_restart_trampoline)(void proc) C_regparm C_noret;
372
373	C_TLS int
374	C_abort_on_thread_exceptions,
375	C_enable_repl,
376	C_interrupts_enabled,
377	C_disable_overflow_check,
378	#ifdef C_COLLECT_ALL_SYMBOLS
379	C_enable_gcweak = 1,
380	#else
381	C_enable_gcweak = 0,
382	#endif
383	C_heap_size_is_fixed,
384	C_trace_buffer_size = DEFAULT_TRACE_BUFFER_SIZE,
385	C_max_pending_finalizers = C_DEFAULT_MAX_PENDING_FINALIZERS,
386	C_main_argc;
387	C_TLS C_uword
388	C_heap_growth,
389	C_heap_shrinkage;
390	C_TLS C_uword C_maximal_heap_size;
391	C_TLS time_t C_startup_time_seconds;
392
393	C_TLS char
394	**C_main_argv,
395	*C_dlerror;
396
397	static C_TLS TRACE_INFO
398	*trace_buffer,
399	*trace_buffer_limit,
400	*trace_buffer_top;
401
402	static C_TLS C_byte
403	*heapspace1,
404	*heapspace2,
405	*fromspace_start,
406	*tospace_start,
407	*tospace_top,
408	*tospace_limit,
409	*new_tospace_start,
410	*new_tospace_top,
411	*new_tospace_limit,
412	*heap_scan_top,
413	*timer_start_fromspace_top;
414	static C_TLS size_t
415	heapspace1_size,
416	heapspace2_size;
417	static C_TLS C_char
418	buffer[ STRING_BUFFER_SIZE ],
419	*current_module_name,
420	*save_string;
421	static C_TLS C_SYMBOL_TABLE
422	*symbol_table,
423	*symbol_table_list;
424	static C_TLS C_word
425	**collectibles,
426	**collectibles_top,
427	**collectibles_limit,
428	*saved_stack_limit,
429	**mutation_stack_bottom,
430	**mutation_stack_limit,
431	**mutation_stack_top,
432	*stack_bottom,
433	*locative_table,
434	error_location,
435	interrupt_hook_symbol,
436	current_thread_symbol,
437	error_hook_symbol,
438	invalid_procedure_call_hook_symbol,
439	unbound_variable_value_hook_symbol,
440	last_invalid_procedure_symbol,
441	identity_unbound_value_symbol,
442	apply_hook_symbol,
443	last_applied_procedure_symbol,
444	pending_finalizers_symbol,
445	callback_continuation_stack_symbol,
446	*forwarding_table;
447	static C_TLS int
448	trace_buffer_full,
449	forwarding_table_size,
450	return_to_host,
451	page_size,
452	show_trace,
453	fake_tty_flag,
454	debug_mode,
455	gc_bell,
456	gc_report_flag,
457	gc_mode,
458	gc_count_1,
459	gc_count_2,
460	timer_start_gc_count_1,
461	timer_start_gc_count_2,
462	interrupt_reason,
463	stack_size_changed,
464	dlopen_flags,
465	heap_size_changed,
466	chicken_is_running,
467	chicken_ran_once,
468	callback_continuation_level;
469	static C_TLS unsigned int
470	mutation_count,
471	stack_size,
472	heap_size,
473	timer_start_mutation_count;
474	static C_TLS int chicken_is_initialized;
475	static C_TLS jmp_buf gc_restart;
476	static C_TLS long
477	timer_start_ms,
478	timer_start_gc_ms,
479	timer_accumulated_gc_ms,
480	interrupt_time,
481	last_interrupt_latency;
482	static C_TLS LF_LIST
483	*lf_list,
484	*reload_lf;
485	static C_TLS int signal_mapping_table[ NSIG ];
486	static C_TLS int
487	locative_table_size,
488	locative_table_count,
489	live_finalizer_count,
490	allocated_finalizer_count,
491	pending_finalizer_count,
492	callback_returned_flag;
493	static C_TLS WEAK_TABLE_ENTRY *weak_item_table;
494	static C_TLS C_GC_ROOT *gc_root_list = NULL;
495	static C_TLS FINALIZER_NODE
496	*finalizer_list,
497	*finalizer_free_list,
498	**pending_finalizer_indices;
499	static C_TLS void *current_module_handle;
500	static C_TLS int flonum_print_precision = FLONUM_PRINT_PRECISION;
501
502	/* Prototypes: */
503
504	static void parse_argv(C_char *cmds);
505	static void initialize_symbol_table(void);
506	static void global_signal_handler(int signum);
507	static C_word arg_val(C_char *arg);
508	static void barf(int code, char *loc, ...) C_noret;
509	static void panic(C_char *msg) C_noret;
510	static void usual_panic(C_char *msg) C_noret;
511	static void horror(C_char *msg) C_noret;
512	static void C_fcall initial_trampoline(void *proc) C_regparm C_noret;
513	static C_ccall void termination_continuation(C_word c, C_word self, C_word result) C_noret;
514	static void C_fcall mark_system_globals(void) C_regparm;
515	static void C_fcall mark(C_word *x) C_regparm;
516	static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) C_regparm;
517	static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
518	static C_word add_symbol(C_word *ptr, C_word key, C_word string, C_SYMBOL_TABLE stable);
519	static int C_fcall hash_string(int len, C_char *str, unsigned int m) C_regparm;
520	static C_word C_fcall lookup(C_word key, int len, C_char str, C_SYMBOL_TABLE stable) C_regparm;
521	static double compute_symbol_table_load(double avg_bucket_len, int total);
522	static C_word C_fcall convert_string_to_number(C_char str, int radix, C_word fix, double *flo) C_regparm;
523	static long C_fcall milliseconds(void);
524	static long C_fcall cpu_milliseconds(void);
525	static void C_fcall remark_system_globals(void) C_regparm;
526	static void C_fcall remark(C_word *x) C_regparm;
527	static C_word C_fcall intern0(C_char *name) C_regparm;
528	static void C_fcall update_locative_table(int mode) C_regparm;
529	static C_word get_unbound_variable_value(C_word sym);
530	static LF_LIST find_module_handle(C_char name);
531	static void lock_tospace(int lock);
532
533	static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
534	static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
535	static void cons_flonum_trampoline(void *dummy) C_noret;
536	static void gc_2(void *dummy) C_noret;
537	static void allocate_vector_2(void *dummy) C_noret;
538	static void cons_string_trampoline(void *dummy) C_noret;
539	static void get_argv_2(void *dummy) C_noret;
540	static void make_structure_2(void *dummy) C_noret;
541	static void generic_trampoline(void *dummy) C_noret;
542	static void file_info_2(void *dummy) C_noret;
543	static void get_environment_variable_2(void *dummy) C_noret;
544	static void handle_interrupt(void trampoline, void proc) C_noret;
545	static void callback_trampoline(void *dummy) C_noret;
546	static C_ccall void callback_return_continuation(C_word c, C_word self, C_word r) C_noret;
547	static void become_2(void *dummy) C_noret;
548	static void copy_closure_2(void *dummy) C_noret;
549
550	static C_PTABLE_ENTRY *create_initial_ptable();
551
552	#if !defined(NO_DLOAD2) &&(defined(HAVE_DLFCN_H) \|\| defined(HAVE_DL_H) \|\| (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
553	static void dload_2(void *dummy) C_noret;
554	#endif
555
556
557	/* Startup code: */
558
559	int CHICKEN_main(int argc, char argv[], void toplevel)
560	{
561	C_word h, s, n;
562
563	#if defined(__MWERKS__) && !defined(__INTEL__) && !defined(MACINTOSH_GUI)
564	argc = ccommand(&argv);
565	SIOUXSettings.asktosaveonclose = 0;
566	SIOUXSettings.autocloseonquit = 1;
567	#elif defined(C_WINDOWS_GUI)
568	parse_argv(GetCommandLine());
569	argc = C_main_argc;
570	argv = C_main_argv;
571	#endif
572
573	CHICKEN_parse_command_line(argc, argv, &h, &s, &n);
574
575	if(!CHICKEN_initialize(h, s, n, toplevel))
576	panic(C_text("can not initialize - out of memory"));
577
578	CHICKEN_run(NULL);
579	return 0;
580	}
581
582
583	/* Custom argv parser for Windoze: */
584
585	#ifdef C_WINDOWS_GUI
586	void parse_argv(C_char *cmds)
587	{
588	C_char *ptr = cmds,
589	bptr0, bptr, *aptr;
590	int n = 0;
591
592	C_main_argv = (C_char *)malloc(MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS sizeof(C_char *));
593
594	if(C_main_argv == NULL)
595	panic(C_text("can not allocate argument-list buffer"));
596
597	C_main_argc = 0;
598
599	for(;;) {
600	while(isspace(*ptr)) ++ptr;
601
602	if(*ptr == '\0') break;
603
604	for(bptr0 = bptr = buffer; !isspace(ptr) && ptr != '\0'; (bptr++) = (ptr++))
605	++n;
606
607	*bptr = '\0';
608	aptr = (C_char )malloc(sizeof(C_char) (n + 1));
609
610	if(aptr == NULL)
611	panic(C_text("can not allocate argument buffer"));
612
613	C_strcpy(aptr, bptr0);
614	C_main_argv[ C_main_argc++ ] = aptr;
615	}
616	}
617	#endif
618
619
620	#if defined(__MWERKS__) && !defined(__INTEL__)
621	int strncasecmp(const C_char one, const C_char two, size_t n)
622	{
623	int c;
624
625	while(n--) {
626	if((c = C_tolower((one++)) - C_tolower((two++))) < 0) return -1;
627	else if(c > 0) return 1;
628	}
629
630	return 0;
631	}
632	#endif
633
634
635	/* Initialize runtime system: */
636
637	int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
638	{
639	int i;
640
641	#ifndef C_NONUNIX
642	struct timeval tv;
643	C_gettimeofday(&tv, NULL);
644	C_startup_time_seconds = tv.tv_sec;
645	#else
646	C_startup_time_seconds = (time_t)0;
647	#endif
648
649	if(chicken_is_initialized) return 1;
650	else chicken_is_initialized = 1;
651
652	if(debug_mode) C_printf(C_text("[debug] application startup...\n"));
653
654	C_panic_hook = usual_panic;
655	symbol_table_list = NULL;
656
657	if((symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE)) == NULL)
658	return 0;
659
660	#ifdef C_LOCK_TOSPACE
661	page_size = sysconf(_SC_PAGESIZE);
662	assert(page_size > -1);
663	#else
664	page_size = 0;
665	#endif
666	stack_size = stack ? stack : DEFAULT_STACK_SIZE;
667	C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);
668
669	/* Allocate temporary stack: */
670	if((C_temporary_stack_limit = (C_word )C_malloc(TEMPORARY_STACK_SIZE sizeof(C_word))) == NULL)
671	return 0;
672
673	C_temporary_stack_bottom = C_temporary_stack_limit + TEMPORARY_STACK_SIZE;
674	C_temporary_stack = C_temporary_stack_bottom;
675
676	/* Allocate mutation stack: */
677	mutation_stack_bottom = (C_word *)C_malloc(DEFAULT_MUTATION_STACK_SIZE sizeof(C_word *));
678
679	if(mutation_stack_bottom == NULL) return 0;
680
681	mutation_stack_top = mutation_stack_bottom;
682	mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;
683	C_gc_mutation_hook = NULL;
684	C_gc_trace_hook = NULL;
685	C_get_unbound_variable_value_hook = get_unbound_variable_value;
686
687	/* Allocate weak item table: */
688	if(C_enable_gcweak) {
689	if((weak_item_table = (WEAK_TABLE_ENTRY *)C_calloc(WEAK_TABLE_SIZE, sizeof(WEAK_TABLE_ENTRY))) == NULL)
690	return 0;
691	}
692
693	/* Initialize finalizer lists: */
694	finalizer_list = NULL;
695	finalizer_free_list = NULL;
696	pending_finalizer_indices = (FINALIZER_NODE *)C_malloc(C_max_pending_finalizers sizeof(FINALIZER_NODE *));
697
698	if(pending_finalizer_indices == NULL) return 0;
699
700	/* Initialize forwarding table: */
701	forwarding_table = (C_word )C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) 2 * sizeof(C_word));
702
703	if(forwarding_table == NULL) return 0;
704
705	*forwarding_table = 0;
706	forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;
707
708	/* Initialize locative table: */
709	locative_table = (C_word )C_malloc(DEFAULT_LOCATIVE_TABLE_SIZE sizeof(C_word));
710
711	if(locative_table == NULL) return 0;
712
713	locative_table_size = DEFAULT_LOCATIVE_TABLE_SIZE;
714	locative_table_count = 0;
715
716	/* Setup collectibles: */
717	collectibles = (C_word *)C_malloc(sizeof(C_word ) * DEFAULT_COLLECTIBLES_SIZE);
718
719	if(collectibles == NULL) return 0;
720
721	collectibles_top = collectibles;
722	collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;
723	gc_root_list = NULL;
724
725	/* Initialize global variables: */
726	if(C_heap_growth == 0) C_heap_growth = DEFAULT_HEAP_GROWTH;
727
728	if(C_heap_shrinkage == 0) C_heap_shrinkage = DEFAULT_HEAP_SHRINKAGE;
729
730	if(C_maximal_heap_size == 0) C_maximal_heap_size = DEFAULT_MAXIMAL_HEAP_SIZE;
731
732	#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
733	dlopen_flags = RTLD_LAZY \| RTLD_GLOBAL;
734	#else
735	dlopen_flags = 0;
736	#endif
737
738	gc_report_flag = 0;
739	mutation_count = gc_count_1 = gc_count_2 = 0;
740	lf_list = NULL;
741	C_register_lf2(NULL, 0, create_initial_ptable());
742	C_restart_address = toplevel;
743	C_restart_trampoline = initial_trampoline;
744	trace_buffer = NULL;
745	C_clear_trace_buffer();
746	chicken_is_running = chicken_ran_once = 0;
747	interrupt_reason = 0;
748	last_interrupt_latency = 0;
749	C_interrupts_enabled = 1;
750	C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;
751	C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;
752	memset(signal_mapping_table, 0, sizeof(int) * NSIG);
753	initialize_symbol_table();
754	C_dlerror = "can not load compiled code dynamically - this is a statically linked executable";
755	error_location = C_SCHEME_FALSE;
756	C_pre_gc_hook = NULL;
757	C_post_gc_hook = NULL;
758	live_finalizer_count = 0;
759	allocated_finalizer_count = 0;
760	current_module_name = NULL;
761	current_module_handle = NULL;
762	reload_lf = NULL;
763	callback_continuation_level = 0;
764	timer_start_gc_ms = 0;
765	C_randomize(time(NULL));
766	return 1;
767	}
768
769
770	static C_PTABLE_ENTRY *create_initial_ptable()
771	{
772	C_PTABLE_ENTRY pt = (C_PTABLE_ENTRY )C_malloc(sizeof(C_PTABLE_ENTRY) * 66);
773	int i = 0;
774
775	if(pt == NULL)
776	panic(C_text("out of memory - can not create initial ptable"));
777
778	C_pte(termination_continuation);
779	C_pte(callback_return_continuation);
780	C_pte(values_continuation);
781	C_pte(call_cc_values_wrapper);
782	C_pte(call_cc_wrapper);
783	C_pte(C_gc);
784	C_pte(C_allocate_vector);
785	C_pte(C_get_argv);
786	C_pte(C_make_structure);
787	C_pte(C_ensure_heap_reserve);
788	C_pte(C_return_to_host);
789	C_pte(C_file_info);
790	C_pte(C_get_symbol_table_info);
791	C_pte(C_get_memory_info);
792	C_pte(C_cpu_time);
793	C_pte(C_decode_seconds);
794	C_pte(C_get_environment_variable);
795	C_pte(C_stop_timer);
796	C_pte(C_dload);
797	C_pte(C_set_dlopen_flags);
798	C_pte(C_become);
799	C_pte(C_apply_values);
800	C_pte(C_times);
801	C_pte(C_minus);
802	C_pte(C_plus);
803	C_pte(C_divide);
804	C_pte(C_nequalp);
805	C_pte(C_greaterp);
806	C_pte(C_lessp);
807	C_pte(C_greater_or_equal_p);
808	C_pte(C_less_or_equal_p);
809	C_pte(C_flonum_floor);
810	C_pte(C_flonum_ceiling);
811	C_pte(C_flonum_truncate);
812	C_pte(C_flonum_round);
813	C_pte(C_quotient);
814	C_pte(C_cons_flonum);
815	C_pte(C_flonum_fraction);
816	C_pte(C_expt);
817	C_pte(C_exact_to_inexact);
818	C_pte(C_string_to_number);
819	C_pte(C_number_to_string);
820	C_pte(C_make_symbol);
821	C_pte(C_string_to_symbol);
822	C_pte(C_apply);
823	C_pte(C_call_cc);
824	C_pte(C_values);
825	C_pte(C_call_with_values);
826	C_pte(C_continuation_graft);
827	C_pte(C_open_file_port);
828	C_pte(C_software_type);
829	C_pte(C_machine_type);
830	C_pte(C_machine_byte_order);
831	C_pte(C_software_version);
832	C_pte(C_build_platform);
833	C_pte(C_c_runtime);
834	C_pte(C_make_pointer);
835	C_pte(C_make_tagged_pointer);
836	C_pte(C_peek_signed_integer);
837	C_pte(C_peek_unsigned_integer);
838	C_pte(C_context_switch);
839	C_pte(C_register_finalizer);
840	C_pte(C_locative_ref);
841	C_pte(C_call_with_cthulhu);
842	C_pte(C_dunload);
843	pt[ i ].id = NULL;
844	return pt;
845	}
846
847
848	void *CHICKEN_new_gc_root()
849	{
850	C_GC_ROOT r = (C_GC_ROOT )C_malloc(sizeof(C_GC_ROOT));
851
852	if(r == NULL)
853	panic(C_text("out of memory - can not allocate GC root"));
854
855	r->value = C_SCHEME_UNDEFINED;
856	r->next = gc_root_list;
857	r->prev = NULL;
858
859	if(gc_root_list != NULL) gc_root_list->prev = r;
860
861	gc_root_list = r;
862	return (void *)r;
863	}
864
865
866	void CHICKEN_delete_gc_root(void *root)
867	{
868	C_GC_ROOT r = (C_GC_ROOT )root;
869
870	if(r->prev == NULL) gc_root_list = r->next;
871	else r->prev->next = r->next;
872
873	if(r->next != NULL) r->next->prev = r->prev;
874
875	C_free(root);
876	}
877
878
879	void CHICKEN_global_lookup(char name)
880	{
881	int
882	len = C_strlen(name),
883	key = hash_string(len, name, symbol_table->size);
884	C_word s;
885	void *root = CHICKEN_new_gc_root();
886
887	if(C_truep(s = lookup(key, len, name, symbol_table))) {
888	if(C_u_i_car(s) != C_SCHEME_UNBOUND) {
889	CHICKEN_gc_root_set(root, s);
890	return root;
891	}
892	}
893
894	return NULL;
895	}
896
897
898	int CHICKEN_is_running()
899	{
900	return chicken_is_running;
901	}
902
903
904	void CHICKEN_interrupt()
905	{
906	C_timer_interrupt_counter = 0;
907	}
908
909
910	C_regparm C_SYMBOL_TABLE C_new_symbol_table(char name, unsigned int size)
911	{
912	C_SYMBOL_TABLE *stp;
913	int i;
914
915	if((stp = C_find_symbol_table(name)) != NULL) return stp;
916
917	if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)
918	return NULL;
919
920	stp->name = name;
921	stp->size = size;
922	stp->next = symbol_table_list;
923
924	if((stp->table = (C_word )C_malloc(size sizeof(C_word))) == NULL)
925	return NULL;
926
927	for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);
928
929	symbol_table_list = stp;
930	return stp;
931	}
932
933
934	C_regparm void C_delete_symbol_table(C_SYMBOL_TABLE *st)
935	{
936	C_SYMBOL_TABLE stp, prev = NULL;
937
938	for(stp = symbol_table_list; stp != NULL; stp = stp->next)
939	if(stp == st) {
940	if(prev != NULL) prev->next = stp->next;
941	else symbol_table_list = stp->next;
942
943	return;
944	}
945	}
946
947
948	C_regparm void C_set_symbol_table(C_SYMBOL_TABLE *st)
949	{
950	symbol_table = st;
951	}
952
953
954	C_regparm C_SYMBOL_TABLE C_find_symbol_table(char name)
955	{
956	C_SYMBOL_TABLE *stp;
957
958	for(stp = symbol_table_list; stp != NULL; stp = stp->next)
959	if(!C_strcmp(name, stp->name)) return stp;
960
961	return NULL;
962	}
963
964
965	C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)
966	{
967	char *sptr = C_c_string(str);
968	int
969	len = C_header_size(str),
970	key = hash_string(len, sptr, stable->size);
971	C_word s;
972
973	if(C_truep(s = lookup(key, len, sptr, stable))) return s;
974	else return C_SCHEME_FALSE;
975	}
976
977
978	C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos)
979	{
980	int i;
981	C_word
982	sym,
983	bucket = C_u_i_car(pos);
984
985	if(!C_truep(bucket)) return C_SCHEME_FALSE; /* end already reached */
986	else i = C_unfix(bucket);
987
988	bucket = C_u_i_cdr(pos);
989
990	while(bucket == C_SCHEME_END_OF_LIST) {
991	if(++i >= stable->size) {
992	C_set_block_item(pos, 0, C_SCHEME_FALSE); /* no more buckets */
993	return C_SCHEME_FALSE;
994	}
995	else bucket = stable->table[ i ];
996	}
997
998	sym = C_u_i_car(bucket);
999	C_set_block_item(pos, 0, C_fix(i));
1000	C_mutate(&C_u_i_cdr(pos), C_u_i_cdr(bucket));
1001	return sym;
1002	}
1003
1004
1005	/* Setup symbol-table with internally used symbols; */
1006
1007	void initialize_symbol_table(void)
1008	{
1009	int i;
1010
1011	for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);
1012
1013	/* Obtain reference to hooks for later: */
1014	interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
1015	error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
1016	callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
1017	pending_finalizers_symbol = C_intern2(C_heaptop, C_text("\003syspending-finalizers"));
1018	invalid_procedure_call_hook_symbol = C_intern3(C_heaptop, C_text("\003sysinvalid-procedure-call-hook"), C_SCHEME_FALSE);
1019	unbound_variable_value_hook_symbol = C_intern3(C_heaptop, C_text("\003sysunbound-variable-value-hook"), C_SCHEME_FALSE);
1020	last_invalid_procedure_symbol = C_intern3(C_heaptop, C_text("\003syslast-invalid-procedure"), C_SCHEME_FALSE);
1021	identity_unbound_value_symbol = C_intern3(C_heaptop, C_text("\003sysidentity-unbound-value"), C_SCHEME_FALSE);
1022	current_thread_symbol = C_intern3(C_heaptop, C_text("\003syscurrent-thread"), C_SCHEME_FALSE);
1023	apply_hook_symbol = C_intern3(C_heaptop, C_text("\003sysapply-hook"), C_SCHEME_FALSE);
1024	last_applied_procedure_symbol = C_intern2(C_heaptop, C_text("\003syslast-applied-procedure"));
1025	}
1026
1027
1028	/* This is called from POSIX signals: */
1029
1030	void global_signal_handler(int signum)
1031	{
1032	C_raise_interrupt(signal_mapping_table[ signum ]);
1033	signal(signum, global_signal_handler);
1034	}
1035
1036
1037	/* Align memory to page boundary */
1038
1039	#ifndef C_LOCK_TOSPACE
1040	static void align_to_page(void mem)
1041	{
1042	return (void *)C_align((C_uword)mem);
1043	}
1044	#endif
1045
1046	static C_byte *
1047	heap_alloc (size_t size, C_byte **page_aligned)
1048	{
1049	C_byte *p;
1050	#ifdef C_LOCK_TOSPACE
1051	p = (C_byte *)mmap (NULL, size, (PROT_READ \| PROT_WRITE),
1052	(MAP_PRIVATE \| MAP_ANON), -1, 0);
1053	if (p != NULL && page_aligned) *page_aligned = p;
1054	#else
1055	p = (C_byte *)C_malloc (size + page_size);
1056	if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
1057	#endif
1058
1059	/* . */
1060	return p;
1061	}
1062
1063	static void
1064	heap_free (C_byte *ptr, size_t size)
1065	{
1066	#ifdef C_LOCK_TOSPACE
1067	int r = munmap (ptr, size);
1068	assert (r == 0);
1069	#else
1070	C_free (ptr);
1071	#endif
1072	/* . */
1073	}
1074
1075	static C_byte *
1076	heap_realloc (C_byte *ptr, size_t old_size,
1077	size_t new_size, C_byte **page_aligned)
1078	{
1079	C_byte *p;
1080	#ifdef C_LOCK_TOSPACE
1081	p = (C_byte *)mmap (NULL, new_size, (PROT_READ \| PROT_WRITE),
1082	(MAP_PRIVATE \| MAP_ANON), -1, 0);
1083	if (ptr != NULL) {
1084	memcpy (p, ptr, old_size);
1085	heap_free (ptr, old_size);
1086	}
1087	if (p != NULL && page_aligned) *page_aligned = p;
1088	#else
1089	p = (C_byte *)C_realloc (ptr, new_size + page_size);
1090	if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
1091	#endif
1092
1093	/* . */
1094	return p;
1095	}
1096
1097	/* Modify heap size at runtime: */
1098
1099	void C_set_or_change_heap_size(C_word heap, int reintern)
1100	{
1101	C_byte ptr1, ptr2, ptr1a, ptr2a;
1102	C_word size = heap / 2;
1103
1104	if(heap_size_changed && fromspace_start) return;
1105
1106	if(fromspace_start && heap_size >= heap) return;
1107
1108	if(debug_mode) C_printf(C_text("[debug] heap resized to %d bytes\n"), (int)heap);
1109
1110	heap_size = heap;
1111
1112	if((ptr1 = heap_realloc (fromspace_start,
1113	C_fromspace_limit - fromspace_start,
1114	size, &ptr1a)) == NULL \|\|
1115	(ptr2 = heap_realloc (tospace_start,
1116	tospace_limit - tospace_start,
1117	size, &ptr2a)) == NULL)
1118	panic(C_text("out of memory - can not allocate heap"));
1119
1120	heapspace1 = ptr1, heapspace1_size = size;
1121	heapspace2 = ptr2, heapspace2_size = size;
1122	fromspace_start = ptr1a;
1123	C_fromspace_top = fromspace_start;
1124	C_fromspace_limit = fromspace_start + size;
1125	tospace_start = ptr2a;
1126	tospace_top = tospace_start;
1127	tospace_limit = tospace_start + size;
1128	mutation_stack_top = mutation_stack_bottom;
1129	lock_tospace(1);
1130
1131	if(reintern) initialize_symbol_table();
1132	}
1133
1134
1135	/* Modify stack-size at runtime: */
1136
1137	void C_do_resize_stack(C_word stack)
1138	{
1139	C_uword old = stack_size,
1140	diff = stack - old;
1141
1142	if(diff != 0 && !stack_size_changed) {
1143	if(debug_mode) C_printf(C_text("[debug] stack resized to %d bytes\n"), (int)stack);
1144
1145	stack_size = stack;
1146
1147	#if C_STACK_GROWS_DOWNWARD
1148	C_stack_limit = (C_word )((C_byte )C_stack_limit - diff);
1149	#else
1150	C_stack_limit = (C_word )((C_byte )C_stack_limit + diff);
1151	#endif
1152	}
1153	}
1154
1155
1156	/* Check whether nursery is sufficiently big: */
1157
1158	void C_check_nursery_minimum(C_word words)
1159	{
1160	if(words >= C_bytestowords(stack_size))
1161	panic(C_text("nursery is too small - try higher setting using the `-:s' option"));
1162	}
1163
1164	C_word C_resize_pending_finalizers(C_word size) {
1165	int sz = C_num_to_int(size);
1166
1167	FINALIZER_NODE **newmem =
1168	(FINALIZER_NODE *)C_realloc(pending_finalizer_indices, sz sizeof(FINALIZER_NODE *));
1169
1170	if (newmem == NULL)
1171	return C_SCHEME_FALSE;
1172
1173	pending_finalizer_indices = newmem;
1174	C_max_pending_finalizers = sz;
1175	return C_SCHEME_TRUE;
1176	}
1177
1178
1179	/* Parse runtime options from command-line: */
1180
1181	void CHICKEN_parse_command_line(int argc, char argv[], C_word heap, C_word stack, C_word symbols)
1182	{
1183	int i;
1184	char *ptr;
1185	C_word x;
1186
1187	C_main_argc = argc;
1188	C_main_argv = argv;
1189	*heap = DEFAULT_HEAP_SIZE;
1190	*stack = DEFAULT_STACK_SIZE;
1191	*symbols = DEFAULT_SYMBOL_TABLE_SIZE;
1192
1193	for(i = 1; i < C_main_argc; ++i)
1194	if(!strncmp(C_main_argv[ i ], C_text("-:"), 2)) {
1195	for(ptr = &C_main_argv[ i ][ 2 ]; *ptr != '\0';) {
1196	switch(*(ptr++)) {
1197	case '?':
1198	C_printf("\nRuntime options:\n\n"
1199	" -:? display this text\n"
1200	" -:c always treat stdin as console\n"
1201	" -:d enable debug output\n"
1202	" -:D enable more debug output\n"
1203	" -:o disable stack overflow checks\n"
1204	" -:hiSIZE set initial heap size\n"
1205	" -:hmSIZE set maximal heap size\n"
1206	" -:hgPERCENTAGE set heap growth percentage\n"
1207	" -:hsPERCENTAGE set heap shrink percentage\n"
1208	" -:hSIZE set fixed heap size\n"
1209	" -:r write trace output to stderr\n"
1210	" -:sSIZE set nursery (stack) size\n"
1211	" -:tSIZE set symbol-table size\n"
1212	" -:fSIZE set maximal number of pending finalizers\n"
1213	" -:w enable garbage collection of unused symbols\n"
1214	" -:x deliver uncaught exceptions of other threads to primordial one\n"
1215	" -:b enter REPL on error\n"
1216	" -:B sound bell on major GC\n"
1217	" -:aSIZE set trace-buffer/call-chain size\n"
1218	"\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"
1219	" times 1024, 1048576, and 1073741824, respectively.\n\n");
1220	exit(0);
1221
1222	case 'h':
1223	switch(*ptr) {
1224	case 'i':
1225	*heap = arg_val(ptr + 1);
1226	heap_size_changed = 1;
1227	goto next;
1228	case 'g':
1229	C_heap_growth = arg_val(ptr + 1);
1230	goto next;
1231	case 'm':
1232	C_maximal_heap_size = arg_val(ptr + 1);
1233	goto next;
1234	case 's':
1235	C_heap_shrinkage = arg_val(ptr + 1);
1236	goto next;
1237	default:
1238	*heap = arg_val(ptr);
1239	heap_size_changed = 1;
1240	C_heap_size_is_fixed = 1;
1241	goto next;
1242	}
1243
1244	case 'o':
1245	C_disable_overflow_check = 1;
1246	break;
1247
1248	case 'B':
1249	gc_bell = 1;
1250	break;
1251
1252	case 's':
1253	*stack = arg_val(ptr);
1254	stack_size_changed = 1;
1255	goto next;
1256
1257	case 'f':
1258	C_max_pending_finalizers = arg_val(ptr);
1259	goto next;
1260
1261	case 'a':
1262	C_trace_buffer_size = arg_val(ptr);
1263	goto next;
1264
1265	case 't':
1266	*symbols = arg_val(ptr);
1267	goto next;
1268
1269	case 'c':
1270	fake_tty_flag = 1;
1271	break;
1272
1273	case 'd':
1274	debug_mode = 1;
1275	break;
1276
1277	case 'D':
1278	debug_mode = 2;
1279	break;
1280
1281	case 'w':
1282	C_enable_gcweak = 1;
1283	break;
1284
1285	case 'r':
1286	show_trace = 1;
1287	break;
1288
1289	case 'x':
1290	C_abort_on_thread_exceptions = 1;
1291	break;
1292
1293	case 'b':
1294	C_enable_repl = 1;
1295	break;
1296
1297	default: panic(C_text("illegal runtime option"));
1298	}
1299	}
1300
1301	next:;
1302	}
1303	}
1304
1305
1306	C_word arg_val(C_char *arg)
1307	{
1308	int len;
1309
1310	if (arg == NULL) panic(C_text("illegal runtime-option argument"));
1311
1312	len = C_strlen(arg);
1313
1314	if(len < 1) panic(C_text("illegal runtime-option argument"));
1315
1316	switch(arg[ len - 1 ]) {
1317	case 'k':
1318	case 'K':
1319	return atol(arg) * 1024;
1320
1321	case 'm':
1322	case 'M':
1323	return atol(arg) * 1024 * 1024;
1324
1325	case 'g':
1326	case 'G':
1327	return atol(arg) * 1024 * 1024 * 1024;
1328
1329	default:
1330	return atol(arg);
1331	}
1332	}
1333
1334
1335	/* Run embedded code with arguments: */
1336
1337	C_word CHICKEN_run(void *toplevel)
1338	{
1339	if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))
1340	panic(C_text("could not initialize"));
1341
1342	if(chicken_is_running)
1343	panic(C_text("re-invocation of Scheme world while process is already running"));
1344
1345	chicken_is_running = chicken_ran_once = 1;
1346	return_to_host = 0;
1347
1348	#if C_STACK_GROWS_DOWNWARD
1349	C_stack_limit = (C_word )((C_byte )C_stack_pointer - stack_size);
1350	#else
1351	C_stack_limit = (C_word )((C_byte )C_stack_pointer + stack_size);
1352	#endif
1353
1354	stack_bottom = C_stack_pointer;
1355
1356	if(debug_mode)
1357	C_printf(C_text("[debug] stack bottom is 0x%lx.\n"), (long)stack_bottom);
1358
1359	/* The point of (usually) no return... */
1360	C_setjmp(C_restart);
1361
1362	if(!return_to_host)
1363	(C_restart_trampoline)(C_restart_address);
1364
1365	chicken_is_running = 0;
1366	return C_restore;
1367	}
1368
1369
1370	C_word CHICKEN_continue(C_word k)
1371	{
1372	if(C_temporary_stack_bottom != C_temporary_stack)
1373	panic(C_text("invalid temporary stack level"));
1374
1375	if(!chicken_is_initialized)
1376	panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));
1377
1378	C_save(k);
1379	return CHICKEN_run(NULL);
1380	}
1381
1382
1383	/* Trampoline called at system startup: */
1384
1385	C_regparm void C_fcall initial_trampoline(void *proc)
1386	{
1387	TOPLEVEL top = (TOPLEVEL)proc;
1388	C_word closure = (C_word)C_alloc(2);
1389
1390	((C_SCHEME_BLOCK *)closure)->header = C_CLOSURE_TYPE \| 1;
1391	C_set_block_item(closure, 0, (C_word)termination_continuation);
1392	(top)(2, C_SCHEME_UNDEFINED, closure);
1393	}
1394
1395
1396	/* The final continuation: */
1397
1398	void C_ccall termination_continuation(C_word c, C_word self, C_word result)
1399	{
1400	if(debug_mode) C_printf(C_text("[debug] application terminated normally.\n"));
1401
1402	exit(0);
1403	}
1404
1405
1406	/* Signal unrecoverable runtime error: */
1407
1408	void panic(C_char *msg)
1409	{
1410	if (C_panic_hook != NULL) C_panic_hook(msg);
1411	usual_panic(msg);
1412	}
1413
1414
1415	void usual_panic(C_char *msg)
1416	{
1417	C_char *dmp = C_dump_trace(0);
1418
1419	C_dbg_hook(C_SCHEME_UNDEFINED);
1420
1421	#ifdef C_MICROSOFT_WINDOWS
1422	C_sprintf(buffer, C_text("%s\n\n%s"), msg, dmp);
1423
1424	MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
1425	ExitProcess(1);
1426	#else
1427	C_fprintf(C_stderr, C_text("\n%s - execution terminated\n\n%s"), msg, dmp);
1428
1429	# if defined(__MWERKS__) && !defined(__INTEL__) && !defined(MACINTOSH_GUI)
1430	C_printf("\n[press RETURN to exit...]");
1431	C_fflush(C_stdout);
1432	C_getchar();
1433	# endif
1434
1435	C_exit(1);
1436	#endif
1437	}
1438
1439
1440	void horror(C_char *msg)
1441	{
1442	C_dbg_hook(C_SCHEME_UNDEFINED);
1443
1444	#ifdef C_MICROSOFT_WINDOWS
1445	C_sprintf(buffer, C_text("%s"), msg);
1446
1447	MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
1448	ExitProcess(1);
1449	#else
1450	C_fprintf(C_stderr, C_text("\n%s - execution terminated"), msg);
1451
1452	# if defined(__MWERKS__) && !defined(__INTEL__) && !defined(MACINTOSH_GUI)
1453	C_printf("\n[press RETURN to exit...]");
1454	C_fflush(C_stdout);
1455	C_getchar();
1456	# endif
1457
1458	C_exit(1);
1459	#endif
1460	}
1461
1462
1463	/* Error-hook, called from C-level runtime routines: */
1464
1465	void barf(int code, char *loc, ...)
1466	{
1467	C_char *msg;
1468	C_word err = error_hook_symbol;
1469	int c, i;
1470	va_list v;
1471
1472	C_dbg_hook(C_SCHEME_UNDEFINED);
1473
1474	C_temporary_stack = C_temporary_stack_bottom;
1475	err = C_u_i_car(err);
1476
1477	if(C_immediatep(err))
1478	panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));
1479
1480	switch(code) {
1481	case C_BAD_ARGUMENT_COUNT_ERROR:
1482	msg = C_text("wrong number of arguments in function call");
1483	c = 3;
1484	break;
1485
1486	case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
1487	msg = C_text("too few arguments in function call");
1488	c = 3;
1489	break;
1490
1491	case C_BAD_ARGUMENT_TYPE_ERROR:
1492	msg = C_text("bad argument type");
1493	c = 1;
1494	break;
1495
1496	case C_UNBOUND_VARIABLE_ERROR:
1497	msg = C_text("unbound variable");
1498	c = 1;
1499	break;
1500
1501	case C_TOO_MANY_PARAMETERS_ERROR:
1502	msg = C_text("parameter limit exceeded");
1503	c = 0;
1504	break;
1505
1506	case C_OUT_OF_MEMORY_ERROR:
1507	msg = C_text("not enough memory");
1508	c = 0;
1509	break;
1510
1511	case C_DIVISION_BY_ZERO_ERROR:
1512	msg = C_text("division by zero");
1513	c = 0;
1514	break;
1515
1516	case C_OUT_OF_RANGE_ERROR:
1517	msg = C_text("out of range");
1518	c = 2;
1519	break;
1520
1521	case C_NOT_A_CLOSURE_ERROR:
1522	msg = C_text("call of non-procedure");
1523	c = 1;
1524	break;
1525
1526	case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:
1527	msg = C_text("continuation can not receive multiple values");
1528	c = 1;
1529	break;
1530
1531	case C_TOO_DEEP_RECURSION_ERROR:
1532	msg = C_text("recursion too deep");
1533	c = 0;
1534	break;
1535
1536	case C_CANT_REPRESENT_INEXACT_ERROR:
1537	msg = C_text("inexact number can not be represented as an exact number");
1538	c = 1;
1539	break;
1540
1541	case C_NOT_A_PROPER_LIST_ERROR:
1542	msg = C_text("argument is not a proper list");
1543	c = 1;
1544	break;
1545
1546	case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:
1547	msg = C_text("bad argument type - not a fixnum");
1548	c = 1;
1549	break;
1550
1551	case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:
1552	msg = C_text("bad argument type - not a string");
1553	c = 1;
1554	break;
1555
1556	case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:
1557	msg = C_text("bad argument type - not a pair");
1558	c = 1;
1559	break;
1560
1561	case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:
1562	msg = C_text("bad argument type - not a list");
1563	c = 1;
1564	break;
1565
1566	case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:
1567	msg = C_text("bad argument type - not a number");
1568	c = 1;
1569	break;
1570
1571	case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:
1572	msg = C_text("bad argument type - not a symbol");
1573	c = 1;
1574	break;
1575
1576	case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:
1577	msg = C_text("bad argument type - not a vector");
1578	c = 1;
1579	break;
1580
1581	case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:
1582	msg = C_text("bad argument type - not a character");
1583	c = 1;
1584	break;
1585
1586	case C_STACK_OVERFLOW_ERROR:
1587	msg = C_text("stack overflow");
1588	c = 0;
1589	break;
1590
1591	case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:
1592	msg = C_text("bad argument type - not a structure of the required type");
1593	c = 2;
1594	break;
1595
1596	case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:
1597	msg = C_text("bad argument type - not a blob");
1598	c = 1;
1599	break;
1600
1601	case C_LOST_LOCATIVE_ERROR:
1602	msg = C_text("locative refers to reclaimed object");
1603	c = 1;
1604	break;
1605
1606	case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:
1607	msg = C_text("bad argument type - immediate value expected");
1608	c = 1;
1609	break;
1610
1611	case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:
1612	msg = C_text("bad argument type - number vector expected");
1613	c = 2;
1614	break;
1615
1616	case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
1617	msg = C_text("bad argument type - integer expected");
1618	c = 1;
1619	break;
1620
1621	case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
1622	msg = C_text("bad argument type - unsigned integer expected");
1623	c = 1;
1624	break;
1625
1626	case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:
1627	msg = C_text("bad argument type - pointer expected");
1628	c = 1;
1629	break;
1630
1631	case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:
1632	msg = C_text("bad argument type - tagged pointer expected");
1633	c = 2;
1634	break;
1635
1636	case C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR:
1637	msg = C_text("code to load dynamically was linked with safe runtime libraries, but executing runtime was not");
1638	c = 0;
1639	break;
1640
1641	case C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR:
1642	msg = C_text("code to load dynamically was linked with unsafe runtime libraries, but executing runtime was not");
1643	c = 0;
1644	break;
1645
1646	case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
1647	msg = C_text("bad argument type - floating-point number expected");
1648	c = 1;
1649	break;
1650
1651	case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:
1652	msg = C_text("bad argument type - procedure expected");
1653	c = 1;
1654	break;
1655
1656	default: panic(C_text("illegal internal error code"));
1657	}
1658
1659	if(!C_immediatep(err)) {
1660	C_save(C_fix(code));
1661
1662	if(loc != NULL)
1663	C_save(intern0(loc));
1664	else {
1665	C_save(error_location);
1666	error_location = C_SCHEME_FALSE;
1667	}
1668
1669	va_start(v, loc);
1670	i = c;
1671
1672	while(i--)
1673	C_save(va_arg(v, C_word));
1674
1675	va_end(v);
1676	/* No continuation is passed: '##sys#error-hook' may not return: */
1677	C_do_apply(c + 2, err, C_SCHEME_UNDEFINED);
1678	}
1679	else panic(msg);
1680	}
1681
1682
1683	/* Hook for setting breakpoints */
1684
1685	C_word C_dbg_hook(C_word dummy)
1686	{
1687	return dummy;
1688	}
1689
1690
1691	/* Timing routines: */
1692
1693	long C_fcall milliseconds(void)
1694	{
1695	#ifdef C_NONUNIX
1696	if(CLOCKS_PER_SEC == 1000) return clock();
1697	else return ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
1698	#else
1699	struct timeval tv;
1700
1701	if(C_gettimeofday(&tv, NULL) == -1) return 0;
1702	else return (tv.tv_sec - C_startup_time_seconds) * 1000 + tv.tv_usec / 1000;
1703	#endif
1704	}
1705
1706
1707	C_regparm time_t C_fcall C_seconds(long *ms)
1708	{
1709	#ifdef C_NONUNIX
1710	if(ms != NULL) *ms = 0;
1711
1712	return (time_t)(clock() / CLOCKS_PER_SEC);
1713	#else
1714	struct timeval tv;
1715
1716	if(C_gettimeofday(&tv, NULL) == -1) {
1717	if(ms != NULL) *ms = 0;
1718
1719	return (time_t)0;
1720	}
1721	else {
1722	if(ms != NULL) *ms = tv.tv_usec / 1000;
1723
1724	return tv.tv_sec;
1725	}
1726	#endif
1727	}
1728
1729
1730	long C_fcall cpu_milliseconds(void)
1731	{
1732	#if defined(C_NONUNIX) \|\| defined(__CYGWIN__)
1733	if(CLOCKS_PER_SEC == 1000) return clock();
1734	else return ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
1735	#else
1736	struct rusage ru;
1737
1738	if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;
1739	else return (ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 1000 + (ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000;
1740	#endif
1741	}
1742
1743
1744	/* Support code for callbacks: */
1745
1746	int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)
1747	{
1748	C_word p = C_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
1749
1750	C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), p);
1751	return ++callback_continuation_level;
1752	}
1753
1754
1755	C_word C_fcall C_restore_callback_continuation(void)
1756	{
1757	/* obsolete, but retained for keeping old code working */
1758	C_word p = C_block_item(callback_continuation_stack_symbol, 0),
1759	k;
1760
1761	assert(!C_immediatep(p) && C_block_header(p) == C_PAIR_TAG);
1762	k = C_u_i_car(p);
1763
1764	C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
1765	--callback_continuation_level;
1766	return k;
1767	}
1768
1769
1770	C_word C_fcall C_restore_callback_continuation2(int level)
1771	{
1772	C_word p = C_block_item(callback_continuation_stack_symbol, 0),
1773	k;
1774
1775	#ifndef C_UNSAFE_RUNTIME
1776	if(level != callback_continuation_level \|\| C_immediatep(p) \|\| C_block_header(p) != C_PAIR_TAG)
1777	panic(C_text("unbalanced callback continuation stack"));
1778	#endif
1779
1780	k = C_u_i_car(p);
1781
1782	C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
1783	--callback_continuation_level;
1784	return k;
1785	}
1786
1787
1788	C_word C_fcall C_callback(C_word closure, int argc)
1789	{
1790	jmp_buf prev;
1791	C_word
1792	*a = C_alloc(2),
1793	k = C_closure(&a, 1, (C_word)callback_return_continuation);
1794	int old = chicken_is_running;
1795
1796	#ifndef C_UNSAFE_RUNTIME
1797	if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)
1798	panic(C_text("callback invoked in non-safe context"));
1799	#endif
1800
1801	C_memcpy(&prev, &C_restart, sizeof(jmp_buf));
1802	callback_returned_flag = 0;
1803	chicken_is_running = 1;
1804
1805	if(!C_setjmp(C_restart)) C_do_apply(argc, closure, k);
1806
1807	if(!callback_returned_flag) (C_restart_trampoline)(C_restart_address);
1808	else {
1809	C_memcpy(&C_restart, &prev, sizeof(jmp_buf));
1810	callback_returned_flag = 0;
1811	}
1812
1813	chicken_is_running = old;
1814	return C_restore;
1815	}
1816
1817
1818	void C_fcall C_callback_adjust_stack(C_word *a, int size)
1819	{
1820	if(!chicken_is_running && !C_in_stackp((C_word)a)) {
1821	if(debug_mode)
1822	C_printf(C_text("[debug] callback invoked in lower stack region - adjusting limits:\n"
1823	"[debug] current: \t%p\n"
1824	"[debug] previous: \t%p (bottom) - %p (limit)\n"),
1825	a, stack_bottom, C_stack_limit);
1826
1827	#if C_STACK_GROWS_DOWNWARD
1828	C_stack_limit = (C_word )((C_byte )a - stack_size);
1829	stack_bottom = a + size;
1830	#else
1831	C_stack_limit = (C_word )((C_byte )a + stack_size);
1832	stack_bottom = a;
1833	#endif
1834
1835	if(debug_mode)
1836	C_printf(C_text("[debug] new: \t%p (bottom) - %p (limit)\n"),
1837	stack_bottom, C_stack_limit);
1838	}
1839	}
1840
1841
1842	void C_fcall C_callback_adjust_stack_limits(C_word a) / DEPRECATED */
1843	{
1844	if(!chicken_is_running && !C_in_stackp((C_word)a)) {
1845	if(debug_mode)
1846	C_printf(C_text("[debug] callback invoked in lower stack region - adjusting limits:\n"
1847	"[debug] current: \t%p\n"
1848	"[debug] previous: \t%p (bottom) - %p (limit)\n"),
1849	a, stack_bottom, C_stack_limit);
1850
1851	#if C_STACK_GROWS_DOWNWARD
1852	C_stack_limit = (C_word )((C_byte )a - stack_size);
1853	#else
1854	C_stack_limit = (C_word )((C_byte )a + stack_size);
1855	#endif
1856	stack_bottom = a;
1857
1858	if(debug_mode)
1859	C_printf(C_text("[debug] new: \t%p (bottom) - %p (limit)\n"),
1860	stack_bottom, C_stack_limit);
1861	}
1862	}
1863
1864
1865	C_word C_fcall C_callback_wrapper(void *proc, int argc)
1866	{
1867	C_word
1868	*a = C_alloc(2),
1869	closure = C_closure(&a, 1, (C_word)proc),
1870	result;
1871
1872	result = C_callback(closure, argc);
1873	assert(C_temporary_stack == C_temporary_stack_bottom);
1874	return result;
1875	}
1876
1877
1878	void C_ccall callback_return_continuation(C_word c, C_word self, C_word r)
1879	{
1880	assert(callback_returned_flag == 0);
1881	callback_returned_flag = 1;
1882	C_save(r);
1883	C_reclaim(NULL, NULL);
1884	}
1885
1886
1887	/* Zap symbol names: */
1888
1889	void C_zap_strings(C_word str)
1890	{
1891	C_word bucket, sym;
1892	int i;
1893
1894	for(i = 0; i < symbol_table->size; ++i)
1895	for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
1896	sym = C_u_i_car(bucket);
1897	C_set_block_item(sym, 1, str);
1898	}
1899	}
1900
1901
1902	/* Register/unregister literal frame: */
1903
1904	void C_initialize_lf(C_word *lf, int count)
1905	{
1906	while(count-- > 0)
1907	*(lf++) = C_SCHEME_UNBOUND;
1908	}
1909
1910
1911	void C_register_lf(C_word lf, int count)
1912	{
1913	return C_register_lf2(lf, count, NULL);
1914	}
1915
1916
1917	void C_register_lf2(C_word lf, int count, C_PTABLE_ENTRY *ptable)
1918	{
1919	LF_LIST node = (LF_LIST )C_malloc(sizeof(LF_LIST));
1920	LF_LIST *np;
1921	int status = 0;
1922
1923	node->lf = lf;
1924	node->count = count;
1925	node->ptable = ptable;
1926	node->module_name = NULL;
1927	node->module_handle = NULL;
1928
1929	if(reload_lf != NULL) {
1930	if(debug_mode)
1931	C_printf(C_text("[debug] replacing previous LF-entry for `%s'\n"), current_module_name);
1932
1933	C_free(reload_lf->module_name);
1934	reload_lf->lf = lf;
1935	reload_lf->count = count;
1936	reload_lf->ptable = ptable;
1937	C_free(node);
1938	node = reload_lf;
1939	}
1940
1941	node->module_name = current_module_name;
1942	node->module_handle = current_module_handle;
1943	current_module_handle = NULL;
1944
1945	if(reload_lf != node) {
1946	if(lf_list) lf_list->prev = node;
1947
1948	node->next = lf_list;
1949	node->prev = NULL;
1950	lf_list = node;
1951	}
1952	else reload_lf = NULL;
1953
1954	return (void *)node;
1955	}
1956
1957
1958	LF_LIST find_module_handle(char name)
1959	{
1960	LF_LIST *np;
1961
1962	for(np = lf_list; np != NULL; np = np->next) {
1963	if(np->module_name != NULL && !C_strcmp(np->module_name, name))
1964	return np;
1965	}
1966
1967	return NULL;
1968	}
1969
1970
1971	void C_unregister_lf(void *handle)
1972	{
1973	LF_LIST node = (LF_LIST ) handle;
1974
1975	if (node->next) node->next->prev = node->prev;
1976
1977	if (node->prev) node->prev->next = node->next;
1978
1979	if (lf_list == node) lf_list = node->next;
1980
1981	C_free(node->module_name);
1982	C_free(node);
1983	}
1984
1985
1986	/* Intern symbol into symbol-table: */
1987
1988	C_regparm C_word C_fcall C_intern(C_word *ptr, int len, C_char str)
1989	{
1990	return C_intern_in(ptr, len, str, symbol_table);
1991	}
1992
1993
1994	C_regparm C_word C_fcall C_h_intern(C_word slot, int len, C_char str)
1995	{
1996	return C_h_intern_in(slot, len, str, symbol_table);
1997	}
1998
1999
2000	C_regparm C_word C_fcall C_intern_in(C_word *ptr, int len, C_char str, C_SYMBOL_TABLE *stable)
2001	{
2002	int key;
2003	C_word s;
2004
2005	if(stable == NULL) stable = symbol_table;
2006
2007	key = hash_string(len, str, stable->size);
2008
2009	if(C_truep(s = lookup(key, len, str, stable))) return s;
2010
2011	s = C_string(ptr, len, str);
2012	return add_symbol(ptr, key, s, stable);
2013	}
2014
2015
2016	C_regparm C_word C_fcall C_h_intern_in(C_word slot, int len, C_char str, C_SYMBOL_TABLE *stable)
2017	{
2018	/* Intern as usual, but remember slot, if looked up symbol is in nursery.
2019	also: allocate in static memory. */
2020	int key;
2021	C_word s;
2022
2023	if(stable == NULL) stable = symbol_table;
2024
2025	key = hash_string(len, str, stable->size);
2026
2027	if(C_truep(s = lookup(key, len, str, stable))) {
2028	if(C_in_stackp(s)) C_mutate(slot, s);
2029
2030	return s;
2031	}
2032
2033	s = C_static_string(C_heaptop, len, str);
2034	return add_symbol(C_heaptop, key, s, stable);
2035	}
2036
2037
2038	C_regparm C_word C_fcall intern0(C_char *str)
2039	{
2040	int len = C_strlen(str);
2041	int key = hash_string(len, str, symbol_table->size);
2042	C_word s;
2043
2044	if(C_truep(s = lookup(key, len, str, symbol_table))) return s;
2045	else return C_SCHEME_FALSE;
2046	}
2047
2048
2049	C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
2050	{
2051	int key;
2052	C_word str = C_block_item(sym, 1);
2053	int len = C_header_size(str);
2054
2055	key = hash_string(len, C_c_string(str), symbol_table->size);
2056
2057	return lookup(key, len, C_c_string(str), symbol_table);
2058	}
2059
2060
2061	C_regparm C_word C_fcall C_intern2(C_word *ptr, C_char str)
2062	{
2063	return C_intern_in(ptr, C_strlen(str), str, symbol_table);
2064	}
2065
2066
2067	C_regparm C_word C_fcall C_intern3(C_word *ptr, C_char str, C_word value)
2068	{
2069	C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);
2070
2071	C_mutate(&C_u_i_car(s), value);
2072	return s;
2073	}
2074
2075
2076	C_regparm int C_fcall hash_string(int len, C_char *str, unsigned int m)
2077	{
2078	unsigned int key = 2166136261U;
2079
2080	while(len--) key = ((key * 16777619U) + (*str++));
2081
2082	return (int)(key % m);
2083	}
2084
2085
2086	C_regparm C_word C_fcall lookup(C_word key, int len, C_char str, C_SYMBOL_TABLE stable)
2087	{
2088	C_word bucket, sym, s;
2089
2090	for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
2091	sym = C_u_i_car(bucket);
2092	s = C_u_i_cdr(sym);
2093
2094	if(C_header_size(s) == (C_word)len && !C_memcmp(str, (C_char )((C_SCHEME_BLOCK )s)->data, len))
2095	return sym;
2096	}
2097
2098	return C_SCHEME_FALSE;
2099	}
2100
2101
2102	double compute_symbol_table_load(double avg_bucket_len, int total_n)
2103	{
2104	C_word bucket;
2105	int i, j, alen = 0, bcount = 0, total = 0;
2106
2107	for(i = 0; i < symbol_table->size; ++i) {
2108	bucket = symbol_table->table[ i ];
2109
2110	for(j = 0; bucket != C_SCHEME_END_OF_LIST; ++j)
2111	bucket = C_u_i_cdr(bucket);
2112
2113	if(j > 0) {
2114	alen += j;
2115	++bcount;
2116	}
2117
2118	total += j;
2119	}
2120
2121	if(avg_bucket_len != NULL)
2122	*avg_bucket_len = (double)alen / (double)bcount;
2123
2124	*total_n = total;
2125
2126	/* return load: */
2127	return (double)total / (double)symbol_table->size;
2128	}
2129
2130
2131	C_word add_symbol(C_word *ptr, C_word key, C_word string, C_SYMBOL_TABLE stable)
2132	{
2133	C_word bucket, sym, b2, *p;
2134	int keyw = C_header_size(string) > 0 && ((char )C_data_pointer(string)) == 0;
2135
2136	p = *ptr;
2137	sym = (C_word)p;
2138	p += C_SIZEOF_SYMBOL;
2139	((C_SCHEME_BLOCK *)sym)->header = C_SYMBOL_TYPE \| (C_SIZEOF_SYMBOL - 1);
2140	C_set_block_item(sym, 0, keyw ? sym : C_SCHEME_UNBOUND); /* keyword? */
2141	C_set_block_item(sym, 1, string);
2142	C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
2143	*ptr = p;
2144	b2 = stable->table[ key ]; /* previous bucket */
2145	bucket = C_pair(ptr, sym, b2); /* create new bucket */
2146	((C_SCHEME_BLOCK *)bucket)->header =
2147	(((C_SCHEME_BLOCK *)bucket)->header & ~C_HEADER_TYPE_BITS) \| C_BUCKET_TYPE;
2148
2149	if(ptr != C_heaptop) C_mutate(&stable->table[ key ], bucket);
2150	else {
2151	/* If a stack-allocated bucket was here, and we allocate from
2152	heap-top (say, in a toplevel literal frame allocation) then we have
2153	to inform the memory manager that a 2nd gen. block points to a
2154	1st gen. block, hence the mutation: */
2155	C_mutate(&C_u_i_cdr(bucket), b2);
2156	stable->table[ key ] = bucket;
2157	}
2158
2159	return sym;
2160	}
2161
2162
2163	/* Check block allocation: */
2164
2165	C_regparm C_word C_fcall C_permanentp(C_word x)
2166	{
2167	return C_mk_bool(!C_immediatep(x) && !C_in_stackp(x) && !C_in_heapp(x));
2168	}
2169
2170
2171	C_regparm int C_in_stackp(C_word x)
2172	{
2173	C_word ptr = (C_word )(C_uword)x;
2174
2175	#if C_STACK_GROWS_DOWNWARD
2176	return ptr >= C_stack_pointer_test && ptr <= stack_bottom;
2177	#else
2178	return ptr < C_stack_pointer_test && ptr >= stack_bottom;
2179	#endif
2180	}
2181
2182
2183	C_regparm int C_fcall C_in_heapp(C_word x)
2184	{
2185	C_byte ptr = (C_byte )(C_uword)x;
2186	return (ptr >= fromspace_start && ptr < C_fromspace_limit) \|\|
2187	(ptr >= tospace_start && ptr < tospace_limit);
2188	}
2189
2190
2191	C_regparm int C_fcall C_in_fromspacep(C_word x)
2192	{
2193	C_byte ptr = (C_byte )(C_uword)x;
2194	return (ptr >= fromspace_start && ptr < C_fromspace_limit);
2195	}
2196
2197
2198	/* Cons the rest-aguments together: */
2199
2200	C_regparm C_word C_fcall C_restore_rest(C_word *ptr, int num)
2201	{
2202	C_word x = C_SCHEME_END_OF_LIST;
2203	C_SCHEME_BLOCK *node;
2204
2205	while(num--) {
2206	node = (C_SCHEME_BLOCK *)ptr;
2207	ptr += 3;
2208	node->header = C_PAIR_TYPE \| (C_SIZEOF_PAIR - 1);
2209	node->data[ 0 ] = C_restore;
2210	node->data[ 1 ] = x;
2211	x = (C_word)node;
2212	}
2213
2214	return x;
2215	}
2216
2217
2218	C_regparm C_word C_fcall C_restore_rest_vector(C_word *ptr, int num)
2219	{
2220	C_word *p0 = ptr;
2221
2222	*(ptr++) = C_VECTOR_TYPE \| num;
2223	ptr += num;
2224
2225	while(num--) *(--ptr) = C_restore;
2226
2227	return (C_word)p0;
2228	}
2229
2230
2231	/* Print error messages and exit: */
2232
2233	void C_bad_memory(void)
2234	{
2235	panic(C_text("there is not enough stack-space to run this executable"));
2236	}
2237
2238
2239	void C_bad_memory_2(void)
2240	{
2241	panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));
2242	}
2243
2244
2245	/* The following two can be thrown out in the next release... */
2246
2247	void C_bad_argc(int c, int n)
2248	{
2249	C_bad_argc_2(c, n, C_SCHEME_FALSE);
2250	}
2251
2252
2253	void C_bad_min_argc(int c, int n)
2254	{
2255	C_bad_min_argc_2(c, n, C_SCHEME_FALSE);
2256	}
2257
2258
2259	void C_bad_argc_2(int c, int n, C_word closure)
2260	{
2261	barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);
2262	}
2263
2264
2265	void C_bad_min_argc_2(int c, int n, C_word closure)
2266	{
2267	barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);
2268	}
2269
2270
2271	void C_stack_overflow(void)
2272	{
2273	barf(C_STACK_OVERFLOW_ERROR, NULL);
2274	}
2275
2276
2277	void C_unbound_error(C_word sym)
2278	{
2279	barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
2280	}
2281
2282
2283	void C_no_closure_error(C_word x)
2284	{
2285	barf(C_NOT_A_CLOSURE_ERROR, NULL, x);
2286	}
2287
2288
2289	/* Allocate and initialize record: */
2290
2291	C_regparm C_word C_fcall C_string(C_word *ptr, int len, C_char str)
2292	{
2293	C_word strblock = (C_word)(*ptr);
2294
2295	ptr = (C_word )((C_word)(*ptr) + sizeof(C_header) + C_align(len));
2296	((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE \| len;
2297	C_memcpy(C_data_pointer(strblock), str, len);
2298	return strblock;
2299	}
2300
2301
2302	C_regparm C_word C_fcall C_static_string(C_word *ptr, int len, C_char str)
2303	{
2304	C_word dptr = (C_word )C_malloc(sizeof(C_header) + C_align(len));
2305	C_word strblock;
2306
2307	if(dptr == NULL)
2308	panic(C_text("out of memory - can not allocate static string"));
2309
2310	strblock = (C_word)dptr;
2311	((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE \| len;
2312	C_memcpy(C_data_pointer(strblock), str, len);
2313	return strblock;
2314	}
2315
2316
2317	C_regparm C_word C_fcall C_static_lambda_info(C_word *ptr, int len, C_char str)
2318	{
2319	int dlen = sizeof(C_header) + C_align(len);
2320	void *dptr = C_malloc(dlen);
2321	C_word strblock;
2322
2323	if(dptr == NULL)
2324	panic(C_text("out of memory - can not allocate static lambda info"));
2325
2326	strblock = (C_word)dptr;
2327	((C_SCHEME_BLOCK *)strblock)->header = C_LAMBDA_INFO_TYPE \| len;
2328	C_memcpy(C_data_pointer(strblock), str, len);
2329	return strblock;
2330	}
2331
2332
2333	C_regparm C_word C_fcall C_bytevector(C_word *ptr, int len, C_char str)
2334	{
2335	C_word strblock = C_string(ptr, len, str);
2336
2337	C_string_to_bytevector(strblock);
2338	return strblock;
2339	}
2340
2341
2342	C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)
2343	{
2344	C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));
2345
2346	if(pbv == NULL) panic(C_text("out of memory - can not allocate permanent blob"));
2347
2348	pbv->header = C_BYTEVECTOR_TYPE \| len;
2349	C_memcpy(pbv->data, str, len);
2350	return (C_word)pbv;
2351	}
2352
2353
2354	C_regparm C_word C_fcall C_string_aligned8(C_word *ptr, int len, C_char str)
2355	{
2356	C_word p = ptr,
2357	*p0;
2358
2359	#ifndef C_SIXTY_FOUR
2360	/* Align on 8-byte boundary: */
2361	if(aligned8(p)) ++p;
2362	#endif
2363
2364	p0 = p;
2365	*ptr = p + 1 + C_bytestowords(len);
2366	*(p++) = C_STRING_TYPE \| C_8ALIGN_BIT \| len;
2367	C_memcpy(p, str, len);
2368	return (C_word)p0;
2369	}
2370
2371
2372	C_regparm C_word C_fcall C_string2(C_word *ptr, C_char str)
2373	{
2374	C_word strblock = (C_word)(*ptr);
2375	int len;
2376
2377	if(str == NULL) return C_SCHEME_FALSE;
2378
2379	len = C_strlen(str);
2380	ptr = (C_word )((C_word)(*ptr) + sizeof(C_header) + C_align(len));
2381	((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE \| len;
2382	C_memcpy(((C_SCHEME_BLOCK *)strblock)->data, str, len);
2383	return strblock;
2384	}
2385
2386
2387	C_regparm C_word C_fcall C_string2_safe(C_word *ptr, int max, C_char str)
2388	{
2389	C_word strblock = (C_word)(*ptr);
2390	int len;
2391
2392	if(str == NULL) return C_SCHEME_FALSE;
2393
2394	len = C_strlen(str);
2395
2396	if(len >= max) {
2397	C_sprintf(buffer, C_text("foreign string result exceeded maximum of %d bytes"), max);
2398	panic(buffer);
2399	}
2400
2401	ptr = (C_word )((C_word)(*ptr) + sizeof(C_header) + C_align(len));
2402	((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE \| len;
2403	C_memcpy(((C_SCHEME_BLOCK *)strblock)->data, str, len);
2404	return strblock;
2405	}
2406
2407
2408	C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)
2409	{
2410	va_list va;
2411	C_word p = ptr,
2412	*p0 = p;
2413
2414	*p = C_CLOSURE_TYPE \| cells;
2415	*(++p) = proc;
2416
2417	for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));
2418
2419	va_end(va);
2420	*ptr = p + 1;
2421	return (C_word)p0;
2422	}
2423
2424
2425	C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)
2426	{
2427	C_word p = ptr,
2428	*p0 = p;
2429
2430	*(p++) = C_PAIR_TYPE \| (C_SIZEOF_PAIR - 1);
2431	*(p++) = car;
2432	*(p++) = cdr;
2433	*ptr = p;
2434	return (C_word)p0;
2435	}
2436
2437
2438	C_regparm C_word C_fcall C_h_pair(C_word car, C_word cdr)
2439	{
2440	/* Allocate on heap and check for non-heap slots: */
2441	C_word p = (C_word )C_fromspace_top,
2442	*p0 = p;
2443
2444	*(p++) = C_PAIR_TYPE \| (C_SIZEOF_PAIR - 1);
2445
2446	if(C_in_stackp(car)) C_mutate(p++, car);
2447	else *(p++) = car;
2448
2449	if(C_in_stackp(cdr)) C_mutate(p++, cdr);
2450	else *(p++) = cdr;
2451
2452	C_fromspace_top = (C_byte *)p;
2453	return (C_word)p0;
2454	}
2455
2456
2457	C_regparm C_word C_fcall C_flonum(C_word **ptr, double n)
2458	{
2459	C_word
2460	p = ptr,
2461	*p0;
2462
2463	#ifndef C_SIXTY_FOUR
2464	#ifndef C_DOUBLE_IS_32_BITS
2465	/* Align double on 8-byte boundary: */
2466	if(aligned8(p)) ++p;
2467	#endif
2468	#endif
2469
2470	p0 = p;
2471	*(p++) = C_FLONUM_TAG;
2472	((double )p) = n;
2473	*ptr = p + sizeof(double) / sizeof(C_word);
2474	return (C_word)p0;
2475	}
2476
2477
2478	C_regparm C_word C_fcall C_number(C_word **ptr, double n)
2479	{
2480	C_word
2481	p = ptr,
2482	*p0;
2483	double m;
2484
2485	if(n <= (double)C_MOST_POSITIVE_FIXNUM && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0)
2486	return C_fix(n);
2487
2488	#ifndef C_SIXTY_FOUR
2489	#ifndef C_DOUBLE_IS_32_BITS
2490	/* Align double on 8-byte boundary: */
2491	if(aligned8(p)) ++p;
2492	#endif
2493	#endif
2494
2495	p0 = p;
2496	*(p++) = C_FLONUM_TAG;
2497	((double )p) = n;
2498	*ptr = p + sizeof(double) / sizeof(C_word);
2499	return (C_word)p0;
2500	}
2501
2502
2503	C_regparm C_word C_fcall C_mpointer(C_word *ptr, void mp)
2504	{
2505	C_word
2506	p = ptr,
2507	*p0 = p;
2508
2509	*(p++) = C_POINTER_TYPE \| 1;
2510	((void *)p) = mp;
2511	*ptr = p + 1;
2512	return (C_word)p0;
2513	}
2514
2515
2516	C_regparm C_word C_fcall C_mpointer_or_false(C_word *ptr, void mp)
2517	{
2518	C_word
2519	p = ptr,
2520	*p0 = p;
2521
2522	if(mp == NULL) return C_SCHEME_FALSE;
2523
2524	*(p++) = C_POINTER_TYPE \| 1;
2525	((void *)p) = mp;
2526	*ptr = p + 1;
2527	return (C_word)p0;
2528	}
2529
2530
2531	C_regparm C_word C_fcall C_taggedmpointer(C_word *ptr, C_word tag, void mp)
2532	{
2533	C_word
2534	p = ptr,
2535	*p0 = p;
2536
2537	*(p++) = C_TAGGED_POINTER_TAG;
2538	((void *)p) = mp;
2539	*(++p) = tag;
2540	*ptr = p + 1;
2541	return (C_word)p0;
2542	}
2543
2544
2545	C_regparm C_word C_fcall C_taggedmpointer_or_false(C_word *ptr, C_word tag, void mp)
2546	{
2547	C_word
2548	p = ptr,
2549	*p0 = p;
2550
2551	if(mp == NULL) return C_SCHEME_FALSE;
2552
2553	*(p++) = C_TAGGED_POINTER_TAG;
2554	((void *)p) = mp;
2555	*(++p) = tag;
2556	*ptr = p + 1;
2557	return (C_word)p0;
2558	}
2559
2560
2561	C_regparm C_word C_fcall C_swigmpointer(C_word *ptr, void mp, void *sdata)
2562	{
2563	C_word
2564	p = ptr,
2565	*p0 = p;
2566
2567	*(p++) = C_SWIG_POINTER_TAG;
2568	((void *)p) = mp;
2569	((void *)p + 1) = sdata;
2570	*ptr = p + 2;
2571	return (C_word)p0;
2572	}
2573
2574
2575	C_word C_vector(C_word **ptr, int n, ...)
2576	{
2577	va_list v;
2578	C_word
2579	p = ptr,
2580	*p0 = p;
2581
2582	*(p++) = C_VECTOR_TYPE \| n;
2583	va_start(v, n);
2584
2585	while(n--)
2586	*(p++) = va_arg(v, C_word);
2587
2588	*ptr = p;
2589	va_end(v);
2590	return (C_word)p0;
2591	}
2592
2593
2594	C_word C_structure(C_word **ptr, int n, ...)
2595	{
2596	va_list v;
2597	C_word p = ptr,
2598	*p0 = p;
2599
2600	*(p++) = C_STRUCTURE_TYPE \| n;
2601	va_start(v, n);
2602
2603	while(n--)
2604	*(p++) = va_arg(v, C_word);
2605
2606	*ptr = p;
2607	va_end(v);
2608	return (C_word)p0;
2609	}
2610
2611
2612	C_word C_h_vector(int n, ...)
2613	{
2614	/* As C_vector(), but remember slots containing nursery pointers: */
2615	va_list v;
2616	C_word p = (C_word )C_fromspace_top,
2617	*p0 = p,
2618	x;
2619
2620	*(p++) = C_VECTOR_TYPE \| n;
2621	va_start(v, n);
2622
2623	while(n--) {
2624	x = va_arg(v, C_word);
2625
2626	if(C_in_stackp(x)) C_mutate(p++, x);
2627	else *(p++) = x;
2628	}
2629
2630	C_fromspace_top = (C_byte *)p;
2631	va_end(v);
2632	return (C_word)p0;
2633	}
2634
2635
2636	C_word C_h_structure(int n, ...)
2637	{
2638	/* As C_structure(), but remember slots containing nursery pointers: */
2639	va_list v;
2640	C_word p = (C_word )C_fromspace_top,
2641	*p0 = p,
2642	x;
2643
2644	*(p++) = C_STRUCTURE_TYPE \| n;
2645	va_start(v, n);
2646
2647	while(n--) {
2648	x = va_arg(v, C_word);
2649
2650	if(C_in_stackp(x)) C_mutate(p++, x);
2651	else *(p++) = x;
2652	}
2653
2654	C_fromspace_top = (C_byte *)p;
2655	va_end(v);
2656	return (C_word)p0;
2657	}
2658
2659
2660	C_regparm C_word C_fcall C_mutate(C_word *slot, C_word val)
2661	{
2662	int mssize;
2663
2664	if(!C_immediatep(val)) {
2665	#ifdef C_GC_HOOKS
2666	if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;
2667	#endif
2668
2669	if(mutation_stack_top >= mutation_stack_limit) {
2670	assert(mutation_stack_top == mutation_stack_limit);
2671	mssize = mutation_stack_top - mutation_stack_bottom;
2672	mutation_stack_bottom = (C_word *)realloc(mutation_stack_bottom, (mssize + MUTATION_STACK_GROWTH) sizeof(C_word *));
2673
2674	if(mutation_stack_bottom == NULL)
2675	panic(C_text("out of memory - can not re-allocate mutation stack"));
2676
2677	mutation_stack_limit = mutation_stack_bottom + mssize + MUTATION_STACK_GROWTH;
2678	mutation_stack_top = mutation_stack_bottom + mssize;
2679	}
2680
2681	*(mutation_stack_top++) = slot;
2682	++mutation_count;
2683	}
2684
2685	return *slot = val;
2686	}
2687
2688
2689	/* Initiate garbage collection: */
2690
2691
2692	void C_save_and_reclaim(void trampoline, void proc, int n, ...)
2693	{
2694	va_list v;
2695
2696	va_start(v, n);
2697
2698	while(n--) C_save(va_arg(v, C_word));
2699
2700	va_end(v);
2701	C_reclaim(trampoline, proc);
2702	}
2703
2704
2705	static void lock_tospace(int lock)
2706	{
2707	#ifdef C_LOCK_TOSPACE
2708	int r;
2709
2710	r = mprotect(tospace_start, (heap_size / 2),
2711	lock ? PROT_NONE : (PROT_READ \| PROT_WRITE));
2712
2713	if(r == -1) panic(strerror(errno));
2714	#endif
2715	}
2716
2717
2718	C_regparm void C_fcall C_reclaim(void trampoline, void proc)
2719	{
2720	int i, j, n, fcount, weakn;
2721	C_uword count, bytes;
2722	C_word p, *msp, bucket, last, item, container;
2723	C_header h;
2724	C_byte tmp, start;
2725	LF_LIST *lfn;
2726	C_SCHEME_BLOCK *bp;
2727	C_GC_ROOT *gcrp;
2728	WEAK_TABLE_ENTRY *wep;
2729	long tgc;
2730	C_SYMBOL_TABLE *stp;
2731	volatile int finalizers_checked;
2732	FINALIZER_NODE *flist;
2733	TRACE_INFO *tinfo;
2734
2735	/* assert(C_timer_interrupt_counter >= 0); */
2736
2737	if(interrupt_reason && C_interrupts_enabled)
2738	handle_interrupt(trampoline, proc);
2739
2740	/* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */
2741	if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);
2742
2743	lock_tospace(0);
2744	finalizers_checked = 0;
2745	C_restart_trampoline = (TRAMPOLINE)trampoline;
2746	C_restart_address = proc;
2747	heap_scan_top = (C_byte *)C_align((C_uword)C_fromspace_top);
2748	gc_mode = GC_MINOR;
2749
2750	/* Entry point for second-level GC (on explicit request or because of full fromspace): */
2751	if(C_setjmp(gc_restart) \|\| (start = C_fromspace_top) >= C_fromspace_limit) {
2752	if(gc_bell) C_putchar(7);
2753
2754	tgc = cpu_milliseconds();
2755
2756	if(gc_mode == GC_REALLOC) {
2757	C_rereclaim2(percentage(heap_size, C_heap_growth), 0);
2758	gc_mode = GC_MAJOR;
2759	goto never_mind_edsgar;
2760	}
2761
2762	heap_scan_top = (C_byte *)C_align((C_uword)tospace_top);
2763	gc_mode = GC_MAJOR;
2764
2765	/* Mark items in forwarding table: */
2766	for(p = forwarding_table; *p != 0; p += 2) {
2767	last = p[ 1 ];
2768	mark(&p[ 1 ]);
2769	C_block_header(p[ 0 ]) = C_block_header(last);
2770	}
2771
2772	/* Mark literal frames: */
2773	for(lfn = lf_list; lfn != NULL; lfn = lfn->next)
2774	for(i = 0; i < lfn->count; mark(&lfn->lf[ i++ ]));
2775
2776	/* Mark symbol tables: */
2777	for(stp = symbol_table_list; stp != NULL; stp = stp->next)
2778	for(i = 0; i < stp->size; mark(&stp->table[ i++ ]));
2779
2780	/* Mark collectibles: */
2781	for(msp = collectibles; msp < collectibles_top; ++msp)
2782	if(msp != NULL) mark(msp);
2783
2784	for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
2785	mark(&gcrp->value);
2786
2787	mark_system_globals();
2788	}
2789	else {
2790	/* Mark mutated slots: */
2791	for(msp = mutation_stack_bottom; msp < mutation_stack_top; mark(*(msp++)));
2792	}
2793
2794	/* Clear the mutated slot stack: */
2795	mutation_stack_top = mutation_stack_bottom;
2796
2797	/* Mark live values: */
2798	for(p = C_temporary_stack; p < C_temporary_stack_bottom; mark(p++));
2799
2800	/* Mark trace-buffer: */
2801	for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
2802	mark(&tinfo->cooked1);
2803	mark(&tinfo->cooked2);
2804	mark(&tinfo->thread);
2805	}
2806
2807	rescan:
2808	/* Mark nested values in already moved (marked) blocks in breadth-first manner: */
2809	while(heap_scan_top < (gc_mode == GC_MINOR ? C_fromspace_top : tospace_top)) {
2810	bp = (C_SCHEME_BLOCK *)heap_scan_top;
2811
2812	if(((C_word )bp) == ALIGNMENT_HOLE_MARKER)
2813	bp = (C_SCHEME_BLOCK )((C_word )bp + 1);
2814
2815	n = C_header_size(bp);
2816	h = bp->header;
2817	bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
2818	p = bp->data;
2819
2820	if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
2821	if(h & C_SPECIALBLOCK_BIT) {
2822	--n;
2823	++p;
2824	}
2825
2826	while(n--) mark(p++);
2827	}
2828
2829	heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
2830	}
2831
2832	if(gc_mode == GC_MINOR) {
2833	count = (C_uword)C_fromspace_top - (C_uword)start;
2834	++gc_count_1;
2835	update_locative_table(GC_MINOR);
2836	}
2837	else {
2838	if(!finalizers_checked) {
2839	/* Mark finalizer list and remember pointers to non-forwarded items: */
2840	last = C_block_item(pending_finalizers_symbol, 0);
2841
2842	if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {
2843	/* still finalizers pending: just mark table items... */
2844	if(gc_report_flag)
2845	C_printf(C_text("[GC] %d finalized item(s) still pending\n"), j);
2846
2847	j = fcount = 0;
2848
2849	for(flist = finalizer_list; flist != NULL; flist = flist->next) {
2850	mark(&flist->item);
2851	mark(&flist->finalizer);
2852	++fcount;
2853	}
2854
2855	if(gc_report_flag && fcount > 0)
2856	C_printf(C_text("[GC] %d finalizer value(s) marked\n"), fcount);
2857	}
2858	else {
2859	j = fcount = 0;
2860
2861	for(flist = finalizer_list; flist != NULL; flist = flist->next) {
2862	if(j < C_max_pending_finalizers) {
2863	if(!is_fptr(C_block_header(flist->item)))
2864	pending_finalizer_indices[ j++ ] = flist;
2865	}
2866
2867	mark(&flist->item);
2868	mark(&flist->finalizer);
2869	}
2870	}
2871
2872	pending_finalizer_count = j;
2873	finalizers_checked = 1;
2874
2875	if(pending_finalizer_count > 0 && gc_report_flag)
2876	C_printf(C_text("[GC] finalizers pending for rescan:\t %d (%d live)\n"),
2877	pending_finalizer_count, live_finalizer_count);
2878
2879	goto rescan;
2880	}
2881	else {
2882	/* Copy finalized items with remembered indices into `##sys#pending-finalizers'
2883	(and release finalizer node): */
2884	if(pending_finalizer_count > 0) {
2885	if(gc_report_flag) C_printf(C_text("[GC] queueing %d finalizers\n"), pending_finalizer_count);
2886
2887	last = C_block_item(pending_finalizers_symbol, 0);
2888	assert(C_u_i_car(last) == C_fix(0));
2889	C_set_block_item(last, 0, C_fix(pending_finalizer_count));
2890
2891	for(i = 0; i < pending_finalizer_count; ++i) {
2892	flist = pending_finalizer_indices[ i ];
2893	C_set_block_item(last, 1 + i * 2, flist->item);
2894	C_set_block_item(last, 2 + i * 2, flist->finalizer);
2895
2896	if(flist->previous != NULL) flist->previous->next = flist->next;
2897	else finalizer_list = flist->next;
2898
2899	if(flist->next != NULL) flist->next->previous = flist->previous;
2900
2901	flist->next = finalizer_free_list;
2902	flist->previous = NULL;
2903	finalizer_free_list = flist;
2904	--live_finalizer_count;
2905	}
2906	}
2907	}
2908
2909	update_locative_table(gc_mode);
2910	count = (C_uword)tospace_top - (C_uword)tospace_start;
2911
2912	/*** isn't gc_mode always GC_MAJOR here? */
2913	if(gc_mode == GC_MAJOR &&
2914	count < percentage(percentage(heap_size, C_heap_shrinkage), DEFAULT_HEAP_SHRINKAGE_USED) &&
2915	heap_size > MINIMAL_HEAP_SIZE && !C_heap_size_is_fixed)
2916	C_rereclaim2(percentage(heap_size, C_heap_shrinkage), 0);
2917	else {
2918	C_fromspace_top = tospace_top;
2919	tmp = fromspace_start;
2920	fromspace_start = tospace_start;
2921	tospace_start = tospace_top = tmp;
2922	tmp = C_fromspace_limit;
2923	C_fromspace_limit = tospace_limit;
2924	tospace_limit = tmp;
2925	}
2926
2927	never_mind_edsgar:
2928	++gc_count_2;
2929
2930	if(C_enable_gcweak) {
2931	/* Check entries in weak item table and recover items ref'd only once and which are unbound symbols: */
2932	weakn = 0;
2933	wep = weak_item_table;
2934
2935	for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep)
2936	if(wep->item != 0) {
2937	if((wep->container & WEAK_COUNTER_MAX) == 0 && is_fptr((item = C_block_header(wep->item)))) {
2938	item = fptr_to_ptr(item);
2939	container = wep->container & ~WEAK_COUNTER_MASK;
2940
2941	if(C_header_bits(item) == C_SYMBOL_TYPE && C_u_i_car(item) == C_SCHEME_UNBOUND) {
2942	++weakn;
2943	#ifdef PARANOIA
2944	item = C_u_i_cdr(item);
2945	C_fprintf(C_stderr, C_text("[recovered: %.s]\n"), (int)C_header_size(item), (char )C_data_pointer(item));
2946	#endif
2947	C_set_block_item(container, 0, C_SCHEME_UNDEFINED);
2948	}
2949	}
2950
2951	wep->item = wep->container = 0;
2952	}
2953
2954	/* Remove empty buckets in symbol table: */
2955	for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
2956	for(i = 0; i < stp->size; ++i) {
2957	last = 0;
2958
2959	for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket))
2960	if(C_u_i_car(bucket) == C_SCHEME_UNDEFINED) {
2961	if(last) C_set_block_item(last, 1, C_u_i_cdr(bucket));
2962	else stp->table[ i ] = C_u_i_cdr(bucket);
2963	}
2964	else last = bucket;
2965	}
2966	}
2967	}
2968	}
2969
2970	if(gc_mode == GC_MAJOR) {
2971	tgc = cpu_milliseconds() - tgc;
2972	timer_start_gc_ms += tgc;
2973	timer_accumulated_gc_ms += tgc;
2974	}
2975
2976	/* Display GC report:
2977	Note: stubbornly writes to stdout - there is no provision for other output-ports */
2978	if(gc_report_flag == 1 \|\| (gc_report_flag && gc_mode == GC_MAJOR)) {
2979	C_printf(C_text("[GC] level %d\tgcs(minor) %d\tgcs(major) %d\n"),
2980	gc_mode, gc_count_1, gc_count_2);
2981	i = (C_uword)C_stack_pointer;
2982
2983	#if C_STACK_GROWS_DOWNWARD
2984	C_printf(C_text("[GC] stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
2985	(C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);
2986	#else
2987	C_printf(C_text("[GC] stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
2988	(C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);
2989	#endif
2990
2991	if(gc_mode == GC_MINOR) printf(C_text("\t" UWORD_FORMAT_STRING), count);
2992
2993	C_printf(C_text("\n[GC] from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
2994	(C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);
2995
2996	if(gc_mode == GC_MAJOR) printf(C_text("\t" UWORD_FORMAT_STRING), count);
2997
2998	C_printf(C_text("\n[GC] to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),
2999	(C_uword)tospace_start, (C_uword)tospace_top,
3000	(C_uword)tospace_limit);
3001
3002	if(gc_mode == GC_MAJOR && C_enable_gcweak && weakn)
3003	C_printf(C_text("[GC] %d recoverable weakly held items found\n"), weakn);
3004
3005	C_printf(C_text("[GC] %d locatives (from %d)\n"), locative_table_count, locative_table_size);
3006	}
3007
3008	if(gc_mode == GC_MAJOR) gc_count_1 = 0;
3009
3010	if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc);
3011
3012	lock_tospace(1);
3013	/* Jump from the Empire State Building... */
3014	C_longjmp(C_restart, 1);
3015	}
3016
3017
3018	C_regparm void C_fcall mark_system_globals(void)
3019	{
3020	mark(&interrupt_hook_symbol);
3021	mark(&error_hook_symbol);
3022	mark(&callback_continuation_stack_symbol);
3023	mark(&pending_finalizers_symbol);
3024	mark(&invalid_procedure_call_hook_symbol);
3025	mark(&unbound_variable_value_hook_symbol);
3026	mark(&last_invalid_procedure_symbol);
3027	mark(&identity_unbound_value_symbol);
3028	mark(&current_thread_symbol);
3029	mark(&apply_hook_symbol);
3030	mark(&last_applied_procedure_symbol);
3031	}
3032
3033
3034	C_regparm void C_fcall mark(C_word *x)
3035	{
3036	C_word val, item;
3037	C_uword n, bytes;
3038	C_header h;
3039	C_SCHEME_BLOCK p, p2;
3040	WEAK_TABLE_ENTRY *wep;
3041
3042	val = *x;
3043
3044	if(C_immediatep(val)) return;
3045
3046	p = (C_SCHEME_BLOCK *)val;
3047
3048	/* not in stack and not in heap? */
3049	if (
3050	#if C_STACK_GROWS_DOWNWARD
3051	p < (C_SCHEME_BLOCK )C_stack_pointer \|\| p >= (C_SCHEME_BLOCK )stack_bottom
3052	#else
3053	p >= (C_SCHEME_BLOCK )C_stack_pointer \|\| p < (C_SCHEME_BLOCK )stack_bottom
3054	#endif
3055	)
3056	if((p < (C_SCHEME_BLOCK )fromspace_start \|\| p >= (C_SCHEME_BLOCK )C_fromspace_limit) &&
3057	(p < (C_SCHEME_BLOCK )tospace_start \|\| p >= (C_SCHEME_BLOCK )tospace_limit) ) {
3058	#ifdef C_GC_HOOKS
3059	if(C_gc_trace_hook != NULL)
3060	C_gc_trace_hook(x, gc_mode);
3061	#endif
3062
3063	return;
3064	}
3065
3066	h = p->header;
3067
3068	if(gc_mode == GC_MINOR) {
3069	if(is_fptr(h)) {
3070	*x = val = fptr_to_ptr(h);
3071	return;
3072	}
3073
3074	if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) return;
3075
3076	p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);
3077
3078	#ifndef C_SIXTY_FOUR
3079	if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
3080	((C_word )p2) = ALIGNMENT_HOLE_MARKER;
3081	p2 = (C_SCHEME_BLOCK )((C_word )p2 + 1);
3082	}
3083	#endif
3084
3085	n = C_header_size(p);
3086	bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3087
3088	if(((C_byte *)p2 + bytes + sizeof(C_word)) > C_fromspace_limit)
3089	C_longjmp(gc_restart, 1);
3090
3091	C_fromspace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3092
3093	scavenge:
3094	*x = (C_word)p2;
3095	p2->header = h;
3096	p->header = ptr_to_fptr((C_uword)p2);
3097	C_memcpy(p2->data, p->data, bytes);
3098	}
3099	else {
3100	/* Increase counter if weakly held item: */
3101	if(C_enable_gcweak && (wep = lookup_weak_table_entry(val, 0)) != NULL) {
3102	if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
3103	}
3104
3105	if(is_fptr(h)) {
3106	val = fptr_to_ptr(h);
3107
3108	if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
3109	*x = val;
3110	return;
3111	}
3112
3113	/* Link points into fromspace: fetch new pointer + header and copy... */
3114	p = (C_SCHEME_BLOCK *)val;
3115	h = p->header;
3116
3117	if(is_fptr(h)) {
3118	/* Link points into fromspace and into a link which points into from- or tospace: */
3119	val = fptr_to_ptr(h);
3120
3121	if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
3122	*x = val;
3123	return;
3124	}
3125
3126	p = (C_SCHEME_BLOCK *)val;
3127	h = p->header;
3128	}
3129	}
3130
3131	p2 = (C_SCHEME_BLOCK *)C_align((C_uword)tospace_top);
3132
3133	#ifndef C_SIXTY_FOUR
3134	if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < tospace_limit) {
3135	((C_word )p2) = ALIGNMENT_HOLE_MARKER;
3136	p2 = (C_SCHEME_BLOCK )((C_word )p2 + 1);
3137	}
3138	#endif
3139
3140	if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) {
3141	item = C_u_i_car(val);
3142
3143	/* Lookup item in weak item table or add entry: */
3144	if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) {
3145	/* If item is already forwarded, then set count to 2: */
3146	if(is_fptr(C_block_header(item))) wep->container \|= 2;
3147	}
3148	}
3149
3150	n = C_header_size(p);
3151	bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3152
3153	if(((C_byte *)p2 + bytes + sizeof(C_word)) > tospace_limit) {
3154	if(C_heap_size_is_fixed)
3155	panic(C_text("out of memory - heap full"));
3156
3157	gc_mode = GC_REALLOC;
3158	C_longjmp(gc_restart, 1);
3159	}
3160
3161	tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3162	goto scavenge;
3163	}
3164	}
3165
3166
3167	/* Do a major GC into a freshly allocated heap: */
3168
3169	C_regparm void C_fcall C_rereclaim(long size)
3170	{
3171	C_rereclaim2(size < 0 ? -size : size, size < 0);
3172	}
3173
3174
3175	C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
3176	{
3177	int i, j;
3178	C_uword count, n, bytes;
3179	C_word p, *msp, item, last;
3180	C_header h;
3181	C_byte tmp, start;
3182	LF_LIST *lfn;
3183	C_SCHEME_BLOCK *bp;
3184	WEAK_TABLE_ENTRY *wep;
3185	C_GC_ROOT *gcrp;
3186	C_SYMBOL_TABLE *stp;
3187	FINALIZER_NODE *flist;
3188	TRACE_INFO *tinfo;
3189	C_byte *new_heapspace;
3190	size_t new_heapspace_size;
3191
3192	lock_tospace(0);
3193
3194	if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);
3195
3196	if(double_plus) size = heap_size * 2 + size;
3197
3198	if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;
3199
3200	if(size > C_maximal_heap_size) size = C_maximal_heap_size;
3201
3202	if(size == heap_size) return;
3203
3204	if(debug_mode)
3205	C_printf(C_text("[debug] resizing heap dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),
3206	(C_uword)heap_size / 1000, size / 1000);
3207
3208	if(gc_report_flag) {
3209	C_printf(C_text("(old) fromspace: \tstart=%08lx, \tlimit=%08lx\n"), (long)fromspace_start, (long)C_fromspace_limit);
3210	C_printf(C_text("(old) tospace: \tstart=%08lx, \tlimit=%08lx\n"), (long)tospace_start, (long)tospace_limit);
3211	}
3212
3213	heap_size = size;
3214	size /= 2;
3215
3216	if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)
3217	panic(C_text("out of memory - can not allocate heap segment"));
3218	new_heapspace_size = size;
3219
3220	new_tospace_top = new_tospace_start;
3221	new_tospace_limit = new_tospace_start + size;
3222	heap_scan_top = new_tospace_top;
3223
3224	/* Mark items in forwarding table: */
3225	for(p = forwarding_table; *p != 0; p += 2) {
3226	last = p[ 1 ];
3227	remark(&p[ 1 ]);
3228	C_block_header(p[ 0 ]) = C_block_header(last);
3229	}
3230
3231	/* Mark literal frames: */
3232	for(lfn = lf_list; lfn != NULL; lfn = lfn->next)
3233	for(i = 0; i < lfn->count; remark(&lfn->lf[ i++ ]));
3234
3235	/* Mark symbol table: */
3236	for(stp = symbol_table_list; stp != NULL; stp = stp->next)
3237	for(i = 0; i < stp->size; remark(&stp->table[ i++ ]));
3238
3239	/* Mark collectibles: */
3240	for(msp = collectibles; msp < collectibles_top; ++msp)
3241	if(msp != NULL) remark(msp);
3242
3243	for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
3244	remark(&gcrp->value);
3245
3246	remark_system_globals();
3247
3248	/* Clear the mutated slot stack: */
3249	mutation_stack_top = mutation_stack_bottom;
3250
3251	/* Mark live values: */
3252	for(p = C_temporary_stack; p < C_temporary_stack_bottom; remark(p++));
3253
3254	/* Mark locative table: */
3255	for(i = 0; i < locative_table_count; ++i)
3256	remark(&locative_table[ i ]);
3257
3258	/* Mark finalizer table: */
3259	for(flist = finalizer_list; flist != NULL; flist = flist->next) {
3260	remark(&flist->item);
3261	remark(&flist->finalizer);
3262	}
3263
3264	/* Mark weakly held items: */
3265	if(C_enable_gcweak) {
3266	wep = weak_item_table;
3267
3268	for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep)
3269	if(wep->item != 0) remark(&wep->item);
3270	}
3271
3272	/* Mark trace-buffer: */
3273	for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
3274	remark(&tinfo->cooked1);
3275	remark(&tinfo->cooked2);
3276	remark(&tinfo->thread);
3277	}
3278
3279	update_locative_table(GC_REALLOC);
3280
3281	/* Mark nested values in already moved (marked) blocks in breadth-first manner: */
3282	while(heap_scan_top < new_tospace_top) {
3283	bp = (C_SCHEME_BLOCK *)heap_scan_top;
3284
3285	if(((C_word )bp) == ALIGNMENT_HOLE_MARKER)
3286	bp = (C_SCHEME_BLOCK )((C_word )bp + 1);
3287
3288	n = C_header_size(bp);
3289	h = bp->header;
3290	assert(!is_fptr(h));
3291	bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3292	p = bp->data;
3293
3294	if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
3295	if(h & C_SPECIALBLOCK_BIT) {
3296	--n;
3297	++p;
3298	}
3299
3300	while(n--) remark(p++);
3301	}
3302
3303	heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
3304	}
3305
3306	heap_free (heapspace1, heapspace1_size);
3307	heap_free (heapspace2, heapspace1_size);
3308
3309	if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)
3310	panic(C_text("out ot memory - can not allocate heap segment"));
3311	heapspace2_size = size;
3312
3313	heapspace1 = new_heapspace;
3314	heapspace1_size = new_heapspace_size;
3315	tospace_limit = tospace_start + size;
3316	tospace_top = tospace_start;
3317	fromspace_start = new_tospace_start;
3318	C_fromspace_top = new_tospace_top;
3319	C_fromspace_limit = new_tospace_limit;
3320	lock_tospace(1);
3321
3322	if(gc_report_flag) {
3323	C_printf(C_text("[GC] resized heap to %d bytes\n"), heap_size);
3324	C_printf(C_text("(new) fromspace: \tstart=%08lx, \tlimit=%08lx\n"), (long)fromspace_start, (long)C_fromspace_limit);
3325	C_printf(C_text("(new) tospace: \tstart=%08lx, \tlimit=%08lx\n"), (long)tospace_start, (long)tospace_limit);
3326	}
3327
3328	if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);
3329	}
3330
3331
3332	C_regparm void C_fcall remark_system_globals(void)
3333	{
3334	remark(&interrupt_hook_symbol);
3335	remark(&error_hook_symbol);
3336	remark(&callback_continuation_stack_symbol);
3337	remark(&pending_finalizers_symbol);
3338	remark(&invalid_procedure_call_hook_symbol);
3339	remark(&unbound_variable_value_hook_symbol);
3340	remark(&last_invalid_procedure_symbol);
3341	remark(&identity_unbound_value_symbol);
3342	remark(&current_thread_symbol);
3343	remark(&apply_hook_symbol);
3344	remark(&last_applied_procedure_symbol);
3345	}
3346
3347
3348	C_regparm void C_fcall remark(C_word *x)
3349	{
3350	C_word val, item;
3351	C_uword n, bytes;
3352	C_header h;
3353	C_SCHEME_BLOCK p, p2;
3354	WEAK_TABLE_ENTRY *wep;
3355
3356	val = *x;
3357
3358	if(C_immediatep(val)) return;
3359
3360	p = (C_SCHEME_BLOCK *)val;
3361
3362	/* not in stack and not in heap? */
3363	if(
3364	#if C_STACK_GROWS_DOWNWARD
3365	p < (C_SCHEME_BLOCK )C_stack_pointer \|\| p >= (C_SCHEME_BLOCK )stack_bottom
3366	#else
3367	p >= (C_SCHEME_BLOCK )C_stack_pointer \|\| p < (C_SCHEME_BLOCK )stack_bottom
3368	#endif
3369	)
3370	if((p < (C_SCHEME_BLOCK )fromspace_start \|\| p >= (C_SCHEME_BLOCK )C_fromspace_limit) &&
3371	(p < (C_SCHEME_BLOCK )tospace_start \|\| p >= (C_SCHEME_BLOCK )tospace_limit) &&
3372	(p < (C_SCHEME_BLOCK )new_tospace_start \|\| p >= (C_SCHEME_BLOCK )new_tospace_limit) ) {
3373	#ifdef C_GC_HOOKS
3374	if(C_gc_trace_hook != NULL)
3375	C_gc_trace_hook(x, gc_mode);
3376	#endif
3377
3378	return;
3379	}
3380
3381	h = p->header;
3382
3383	if(is_fptr(h)) {
3384	val = fptr_to_ptr(h);
3385
3386	if((C_uword)val >= (C_uword)new_tospace_start && (C_uword)val < (C_uword)new_tospace_top) {
3387	*x = val;
3388	return;
3389	}
3390
3391	/* Link points into nursery, fromspace or the old tospace: fetch new pointer + header and copy... */
3392	p = (C_SCHEME_BLOCK *)val;
3393	h = p->header;
3394	n = 1;
3395
3396	while(is_fptr(h)) {
3397	/* Link points into fromspace or old tospace and into a link which points into tospace or new-tospace: */
3398	val = fptr_to_ptr(h);
3399
3400	if((C_uword)val >= (C_uword)new_tospace_start && (C_uword)val < (C_uword)new_tospace_top) {
3401	*x = val;
3402	return;
3403	}
3404
3405	p = (C_SCHEME_BLOCK *)val;
3406	h = p->header;
3407
3408	if(++n > 3)
3409	panic(C_text("forwarding chain during re-reclamation is longer than 3. somethings fishy."));
3410	}
3411	}
3412
3413	p2 = (C_SCHEME_BLOCK *)C_align((C_uword)new_tospace_top);
3414
3415	#ifndef C_SIXTY_FOUR
3416	if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < new_tospace_limit) {
3417	((C_word )p2) = ALIGNMENT_HOLE_MARKER;
3418	p2 = (C_SCHEME_BLOCK )((C_word )p2 + 1);
3419	}
3420	#endif
3421
3422	n = C_header_size(p);
3423	bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3424
3425	if(((C_byte *)p2 + bytes + sizeof(C_word)) > new_tospace_limit) {
3426	panic(C_text("out of memory - heap full while resizing"));
3427	}
3428
3429	new_tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3430	*x = (C_word)p2;
3431	p2->header = h;
3432	assert(!is_fptr(h));
3433	p->header = ptr_to_fptr((C_word)p2);
3434	C_memcpy(p2->data, p->data, bytes);
3435	}
3436
3437
3438	C_regparm void C_fcall update_locative_table(int mode)
3439	{
3440	int i, hi = 0;
3441	C_header h;
3442	C_word loc, obj, obj2, offset, loc2, ptr;
3443	C_uword ptr2;
3444
3445	/* C_printf("major: %d, %d locs in %d\n", major, locative_table_count, locative_table_size); */
3446
3447	for(i = 0; i < locative_table_count; ++i) {
3448	loc = locative_table[ i ];
3449	/* C_printf("%d: %08lx %d/%d\n", i, loc, C_in_stackp(loc), C_in_heapp(loc)); */
3450
3451	if(loc != C_SCHEME_UNDEFINED) {
3452	h = C_block_header(loc);
3453
3454	switch(mode) {
3455	case GC_MINOR:
3456	if(is_fptr(h)) /* forwarded? update l-table entry */
3457	loc = locative_table[ i ] = fptr_to_ptr(h);
3458	else if(C_in_stackp(loc)) { /* otherwise it must have been GC'd (since this is a minor one) */
3459	locative_table[ i ] = C_SCHEME_UNDEFINED;
3460	C_set_block_item(loc, 0, 0);
3461	break;
3462	}
3463
3464	ptr = C_block_item(loc, 0); /* forwarded. fix up ptr and check pointed-at object for being forwarded... */
3465	offset = C_unfix(C_block_item(loc, 1));
3466	obj = ptr - offset;
3467	h = C_block_header(obj);
3468
3469	if(is_fptr(h)) { /* pointed-at object forwarded? update */
3470	C_set_block_item(loc, 0, (C_uword)fptr_to_ptr(h) + offset);
3471	hi = i + 1;
3472	}
3473	else if(C_in_stackp(obj)) { /* pointed-at object GC'd, locative is invalid */
3474	locative_table[ i ] = C_SCHEME_UNDEFINED;
3475	C_set_block_item(loc, 0, 0);
3476	}
3477	else hi = i + 1;
3478
3479	break;
3480
3481	case GC_MAJOR:
3482	if(is_fptr(h)) /* forwarded? update l-table entry */
3483	loc = locative_table[ i ] = fptr_to_ptr(h);
3484	else { /* otherwise, throw away */
3485	locative_table[ i ] = C_SCHEME_UNDEFINED;
3486	C_set_block_item(loc, 0, 0);
3487	break;
3488	}
3489
3490	h = C_block_header(loc);
3491
3492	if(is_fptr(h)) /* new instance is forwarded itself? update again */
3493	loc = locative_table[ i ] = fptr_to_ptr(h);
3494
3495	ptr = C_block_item(loc, 0); /* fix up ptr */
3496	offset = C_unfix(C_block_item(loc, 1));
3497	obj = ptr - offset;
3498	h = C_block_header(obj);
3499
3500	if(is_fptr(h)) { /* pointed-at object has been forwarded? */
3501	ptr2 = (C_uword)fptr_to_ptr(h);
3502	h = C_block_header(ptr2);
3503
3504	if(is_fptr(h)) { /* secondary forwarding check for pointed-at object */
3505	ptr2 = (C_uword)fptr_to_ptr(h) + offset;
3506	C_set_block_item(loc, 0, ptr2);
3507	}
3508	else C_set_block_item(loc, 0, ptr2 + offset); /* everything's fine, fixup pointer */
3509
3510	hi = i + 1;
3511	}
3512	else {
3513	locative_table[ i ] = C_SCHEME_UNDEFINED; /* pointed-at object is dead */
3514	C_set_block_item(loc, 0, 0);
3515	}
3516
3517	break;
3518
3519	case GC_REALLOC:
3520	ptr = C_block_item(loc, 0); /* just update ptr's pointed-at objects */
3521	offset = C_unfix(C_block_item(loc, 1));
3522	obj = ptr - offset;
3523	remark(&obj);
3524	C_set_block_item(loc, 0, obj + offset);
3525	break;
3526	}
3527	}
3528	}
3529
3530	if(mode != GC_REALLOC) locative_table_count = hi;
3531	}
3532
3533
3534	C_regparm WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container)
3535	{
3536	int key = (C_uword)item >> 2,
3537	disp = 0,
3538	n;
3539	WEAK_TABLE_ENTRY *wep;
3540
3541	for(n = 0; n < WEAK_HASH_ITERATIONS; ++n) {
3542	key = (key + disp) % WEAK_TABLE_SIZE;
3543	wep = &weak_item_table[ key ];
3544
3545	if(wep->item == 0) {
3546	if(container != 0) {
3547	/* Add fresh entry: */
3548	wep->item = item;
3549	wep->container = container;
3550	return wep;
3551	}
3552
3553	return NULL;
3554	}
3555	else if(wep->item == item) return wep;
3556	else disp += WEAK_HASH_DISPLACEMENT;
3557	}
3558
3559	return NULL;
3560	}
3561
3562
3563	void handle_interrupt(void trampoline, void proc)
3564	{
3565	C_word *p, x, n;
3566	int i;
3567	long c;
3568
3569	/* Build vector with context information: */
3570	n = C_temporary_stack_bottom - C_temporary_stack;
3571	p = C_alloc(19 + n); /* 19 <=> 2 headers + trampoline + proc + 1 extra slot + 9 for interning + 5 for string */
3572	x = (C_word)p;
3573	(p++) = C_VECTOR_TYPE \| C_BYTEBLOCK_BIT \| (2 sizeof(C_word));
3574	*(p++) = (C_word)trampoline;
3575	*(p++) = (C_word)proc;
3576	C_save(x);
3577	x = (C_word)p;
3578	*(p++) = C_VECTOR_TYPE \| (n + 1);
3579	*(p++) = C_restore;
3580	C_memcpy(p, C_temporary_stack, n * sizeof(C_word));
3581
3582	/* Restore state to the one at the time of the interrupt: */
3583	C_temporary_stack = C_temporary_stack_bottom;
3584	i = interrupt_reason;
3585	interrupt_reason = 0;
3586	C_stack_limit = saved_stack_limit;
3587
3588	/* Invoke high-level interrupt handler: */
3589	C_save(C_fix(i));
3590	C_save(x);
3591	x = C_block_item(interrupt_hook_symbol, 0);
3592
3593	if(C_immediatep(x))
3594	panic(C_text("`##sys#interrupt-hook' is not defined"));
3595
3596	c = cpu_milliseconds() - interrupt_time;
3597	last_interrupt_latency = c;
3598	C_timer_interrupt_counter = C_initial_timer_interrupt_period; /* just in case */
3599	C_do_apply(2, x, C_SCHEME_UNDEFINED); /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
3600	}
3601
3602
3603	C_regparm C_word C_fcall C_retrieve(C_word sym)
3604	{
3605	C_word val = C_u_i_car(sym);
3606
3607	if(val == C_SCHEME_UNBOUND)
3608	return C_get_unbound_variable_value_hook(sym);
3609
3610	return val;
3611	}
3612
3613
3614	C_word get_unbound_variable_value(C_word sym)
3615	{
3616	C_word x = C_block_item(unbound_variable_value_hook_symbol, 0);
3617
3618	if(x == identity_unbound_value_symbol) return sym;
3619	else if(x == C_SCHEME_FALSE)
3620	barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
3621
3622	return C_block_item(x, 0);
3623	}
3624
3625
3626	C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
3627	{
3628	C_word *p;
3629	int len;
3630
3631	if(val == C_SCHEME_UNBOUND) {
3632	len = C_strlen(name);
3633	p = C_alloc(C_SIZEOF_STRING(len)); /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */
3634	return get_unbound_variable_value(C_string2(&p, name));
3635	}
3636
3637	return val;
3638	}
3639
3640
3641	#ifndef C_UNSAFE_RUNTIME
3642	static C_word resolve_procedure(C_word closure, C_char *where)
3643	{
3644	C_word s;
3645
3646	if(C_immediatep(closure) \|\| C_header_bits(closure) != C_CLOSURE_TYPE) {
3647	s = C_block_item(invalid_procedure_call_hook_symbol, 0);
3648
3649	if(s == C_SCHEME_FALSE)
3650	barf(C_NOT_A_CLOSURE_ERROR, where, closure);
3651
3652	C_mutate(&C_block_item(last_invalid_procedure_symbol, 0), closure);
3653	closure = s;
3654	}
3655
3656	return closure;
3657	}
3658	#endif
3659
3660
3661	C_regparm void *C_fcall C_retrieve_proc(C_word closure)
3662	{
3663	closure = resolve_procedure(closure, NULL);
3664
3665	#ifndef C_NO_APPLY_HOOK
3666	if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
3667	C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
3668	return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
3669	}
3670	#endif
3671
3672	return (void *)C_block_item(closure, 0);
3673	}
3674
3675
3676	C_regparm void C_fcall C_trace(C_char *name)
3677	{
3678	if(show_trace) {
3679	C_fputs(name, C_stderr);
3680	C_fputc('\n', C_stderr);
3681	}
3682
3683	if(trace_buffer_top >= trace_buffer_limit) {
3684	trace_buffer_top = trace_buffer;
3685	trace_buffer_full = 1;
3686	}
3687
3688	trace_buffer_top->raw = name;
3689	trace_buffer_top->cooked1 = C_SCHEME_FALSE;
3690	trace_buffer_top->cooked2 = C_SCHEME_FALSE;
3691	trace_buffer_top->thread = C_block_item(current_thread_symbol, 0);
3692	++trace_buffer_top;
3693	}
3694
3695
3696	/* DEPRECATED: throw out at some stage: */
3697	C_regparm C_word C_fcall C_emit_trace_info(C_word x, C_word y, C_word t)
3698	{
3699	if(trace_buffer_top >= trace_buffer_limit) {
3700	trace_buffer_top = trace_buffer;
3701	trace_buffer_full = 1;
3702	}
3703
3704	trace_buffer_top->raw = "<eval>";
3705	trace_buffer_top->cooked1 = x;
3706	trace_buffer_top->cooked2 = y;
3707	trace_buffer_top->thread = t;
3708	++trace_buffer_top;
3709	return x;
3710	}
3711
3712
3713	C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t)
3714	{
3715	if(trace_buffer_top >= trace_buffer_limit) {
3716	trace_buffer_top = trace_buffer;
3717	trace_buffer_full = 1;
3718	}
3719
3720	trace_buffer_top->raw = raw;
3721	trace_buffer_top->cooked1 = x;
3722	trace_buffer_top->cooked2 = y;
3723	trace_buffer_top->thread = t;
3724	++trace_buffer_top;
3725	return x;
3726	}
3727
3728
3729	C_char *C_dump_trace(int start)
3730	{
3731	TRACE_INFO *ptr;
3732	C_char *result;
3733	int i;
3734
3735	if((result = (char *)C_malloc(STRING_BUFFER_SIZE)) == NULL)
3736	horror(C_text("out of memory - can not allocate trace-dump buffer"));
3737
3738	*result = '\0';
3739
3740	if(trace_buffer_top > trace_buffer \|\| trace_buffer_full) {
3741	if(trace_buffer_full) {
3742	i = C_trace_buffer_size;
3743	C_strcat(result, C_text("...more...\n"));
3744	}
3745	else i = trace_buffer_top - trace_buffer;
3746
3747	ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
3748	ptr += start;
3749	i -= start;
3750
3751	for(;i--; ++ptr) {
3752	if(ptr >= trace_buffer_limit) ptr = trace_buffer;
3753
3754	if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {
3755	if((result = C_realloc(result, C_strlen(result) * 2)) == NULL)
3756	horror(C_text("out of memory - can not reallocate trace-dump buffer"));
3757	}
3758
3759	C_strcat(result, ptr->raw);
3760
3761	if(i > 0) C_strcat(result, "\n");
3762	else C_strcat(result, " \t<--\n");
3763	}
3764	}
3765
3766	return result;
3767	}
3768
3769
3770	C_regparm void C_fcall C_clear_trace_buffer(void)
3771	{
3772	int i;
3773
3774	if(trace_buffer == NULL) {
3775	trace_buffer = (TRACE_INFO )C_malloc(sizeof(TRACE_INFO) C_trace_buffer_size);
3776
3777	if(trace_buffer == NULL)
3778	panic(C_text("out of memory - can not allocate trace-buffer"));
3779	}
3780
3781	trace_buffer_top = trace_buffer;
3782	trace_buffer_limit = trace_buffer + C_trace_buffer_size;
3783	trace_buffer_full = 0;
3784
3785	for(i = 0; i < C_trace_buffer_size; ++i) {
3786	trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;
3787	trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;
3788	trace_buffer[ i ].thread = C_SCHEME_FALSE;
3789	}
3790	}
3791
3792
3793	C_word C_fetch_trace(C_word starti, C_word buffer)
3794	{
3795	TRACE_INFO *ptr;
3796	int i, p = 0, start = C_unfix(starti);
3797
3798	if(trace_buffer_top > trace_buffer \|\| trace_buffer_full) {
3799	if(trace_buffer_full) i = C_trace_buffer_size;
3800	else i = trace_buffer_top - trace_buffer;
3801
3802	ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
3803	ptr += start;
3804	i -= start;
3805
3806	if(C_header_size(buffer) < i * 4)
3807	panic(C_text("destination buffer too small for call-chain"));
3808
3809	for(;i--; ++ptr) {
3810	if(ptr >= trace_buffer_limit) ptr = trace_buffer;
3811
3812	C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw); /* outside-pointer, will be ignored by GC */
3813	C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
3814	C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
3815	C_mutate(&C_block_item(buffer, p++), ptr->thread);
3816	}
3817	}
3818
3819	return C_fix(p);
3820	}
3821
3822
3823	C_regparm C_word C_fcall C_hash_string(C_word str)
3824	{
3825	unsigned C_word key = 2166136261U;
3826	int len = C_header_size(str);
3827	C_byte *ptr = C_data_pointer(str);
3828
3829	while(len--) key = ((key * 16777619U) + (*ptr++));
3830
3831	return C_fix(key & C_MOST_POSITIVE_FIXNUM);
3832	}
3833
3834
3835	C_regparm C_word C_fcall C_hash_string_ci(C_word str)
3836	{
3837	unsigned C_word key = 2166136261U;
3838	int len = C_header_size(str);
3839	C_byte *ptr = C_data_pointer(str);
3840
3841	while(len--) key = ((key * 16777619U) + C_tolower(*ptr++));
3842
3843	return C_fix(key & C_MOST_POSITIVE_FIXNUM);
3844	}
3845
3846
3847	C_regparm void C_fcall C_toplevel_entry(C_char *name)
3848	{
3849	if(debug_mode) {
3850	C_printf(C_text("[debug] entering toplevel %s...\n"), name);
3851	C_fflush(stdout);
3852	}
3853	}
3854
3855
3856	C_word C_halt(C_word msg)
3857	{
3858	C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;
3859
3860	#ifdef C_MICROSOFT_WINDOWS
3861	if(msg != C_SCHEME_FALSE) {
3862	int n = C_header_size(msg);
3863
3864	C_strncpy(buffer, (C_char *)C_data_pointer(msg), n);
3865	buffer[ n ] = '\0';
3866	}
3867	else C_strcpy(buffer, C_text("(aborted)"));
3868
3869	C_strcat(buffer, C_text("\n\n"));
3870
3871	if(dmp != NULL) C_strcat(buffer, dmp);
3872
3873	MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
3874	#else
3875	if(msg != C_SCHEME_FALSE) {
3876	C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);
3877	C_fputc('\n', C_stderr);
3878	}
3879
3880	if(dmp != NULL) C_fprintf(stderr, C_text("\n%s"), dmp);
3881	#endif
3882
3883	C_exit(EX_SOFTWARE);
3884	return 0;
3885	}
3886
3887
3888	C_word C_message(C_word msg)
3889	{
3890	#ifdef C_MICROSOFT_WINDOWS
3891	int n = C_header_size(msg);
3892
3893	C_strncpy(buffer, (C_char )((C_SCHEME_BLOCK )msg)->data, n);
3894	buffer[ n ] = '\0';
3895	MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
3896	#else
3897	C_fwrite(((C_SCHEME_BLOCK *)msg)->data, C_header_size(msg), sizeof(C_char), stdout);
3898	C_putchar('\n');
3899	#endif
3900	return C_SCHEME_UNDEFINED;
3901	}
3902
3903
3904	C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
3905	{
3906	C_header header;
3907	C_word bits, n, i;
3908
3909	C_stack_check;
3910
3911	loop:
3912	if(x == y) return 1;
3913
3914	if(C_immediatep(x) \|\| C_immediatep(y)) return 0;
3915
3916	if((header = C_block_header(x)) != C_block_header(y)) return 0;
3917	else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {
3918	if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)
3919	return C_flonum_magnitude(x) == C_flonum_magnitude(y);
3920	else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);
3921	}
3922	else if(header == C_SYMBOL_TAG) return 0;
3923	else {
3924	i = 0;
3925	n = header & C_HEADER_SIZE_MASK;
3926
3927	if(bits & C_SPECIALBLOCK_BIT) {
3928	if(C_u_i_car(x) != C_u_i_car(y)) return 0;
3929	else ++i;
3930
3931	if(n == 1) return 1;
3932	}
3933
3934	if(--n < 0) return 1;
3935
3936	while(i < n)
3937	if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;
3938	else ++i;
3939
3940	x = C_block_item(x, i);
3941	y = C_block_item(y, i);
3942	goto loop;
3943	}
3944
3945	return 1;
3946	}
3947
3948
3949	C_regparm C_word C_fcall C_set_gc_report(C_word flag)
3950	{
3951	if(flag == C_SCHEME_FALSE) gc_report_flag = 0;
3952	else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;
3953	else gc_report_flag = 1;
3954
3955	return C_SCHEME_UNDEFINED;
3956	}
3957
3958
3959	C_regparm C_word C_fcall C_start_timer(void)
3960	{
3961	timer_start_mutation_count = mutation_count;
3962	timer_start_gc_count_1 = gc_count_1;
3963	timer_start_gc_count_2 = gc_count_2;
3964	timer_start_fromspace_top = C_fromspace_top;
3965	timer_start_ms = cpu_milliseconds();
3966	timer_start_gc_ms = 0;
3967	return C_SCHEME_UNDEFINED;
3968	}
3969
3970
3971	void C_ccall C_stop_timer(C_word c, C_word closure, C_word k)
3972	{
3973	long t0 = cpu_milliseconds() - timer_start_ms;
3974	int gc2 = gc_count_2 - timer_start_gc_count_2,
3975	gc1 = gc2 ? gc_count_1 : (gc_count_1 - timer_start_gc_count_1),
3976	mutations = mutation_count - timer_start_mutation_count,
3977	from = gc2 ? ((C_uword)C_fromspace_top - (C_uword)fromspace_start)
3978	: ((C_uword)C_fromspace_top - (C_uword)timer_start_fromspace_top);
3979	C_word
3980	ab[ WORDS_PER_FLONUM * 2 + 7 ], /* 2 flonums, 1 vector of 6 elements */
3981	*a = ab,
3982	elapsed = C_flonum(&a, (double)t0 / 1000.0),
3983	gc_time = C_flonum(&a, (double)timer_start_gc_ms / 1000.0),
3984	info;
3985
3986	info = C_vector(&a, 6, elapsed, gc_time, C_fix(mutations), C_fix(gc1), C_fix(gc2), C_fix(from));
3987	C_kontinue(k, info);
3988	}
3989
3990
3991	C_word C_exit_runtime(C_word code)
3992	{
3993	exit(C_unfix(code));
3994	return 0; /* to please the compiler... */
3995	}
3996
3997
3998	C_regparm C_word C_fcall C_set_print_precision(C_word n)
3999	{
4000	flonum_print_precision = C_unfix(n);
4001	return C_SCHEME_UNDEFINED;
4002	}
4003
4004
4005	C_regparm C_word C_fcall C_get_print_precision(void)
4006	{
4007	return C_fix(flonum_print_precision);
4008	}
4009
4010
4011	C_regparm C_word C_fcall C_display_flonum(C_word port, C_word n)
4012	{
4013	C_FILEPTR fp = C_port_file(port);
4014
4015	#ifdef HAVE_GCVT
4016	C_fprintf(fp, C_text("%s"), C_gcvt(C_flonum_magnitude(n), flonum_print_precision, buffer));
4017	#else
4018	C_fprintf(fp, C_text("%.*g"), flonum_print_precision, C_flonum_magnitude(n));
4019	#endif
4020	return C_SCHEME_UNDEFINED;
4021	}
4022
4023
4024	C_regparm C_word C_fcall C_read_char(C_word port)
4025	{
4026	int c = C_fgetc(C_port_file(port));
4027
4028	return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
4029	}
4030
4031
4032	C_regparm C_word C_fcall C_peek_char(C_word port)
4033	{
4034	C_FILEPTR fp = C_port_file(port);
4035	int c = C_fgetc(fp);
4036
4037	C_ungetc(c, fp);
4038	return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
4039	}
4040
4041
4042	C_regparm C_word C_fcall C_execute_shell_command(C_word string)
4043	{
4044	int n = C_header_size(string);
4045	char *buf = buffer;
4046
4047	/* Windows doc says to flush all output streams before calling system.
4048	Probably a good idea for all platforms. */
4049	(void)fflush(NULL);
4050
4051	if(n >= STRING_BUFFER_SIZE) {
4052	if((buf = (char *)C_malloc(n + 1)) == NULL)
4053	barf(C_OUT_OF_MEMORY_ERROR, "system");
4054	}
4055
4056	C_memcpy(buf, ((C_SCHEME_BLOCK *)string)->data, n);
4057	buf[ n ] = '\0';
4058
4059	n = C_system(buf);
4060
4061	if(buf != buffer) C_free(buf);
4062
4063	return C_fix(n);
4064	}
4065
4066
4067	C_regparm C_word C_fcall C_string_to_pbytevector(C_word s)
4068	{
4069	return C_pbytevector(C_header_size(s), C_data_pointer(s));
4070	}
4071
4072
4073	C_regparm C_word C_fcall C_char_ready_p(C_word port)
4074	{
4075	#if !defined(C_NONUNIX)
4076	fd_set fs;
4077	struct timeval to;
4078	int fd = C_fileno(C_port_file(port));
4079
4080	FD_ZERO(&fs);
4081	FD_SET(fd, &fs);
4082	to.tv_sec = to.tv_usec = 0;
4083	return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
4084	#else
4085	return C_SCHEME_TRUE;
4086	#endif
4087	}
4088
4089
4090	C_regparm C_word C_fcall C_flush_output(C_word port)
4091	{
4092	C_fflush(C_port_file(port));
4093	return C_SCHEME_UNDEFINED;
4094	}
4095
4096
4097	C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
4098	{
4099	int i, j;
4100	long tgc;
4101
4102	switch(fudge_factor) {
4103	case C_fix(1): return C_SCHEME_END_OF_FILE;
4104	case C_fix(2):
4105	/* can be considered broken (overflows into negatives), but is useful for randomize */
4106	return C_fix(C_MOST_POSITIVE_FIXNUM & time(NULL));
4107
4108	case C_fix(3):
4109	#ifdef C_SIXTY_FOUR
4110	return C_SCHEME_TRUE;
4111	#else
4112	return C_SCHEME_FALSE;
4113	#endif
4114
4115	case C_fix(4):
4116	#ifdef C_GENERIC_CONSOLE
4117	return C_SCHEME_TRUE;
4118	#else
4119	return C_SCHEME_FALSE;
4120	#endif
4121
4122	case C_fix(5):
4123	#ifdef C_GENERIC_CONSOLE
4124	return C_fix(0);
4125	#elif defined(C_WINDOWS_GUI)
4126	return C_fix(1);
4127	#else
4128	return C_SCHEME_FALSE;
4129	#endif
4130
4131	case C_fix(6):
4132	return C_fix(C_MOST_POSITIVE_FIXNUM & cpu_milliseconds());
4133
4134	case C_fix(7):
4135	return C_fix(sizeof(C_word));
4136
4137	case C_fix(8):
4138	return C_fix(C_wordsperdouble(1));
4139
4140	case C_fix(9):
4141	return C_fix(last_interrupt_latency);
4142
4143	case C_fix(10):
4144	return C_fix(CLOCKS_PER_SEC);
4145
4146	case C_fix(11):
4147	#ifdef MACINTOSH_GUI
4148	return C_SCHEME_TRUE;
4149	#else
4150	return C_SCHEME_FALSE;
4151	#endif
4152
4153	case C_fix(12):
4154	return C_mk_bool(fake_tty_flag);
4155
4156	case C_fix(13):
4157	return C_mk_bool(debug_mode);
4158
4159	case C_fix(14):
4160	return C_mk_bool(C_interrupts_enabled);
4161
4162	case C_fix(15):
4163	return C_mk_bool(C_enable_gcweak);
4164
4165	case C_fix(16):
4166	return C_fix(C_MOST_POSITIVE_FIXNUM & milliseconds());
4167
4168	case C_fix(17):
4169	return(C_mk_bool(C_heap_size_is_fixed));
4170
4171	case C_fix(18):
4172	return(C_fix(C_STACK_GROWS_DOWNWARD));
4173
4174	case C_fix(19):
4175	for(i = j = 0; i < locative_table_count; ++i)
4176	if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j;
4177
4178	return C_fix(j);
4179
4180	case C_fix(20):
4181	#ifdef C_UNSAFE_RUNTIME
4182	return C_SCHEME_TRUE;
4183	#else
4184	return C_SCHEME_FALSE;
4185	#endif
4186
4187	case C_fix(21):
4188	return C_fix(C_MOST_POSITIVE_FIXNUM);
4189
4190	case C_fix(22):
4191	#ifdef C_LOCK_TOSPACE
4192	return C_SCHEME_TRUE;
4193	#else
4194	return C_SCHEME_FALSE;
4195	#endif
4196
4197	case C_fix(23):
4198	return C_fix(C_startup_time_seconds);
4199
4200	case C_fix(24):
4201	#ifdef NO_DLOAD2
4202	return C_SCHEME_FALSE;
4203	#else
4204	return C_SCHEME_TRUE;
4205	#endif
4206
4207	case C_fix(25):
4208	return C_mk_bool(C_enable_repl);
4209
4210	case C_fix(26):
4211	return C_fix(live_finalizer_count);
4212
4213	case C_fix(27):
4214	return C_fix(allocated_finalizer_count);
4215
4216	case C_fix(28):
4217	#ifdef C_ENABLE_PTABLES
4218	return C_SCHEME_TRUE;
4219	#else
4220	return C_SCHEME_FALSE;
4221	#endif
4222
4223	case C_fix(29):
4224	return C_fix(C_trace_buffer_size);
4225
4226	case C_fix(30):
4227	#ifdef _MSC_VER
4228	return C_fix(_MSC_VER);
4229	#else
4230	return C_SCHEME_FALSE;
4231	#endif
4232
4233	case C_fix(31):
4234	tgc = timer_accumulated_gc_ms;
4235	timer_accumulated_gc_ms = 0;
4236	return C_fix(tgc);
4237
4238	case C_fix(32):
4239	#ifdef C_GC_HOOKS
4240	return C_SCHEME_TRUE;
4241	#else
4242	return C_SCHEME_FALSE;
4243	#endif
4244
4245	case C_fix(33):
4246	return C_SCHEME_TRUE;
4247
4248	case C_fix(34):
4249	#ifdef C_HACKED_APPLY
4250	return C_fix(TEMPORARY_STACK_SIZE);
4251	#else
4252	return C_fix(126);
4253	#endif
4254
4255	case C_fix(35):
4256	#ifndef C_NO_APPLY_HOOK
4257	return C_SCHEME_TRUE;
4258	#else
4259	return C_SCHEME_FALSE;
4260	#endif
4261
4262	case C_fix(36):
4263	debug_mode = !debug_mode;
4264	return C_mk_bool(debug_mode);
4265
4266	case C_fix(37):
4267	#ifdef C_USE_HOST_PCRE
4268	return C_SCHEME_TRUE;
4269	#else
4270	return C_SCHEME_FALSE;
4271	#endif
4272
4273	case C_fix(38):
4274	#ifdef C_SVN_REVISION
4275	return C_fix(C_SVN_REVISION);
4276	#else
4277	return C_fix(0);
4278	#endif
4279
4280	case C_fix(39):
4281	#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
4282	return C_SCHEME_TRUE;
4283	#else
4284	return C_SCHEME_FALSE;
4285	#endif
4286
4287	case C_fix(40):
4288	#if defined(C_HACKED_APPLY)
4289	return C_SCHEME_TRUE;
4290	#else
4291	return C_SCHEME_FALSE;
4292	#endif
4293
4294	case C_fix(41):
4295	return C_fix(C_MAJOR_VERSION);
4296
4297	case C_fix(42):
4298	#ifdef C_BINARY_VERSION
4299	return C_fix(C_BINARY_VERSION);
4300	#else
4301	return C_SCHEME_FALSE;
4302	#endif
4303
4304	default: return C_SCHEME_UNDEFINED;
4305	}
4306	}
4307
4308
4309	C_regparm void C_fcall C_paranoid_check_for_interrupt(void)
4310	{
4311	if(--C_timer_interrupt_counter <= 0)
4312	C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER);
4313	}
4314
4315
4316	C_regparm void C_fcall C_raise_interrupt(int reason)
4317	{
4318	if(C_interrupts_enabled) {
4319	saved_stack_limit = C_stack_limit;
4320
4321	#if C_STACK_GROWS_DOWNWARD
4322	C_stack_limit = C_stack_pointer + 1000;
4323	#else
4324	C_stack_limit = C_stack_pointer - 1000;
4325	#endif
4326
4327	interrupt_reason = reason;
4328	interrupt_time = cpu_milliseconds();
4329	}
4330	}
4331
4332
4333	C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
4334	{
4335	C_initial_timer_interrupt_period = C_unfix(n);
4336	return C_SCHEME_UNDEFINED;
4337	}
4338
4339
4340	C_regparm C_word C_fcall C_enable_interrupts(void)
4341	{
4342	C_timer_interrupt_counter = C_initial_timer_interrupt_period;
4343	/* assert(C_timer_interrupt_counter > 0); */
4344	C_interrupts_enabled = 1;
4345	return C_SCHEME_UNDEFINED;
4346	}
4347
4348
4349	C_regparm C_word C_fcall C_disable_interrupts(void)
4350	{
4351	C_interrupts_enabled = 0;
4352	return C_SCHEME_UNDEFINED;
4353	}
4354
4355
4356	C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason)
4357	{
4358	int sig = C_unfix(signum);
4359
4360	if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
4361	else {
4362	signal_mapping_table[ sig ] = C_unfix(reason);
4363	C_signal(sig, global_signal_handler);
4364	}
4365
4366	return C_SCHEME_UNDEFINED;
4367	}
4368
4369
4370	C_regparm C_word C_fcall C_flonum_in_fixnum_range_p(C_word n)
4371	{
4372	double f = C_flonum_magnitude(n);
4373
4374	return C_mk_bool(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM);
4375	}
4376
4377
4378	C_regparm C_word C_fcall C_double_to_number(C_word n)
4379	{
4380	double m, f = C_flonum_magnitude(n);
4381
4382	if(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
4383	return C_fix(f);
4384	else return n;
4385	}
4386
4387
4388	C_regparm C_word C_fcall C_fits_in_int_p(C_word x)
4389	{
4390	double n, m;
4391
4392	if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4393
4394	n = C_flonum_magnitude(x);
4395	return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
4396	}
4397
4398
4399	C_regparm C_word C_fcall C_fits_in_unsigned_int_p(C_word x)
4400	{
4401	double n, m;
4402
4403	if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4404
4405	n = C_flonum_magnitude(x);
4406	return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
4407	}
4408
4409
4410	/* Copy blocks into collected or static memory: */
4411
4412	C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
4413	{
4414	int n = C_header_size(from);
4415	long bytes;
4416
4417	if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
4418	bytes = n;
4419	C_memcpy((C_SCHEME_BLOCK )to, (C_SCHEME_BLOCK )from, bytes + sizeof(C_header));
4420	}
4421	else {
4422	bytes = C_wordstobytes(n);
4423	C_memcpy((C_SCHEME_BLOCK )to, (C_SCHEME_BLOCK )from, bytes + sizeof(C_header));
4424	}
4425
4426	return to;
4427	}
4428
4429
4430	C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
4431	{
4432	int n = C_header_size(from);
4433	long bytes;
4434	C_word p = (C_word )C_pointer_address(ptr);
4435
4436	if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
4437	else bytes = C_wordstobytes(n);
4438
4439	C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4440	return (C_word)p;
4441	}
4442
4443
4444	/* Conversion routines: */
4445
4446	C_regparm double C_fcall C_c_double(C_word x)
4447	{
4448	if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
4449	else return C_flonum_magnitude(x);
4450	}
4451
4452
4453	C_regparm C_word C_fcall C_num_to_int(C_word x)
4454	{
4455	if(x & C_FIXNUM_BIT) return C_unfix(x);
4456	else return (int)C_flonum_magnitude(x);
4457	}
4458
4459
4460	C_regparm C_s64 C_fcall C_num_to_int64(C_word x)
4461	{
4462	if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
4463	else return (C_s64)C_flonum_magnitude(x);
4464	}
4465
4466
4467	C_regparm C_uword C_fcall C_num_to_unsigned_int(C_word x)
4468	{
4469	if(x & C_FIXNUM_BIT) return C_unfix(x);
4470	else return (unsigned int)C_flonum_magnitude(x);
4471	}
4472
4473
4474	C_regparm C_word C_fcall C_int_to_num(C_word **ptr, C_word n)
4475	{
4476	if(C_fitsinfixnump(n)) return C_fix(n);
4477	else return C_flonum(ptr, (double)n);
4478	}
4479
4480
4481	C_regparm C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n)
4482	{
4483	if(C_ufitsinfixnump(n)) return C_fix(n);
4484	else return C_flonum(ptr, (double)n);
4485	}
4486
4487
4488	C_regparm C_word C_fcall C_long_to_num(C_word **ptr, long n)
4489	{
4490	if(C_fitsinfixnump(n)) return C_fix(n);
4491	else return C_flonum(ptr, (double)n);
4492	}
4493
4494
4495	C_regparm C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n)
4496	{
4497	if(C_ufitsinfixnump(n)) return C_fix(n);
4498	else return C_flonum(ptr, (double)n);
4499	}
4500
4501
4502	C_regparm C_word C_fcall C_flonum_in_int_range_p(C_word n)
4503	{
4504	double m = C_flonum_magnitude(n);
4505
4506	return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
4507	}
4508
4509
4510	C_regparm C_word C_fcall C_flonum_in_uint_range_p(C_word n)
4511	{
4512	double m = C_flonum_magnitude(n);
4513
4514	return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
4515	}
4516
4517
4518	C_regparm char *C_fcall C_string_or_null(C_word x)
4519	{
4520	return C_truep(x) ? C_c_string(x) : NULL;
4521	}
4522
4523
4524	C_regparm void *C_fcall C_data_pointer_or_null(C_word x)
4525	{
4526	return C_truep(x) ? C_data_pointer(x) : NULL;
4527	}
4528
4529
4530	C_regparm void *C_fcall C_srfi_4_vector_or_null(C_word x)
4531	{
4532	return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
4533	}
4534
4535
4536	C_regparm void *C_fcall C_c_pointer_or_null(C_word x)
4537	{
4538	return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
4539	}
4540
4541
4542	C_regparm void *C_fcall C_scheme_or_c_pointer(C_word x)
4543	{
4544	return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
4545	}
4546
4547
4548	C_regparm long C_fcall C_num_to_long(C_word x)
4549	{
4550	if(x & C_FIXNUM_BIT) return C_unfix(x);
4551	else return (long)C_flonum_magnitude(x);
4552	}
4553
4554
4555	C_regparm unsigned long C_fcall C_num_to_unsigned_long(C_word x)
4556	{
4557	if(x & C_FIXNUM_BIT) return C_unfix(x);
4558	else return (unsigned long)C_flonum_magnitude(x);
4559	}
4560
4561
4562	/* Inline versions of some standard procedures: */
4563
4564	C_regparm C_word C_fcall C_i_listp(C_word x)
4565	{
4566	C_word fast = x, slow = x;
4567
4568	while(fast != C_SCHEME_END_OF_LIST)
4569	if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
4570	fast = C_u_i_cdr(fast);
4571
4572	if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
4573	else if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
4574	fast = C_u_i_cdr(fast);
4575	slow = C_u_i_cdr(slow);
4576
4577	if(fast == slow) return C_SCHEME_FALSE;
4578	}
4579	else return C_SCHEME_FALSE;
4580	}
4581	else return C_SCHEME_FALSE;
4582
4583	return C_SCHEME_TRUE;
4584	}
4585
4586
4587	C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
4588	{
4589	C_word n;
4590
4591	if(C_immediatep(x) \|\| C_header_bits(x) != C_STRING_TYPE)
4592	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);
4593
4594	if(C_immediatep(y) \|\| C_header_bits(y) != C_STRING_TYPE)
4595	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);
4596
4597	n = C_header_size(x);
4598
4599	return C_mk_bool(n == C_header_size(y) && !C_memcmp((char )C_data_pointer(x), (char )C_data_pointer(y), n));
4600	}
4601
4602
4603	C_regparm C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y)
4604	{
4605	C_word n;
4606
4607	n = C_header_size(x);
4608	return C_mk_bool(n == C_header_size(y) && !C_memcmp((char )C_data_pointer(x), (char )C_data_pointer(y), n));
4609	}
4610
4611
4612	C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
4613	{
4614	C_word n;
4615	char p1, p2;
4616
4617	if(C_immediatep(x) \|\| C_header_bits(x) != C_STRING_TYPE)
4618	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);
4619
4620	if(C_immediatep(y) \|\| C_header_bits(y) != C_STRING_TYPE)
4621	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);
4622
4623	n = C_header_size(x);
4624
4625	if(n != C_header_size(y)) return C_SCHEME_FALSE;
4626
4627	p1 = (char *)C_data_pointer(x);
4628	p2 = (char *)C_data_pointer(y);
4629
4630	while(n--)
4631	if(C_tolower((p1++)) != C_tolower((p2++))) return C_SCHEME_FALSE;
4632
4633	return C_SCHEME_TRUE;
4634	}
4635
4636
4637	C_regparm C_word C_fcall C_i_eqvp(C_word x, C_word y)
4638	{
4639	return
4640	C_mk_bool(x == y \|\|
4641	(!C_immediatep(x) && !C_immediatep(y) &&
4642	C_block_header(x) == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG &&
4643	C_flonum_magnitude(x) == C_flonum_magnitude(y) ) );
4644	}
4645
4646
4647	C_regparm C_word C_fcall C_i_symbolp(C_word x)
4648	{
4649	return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG);
4650	}
4651
4652
4653	C_regparm C_word C_fcall C_i_pairp(C_word x)
4654	{
4655	return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
4656	}
4657
4658
4659	C_regparm C_word C_fcall C_i_stringp(C_word x)
4660	{
4661	return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
4662	}
4663
4664
4665	C_regparm C_word C_fcall C_i_locativep(C_word x)
4666	{
4667	return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
4668	}
4669
4670
4671	C_regparm C_word C_fcall C_i_vectorp(C_word x)
4672	{
4673	return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
4674	}
4675
4676
4677	C_regparm C_word C_fcall C_i_portp(C_word x)
4678	{
4679	return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
4680	}
4681
4682
4683	C_regparm C_word C_fcall C_i_closurep(C_word x)
4684	{
4685	return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
4686	}
4687
4688
4689	C_regparm C_word C_fcall C_i_numberp(C_word x)
4690	{
4691	return C_mk_bool((x & C_FIXNUM_BIT) \|\| (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
4692	}
4693
4694
4695	C_regparm C_word C_fcall C_i_integerp(C_word x)
4696	{
4697	double dummy;
4698
4699	return C_mk_bool((x & C_FIXNUM_BIT) \|\|
4700	((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
4701	modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
4702	}
4703
4704
4705	C_regparm C_word C_fcall C_i_flonump(C_word x)
4706	{
4707	return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
4708	}
4709
4710
4711	C_regparm C_word C_fcall C_i_finitep(C_word x)
4712	{
4713	if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
4714	else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
4715	}
4716
4717
4718	C_regparm C_word C_fcall C_i_fixnum_min(C_word x, C_word y)
4719	{
4720	return ((C_word)x < (C_word)y) ? x : y;
4721	}
4722
4723
4724	C_regparm C_word C_fcall C_i_fixnum_max(C_word x, C_word y)
4725	{
4726	return ((C_word)x > (C_word)y) ? x : y;
4727	}
4728
4729
4730	C_regparm C_word C_fcall C_i_flonum_min(C_word x, C_word y)
4731	{
4732	double
4733	xf = C_flonum_magnitude(x),
4734	yf = C_flonum_magnitude(y);
4735
4736	return xf < yf ? x : y;
4737	}
4738
4739
4740	C_regparm C_word C_fcall C_i_flonum_max(C_word x, C_word y)
4741	{
4742	double
4743	xf = C_flonum_magnitude(x),
4744	yf = C_flonum_magnitude(y);
4745
4746	return xf > yf ? x : y;
4747	}
4748
4749
4750	#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
4751
4752	C_word C_a_i(C_word *a, int n)
4753	{
4754	C_word p = a;
4755
4756	*a += n;
4757	return p;
4758	}
4759
4760	#endif
4761
4762
4763	C_word C_a_i_list(C_word **a, int c, ...)
4764	{
4765	va_list v;
4766	C_word x, last, current,
4767	first = C_SCHEME_END_OF_LIST;
4768
4769	va_start(v, c);
4770
4771	for(last = C_SCHEME_UNDEFINED; c--; last = current) {
4772	x = va_arg(v, C_word);
4773	current = C_pair(a, x, C_SCHEME_END_OF_LIST);
4774
4775	if(last != C_SCHEME_UNDEFINED)
4776	C_set_block_item(last, 1, current);
4777	else first = current;
4778	}
4779
4780	va_end(v);
4781	return first;
4782	}
4783
4784
4785	C_word C_h_list(int c, ...)
4786	{
4787	/* Similar to C_a_i_list(), but put slots with nursery data into mutation stack: */
4788	va_list v;
4789	C_word x, last, current,
4790	first = C_SCHEME_END_OF_LIST;
4791
4792	va_start(v, c);
4793
4794	for(last = C_SCHEME_UNDEFINED; c--; last = current) {
4795	x = va_arg(v, C_word);
4796	current = C_pair(C_heaptop, x, C_SCHEME_END_OF_LIST);
4797
4798	if(C_in_stackp(x))
4799	C_mutate(&C_u_i_car(current), x);
4800
4801	if(last != C_SCHEME_UNDEFINED)
4802	C_set_block_item(last, 1, current);
4803	else first = current;
4804	}
4805
4806	va_end(v);
4807	return first;
4808	}
4809
4810
4811	C_word C_a_i_string(C_word **a, int c, ...)
4812	{
4813	va_list v;
4814	C_word x, s = (C_word)(*a);
4815	char *p;
4816
4817	a = (C_word )((C_word)(*a) + sizeof(C_header) + C_align(c));
4818	((C_SCHEME_BLOCK *)s)->header = C_STRING_TYPE \| c;
4819	p = (char *)C_data_pointer(s);
4820	va_start(v, c);
4821
4822	while(c--) {
4823	x = va_arg(v, C_word);
4824
4825	if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
4826	*(p++) = C_character_code(x);
4827	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);
4828	}
4829
4830	return s;
4831	}
4832
4833
4834	C_word C_a_i_record(C_word **ptr, int n, ...)
4835	{
4836	va_list v;
4837	C_word p = ptr,
4838	*p0 = p;
4839
4840	*(p++) = C_STRUCTURE_TYPE \| n;
4841	va_start(v, n);
4842
4843	while(n--)
4844	*(p++) = va_arg(v, C_word);
4845
4846	*ptr = p;
4847	va_end(v);
4848	return (C_word)p0;
4849	}
4850
4851
4852	C_word C_a_i_port(C_word **ptr, int n)
4853	{
4854	C_word
4855	p = ptr,
4856	*p0 = p;
4857	int i;
4858
4859	*(p++) = C_PORT_TYPE \| (C_SIZEOF_PORT - 1);
4860	*(p++) = (C_word)NULL;
4861
4862	for(i = 0; i < C_SIZEOF_PORT - 2; ++i)
4863	*(p++) = C_SCHEME_FALSE;
4864
4865	*ptr = p;
4866	return (C_word)p0;
4867	}
4868
4869
4870	C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
4871	{
4872	C_word p = ptr,
4873	*p0;
4874	int n = C_unfix(num);
4875
4876	#ifndef C_SIXTY_FOUR
4877	/* Align on 8-byte boundary: */
4878	if(aligned8(p)) ++p;
4879	#endif
4880
4881	p0 = p;
4882	*(p++) = C_BYTEVECTOR_TYPE \| C_wordstobytes(n);
4883	*ptr = p + n;
4884	return (C_word)p0;
4885	}
4886
4887
4888	C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
4889	{
4890	C_word
4891	p = ptr,
4892	*p0 = p;
4893	void *mp;
4894
4895	if(C_immediatep(x)) mp = NULL;
4896	else if((C_header_bits(x) && C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);
4897	else mp = C_data_pointer(x);
4898
4899	*(p++) = C_POINTER_TYPE \| 1;
4900	((void *)p) = mp;
4901	*ptr = p + 1;
4902	return (C_word)p0;
4903	}
4904
4905
4906	C_regparm C_word C_fcall C_i_exactp(C_word x)
4907	{
4908	if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4909
4910	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
4911	barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact?", x);
4912
4913	return C_SCHEME_FALSE;
4914	}
4915
4916
4917	C_regparm C_word C_fcall C_u_i_exactp(C_word x)
4918	{
4919	if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4920
4921	return C_SCHEME_FALSE;
4922	}
4923
4924
4925	C_regparm C_word C_fcall C_i_inexactp(C_word x)
4926	{
4927	if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
4928
4929	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
4930	barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact?", x);
4931
4932	return C_SCHEME_TRUE;
4933	}
4934
4935
4936	C_regparm C_word C_fcall C_u_i_inexactp(C_word x)
4937	{
4938	if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
4939
4940	return C_SCHEME_TRUE;
4941	}
4942
4943
4944	C_regparm C_word C_fcall C_i_zerop(C_word x)
4945	{
4946	if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
4947
4948	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
4949	barf(C_BAD_ARGUMENT_TYPE_ERROR, "zero?", x);
4950
4951	return C_mk_bool(C_flonum_magnitude(x) == 0.0);
4952	}
4953
4954
4955	C_regparm C_word C_fcall C_u_i_zerop(C_word x)
4956	{
4957	if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
4958
4959	return C_mk_bool(C_flonum_magnitude(x) == 0.0);
4960	}
4961
4962
4963	C_regparm C_word C_fcall C_i_positivep(C_word x)
4964	{
4965	if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
4966
4967	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
4968	barf(C_BAD_ARGUMENT_TYPE_ERROR, "positive?", x);
4969
4970	return C_mk_bool(C_flonum_magnitude(x) > 0.0);
4971	}
4972
4973
4974	C_regparm C_word C_fcall C_u_i_positivep(C_word x)
4975	{
4976	if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
4977
4978	return C_mk_bool(C_flonum_magnitude(x) > 0.0);
4979	}
4980
4981
4982	C_regparm C_word C_fcall C_i_negativep(C_word x)
4983	{
4984	if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
4985
4986	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
4987	barf(C_BAD_ARGUMENT_TYPE_ERROR, "negative?", x);
4988
4989	return C_mk_bool(C_flonum_magnitude(x) < 0.0);
4990	}
4991
4992
4993	C_regparm C_word C_fcall C_u_i_negativep(C_word x)
4994	{
4995	if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
4996
4997	return C_mk_bool(C_flonum_magnitude(x) < 0.0);
4998	}
4999
5000
5001	C_regparm C_word C_fcall C_i_evenp(C_word x)
5002	{
5003	if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
5004
5005	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
5006	barf(C_BAD_ARGUMENT_TYPE_ERROR, "even?", x);
5007
5008	return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
5009	}
5010
5011
5012	C_regparm C_word C_fcall C_u_i_evenp(C_word x)
5013	{
5014	if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
5015
5016	return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
5017	}
5018
5019
5020	C_regparm C_word C_fcall C_i_oddp(C_word x)
5021	{
5022	if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
5023
5024	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
5025	barf(C_BAD_ARGUMENT_TYPE_ERROR, "odd?", x);
5026
5027	return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
5028	}
5029
5030
5031	C_regparm C_word C_fcall C_u_i_oddp(C_word x)
5032	{
5033	if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
5034
5035	return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
5036	}
5037
5038
5039	C_regparm C_word C_fcall C_i_car(C_word x)
5040	{
5041	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG)
5042	barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);
5043
5044	return C_u_i_car(x);
5045	}
5046
5047
5048	C_regparm C_word C_fcall C_i_cdr(C_word x)
5049	{
5050	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG)
5051	barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);
5052
5053	return C_u_i_cdr(x);
5054	}
5055
5056
5057	C_regparm C_word C_fcall C_i_cadr(C_word x)
5058	{
5059	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5060	bad:
5061	barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);
5062	}
5063
5064	x = C_u_i_cdr(x);
5065	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5066
5067	return C_u_i_car(x);
5068	}
5069
5070
5071	C_regparm C_word C_fcall C_i_cddr(C_word x)
5072	{
5073	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5074	bad:
5075	barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);
5076	}
5077
5078	x = C_u_i_cdr(x);
5079	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5080
5081	return C_u_i_cdr(x);
5082	}
5083
5084
5085	C_regparm C_word C_fcall C_i_caddr(C_word x)
5086	{
5087	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5088	bad:
5089	barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);
5090	}
5091
5092	x = C_u_i_cdr(x);
5093	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5094	x = C_u_i_cdr(x);
5095	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5096
5097	return C_u_i_car(x);
5098	}
5099
5100
5101	C_regparm C_word C_fcall C_i_cdddr(C_word x)
5102	{
5103	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5104	bad:
5105	barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);
5106	}
5107
5108	x = C_u_i_cdr(x);
5109	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5110	x = C_u_i_cdr(x);
5111	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5112
5113	return C_u_i_cdr(x);
5114	}
5115
5116
5117	C_regparm C_word C_fcall C_i_cadddr(C_word x)
5118	{
5119	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5120	bad:
5121	barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);
5122	}
5123
5124	x = C_u_i_cdr(x);
5125	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5126	x = C_u_i_cdr(x);
5127	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5128	x = C_u_i_cdr(x);
5129	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5130
5131	return C_u_i_car(x);
5132	}
5133
5134
5135	C_regparm C_word C_fcall C_i_cddddr(C_word x)
5136	{
5137	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5138	bad:
5139	barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);
5140	}
5141
5142	x = C_u_i_cdr(x);
5143	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5144	x = C_u_i_cdr(x);
5145	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5146	x = C_u_i_cdr(x);
5147	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) goto bad;
5148
5149	return C_u_i_cdr(x);
5150	}
5151
5152
5153	C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
5154	{
5155	C_word lst0 = lst;
5156	int n;
5157
5158	if(i & C_FIXNUM_BIT) n = C_unfix(i);
5159	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);
5160
5161	while(n--) {
5162	if(C_immediatep(lst) \|\| C_block_header(lst) != C_PAIR_TAG)
5163	barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);
5164
5165	lst = C_u_i_cdr(lst);
5166	}
5167
5168	return lst;
5169	}
5170
5171
5172	C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
5173	{
5174	int j;
5175
5176	if(C_immediatep(v) \|\| C_header_bits(v) != C_VECTOR_TYPE)
5177	barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);
5178
5179	if(i & C_FIXNUM_BIT) {
5180	j = C_unfix(i);
5181
5182	if(j < 0 \|\| j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-ref", v, i);
5183
5184	return C_block_item(v, j);
5185	}
5186
5187	barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);
5188	return C_SCHEME_UNDEFINED;
5189	}
5190
5191
5192	C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
5193	{
5194	int j;
5195
5196	if(C_immediatep(x) \|\| (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)
5197	barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);
5198
5199	if(i & C_FIXNUM_BIT) {
5200	j = C_unfix(i);
5201
5202	if(j < 0 \|\| j >= C_header_size(x)) barf(C_OUT_OF_RANGE_ERROR, "##sys#block-ref", x, i);
5203
5204	return C_block_item(x, j);
5205	}
5206
5207	barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);
5208	return C_SCHEME_UNDEFINED;
5209	}
5210
5211
5212	C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)
5213	{
5214	int j;
5215
5216	if(C_immediatep(s) \|\| C_header_bits(s) != C_STRING_TYPE)
5217	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);
5218
5219	if(!C_immediatep(c) \|\| (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5220	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);
5221
5222	if(i & C_FIXNUM_BIT) {
5223	j = C_unfix(i);
5224
5225	if(j < 0 \|\| j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-set!", s, i);
5226
5227	return C_setsubchar(s, i, c);
5228	}
5229
5230	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);
5231	return C_SCHEME_UNDEFINED;
5232	}
5233
5234
5235	C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
5236	{
5237	int j;
5238
5239	if(C_immediatep(s) \|\| C_header_bits(s) != C_STRING_TYPE)
5240	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);
5241
5242	if(i & C_FIXNUM_BIT) {
5243	j = C_unfix(i);
5244
5245	if(j < 0 \|\| j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-ref", s, i);
5246
5247	return C_subchar(s, i);
5248	}
5249
5250	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);
5251	return C_SCHEME_UNDEFINED;
5252	}
5253
5254
5255	C_regparm C_word C_fcall C_i_vector_length(C_word v)
5256	{
5257	if(C_immediatep(v) \|\| C_header_bits(v) != C_VECTOR_TYPE)
5258	barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);
5259
5260	return C_fix(C_header_size(v));
5261	}
5262
5263
5264	C_regparm C_word C_fcall C_i_string_length(C_word s)
5265	{
5266	if(C_immediatep(s) \|\| C_header_bits(s) != C_STRING_TYPE)
5267	barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);
5268
5269	return C_fix(C_header_size(s));
5270	}
5271
5272
5273	C_regparm C_word C_fcall C_i_length(C_word lst)
5274	{
5275	int n = 0;
5276
5277	if(lst != C_SCHEME_END_OF_LIST) {
5278	if(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5279	do {
5280	lst = C_u_i_cdr(lst);
5281	++n;
5282	} while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG);
5283	}
5284	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "length", lst);
5285	}
5286
5287	return C_fix(n);
5288	}
5289
5290
5291	C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
5292	{
5293	double m;
5294	C_word r;
5295
5296	if(n & C_FIXNUM_BIT) return n;
5297	else if(C_immediatep(n) \|\| C_block_header(n) != C_FLONUM_TAG)
5298	barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
5299
5300	if(modf(C_flonum_magnitude(n), &m) == 0.0) {
5301	r = (C_word)m;
5302
5303	if(r == m && C_fitsinfixnump(r))
5304	return C_fix(r);
5305	}
5306
5307	barf(C_CANT_REPRESENT_INEXACT_ERROR, "inexact->exact", n);
5308	return 0;
5309	}
5310
5311
5312	C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
5313	{
5314	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG)
5315	barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);
5316
5317	C_mutate(&C_u_i_car(x), val);
5318	return C_SCHEME_UNDEFINED;
5319	}
5320
5321
5322	C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
5323	{
5324	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG)
5325	barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);
5326
5327	C_mutate(&C_u_i_cdr(x), val);
5328	return C_SCHEME_UNDEFINED;
5329	}
5330
5331
5332	C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
5333	{
5334	int j;
5335
5336	if(C_immediatep(v) \|\| C_header_bits(v) != C_VECTOR_TYPE)
5337	barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);
5338
5339	if(i & C_FIXNUM_BIT) {
5340	j = C_unfix(i);
5341
5342	if(j < 0 \|\| j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-set!", v, i);
5343
5344	C_mutate(&C_block_item(v, j), x);
5345	}
5346	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);
5347
5348	return C_SCHEME_UNDEFINED;
5349	}
5350
5351
5352	C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
5353	{
5354	if(x & C_FIXNUM_BIT) return C_fix(abs(C_unfix(x)));
5355
5356	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
5357	barf(C_BAD_ARGUMENT_TYPE_ERROR, "abs", x);
5358
5359	return C_flonum(a, fabs(C_flonum_magnitude(x)));
5360	}
5361
5362
5363	C_regparm C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2)
5364	{
5365	return C_flonum(a, C_flonum_magnitude(n1) + C_flonum_magnitude(n2));
5366	}
5367
5368
5369	C_regparm C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2)
5370	{
5371	return C_flonum(a, C_flonum_magnitude(n1) - C_flonum_magnitude(n2));
5372	}
5373
5374
5375	C_regparm C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2)
5376	{
5377	return C_flonum(a, C_flonum_magnitude(n1) * C_flonum_magnitude(n2));
5378	}
5379
5380
5381	C_regparm C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2)
5382	{
5383	return C_flonum(a, C_flonum_magnitude(n1) / C_flonum_magnitude(n2));
5384	}
5385
5386
5387	C_regparm C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n)
5388	{
5389	return C_flonum(a, -C_flonum_magnitude(n));
5390	}
5391
5392
5393	C_regparm C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2)
5394	{
5395	double f1, f2;
5396	C_uword nn1, nn2;
5397
5398	# ifdef BITWISE_UINT_ONLY
5399	C_check_uint(n1, f1, nn1, "bitwise-and");
5400	C_check_uint(n2, f2, nn2, "bitwise-and");
5401	# else
5402	C_check_uintX(n1, f1, nn1, "bitwise-and");
5403	C_check_uintX(n2, f2, nn2, "bitwise-and");
5404	# endif
5405	nn1 = C_limit_fixnum(nn1 & nn2);
5406
5407	if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5408	else return C_flonum(a, nn1);
5409	}
5410
5411
5412	C_regparm C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2)
5413	{
5414	double f1, f2;
5415	C_uword nn1, nn2;
5416
5417	# ifdef BITWISE_UINT_ONLY
5418	C_check_uint(n1, f1, nn1, "bitwise-ior");
5419	C_check_uint(n2, f2, nn2, "bitwise-ior");
5420	# else
5421	C_check_uintX(n1, f1, nn1, "bitwise-ior");
5422	C_check_uintX(n2, f2, nn2, "bitwise-ior");
5423	# endif
5424	nn1 = C_limit_fixnum(nn1 \| nn2);
5425
5426	if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5427	else return C_flonum(a, nn1);
5428	}
5429
5430
5431	C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2)
5432	{
5433	double f1, f2;
5434	C_uword nn1, nn2;
5435
5436	# ifdef BITWISE_UINT_ONLY
5437	C_check_uint(n1, f1, nn1, "bitwise-xor");
5438	C_check_uint(n2, f2, nn2, "bitwise-xor");
5439	# else
5440	C_check_uintX(n1, f1, nn1, "bitwise-xor");
5441	C_check_uintX(n2, f2, nn2, "bitwise-xor");
5442	# endif
5443	nn1 = C_limit_fixnum(nn1 ^ nn2);
5444
5445	if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5446	else return C_flonum(a, nn1);
5447	}
5448
5449
5450	C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
5451	{
5452	double f1;
5453	C_uword nn1;
5454	int index;
5455
5456	if((i & C_FIXNUM_BIT) == 0)
5457	barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "bit-set?", i);
5458
5459	index = C_unfix(i);
5460
5461	if(index < 0 \|\| index >= C_WORD_SIZE)
5462	barf(C_OUT_OF_RANGE_ERROR, "bit-set?", n, i);
5463
5464	# ifdef BITWISE_UINT_ONLY
5465	C_check_uint(n, f1, nn1, "bit-set?");
5466	# else
5467	C_check_uintX(n, f1, nn1, "bit-set?");
5468	# endif
5469	return C_mk_bool((nn1 & (1 << index)) != 0);
5470	}
5471
5472
5473	C_regparm C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n)
5474	{
5475	double f;
5476	C_uword nn;
5477
5478	# ifdef BITWISE_UINT_ONLY
5479	C_check_uint(n, f, nn, "bitwise-not");
5480	# else
5481	C_check_uintX(n, f, nn, "bitwise-not");
5482	# endif
5483	nn = C_limit_fixnum(~nn);
5484
5485	if(C_ufitsinfixnump(nn)) return C_fix(nn);
5486	else return C_flonum(a, nn);
5487	}
5488
5489
5490	C_regparm C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2)
5491	{
5492	C_word nn;
5493	C_uword unn;
5494	C_word s;
5495	int sgn = 1;
5496
5497	if((n1 & C_FIXNUM_BIT) != 0) {
5498	nn = C_unfix(n1);
5499
5500	if((sgn = nn < 0 ? -1 : 1) >= 0) unn = nn;
5501	}
5502	else if(C_immediatep(n1) \|\| C_block_header(n1) != C_FLONUM_TAG)
5503	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "arithmetic-shift", n1);
5504	else {
5505	double m, f;
5506
5507	f = C_flonum_magnitude(n1);
5508
5509	if(modf(f, &m) != 0.0)
5510	barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5511
5512	if(f < C_WORD_MIN \|\| f > C_UWORD_MAX)
5513	barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5514	else if(f < 0) {
5515	if(f > C_WORD_MAX)
5516	barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5517	else {
5518	sgn = -1;
5519	nn = (C_word)f;
5520	}
5521	}
5522	else if(f > C_WORD_MAX) unn = (C_uword)f;
5523	else {
5524	nn = (C_word)f;
5525	sgn = -1;
5526	}
5527	}
5528
5529	if((n2 & C_FIXNUM_BIT) != 0) s = C_unfix(n2);
5530	else barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", n2);
5531
5532	if(sgn < 0) {
5533	if(s < 0) nn >>= -s;
5534	else nn <<= s;
5535
5536	if(C_fitsinfixnump(nn)) return C_fix(nn);
5537	else return C_flonum(a, nn);
5538	}
5539	else {
5540	if(s < 0) unn >>= -s;
5541	else unn <<= s;
5542
5543	if(C_ufitsinfixnump(unn)) return C_fix(unn);
5544	else return C_flonum(a, unn);
5545	}
5546	}
5547
5548
5549	C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
5550	{
5551	double f;
5552
5553	C_check_real(n, "exp", f);
5554	return C_flonum(a, exp(f));
5555	}
5556
5557
5558	C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
5559	{
5560	double f;
5561
5562	C_check_real(n, "log", f);
5563	return C_flonum(a, log(f));
5564	}
5565
5566
5567	C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
5568	{
5569	double f;
5570
5571	C_check_real(n, "sin", f);
5572	return C_flonum(a, sin(f));
5573	}
5574
5575
5576	C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
5577	{
5578	double f;
5579
5580	C_check_real(n, "cos", f);
5581	return C_flonum(a, cos(f));
5582	}
5583
5584
5585	C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
5586	{
5587	double f;
5588
5589	C_check_real(n, "tan", f);
5590	return C_flonum(a, tan(f));
5591	}
5592
5593
5594	C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
5595	{
5596	double f;
5597
5598	C_check_real(n, "asin", f);
5599	return C_flonum(a, asin(f));
5600	}
5601
5602
5603	C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
5604	{
5605	double f;
5606
5607	C_check_real(n, "acos", f);
5608	return C_flonum(a, acos(f));
5609	}
5610
5611
5612	C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
5613	{
5614	double f;
5615
5616	C_check_real(n, "atan", f);
5617	return C_flonum(a, atan(f));
5618	}
5619
5620
5621	C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
5622	{
5623	double f1, f2;
5624
5625	C_check_real(n1, "atan", f1);
5626	C_check_real(n2, "atan", f2);
5627	return C_flonum(a, atan2(f1, f2));
5628	}
5629
5630
5631	C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
5632	{
5633	double f;
5634
5635	C_check_real(n, "sqrt", f);
5636	return C_flonum(a, sqrt(f));
5637	}
5638
5639
5640	C_regparm C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c)
5641	{
5642	if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
5643	else return C_fixnum_shift_left(n, c);
5644	}
5645
5646
5647	C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
5648	{
5649	C_word a;
5650
5651	while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5652	a = C_u_i_car(lst);
5653
5654	if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5655	if(C_u_i_car(a) == x) return a;
5656	}
5657	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);
5658
5659	lst = C_u_i_cdr(lst);
5660	}
5661
5662	return C_SCHEME_FALSE;
5663	}
5664
5665
5666	C_regparm C_word C_fcall C_u_i_assq(C_word x, C_word lst)
5667	{
5668	C_word a;
5669
5670	while(!C_immediatep(lst)) {
5671	a = C_u_i_car(lst);
5672
5673	if(C_u_i_car(a) == x) return a;
5674	else lst = C_u_i_cdr(lst);
5675	}
5676
5677	return C_SCHEME_FALSE;
5678	}
5679
5680
5681	C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
5682	{
5683	C_word a;
5684
5685	while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5686	a = C_u_i_car(lst);
5687
5688	if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5689	if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;
5690	}
5691	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);
5692
5693	lst = C_u_i_cdr(lst);
5694	}
5695
5696	return C_SCHEME_FALSE;
5697	}
5698
5699
5700	C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
5701	{
5702	C_word a;
5703
5704	while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5705	a = C_u_i_car(lst);
5706
5707	if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5708	if(C_equalp(C_u_i_car(a), x)) return a;
5709	}
5710	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);
5711
5712	lst = C_u_i_cdr(lst);
5713	}
5714
5715	return C_SCHEME_FALSE;
5716	}
5717
5718
5719	C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
5720	{
5721	while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5722	if(C_u_i_car(lst) == x) return lst;
5723	else lst = C_u_i_cdr(lst);
5724	}
5725
5726	return C_SCHEME_FALSE;
5727	}
5728
5729
5730	C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
5731	{
5732	while(!C_immediatep(lst)) {
5733	if(C_u_i_car(lst) == x) return lst;
5734	else lst = C_u_i_cdr(lst);
5735	}
5736
5737	return C_SCHEME_FALSE;
5738	}
5739
5740
5741	C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
5742	{
5743	while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5744	if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;
5745	else lst = C_u_i_cdr(lst);
5746	}
5747
5748	return C_SCHEME_FALSE;
5749	}
5750
5751
5752	C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
5753	{
5754	while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5755	if(C_equalp(C_u_i_car(lst), x)) return lst;
5756	else lst = C_u_i_cdr(lst);
5757	}
5758
5759	return C_SCHEME_FALSE;
5760	}
5761
5762
5763	/* Inline routines for extended bindings: */
5764
5765	C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
5766	{
5767	if(C_immediatep(x) \|\| (C_header_bits(x) != C_CLOSURE_TYPE)) {
5768	error_location = loc;
5769	barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);
5770	}
5771
5772	return C_SCHEME_UNDEFINED;
5773	}
5774
5775
5776	C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
5777	{
5778	if((x & C_FIXNUM_BIT) == 0) {
5779	error_location = loc;
5780	barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
5781	}
5782
5783	return C_SCHEME_UNDEFINED;
5784	}
5785
5786
5787	C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
5788	{
5789	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG) {
5790	error_location = loc;
5791	barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
5792	}
5793
5794	return C_SCHEME_UNDEFINED;
5795	}
5796
5797
5798	C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
5799	{
5800	if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
5801	error_location = loc;
5802	barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
5803	}
5804
5805	return C_SCHEME_UNDEFINED;
5806	}
5807
5808
5809	C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
5810	{
5811	if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)) {
5812	error_location = loc;
5813	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
5814	}
5815
5816	return C_SCHEME_UNDEFINED;
5817	}
5818
5819
5820	C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
5821	{
5822	if(C_immediatep(x) \|\| C_header_bits(x) != C_STRING_TYPE) {
5823	error_location = loc;
5824	barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
5825	}
5826
5827	return C_SCHEME_UNDEFINED;
5828	}
5829
5830
5831	C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
5832	{
5833	if(C_immediatep(x) \|\| C_header_bits(x) != C_BYTEVECTOR_TYPE) {
5834	error_location = loc;
5835	barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);
5836	}
5837
5838	return C_SCHEME_UNDEFINED;
5839	}
5840
5841
5842	C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
5843	{
5844	if(C_immediatep(x) \|\| C_header_bits(x) != C_VECTOR_TYPE) {
5845	error_location = loc;
5846	barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);
5847	}
5848
5849	return C_SCHEME_UNDEFINED;
5850	}
5851
5852
5853	C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
5854	{
5855	if(C_immediatep(x) \|\| C_header_bits(x) != C_STRUCTURE_TYPE \|\| C_u_i_car(x) != st) {
5856	error_location = loc;
5857	barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);
5858	}
5859
5860	return C_SCHEME_UNDEFINED;
5861	}
5862
5863
5864	C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
5865	{
5866	if(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG) {
5867	error_location = loc;
5868	barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);
5869	}
5870
5871	return C_SCHEME_UNDEFINED;
5872	}
5873
5874
5875	C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
5876	{
5877	if(C_immediatep(x) \|\| C_block_header(x) != C_SYMBOL_TAG) {
5878	error_location = loc;
5879	barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
5880	}
5881
5882	return C_SCHEME_UNDEFINED;
5883	}
5884
5885
5886	C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
5887	{
5888	if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG)) {
5889	error_location = loc;
5890	barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);
5891	}
5892
5893	return C_SCHEME_UNDEFINED;
5894	}
5895
5896
5897	C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
5898	{
5899	if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5900	barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
5901
5902	return x;
5903	}
5904
5905
5906	C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
5907	{
5908	if((x & C_FIXNUM_BIT) == 0)
5909	barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
5910
5911	return x;
5912	}
5913
5914
5915	C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
5916	{
5917	if((x & C_FIXNUM_BIT) != 0) return x;
5918
5919	if(C_immediatep(x) \|\| C_block_header(x) != C_FLONUM_TAG)
5920	barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
5921
5922	return x;
5923	}
5924
5925
5926	C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
5927	{
5928	if(C_immediatep(x))
5929	barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);
5930
5931	return x;
5932	}
5933
5934
5935	C_regparm C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x)
5936	{
5937	if(C_immediatep(x) \|\| C_header_bits(x) != C_STRUCTURE_TYPE \|\| C_block_item(x, 0) != t)
5938	barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR, NULL, x, t);
5939
5940	return x;
5941	}
5942
5943
5944	C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
5945	{
5946	if(C_immediatep(x) \|\| C_header_bits(x) != C_STRING_TYPE)
5947	barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
5948
5949	return x;
5950	}
5951
5952
5953	C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
5954	{
5955	if(C_immediatep(x) \|\| C_header_bits(x) != C_SYMBOL_TYPE)
5956	barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
5957
5958	return x;
5959	}
5960
5961
5962	C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
5963	{
5964	if(C_immediatep(x) \|\|
5965	(C_header_bits(x) != C_SWIG_POINTER_TYPE &&
5966	(C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
5967	barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
5968
5969	return x;
5970	}
5971
5972
5973	C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
5974	{
5975	if(C_immediatep(x) \|\|
5976	(C_header_bits(x) != C_SWIG_POINTER_TYPE &&
5977	(C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
5978	barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
5979
5980	return x;
5981	}
5982
5983
5984	C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
5985	{
5986	if(C_immediatep(x) \|\| (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0 \|\| (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
5987	barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);
5988
5989	return x;
5990	}
5991
5992
5993	C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
5994	{
5995	double m;
5996
5997	if((x & C_FIXNUM_BIT) != 0) return x;
5998
5999	if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6000	m = C_flonum_magnitude(x);
6001
6002	if(m >= C_WORD_MIN && m <= C_WORD_MAX) return x;
6003	}
6004
6005	barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
6006	return C_SCHEME_UNDEFINED;
6007	}
6008
6009
6010	C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
6011	{
6012	double m;
6013
6014	if((x & C_FIXNUM_BIT) != 0) return x;
6015
6016	if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6017	m = C_flonum_magnitude(x);
6018
6019	if(m >= 0 && m <= C_UWORD_MAX) return x;
6020	}
6021
6022	barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
6023	return C_SCHEME_UNDEFINED;
6024	}
6025
6026
6027	C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
6028	{
6029	return C_mk_bool(C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG);
6030	}
6031
6032
6033	C_regparm C_word C_fcall C_i_null_list_p(C_word x)
6034	{
6035	if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
6036	else if(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG) return C_SCHEME_FALSE;
6037	else {
6038	barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);
6039	return C_SCHEME_FALSE;
6040	}
6041	}
6042
6043
6044	C_regparm C_word C_fcall C_i_string_null_p(C_word x)
6045	{
6046	if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)
6047	return C_zero_length_p(x);
6048	else {
6049	barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);
6050	return C_SCHEME_FALSE;
6051	}
6052	}
6053
6054
6055	C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
6056	{
6057	if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)
6058	return C_null_pointerp(x);
6059
6060	barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);
6061	return C_SCHEME_FALSE;
6062	}
6063
6064
6065	/* Primitives: */
6066
6067	void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...)
6068	{
6069	va_list v;
6070	int i, n = c - 3;
6071	C_word x, skip, fn2;
6072	#ifdef C_HACKED_APPLY
6073	C_word *buf = C_temporary_stack_limit;
6074	void *proc;
6075	#endif
6076
6077	#ifndef C_UNSAFE_RUNTIME
6078	if(c < 4) C_bad_min_argc(c, 4);
6079	#endif
6080
6081	fn2 = resolve_procedure(fn, "apply");
6082
6083	va_start(v, fn);
6084
6085	for(i = n; i > 1; --i) {
6086	x = va_arg(v, C_word);
6087	#ifdef C_HACKED_APPLY
6088	*(buf++) = x;
6089	#else
6090	C_save(x);
6091	#endif
6092	}
6093
6094	x = va_arg(v, C_word);
6095
6096	#ifndef C_UNSAFE_RUNTIME
6097	if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) \|\| C_block_header(x) != C_PAIR_TAG))
6098	barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", x);
6099	#endif
6100
6101	for(skip = x; !C_immediatep(skip) && C_block_header(skip) == C_PAIR_TAG; skip = C_u_i_cdr(skip)) {
6102	x = C_u_i_car(skip);
6103
6104	#ifdef C_HACKED_APPLY
6105	# ifndef C_UNSAFE_RUNTIME
6106	if(buf >= C_temporary_stack_bottom) barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6107	# endif
6108
6109	*(buf++) = x;
6110	#else
6111	C_save(x);
6112
6113	# ifndef C_UNSAFE_RUNTIME
6114	if(C_temporary_stack < C_temporary_stack_limit)
6115	barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6116	# endif
6117	#endif
6118	++n;
6119	}
6120
6121	va_end(v);
6122	--n;
6123
6124	#ifdef C_HACKED_APPLY
6125	/* 3 additional args + 1 slot for stack-pointer + two for stack-alignment to 16 bytes */
6126	buf = alloca((n + 6) * sizeof(C_word));
6127	# ifdef __x86_64__
6128	buf = (void *)C_align16((C_uword)buf);
6129	# endif
6130	buf[ 0 ] = n + 2;
6131	buf[ 1 ] = fn2;
6132	buf[ 2 ] = k;
6133	C_memcpy(&buf[ 3 ], C_temporary_stack_limit, n * sizeof(C_word));
6134	proc = (void *)C_block_item(fn2, 0);
6135	# ifdef _MSC_VER
6136	__asm {
6137	mov eax, proc
6138	mov esp, buf
6139	call eax
6140	}
6141	# elif defined(__GNUC__)
6142	C_do_apply_hack(proc, buf, n + 3);
6143	# endif
6144	#endif
6145
6146	C_do_apply(n, fn2, k);
6147	}
6148
6149
6150	void C_ccall C_do_apply(C_word n, C_word fn, C_word k)
6151	{
6152	void pr = (void )C_block_item(fn, 0);
6153	C_word *ptr = C_temporary_stack = C_temporary_stack_bottom;
6154
6155	/* PTR_O_p<P>_<B>(o): list of COUNT = ((2 ** P) * B) '*(ptr-I)' arguments,
6156	* with offset I in range [o, o+COUNT-1].
6157	*/
6158	#define PTR_O_p0_0(o)
6159	#define PTR_O_p1_0(o)
6160	#define PTR_O_p2_0(o)
6161	#define PTR_O_p3_0(o)
6162	#define PTR_O_p4_0(o)
6163	#define PTR_O_p5_0(o)
6164	#define PTR_O_p6_0(o)
6165	#define PTR_O_p7_0(o)
6166	#define PTR_O_p0_1(o) , *(ptr-(o))
6167	#define PTR_O_p1_1(o) , (ptr-(o)), (ptr-(o+1))
6168	#define PTR_O_p2_1(o) PTR_O_p1_1(o) PTR_O_p1_1(o+2)
6169	#define PTR_O_p3_1(o) PTR_O_p2_1(o) PTR_O_p2_1(o+4)
6170	#define PTR_O_p4_1(o) PTR_O_p3_1(o) PTR_O_p3_1(o+8)
6171	#define PTR_O_p5_1(o) PTR_O_p4_1(o) PTR_O_p4_1(o+16)
6172	#define PTR_O_p6_1(o) PTR_O_p5_1(o) PTR_O_p5_1(o+32)
6173	#define PTR_O_p7_1(o) PTR_O_p6_1(o) PTR_O_p6_1(o+64)
6174
6175	/* CASE_C_PROC_p0 (n0, p6,p5,p4,p3,p2,p1,p0):
6176	* let's note <N> = <n0> - 2; the macro inserts:
6177	* case <N>: ((C_cproc<n0>)pr) (<n0>, fn, k, <rest>);
6178	* where <rest> is: (ptr-1), ..., (ptr-<N>)
6179	* (<rest> is empty for <n0> == 2).
6180	* We must have: n0 = SUM (i = 7 to 0, p<i> * (1 << i)).
6181	* CASE_C_PROC_p<N+1> (...):
6182	* like CASE_C_PROC_p<N>, but with doubled output...
6183	*/
6184	#define CASE_C_PROC_p0(n0, p6,p5,p4,p3,p2,p1,p0) \
6185	case (n0-2): ((C_proc##n0)pr)(n0, fn, k \
6186	PTR_O_p6_##p6(((n0-2)&0x80)+1)\
6187	PTR_O_p5_##p5(((n0-2)&0xC0)+1)\
6188	PTR_O_p4_##p4(((n0-2)&0xE0)+1)\
6189	PTR_O_p3_##p3(((n0-2)&0xF0)+1)\
6190	PTR_O_p2_##p2(((n0-2)&0xF8)+1)\
6191	PTR_O_p1_##p1(((n0-2)&0xFC)+1)\
6192	PTR_O_p0_##p0(((n0-2)&0xFE)+1));
6193	#define CASE_C_PROC_p1( n0,n1, p6,p5,p4,p3,p2,p1) \
6194	CASE_C_PROC_p0 (n0, p6,p5,p4,p3,p2,p1,0) \
6195	CASE_C_PROC_p0 (n1, p6,p5,p4,p3,p2,p1,1)
6196	#define CASE_C_PROC_p2( n0,n1,n2,n3, p6,p5,p4,p3,p2) \
6197	CASE_C_PROC_p1 (n0,n1, p6,p5,p4,p3,p2,0) \
6198	CASE_C_PROC_p1 (n2,n3, p6,p5,p4,p3,p2,1)
6199	#define CASE_C_PROC_p3( n0,n1,n2,n3,n4,n5,n6,n7, p6,p5,p4,p3) \
6200	CASE_C_PROC_p2 (n0,n1,n2,n3, p6,p5,p4,p3,0) \
6201	CASE_C_PROC_p2 (n4,n5,n6,n7, p6,p5,p4,p3,1)
6202
6203	switch(n) {
6204	CASE_C_PROC_p3 (2,3,4,5,6,7,8,9, 0,0,0,0)
6205	CASE_C_PROC_p3 (10,11,12,13,14,15,16,17, 0,0,0,1)
6206	CASE_C_PROC_p3 (18,19,20,21,22,23,24,25, 0,0,1,0)
6207	CASE_C_PROC_p3 (26,27,28,29,30,31,32,33, 0,0,1,1)
6208	CASE_C_PROC_p3 (34,35,36,37,38,39,40,41, 0,1,0,0)
6209	CASE_C_PROC_p3 (42,43,44,45,46,47,48,49, 0,1,0,1)
6210	CASE_C_PROC_p3 (50,51,52,53,54,55,56,57, 0,1,1,0)
6211	CASE_C_PROC_p3 (58,59,60,61,62,63,64,65, 0,1,1,1)
6212	CASE_C_PROC_p0 (66, 1,0,0,0,0,0,0)
6213	CASE_C_PROC_p0 (67, 1,0,0,0,0,0,1)
6214	CASE_C_PROC_p1 (68,69, 1,0,0,0,0,1)
6215	CASE_C_PROC_p2 (70,71,72,73, 1,0,0,0,1)
6216	CASE_C_PROC_p3 (74,75,76,77,78,79,80,81, 1,0,0,1)
6217	CASE_C_PROC_p3 (82,83,84,85,86,87,88,89, 1,0,1,0)
6218	CASE_C_PROC_p3 (90,91,92,93,94,95,96,97, 1,0,1,1)
6219	CASE_C_PROC_p3 (98,99,100,101,102,103,104,105, 1,1,0,0)
6220	CASE_C_PROC_p3 (106,107,108,109,110,111,112,113, 1,1,0,1)
6221	CASE_C_PROC_p3 (114,115,116,117,118,119,120,121, 1,1,1,0)
6222	CASE_C_PROC_p2 (122,123,124,125, 1,1,1,1,0)
6223	CASE_C_PROC_p1 (126,127, 1,1,1,1,1,0)
6224	CASE_C_PROC_p0 (128, 1,1,1,1,1,1,0)
6225	default: barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6226	}
6227	}
6228
6229
6230	void C_ccall C_call_cc(C_word c, C_word cl, C_word k, C_word cont)
6231	{
6232	C_word *a = C_alloc(3),
6233	wrapper;
6234	void pr = (void )C_u_i_car(cont);
6235
6236	if(C_immediatep(cont) \|\| C_header_bits(cont) != C_CLOSURE_TYPE)
6237	barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
6238
6239	/* Check for values-continuation: */
6240	if(C_u_i_car(k) == (C_word)values_continuation)
6241	wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);
6242	else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);
6243
6244	((C_proc3)pr)(3, cont, k, wrapper);
6245	}
6246
6247
6248	void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result)
6249	{
6250	C_word cont = C_u_i_cdr(closure);
6251
6252	if(c != 3) C_bad_argc(c, 3);
6253
6254	C_kontinue(cont, result);
6255	}
6256
6257
6258	void C_ccall call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...)
6259	{
6260	va_list v;
6261	C_word cont = C_u_i_cdr(closure),
6262	x1;
6263	int n = c;
6264
6265	va_start(v, k);
6266
6267	if(c > 2) {
6268	x1 = va_arg(v, C_word);
6269	--n;
6270
6271	while(--c > 2) C_save(va_arg(v, C_word));
6272	}
6273	else x1 = C_SCHEME_UNBOUND;
6274
6275	va_end(v);
6276	C_do_apply(n - 2, cont, x1);
6277	}
6278
6279
6280	void C_ccall C_continuation_graft(C_word c, C_word self, C_word k, C_word kk, C_word proc)
6281	{
6282	((C_proc2)C_retrieve_proc(proc))(2, proc, C_block_item(kk, 1));
6283	}
6284
6285
6286	void C_ccall C_values(C_word c, C_word closure, C_word k, ...)
6287	{
6288	va_list v;
6289	C_word n = c;
6290
6291	if(c < 2) C_bad_min_argc(c, 2);
6292
6293	va_start(v, k);
6294
6295	/* Check continuation whether it receives multiple values: */
6296	if(C_block_item(k, 0) == (C_word)values_continuation) {
6297	while(c-- > 2)
6298	C_save(va_arg(v, C_word));
6299
6300	va_end(v);
6301	C_do_apply(n - 2, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
6302	}
6303
6304	if(c != 3) {
6305	#ifdef RELAX_MULTIVAL_CHECK
6306	if(c == 2) n = C_SCHEME_UNDEFINED;
6307	else n = va_arg(v, C_word);
6308	#else
6309	barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
6310	#endif
6311	}
6312	else n = va_arg(v, C_word);
6313
6314	va_end(v);
6315	C_kontinue(k, n);
6316	}
6317
6318
6319	void C_ccall C_apply_values(C_word c, C_word closure, C_word k, C_word lst)
6320	{
6321	C_word n;
6322
6323	#ifndef C_UNSAFE_RUNTIME
6324	if(c != 3) C_bad_argc(c, 3);
6325	#endif
6326
6327	/* Check continuation wether it receives multiple values: */
6328	if(C_block_item(k, 0) == (C_word)values_continuation) {
6329	for(n = 0; !C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG; ++n) {
6330	C_save(C_u_i_car(lst));
6331	lst = C_u_i_cdr(lst);
6332	}
6333
6334	C_do_apply(n, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
6335	}
6336
6337	if(C_immediatep(lst) \|\| (C_block_header(lst) == C_PAIR_TAG && C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)) {
6338	#ifdef RELAX_MULTIVAL_CHECK
6339	if(C_immediatep(lst)) n = C_SCHEME_UNDEFINED;
6340	else n = C_u_i_car(lst);
6341	#else
6342	barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
6343	#endif
6344	}
6345	else n = C_u_i_car(lst);
6346
6347	C_kontinue(k, n);
6348	}
6349
6350
6351	void C_ccall C_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
6352	{
6353	C_word *a = C_alloc(4),
6354	kk;
6355
6356	#ifndef C_UNSAFE_RUNTIME
6357	if(c != 4) C_bad_argc(c, 4);
6358
6359	if(C_immediatep(thunk) \|\| C_header_bits(thunk) != C_CLOSURE_TYPE)
6360	barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);
6361
6362	if(C_immediatep(kont) \|\| C_header_bits(kont) != C_CLOSURE_TYPE)
6363	barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);
6364	#endif
6365
6366	kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
6367	C_do_apply(0, thunk, kk);
6368	}
6369
6370
6371	void C_ccall C_u_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
6372	{
6373	C_word *a = C_alloc(4),
6374	kk;
6375
6376	kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
6377	C_do_apply(0, thunk, kk);
6378	}
6379
6380
6381	void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
6382	{
6383	C_word kont = ((C_SCHEME_BLOCK *)closure)->data[ 1 ],
6384	k = ((C_SCHEME_BLOCK *)closure)->data[ 2 ],
6385	n = c,
6386	*ptr;
6387	va_list v;
6388
6389	if(arg0 == C_SCHEME_UNBOUND) { /* This continuation was called by 'values'... */
6390	va_start(v, arg0);
6391
6392	for(; c-- > 2; C_save(va_arg(v, C_word)));
6393
6394	va_end(v);
6395	}
6396	else { /* This continuation was captured and called explicity... */
6397	++n;
6398	c -= 1;
6399
6400	/* move temporary-stack contents upwards one slot: */
6401	for(ptr = C_temporary_stack - c; --c; ++ptr) *ptr = ptr[ 1 ];
6402
6403	C_save(arg0);
6404	}
6405
6406	C_do_apply(n - 2, kont, k);
6407	}
6408
6409
6410	void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
6411	{
6412	va_list v;
6413	C_word x;
6414	C_word iresult = 1;
6415	int fflag = 0;
6416	double fresult = 1;
6417
6418	va_start(v, k);
6419	c -= 2;
6420
6421	while(c--) {
6422	x = va_arg(v, C_word);
6423
6424	if(x & C_FIXNUM_BIT) {
6425	fresult *= C_unfix(x);
6426
6427	if(!fflag) iresult *= C_unfix(x);
6428	}
6429	else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6430	fresult *= C_flonum_magnitude(x);
6431
6432	if(!fflag) fflag = 1;
6433	}
6434	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
6435	}
6436
6437	va_end(v);
6438	x = C_fix(iresult);
6439
6440	if(fflag \|\| (double)C_unfix(x) != fresult) {
6441	C_temporary_flonum = fresult;
6442	C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6443	}
6444
6445	C_kontinue(k, x);
6446	}
6447
6448
6449	C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
6450	{
6451	C_word iresult;
6452	double fresult;
6453	int fflag = 0;
6454
6455	if(x & C_FIXNUM_BIT) {
6456	if(y & C_FIXNUM_BIT) {
6457	iresult = C_unfix(x) * C_unfix(y);
6458	fresult = (double)C_unfix(x) * (double)C_unfix(y);
6459	}
6460	else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6461	fresult = C_unfix(x) * C_flonum_magnitude(y);
6462	fflag = 1;
6463	}
6464	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
6465	}
6466	else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6467	fflag = 1;
6468
6469	if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) * C_unfix(y);
6470	else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6471	fresult = C_flonum_magnitude(x) * C_flonum_magnitude(y);
6472	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
6473	}
6474	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
6475
6476	iresult = C_fix(iresult);
6477
6478	if(fflag \|\| (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6479
6480	return iresult;
6481	}
6482
6483
6484	void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
6485	{
6486	va_list v;
6487	C_word x;
6488	C_word iresult = 0;
6489	int fflag = 0;
6490	double fresult = 0;
6491
6492	va_start(v, k);
6493	c -= 2;
6494
6495	while(c--) {
6496	x = va_arg(v, C_word);
6497
6498	if(x & C_FIXNUM_BIT) {
6499	fresult += C_unfix(x);
6500
6501	if(!fflag) iresult += C_unfix(x);
6502	}
6503	else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6504	fresult += C_flonum_magnitude(x);
6505
6506	if(!fflag) fflag = 1;
6507	}
6508	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
6509	}
6510
6511	va_end(v);
6512	x = C_fix(iresult);
6513
6514	if(fflag \|\| (double)C_unfix(x) != fresult) {
6515	C_temporary_flonum = fresult;
6516	C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6517	}
6518
6519	C_kontinue(k, x);
6520	}
6521
6522
6523	C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
6524	{
6525	C_word iresult;
6526	double fresult;
6527	int fflag = 0;
6528
6529	if(x & C_FIXNUM_BIT) {
6530	if(y & C_FIXNUM_BIT) {
6531	iresult = C_unfix(x) + C_unfix(y);
6532	fresult = (double)C_unfix(x) + (double)C_unfix(y);
6533	}
6534	else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6535	fresult = C_unfix(x) + C_flonum_magnitude(y);
6536	fflag = 1;
6537	}
6538	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
6539	}
6540	else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6541	fflag = 1;
6542
6543	if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) + C_unfix(y);
6544	else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6545	fresult = C_flonum_magnitude(x) + C_flonum_magnitude(y);
6546	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
6547	}
6548	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
6549
6550	iresult = C_fix(iresult);
6551
6552	if(fflag \|\| (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6553
6554	return iresult;
6555	}
6556
6557
6558	void cons_flonum_trampoline(void *dummy)
6559	{
6560	C_word k = C_restore,
6561	*a = C_alloc(WORDS_PER_FLONUM);
6562
6563	C_kontinue(k, C_flonum(&a, C_temporary_flonum));
6564	}
6565
6566
6567	void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
6568	{
6569	va_list v;
6570	C_word iresult;
6571	int fflag;
6572	double fresult;
6573
6574	if(c < 3) C_bad_min_argc(c, 3);
6575
6576	if(n1 & C_FIXNUM_BIT) {
6577	fresult = iresult = C_unfix(n1);
6578	fflag = 0;
6579	}
6580	else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6581	fresult = C_flonum_magnitude(n1);
6582	fflag = 1;
6583	}
6584	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
6585
6586	if(c == 3) {
6587	if(fflag) fresult = -fresult;
6588	else fresult = iresult = -iresult;
6589
6590	goto cont;
6591	}
6592
6593	va_start(v, n1);
6594	c -= 3;
6595
6596	while(c--) {
6597	n1 = va_arg(v, C_word);
6598
6599	if(n1 & C_FIXNUM_BIT) {
6600	fresult -= C_unfix(n1);
6601
6602	if(!fflag) iresult -= C_unfix(n1);
6603	}
6604	else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6605	fresult -= C_flonum_magnitude(n1);
6606
6607	if(!fflag) fflag = 1;
6608	}
6609	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
6610	}
6611
6612	va_end(v);
6613
6614	cont:
6615	n1 = C_fix(iresult);
6616
6617	if(fflag \|\| (double)C_unfix(n1) != fresult) {
6618	C_temporary_flonum = fresult;
6619	C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6620	}
6621
6622	C_kontinue(k, n1);
6623	}
6624
6625
6626	C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
6627	{
6628	C_word iresult;
6629	double fresult;
6630	int fflag = 0;
6631
6632	if(x & C_FIXNUM_BIT) {
6633	if(y & C_FIXNUM_BIT) {
6634	iresult = C_unfix(x) - C_unfix(y);
6635	fresult = (double)C_unfix(x) - (double)C_unfix(y);
6636	}
6637	else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6638	fresult = C_unfix(x) - C_flonum_magnitude(y);
6639	fflag = 1;
6640	}
6641	else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
6642	}
6643	else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6644	fflag = 1;
6645
6646	if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) - C_unfix(y);
6647	else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6648	fresult = C_flonum_magnitude(x) -