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

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

Make sure tzname, etc. variables are set before use. Doubtful if tzname will be used before a time.h proc is used but to be safe.

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