source: project/chicken/branches/chicken-3/runtime.c @ 13143

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

Chgd "can not" -> "cannot" - saves bytes your know ;-)
Renamed "chicken-sys-macros.scm" -> "chicken-primitive-object-inlines.scm"
Added "chicken-primitive-object-inlines.scm"

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