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

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

More work on loaded library introspection

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