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

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

distribution/manifest : added lolevel test
tests/lolevel-tests.scm : new lolevel test (incomplete)
runtime.c : MacOS X is-a BSD
lolevel.scm : better arg checks, grouping, added record-instance procs.
chicken.h : grouped like, comments, swig-pointer is now special
manual/Unit lolevel : discussion of pointer-like & vector-like
chicken-primitive-inlines.scm : wrond identifier for unbound value predicate

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