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

Last change on this file since 12700 was 12700, checked in by felix winkelmann, 11 years ago

removed remaining support for DJGPP, Metrowerks and Watcom

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