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

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

length checks argument for being cyclic (suggested by Taylor Campbell)

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