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

Last change on this file since 12839 was 12839, checked in by felix winkelmann, 12 years ago

finalizer bugfix for problem reported by Alejo

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