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

Last change on this file since 15742 was 15742, checked in by Kon Lovett, 10 years ago

Applied Dave N Murray's OpenBSD patch for 'convert_string_to_number'.

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