source: project/chicken/trunk/runtime.c @ 5852

Last change on this file since 5852 was 5526, checked in by felix winkelmann, 13 years ago

version 2.636; ugly naming hack in runtime.c and apply-hack files

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