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

Last change on this file since 13948 was 13948, checked in by Kon Lovett, 11 years ago

No srandomev for any Linux. Added LINKER_OPTIMIZATION_OPTIONS to TARGET_LINKER_OPTIMIZATION_OPTIONS.

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