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

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

slightly nicer debug output

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