source: project/chicken/branches/prerelease/runtime.c @ 13414

Last change on this file since 13414 was 13414, checked in by felix winkelmann, 11 years ago

merged with trunk rev. 13389

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