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

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

merged trunk svn rev. 13239 into prerelease

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 finalizer procedures: */
2739    for(flist = finalizer_list; flist != NULL; flist = flist->next) 
2740      mark(&flist->finalizer);
2741
2742    mark_system_globals();
2743  }
2744  else {
2745    /* Mark mutated slots: */
2746    for(msp = mutation_stack_bottom; msp < mutation_stack_top; mark(*(msp++)));
2747  }
2748
2749  /* Clear the mutated slot stack: */
2750  mutation_stack_top = mutation_stack_bottom;
2751
2752  /* Mark live values: */
2753  for(p = C_temporary_stack; p < C_temporary_stack_bottom; mark(p++));
2754
2755  /* Mark trace-buffer: */
2756  for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
2757    mark(&tinfo->cooked1);
2758    mark(&tinfo->cooked2);
2759    mark(&tinfo->thread);
2760  }
2761
2762 rescan:
2763  /* Mark nested values in already moved (marked) blocks in breadth-first manner: */
2764  while(heap_scan_top < (gc_mode == GC_MINOR ? C_fromspace_top : tospace_top)) {
2765    bp = (C_SCHEME_BLOCK *)heap_scan_top;
2766
2767    if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER) 
2768      bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
2769
2770    n = C_header_size(bp);
2771    h = bp->header;
2772    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
2773    p = bp->data;
2774
2775    if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
2776      if(h & C_SPECIALBLOCK_BIT) {
2777        --n;
2778        ++p;
2779      }
2780
2781      while(n--) mark(p++);
2782    }
2783
2784    heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
2785  }
2786
2787  if(gc_mode == GC_MINOR) {
2788    count = (C_uword)C_fromspace_top - (C_uword)start;
2789    ++gc_count_1;
2790    update_locative_table(GC_MINOR);
2791  }
2792  else {
2793    if(!finalizers_checked) {
2794      /* Mark finalizer list and remember pointers to non-forwarded items: */
2795      last = C_block_item(pending_finalizers_symbol, 0);
2796
2797      if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) { 
2798        /* still finalizers pending: just mark table items... */
2799        if(gc_report_flag) 
2800          C_printf(C_text("[GC] %d finalized item(s) still pending\n"), j);
2801
2802        j = fcount = 0;
2803
2804        for(flist = finalizer_list; flist != NULL; flist = flist->next) {
2805          mark(&flist->item);
2806          ++fcount;
2807        }
2808
2809        /* mark finalizable GC roots: */
2810        for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
2811          if(gcrp->finalizable) mark(&gcrp->value);
2812        }
2813
2814        if(gc_report_flag && fcount > 0)
2815          C_printf(C_text("[GC] %d finalizer value(s) marked\n"), fcount);
2816      }
2817      else {
2818        j = fcount = 0;
2819
2820        for(flist = finalizer_list; flist != NULL; flist = flist->next) {
2821          if(j < C_max_pending_finalizers) {
2822            if(!is_fptr(C_block_header(flist->item))) 
2823              pending_finalizer_indices[ j++ ] = flist;
2824          }
2825
2826          mark(&flist->item);
2827        }
2828
2829        /* mark finalizable GC roots: */
2830        for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
2831          if(gcrp->finalizable) mark(&gcrp->value);
2832        }
2833      }
2834
2835      pending_finalizer_count = j;
2836      finalizers_checked = 1;
2837
2838      if(pending_finalizer_count > 0 && gc_report_flag)
2839        C_printf(C_text("[GC] finalizers pending: %d (%d live)\n"), 
2840                 pending_finalizer_count, live_finalizer_count);
2841
2842      goto rescan;
2843    }
2844    else {
2845      /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
2846         (and release finalizer node): */
2847      if(pending_finalizer_count > 0) {
2848        if(gc_report_flag) C_printf(C_text("[GC] finalizers queued: %d\n"), pending_finalizer_count);
2849
2850        last = C_block_item(pending_finalizers_symbol, 0);
2851        assert(C_u_i_car(last) == C_fix(0));
2852        C_set_block_item(last, 0, C_fix(pending_finalizer_count));
2853
2854        for(i = 0; i < pending_finalizer_count; ++i) {
2855          flist = pending_finalizer_indices[ i ];
2856          C_set_block_item(last, 1 + i * 2, flist->item);
2857          C_set_block_item(last, 2 + i * 2, flist->finalizer);
2858         
2859          if(flist->previous != NULL) flist->previous->next = flist->next;
2860          else finalizer_list = flist->next;
2861
2862          if(flist->next != NULL) flist->next->previous = flist->previous;
2863
2864          flist->next = finalizer_free_list;
2865          flist->previous = NULL;
2866          finalizer_free_list = flist;
2867          --live_finalizer_count;
2868        }
2869      }
2870    }
2871
2872    update_locative_table(gc_mode);
2873    count = (C_uword)tospace_top - (C_uword)tospace_start;
2874
2875    /*** isn't gc_mode always GC_MAJOR here? */
2876    if(gc_mode == GC_MAJOR && 
2877       count < percentage(percentage(heap_size, C_heap_shrinkage), DEFAULT_HEAP_SHRINKAGE_USED) &&
2878       heap_size > MINIMAL_HEAP_SIZE && !C_heap_size_is_fixed)
2879      C_rereclaim2(percentage(heap_size, C_heap_shrinkage), 0);
2880    else {
2881      C_fromspace_top = tospace_top;
2882      tmp = fromspace_start;
2883      fromspace_start = tospace_start;
2884      tospace_start = tospace_top = tmp;
2885      tmp = C_fromspace_limit;
2886      C_fromspace_limit = tospace_limit;
2887      tospace_limit = tmp;
2888    }
2889
2890  never_mind_edsgar:
2891    ++gc_count_2;
2892
2893    if(C_enable_gcweak) {
2894      /* Check entries in weak item table and recover items ref'd only
2895      * once and which are unbound symbols: */
2896      weakn = 0;
2897      wep = weak_item_table;
2898
2899      for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep)
2900        if(wep->item != 0) { 
2901          if((wep->container & WEAK_COUNTER_MAX) == 0 && is_fptr((item = C_block_header(wep->item)))) {
2902            item = fptr_to_ptr(item);
2903            container = wep->container & ~WEAK_COUNTER_MASK;
2904
2905            if(C_header_bits(item) == C_SYMBOL_TYPE && C_u_i_car(item) == C_SCHEME_UNBOUND) {
2906              ++weakn;
2907#ifdef PARANOIA
2908              item = C_u_i_cdr(item);
2909              C_fprintf(C_stderr, C_text("[recovered: %.*s]\n"), (int)C_header_size(item), (char *)C_data_pointer(item));
2910#endif
2911              C_set_block_item(container, 0, C_SCHEME_UNDEFINED);
2912            }
2913          }
2914
2915          wep->item = wep->container = 0;
2916        }
2917
2918      /* Remove empty buckets in symbol table: */
2919      for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
2920        for(i = 0; i < stp->size; ++i) {
2921          last = 0;
2922         
2923          for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket))
2924            if(C_u_i_car(bucket) == C_SCHEME_UNDEFINED) {
2925              if(last) C_set_block_item(last, 1, C_u_i_cdr(bucket));
2926              else stp->table[ i ] = C_u_i_cdr(bucket);
2927            }
2928            else last = bucket;
2929        }
2930      }
2931    }
2932  }
2933
2934  if(gc_mode == GC_MAJOR) {
2935    tgc = cpu_milliseconds() - tgc;
2936    timer_start_gc_ms += tgc;
2937    timer_accumulated_gc_ms += tgc;
2938  }
2939
2940  /* Display GC report:
2941     Note: stubbornly writes to stdout - there is no provision for other output-ports */
2942  if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {
2943    C_printf(C_text("[GC] level  %d\tgcs(minor)  %d\tgcs(major)  %d\n"),
2944             gc_mode, gc_count_1, gc_count_2);
2945    i = (C_uword)C_stack_pointer;
2946
2947#if C_STACK_GROWS_DOWNWARD
2948    C_printf(C_text("[GC] stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING), 
2949           (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);
2950#else
2951    C_printf(C_text("[GC] stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING), 
2952           (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);
2953#endif
2954
2955    if(gc_mode == GC_MINOR) printf(C_text("\t" UWORD_FORMAT_STRING), count);
2956
2957    C_printf(C_text("\n[GC]  from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
2958           (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);
2959
2960    if(gc_mode == GC_MAJOR) printf(C_text("\t" UWORD_FORMAT_STRING), count);
2961
2962    C_printf(C_text("\n[GC]    to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"), 
2963           (C_uword)tospace_start, (C_uword)tospace_top, 
2964           (C_uword)tospace_limit);
2965
2966    if(gc_mode == GC_MAJOR && C_enable_gcweak && weakn)
2967      C_printf(C_text("[GC] %d recoverable weakly held items found\n"), weakn);
2968
2969    C_printf(C_text("[GC] %d locatives (from %d)\n"), locative_table_count, locative_table_size);
2970  }
2971
2972  if(gc_mode == GC_MAJOR) gc_count_1 = 0;
2973
2974  if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc);
2975
2976  /* Jump from the Empire State Building... */
2977  C_longjmp(C_restart, 1);
2978}
2979
2980
2981C_regparm void C_fcall mark_system_globals(void)
2982{
2983  mark(&interrupt_hook_symbol);
2984  mark(&error_hook_symbol);
2985  mark(&callback_continuation_stack_symbol);
2986  mark(&pending_finalizers_symbol);
2987  mark(&invalid_procedure_call_hook_symbol);
2988  mark(&unbound_variable_value_hook_symbol);
2989  mark(&last_invalid_procedure_symbol);
2990  mark(&identity_unbound_value_symbol);
2991  mark(&current_thread_symbol);
2992  mark(&apply_hook_symbol);
2993  mark(&last_applied_procedure_symbol);
2994}
2995
2996
2997C_regparm void C_fcall mark(C_word *x)
2998{
2999  C_word val, item;
3000  C_uword n, bytes;
3001  C_header h;
3002  C_SCHEME_BLOCK *p, *p2;
3003  WEAK_TABLE_ENTRY *wep;
3004
3005  val = *x;
3006
3007  if(C_immediatep(val)) return;
3008
3009  p = (C_SCHEME_BLOCK *)val;
3010 
3011  /* not in stack and not in heap? */
3012  if (
3013#if C_STACK_GROWS_DOWNWARD
3014       p < (C_SCHEME_BLOCK *)C_stack_pointer || p >= (C_SCHEME_BLOCK *)stack_bottom
3015#else
3016       p >= (C_SCHEME_BLOCK *)C_stack_pointer || p < (C_SCHEME_BLOCK *)stack_bottom
3017#endif
3018     )
3019    if((p < (C_SCHEME_BLOCK *)fromspace_start || p >= (C_SCHEME_BLOCK *)C_fromspace_limit) &&
3020       (p < (C_SCHEME_BLOCK *)tospace_start || p >= (C_SCHEME_BLOCK *)tospace_limit) ) {
3021#ifdef C_GC_HOOKS
3022      if(C_gc_trace_hook != NULL) 
3023        C_gc_trace_hook(x, gc_mode);
3024#endif
3025
3026      return;
3027    }
3028
3029  h = p->header;
3030
3031  if(gc_mode == GC_MINOR) {
3032    if(is_fptr(h)) {
3033      *x = val = fptr_to_ptr(h);
3034      return;
3035    }
3036
3037    if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) return;
3038
3039    p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);
3040
3041#ifndef C_SIXTY_FOUR
3042    if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
3043      *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
3044      p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
3045    }
3046#endif
3047
3048    n = C_header_size(p);
3049    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3050
3051    if(((C_byte *)p2 + bytes + sizeof(C_word)) > C_fromspace_limit)
3052      C_longjmp(gc_restart, 1);
3053
3054    C_fromspace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3055
3056  scavenge:
3057    *x = (C_word)p2;
3058    p2->header = h;
3059    p->header = ptr_to_fptr((C_uword)p2);
3060    C_memcpy(p2->data, p->data, bytes);
3061  }
3062  else {
3063    /* Increase counter if weakly held item: */
3064    if(C_enable_gcweak && (wep = lookup_weak_table_entry(val, 0)) != NULL) {
3065      if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
3066    }
3067
3068    if(is_fptr(h)) {
3069      val = fptr_to_ptr(h);
3070
3071      if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
3072        *x = val;
3073        return;
3074      }
3075
3076      /* Link points into fromspace: fetch new pointer + header and copy... */
3077      p = (C_SCHEME_BLOCK *)val;
3078      h = p->header;
3079
3080      if(is_fptr(h)) {
3081        /* Link points into fromspace and into a link which points into from- or tospace: */
3082        val = fptr_to_ptr(h);
3083       
3084        if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
3085          *x = val;
3086          return;
3087        }
3088
3089        p = (C_SCHEME_BLOCK *)val;
3090        h = p->header;
3091      }
3092    }
3093
3094    p2 = (C_SCHEME_BLOCK *)C_align((C_uword)tospace_top);
3095
3096#ifndef C_SIXTY_FOUR
3097    if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < tospace_limit) {
3098      *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
3099      p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
3100    }
3101#endif
3102
3103    if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) {
3104      item = C_u_i_car(val);
3105
3106      /* Lookup item in weak item table or add entry: */
3107      if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) {
3108        /* If item is already forwarded, then set count to 2: */
3109        if(is_fptr(C_block_header(item))) wep->container |= 2;
3110      }
3111    }
3112
3113    n = C_header_size(p);
3114    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3115
3116    if(((C_byte *)p2 + bytes + sizeof(C_word)) > tospace_limit) {
3117      if(C_heap_size_is_fixed)
3118        panic(C_text("out of memory - heap full"));
3119     
3120      gc_mode = GC_REALLOC;
3121      C_longjmp(gc_restart, 1);
3122    }
3123
3124    tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3125    goto scavenge;
3126  }
3127}
3128
3129
3130/* Do a major GC into a freshly allocated heap: */
3131
3132C_regparm void C_fcall C_rereclaim(long size) 
3133{
3134  C_rereclaim2(size < 0 ? -size : size, size < 0);
3135}
3136
3137
3138C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
3139{
3140  int i, j;
3141  C_uword count, n, bytes;
3142  C_word *p, **msp, item, last;
3143  C_header h;
3144  C_byte *tmp, *start;
3145  LF_LIST *lfn;
3146  C_SCHEME_BLOCK *bp;
3147  WEAK_TABLE_ENTRY *wep;
3148  C_GC_ROOT *gcrp;
3149  C_SYMBOL_TABLE *stp;
3150  FINALIZER_NODE *flist;
3151  TRACE_INFO *tinfo;
3152  C_byte *new_heapspace;
3153  size_t  new_heapspace_size;
3154
3155  if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);
3156
3157  if(double_plus) size = heap_size * 2 + size;
3158
3159  if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;
3160
3161  if(size > C_maximal_heap_size) size = C_maximal_heap_size;
3162
3163  if(size == heap_size) return;
3164
3165  if(debug_mode) 
3166    C_printf(C_text("[debug] resizing heap dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"), 
3167             (C_uword)heap_size / 1000, size / 1000);
3168
3169  if(gc_report_flag) {
3170    C_printf(C_text("(old) fromspace: \tstart=%08lx, \tlimit=%08lx\n"), (long)fromspace_start, (long)C_fromspace_limit);
3171    C_printf(C_text("(old) tospace:   \tstart=%08lx, \tlimit=%08lx\n"), (long)tospace_start, (long)tospace_limit);
3172  }
3173
3174  heap_size = size;
3175  size /= 2;
3176
3177  if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)
3178    panic(C_text("out of memory - cannot allocate heap segment"));
3179  new_heapspace_size = size;
3180
3181  new_tospace_top = new_tospace_start;
3182  new_tospace_limit = new_tospace_start + size;
3183  heap_scan_top = new_tospace_top;
3184
3185  /* Mark items in forwarding table: */
3186  for(p = forwarding_table; *p != 0; p += 2) {
3187    last = p[ 1 ];
3188    remark(&p[ 1 ]);
3189    C_block_header(p[ 0 ]) = C_block_header(last);
3190  }
3191
3192  /* Mark literal frames: */
3193  for(lfn = lf_list; lfn != NULL; lfn = lfn->next)
3194    for(i = 0; i < lfn->count; remark(&lfn->lf[ i++ ]));
3195
3196  /* Mark symbol table: */
3197  for(stp = symbol_table_list; stp != NULL; stp = stp->next)
3198    for(i = 0; i < stp->size; remark(&stp->table[ i++ ]));
3199
3200  /* Mark collectibles: */
3201  for(msp = collectibles; msp < collectibles_top; ++msp)
3202    if(*msp != NULL) remark(*msp);
3203
3204  for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
3205    remark(&gcrp->value);
3206
3207  remark_system_globals();
3208
3209  /* Clear the mutated slot stack: */
3210  mutation_stack_top = mutation_stack_bottom;
3211
3212  /* Mark live values: */
3213  for(p = C_temporary_stack; p < C_temporary_stack_bottom; remark(p++));
3214
3215  /* Mark locative table: */
3216  for(i = 0; i < locative_table_count; ++i)
3217    remark(&locative_table[ i ]);
3218
3219  /* Mark finalizer table: */
3220  for(flist = finalizer_list; flist != NULL; flist = flist->next) {
3221    remark(&flist->item);
3222    remark(&flist->finalizer);
3223  }
3224
3225  /* Mark weakly held items: */
3226  if(C_enable_gcweak) {
3227    wep = weak_item_table; 
3228
3229    for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep)
3230      if(wep->item != 0) remark(&wep->item);
3231  }
3232
3233  /* Mark trace-buffer: */
3234  for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
3235    remark(&tinfo->cooked1);
3236    remark(&tinfo->cooked2);
3237    remark(&tinfo->thread);
3238  }
3239
3240  update_locative_table(GC_REALLOC);
3241
3242  /* Mark nested values in already moved (marked) blocks in breadth-first manner: */
3243  while(heap_scan_top < new_tospace_top) {
3244    bp = (C_SCHEME_BLOCK *)heap_scan_top;
3245
3246    if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER) 
3247      bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
3248
3249    n = C_header_size(bp);
3250    h = bp->header;
3251    assert(!is_fptr(h));
3252    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3253    p = bp->data;
3254
3255    if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
3256      if(h & C_SPECIALBLOCK_BIT) {
3257        --n;
3258        ++p;
3259      }
3260
3261      while(n--) remark(p++);
3262    }
3263
3264    heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
3265  }
3266
3267  heap_free (heapspace1, heapspace1_size);
3268  heap_free (heapspace2, heapspace1_size);
3269 
3270  if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)
3271    panic(C_text("out ot memory - cannot allocate heap segment"));
3272  heapspace2_size = size;
3273
3274  heapspace1 = new_heapspace;
3275  heapspace1_size = new_heapspace_size;
3276  tospace_limit = tospace_start + size;
3277  tospace_top = tospace_start;
3278  fromspace_start = new_tospace_start;
3279  C_fromspace_top = new_tospace_top;
3280  C_fromspace_limit = new_tospace_limit;
3281
3282  if(gc_report_flag) {
3283    C_printf(C_text("[GC] resized heap to %d bytes\n"), heap_size);
3284    C_printf(C_text("(new) fromspace: \tstart=%08lx, \tlimit=%08lx\n"), (long)fromspace_start, (long)C_fromspace_limit);
3285    C_printf(C_text("(new) tospace:   \tstart=%08lx, \tlimit=%08lx\n"), (long)tospace_start, (long)tospace_limit);
3286  }
3287
3288  if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);
3289}
3290
3291
3292C_regparm void C_fcall remark_system_globals(void)
3293{
3294  remark(&interrupt_hook_symbol);
3295  remark(&error_hook_symbol);
3296  remark(&callback_continuation_stack_symbol);
3297  remark(&pending_finalizers_symbol);
3298  remark(&invalid_procedure_call_hook_symbol);
3299  remark(&unbound_variable_value_hook_symbol);
3300  remark(&last_invalid_procedure_symbol);
3301  remark(&identity_unbound_value_symbol);
3302  remark(&current_thread_symbol);
3303  remark(&apply_hook_symbol);
3304  remark(&last_applied_procedure_symbol);
3305}
3306
3307
3308C_regparm void C_fcall remark(C_word *x)
3309{
3310  C_word val, item;
3311  C_uword n, bytes;
3312  C_header h;
3313  C_SCHEME_BLOCK *p, *p2;
3314  WEAK_TABLE_ENTRY *wep;
3315
3316  val = *x;
3317
3318  if(C_immediatep(val)) return;
3319
3320  p = (C_SCHEME_BLOCK *)val;
3321 
3322  /* not in stack and not in heap? */
3323  if(
3324#if C_STACK_GROWS_DOWNWARD
3325       p < (C_SCHEME_BLOCK *)C_stack_pointer || p >= (C_SCHEME_BLOCK *)stack_bottom
3326#else
3327       p >= (C_SCHEME_BLOCK *)C_stack_pointer || p < (C_SCHEME_BLOCK *)stack_bottom
3328#endif
3329    )
3330    if((p < (C_SCHEME_BLOCK *)fromspace_start || p >= (C_SCHEME_BLOCK *)C_fromspace_limit) &&
3331       (p < (C_SCHEME_BLOCK *)tospace_start || p >= (C_SCHEME_BLOCK *)tospace_limit) &&
3332       (p < (C_SCHEME_BLOCK *)new_tospace_start || p >= (C_SCHEME_BLOCK *)new_tospace_limit) ) {
3333#ifdef C_GC_HOOKS
3334      if(C_gc_trace_hook != NULL) 
3335        C_gc_trace_hook(x, gc_mode);
3336#endif
3337
3338      return;
3339    }
3340
3341  h = p->header;
3342
3343  if(is_fptr(h)) {
3344    val = fptr_to_ptr(h);
3345
3346    if((C_uword)val >= (C_uword)new_tospace_start && (C_uword)val < (C_uword)new_tospace_top) {
3347      *x = val;
3348      return;
3349    }
3350
3351    /* Link points into nursery, fromspace or the old tospace:
3352    * fetch new pointer + header and copy... */
3353    p = (C_SCHEME_BLOCK *)val;
3354    h = p->header;
3355    n = 1;
3356
3357    while(is_fptr(h)) {
3358      /* Link points into fromspace or old tospace and into a link which
3359       * points into tospace or new-tospace: */
3360      val = fptr_to_ptr(h);
3361       
3362      if((C_uword)val >= (C_uword)new_tospace_start && (C_uword)val < (C_uword)new_tospace_top) {
3363        *x = val;
3364        return;
3365      }
3366
3367      p = (C_SCHEME_BLOCK *)val;
3368      h = p->header;
3369
3370      if(++n > 3)
3371        panic(C_text("forwarding chain during re-reclamation is longer than 3. somethings fishy."));
3372    }
3373  }
3374
3375  p2 = (C_SCHEME_BLOCK *)C_align((C_uword)new_tospace_top);
3376
3377#ifndef C_SIXTY_FOUR
3378  if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < new_tospace_limit) {
3379    *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
3380    p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
3381  }
3382#endif
3383
3384  n = C_header_size(p);
3385  bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3386
3387  if(((C_byte *)p2 + bytes + sizeof(C_word)) > new_tospace_limit) {
3388    panic(C_text("out of memory - heap full while resizing"));
3389  }
3390
3391  new_tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3392  *x = (C_word)p2;
3393  p2->header = h;
3394  assert(!is_fptr(h));
3395  p->header = ptr_to_fptr((C_word)p2);
3396  C_memcpy(p2->data, p->data, bytes);
3397}
3398
3399
3400C_regparm void C_fcall update_locative_table(int mode)
3401{
3402  int i, hi = 0;
3403  C_header h;
3404  C_word loc, obj, obj2, offset, loc2, ptr;
3405  C_uword ptr2;
3406
3407  /*C_printf("major: %d, %d locs in %d\n", major, locative_table_count, locative_table_size); */
3408
3409  for(i = 0; i < locative_table_count; ++i) {
3410    loc = locative_table[ i ];
3411    /*    C_printf("%d: %08lx %d/%d\n", i, loc, C_in_stackp(loc), C_in_heapp(loc)); */
3412
3413    if(loc != C_SCHEME_UNDEFINED) {
3414      h = C_block_header(loc);
3415
3416      switch(mode) {
3417      case GC_MINOR:
3418        if(is_fptr(h))          /* forwarded? update l-table entry */
3419          loc = locative_table[ i ] = fptr_to_ptr(h);
3420        /* otherwise it must have been GC'd (since this is a minor one) */
3421        else if(C_in_stackp(loc)) {
3422          locative_table[ i ] = C_SCHEME_UNDEFINED;
3423          C_set_block_item(loc, 0, 0);
3424          break;
3425        }
3426
3427        /* forwarded. fix up ptr and check pointed-at object for being forwarded... */
3428        ptr = C_block_item(loc, 0);
3429        offset = C_unfix(C_block_item(loc, 1));
3430        obj = ptr - offset;
3431        h = C_block_header(obj);
3432
3433        if(is_fptr(h)) {        /* pointed-at object forwarded? update */
3434          C_set_block_item(loc, 0, (C_uword)fptr_to_ptr(h) + offset);
3435          hi = i + 1;
3436        }
3437        else if(C_in_stackp(obj)) { /* pointed-at object GC'd, locative is invalid */
3438          locative_table[ i ] = C_SCHEME_UNDEFINED;
3439          C_set_block_item(loc, 0, 0);
3440        }
3441        else hi = i + 1;
3442       
3443        break;
3444
3445      case GC_MAJOR:
3446        if(is_fptr(h))          /* forwarded? update l-table entry */
3447          loc = locative_table[ i ] = fptr_to_ptr(h);
3448        else {                  /* otherwise, throw away */
3449          locative_table[ i ] = C_SCHEME_UNDEFINED;
3450          C_set_block_item(loc, 0, 0);
3451          break;
3452        }
3453
3454        h = C_block_header(loc);
3455       
3456        if(is_fptr(h))          /* new instance is forwarded itself? update again */
3457          loc = locative_table[ i ] = fptr_to_ptr(h);
3458
3459        ptr = C_block_item(loc, 0); /* fix up ptr */
3460        offset = C_unfix(C_block_item(loc, 1));
3461        obj = ptr - offset;
3462        h = C_block_header(obj);
3463
3464        if(is_fptr(h)) {        /* pointed-at object has been forwarded? */
3465          ptr2 = (C_uword)fptr_to_ptr(h);
3466          h = C_block_header(ptr2);
3467
3468          if(is_fptr(h)) {      /* secondary forwarding check for pointed-at object */
3469            ptr2 = (C_uword)fptr_to_ptr(h) + offset;
3470            C_set_block_item(loc, 0, ptr2);
3471          }
3472          else C_set_block_item(loc, 0, ptr2 + offset); /* everything's fine, fixup pointer */
3473
3474          hi = i + 1;
3475        }
3476        else {
3477          locative_table[ i ] = C_SCHEME_UNDEFINED; /* pointed-at object is dead */
3478          C_set_block_item(loc, 0, 0);
3479        }
3480       
3481        break;
3482
3483      case GC_REALLOC:
3484        ptr = C_block_item(loc, 0); /* just update ptr's pointed-at objects */
3485        offset = C_unfix(C_block_item(loc, 1));
3486        obj = ptr - offset;
3487        remark(&obj);
3488        C_set_block_item(loc, 0, obj + offset);       
3489        break;
3490      }
3491    }
3492  }
3493
3494  if(mode != GC_REALLOC) locative_table_count = hi;
3495}
3496
3497
3498C_regparm WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container)
3499{
3500  int key = (C_uword)item >> 2,
3501      disp = 0,
3502      n;
3503  WEAK_TABLE_ENTRY *wep;
3504
3505  for(n = 0; n < WEAK_HASH_ITERATIONS; ++n) {
3506    key = (key + disp) % WEAK_TABLE_SIZE;
3507    wep = &weak_item_table[ key ];
3508
3509    if(wep->item == 0) {
3510      if(container != 0) {
3511        /* Add fresh entry: */
3512        wep->item = item;
3513        wep->container = container;
3514        return wep;
3515      }
3516
3517      return NULL;
3518    }
3519    else if(wep->item == item) return wep;
3520    else disp += WEAK_HASH_DISPLACEMENT;
3521  }
3522
3523  return NULL;
3524}
3525
3526
3527void handle_interrupt(void *trampoline, void *proc)
3528{
3529  C_word *p, x, n;
3530  int i;
3531  long c;
3532
3533  /* Build vector with context information: */
3534  n = C_temporary_stack_bottom - C_temporary_stack;
3535  /* 19 <=> 2 headers + trampoline + proc + 1 extra slot + 9 for interning + 5 for string */
3536  p = C_alloc(19 + n);
3537  x = (C_word)p;
3538  *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | (2 * sizeof(C_word));
3539  *(p++) = (C_word)trampoline;
3540  *(p++) = (C_word)proc;
3541  C_save(x);
3542  x = (C_word)p;
3543  *(p++) = C_VECTOR_TYPE | (n + 1);
3544  *(p++) = C_restore;
3545  C_memcpy(p, C_temporary_stack, n * sizeof(C_word));
3546
3547  /* Restore state to the one at the time of the interrupt: */
3548  C_temporary_stack = C_temporary_stack_bottom;
3549  i = interrupt_reason;
3550  interrupt_reason = 0;
3551  C_stack_limit = saved_stack_limit;
3552
3553  /* Invoke high-level interrupt handler: */
3554  C_save(C_fix(i));
3555  C_save(x);
3556  x = C_block_item(interrupt_hook_symbol, 0);
3557
3558  if(C_immediatep(x))
3559    panic(C_text("`##sys#interrupt-hook' is not defined"));
3560
3561  c = cpu_milliseconds() - interrupt_time;
3562  last_interrupt_latency = c;
3563  C_timer_interrupt_counter = C_initial_timer_interrupt_period; /* just in case */
3564  /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
3565  C_do_apply(2, x, C_SCHEME_UNDEFINED); 
3566}
3567
3568
3569C_regparm C_word C_fcall C_retrieve(C_word sym)
3570{
3571  C_word val = C_block_item(sym, 0);
3572
3573  if(val == C_SCHEME_UNBOUND)
3574    return C_get_unbound_variable_value_hook(sym);
3575
3576  return val;
3577}
3578
3579
3580C_word get_unbound_variable_value(C_word sym)
3581{
3582  C_word x = C_block_item(unbound_variable_value_hook_symbol, 0);
3583
3584  if(x == identity_unbound_value_symbol) return sym;
3585  else if(x == C_SCHEME_FALSE)
3586    barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
3587
3588  return C_block_item(x, 0);
3589}
3590
3591
3592C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
3593{
3594  C_word *p;
3595  int len;
3596
3597  if(val == C_SCHEME_UNBOUND) {
3598    len = C_strlen(name);
3599    /* this is ok: we won't return from `C_retrieve2'
3600     * (or the value isn't needed). */
3601    p = C_alloc(C_SIZEOF_STRING(len));
3602    return get_unbound_variable_value(C_string2(&p, name));
3603  }
3604
3605  return val;
3606}
3607
3608
3609#ifndef C_UNSAFE_RUNTIME
3610static C_word resolve_procedure(C_word closure, C_char *where)
3611{
3612  C_word s;
3613
3614  if(C_immediatep(closure) || C_header_bits(closure) != C_CLOSURE_TYPE) {
3615    s = C_block_item(invalid_procedure_call_hook_symbol, 0);
3616
3617    if(s == C_SCHEME_FALSE)
3618      barf(C_NOT_A_CLOSURE_ERROR, where, closure);
3619
3620    C_mutate(&C_block_item(last_invalid_procedure_symbol, 0), closure);
3621    closure = s;
3622  }
3623
3624  return closure;
3625}
3626#endif
3627
3628
3629C_regparm void *C_fcall C_retrieve_proc(C_word closure)
3630{
3631  closure = resolve_procedure(closure, NULL);
3632
3633#ifndef C_NO_APPLY_HOOK
3634  if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
3635    C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
3636    return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
3637  }
3638#endif
3639
3640  return (void *)C_block_item(closure, 0);
3641}
3642
3643
3644C_regparm void *C_fcall C_retrieve_symbol_proc(C_word sym)
3645{
3646  C_word val = C_block_item(sym, 0);
3647  C_word closure;
3648
3649  if(val == C_SCHEME_UNBOUND)
3650    val = C_get_unbound_variable_value_hook(sym);
3651
3652  closure = resolve_procedure(val, NULL);
3653
3654#ifndef C_NO_APPLY_HOOK
3655  if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
3656    C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
3657    return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
3658  }
3659#endif
3660
3661  return (void *)C_block_item(closure, 0);
3662}
3663
3664
3665C_regparm void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name)
3666{
3667  C_word closure;
3668  C_word *p;
3669  int len;
3670
3671  if(val == C_SCHEME_UNBOUND) {
3672    len = C_strlen(name);
3673    /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */
3674    p = C_alloc(C_SIZEOF_STRING(len));
3675    val = get_unbound_variable_value(C_string2(&p, name));
3676  }
3677
3678  closure = resolve_procedure(val, NULL);
3679
3680#ifndef C_NO_APPLY_HOOK
3681  if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
3682    C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
3683    return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
3684  }
3685#endif
3686
3687  return (void *)C_block_item(closure, 0);
3688}
3689
3690
3691C_regparm void C_fcall C_trace(C_char *name)
3692{
3693  if(show_trace) {
3694    C_fputs(name, C_stderr);
3695    C_fputc('\n', C_stderr);
3696  }
3697
3698  if(trace_buffer_top >= trace_buffer_limit) {
3699    trace_buffer_top = trace_buffer;
3700    trace_buffer_full = 1;
3701  }
3702
3703  trace_buffer_top->raw = name;
3704  trace_buffer_top->cooked1 = C_SCHEME_FALSE;
3705  trace_buffer_top->cooked2 = C_SCHEME_FALSE;
3706  trace_buffer_top->thread = C_block_item(current_thread_symbol, 0);
3707  ++trace_buffer_top;
3708}
3709
3710
3711/* DEPRECATED: throw out at some stage: */
3712C_regparm C_word C_fcall C_emit_trace_info(C_word x, C_word y, C_word t)
3713{
3714  if(trace_buffer_top >= trace_buffer_limit) {
3715    trace_buffer_top = trace_buffer;
3716    trace_buffer_full = 1;
3717  }
3718
3719  trace_buffer_top->raw = "<eval>";
3720  trace_buffer_top->cooked1 = x;
3721  trace_buffer_top->cooked2 = y;
3722  trace_buffer_top->thread = t;
3723  ++trace_buffer_top;
3724  return x;
3725}
3726
3727
3728C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t)
3729{
3730  if(trace_buffer_top >= trace_buffer_limit) {
3731    trace_buffer_top = trace_buffer;
3732    trace_buffer_full = 1;
3733  }
3734
3735  trace_buffer_top->raw = raw;
3736  trace_buffer_top->cooked1 = x;
3737  trace_buffer_top->cooked2 = y;
3738  trace_buffer_top->thread = t;
3739  ++trace_buffer_top;
3740  return x;
3741}
3742
3743
3744C_char *C_dump_trace(int start)
3745{
3746  TRACE_INFO *ptr;
3747  C_char *result;
3748  int i;
3749
3750  if((result = (char *)C_malloc(STRING_BUFFER_SIZE)) == NULL)
3751    horror(C_text("out of memory - cannot allocate trace-dump buffer"));
3752
3753  *result = '\0';
3754
3755  if(trace_buffer_top > trace_buffer || trace_buffer_full) {
3756    if(trace_buffer_full) {
3757      i = C_trace_buffer_size;
3758      C_strcat(result, C_text("...more...\n"));
3759    }
3760    else i = trace_buffer_top - trace_buffer;
3761
3762    ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
3763    ptr += start;
3764    i -= start;
3765
3766    for(;i--; ++ptr) {
3767      if(ptr >= trace_buffer_limit) ptr = trace_buffer;
3768
3769      if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {
3770        if((result = C_realloc(result, C_strlen(result) * 2)) == NULL)
3771          horror(C_text("out of memory - cannot reallocate trace-dump buffer"));
3772      }
3773
3774      C_strcat(result, ptr->raw);
3775
3776      if(i > 0) C_strcat(result, "\n");
3777      else C_strcat(result, " \t<--\n");
3778    }
3779  }
3780
3781  return result;
3782}
3783
3784
3785C_regparm void C_fcall C_clear_trace_buffer(void)
3786{
3787  int i;
3788
3789  if(trace_buffer == NULL) {
3790    trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);
3791
3792    if(trace_buffer == NULL)
3793      panic(C_text("out of memory - cannot allocate trace-buffer"));
3794  }
3795
3796  trace_buffer_top = trace_buffer;
3797  trace_buffer_limit = trace_buffer + C_trace_buffer_size;
3798  trace_buffer_full = 0;
3799
3800  for(i = 0; i < C_trace_buffer_size; ++i) {
3801    trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;
3802    trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;
3803    trace_buffer[ i ].thread = C_SCHEME_FALSE;
3804  }
3805}
3806
3807
3808C_word C_fetch_trace(C_word starti, C_word buffer)
3809{
3810  TRACE_INFO *ptr;
3811  int i, p = 0, start = C_unfix(starti);
3812
3813  if(trace_buffer_top > trace_buffer || trace_buffer_full) {
3814    if(trace_buffer_full) i = C_trace_buffer_size;
3815    else i = trace_buffer_top - trace_buffer;
3816
3817    ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
3818    ptr += start;
3819    i -= start;
3820
3821    if(C_header_size(buffer) < i * 4)
3822      panic(C_text("destination buffer too small for call-chain"));
3823
3824    for(;i--; ++ptr) {
3825      if(ptr >= trace_buffer_limit) ptr = trace_buffer;
3826
3827      /* outside-pointer, will be ignored by GC */
3828      C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw);
3829      C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
3830      C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
3831      C_mutate(&C_block_item(buffer, p++), ptr->thread);
3832    }
3833  }
3834
3835  return C_fix(p);
3836}
3837
3838
3839C_regparm C_word C_fcall C_hash_string(C_word str)
3840{
3841  unsigned C_word key = 0;
3842  int len = C_header_size(str);
3843  C_byte *ptr = C_data_pointer(str);
3844// *(ptr++) means you run off the edge. 
3845  while(len--) key = (key << 4) + (*ptr++);
3846
3847  return C_fix(key & C_MOST_POSITIVE_FIXNUM);
3848}
3849
3850
3851C_regparm C_word C_fcall C_hash_string_ci(C_word str)
3852{
3853  unsigned C_word key = 0;
3854  int len = C_header_size(str);
3855  C_byte *ptr = C_data_pointer(str);
3856
3857  while(len--) key = (key << 4) + C_tolower(*ptr++);
3858
3859  return C_fix(key & C_MOST_POSITIVE_FIXNUM);
3860}
3861
3862
3863C_regparm void C_fcall C_toplevel_entry(C_char *name)
3864{
3865  if(debug_mode) {
3866    C_printf(C_text("[debug] entering toplevel %s...\n"), name);
3867    C_fflush(stdout);
3868  }
3869}
3870
3871
3872C_word C_halt(C_word msg)
3873{
3874  C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;
3875
3876#ifdef C_MICROSOFT_WINDOWS
3877  if(msg != C_SCHEME_FALSE) {
3878    int n = C_header_size(msg);
3879
3880    C_strncpy(buffer, (C_char *)C_data_pointer(msg), n);
3881    buffer[ n ] = '\0';
3882  }
3883  else C_strcpy(buffer, C_text("(aborted)"));
3884
3885  C_strcat(buffer, C_text("\n\n"));
3886
3887  if(dmp != NULL) C_strcat(buffer, dmp);
3888
3889  MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
3890#else
3891  if(msg != C_SCHEME_FALSE) {
3892    C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);
3893    C_fputc('\n', C_stderr);
3894  }
3895
3896  if(dmp != NULL) C_fprintf(stderr, C_text("\n%s"), dmp);
3897#endif
3898 
3899  C_exit(EX_SOFTWARE);
3900  return 0;
3901}
3902
3903
3904C_word C_message(C_word msg)
3905{
3906#ifdef C_MICROSOFT_WINDOWS
3907  int n = C_header_size(msg);
3908
3909  C_strncpy(buffer, (C_char *)((C_SCHEME_BLOCK *)msg)->data, n);
3910  buffer[ n ] = '\0';
3911  MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
3912#else
3913  C_fwrite(((C_SCHEME_BLOCK *)msg)->data, C_header_size(msg), sizeof(C_char), stdout);
3914  C_putchar('\n');
3915#endif
3916  return C_SCHEME_UNDEFINED;
3917}
3918
3919
3920C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
3921{
3922  C_header header;
3923  C_word bits, n, i;
3924
3925  C_stack_check;
3926
3927 loop:
3928  if(x == y) return 1;
3929
3930  if(C_immediatep(x) || C_immediatep(y)) return 0;
3931
3932  if((header = C_block_header(x)) != C_block_header(y)) return 0;
3933  else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {
3934    if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)
3935      return C_flonum_magnitude(x) == C_flonum_magnitude(y);
3936    else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);
3937  }
3938  else if(header == C_SYMBOL_TAG) return 0;
3939  else {
3940    i = 0;
3941    n = header & C_HEADER_SIZE_MASK;
3942
3943    if(bits & C_SPECIALBLOCK_BIT) {
3944      if(C_u_i_car(x) != C_u_i_car(y)) return 0;
3945      else ++i;
3946
3947      if(n == 1) return 1;
3948    }
3949
3950    if(--n < 0) return 1;
3951
3952    while(i < n)
3953      if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;
3954      else ++i;
3955
3956    x = C_block_item(x, i);
3957    y = C_block_item(y, i);
3958    goto loop;
3959  }
3960   
3961  return 1;
3962}
3963
3964
3965C_regparm C_word C_fcall C_set_gc_report(C_word flag)
3966{
3967  if(flag == C_SCHEME_FALSE) gc_report_flag = 0;
3968  else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;
3969  else gc_report_flag = 1;
3970
3971  return C_SCHEME_UNDEFINED;
3972}
3973
3974
3975C_regparm C_word C_fcall C_start_timer(void)
3976{
3977  timer_start_mutation_count = mutation_count;
3978  timer_start_gc_count_1 = gc_count_1;
3979  timer_start_gc_count_2 = gc_count_2;
3980  timer_start_fromspace_top = C_fromspace_top;
3981  timer_start_ms = cpu_milliseconds();
3982  timer_start_gc_ms = 0;
3983  return C_SCHEME_UNDEFINED;
3984}
3985
3986
3987void C_ccall C_stop_timer(C_word c, C_word closure, C_word k)
3988{
3989  long t0 = cpu_milliseconds() - timer_start_ms;
3990  int gc2 = gc_count_2 - timer_start_gc_count_2,
3991      gc1 = gc2 ? gc_count_1 : (gc_count_1 - timer_start_gc_count_1),
3992      mutations = mutation_count - timer_start_mutation_count,
3993      from = gc2 ? ((C_uword)C_fromspace_top - (C_uword)fromspace_start)
3994                 : ((C_uword)C_fromspace_top - (C_uword)timer_start_fromspace_top);
3995  C_word
3996    ab[ WORDS_PER_FLONUM * 2 + 7 ], /* 2 flonums, 1 vector of 6 elements */
3997    *a = ab,
3998    elapsed = C_flonum(&a, (double)t0 / 1000.0),
3999    gc_time = C_flonum(&a, (double)timer_start_gc_ms / 1000.0),
4000    info;
4001
4002  info = C_vector(&a, 6, elapsed, gc_time, C_fix(mutations), C_fix(gc1), C_fix(gc2), C_fix(from));
4003  C_kontinue(k, info);
4004}
4005
4006
4007C_word C_exit_runtime(C_word code)
4008{
4009  exit(C_unfix(code));
4010  return 0;                     /* to please the compiler... */
4011}
4012
4013
4014C_regparm C_word C_fcall C_set_print_precision(C_word n)
4015{
4016  flonum_print_precision = C_unfix(n);
4017  return C_SCHEME_UNDEFINED;
4018}
4019
4020
4021C_regparm C_word C_fcall C_get_print_precision(void)
4022{
4023  return C_fix(flonum_print_precision);
4024}
4025
4026
4027C_regparm C_word C_fcall C_display_flonum(C_word port, C_word n)
4028{
4029  C_FILEPTR fp = C_port_file(port);
4030
4031#ifdef HAVE_GCVT
4032  C_fprintf(fp, C_text("%s"), C_gcvt(C_flonum_magnitude(n), flonum_print_precision, buffer));
4033#else
4034  C_fprintf(fp, C_text("%.*g"), flonum_print_precision, C_flonum_magnitude(n));
4035#endif
4036  return C_SCHEME_UNDEFINED;
4037}
4038
4039
4040C_regparm C_word C_fcall C_read_char(C_word port)
4041{
4042  int c = C_fgetc(C_port_file(port));
4043
4044  return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
4045}
4046
4047
4048C_regparm C_word C_fcall C_peek_char(C_word port)
4049{
4050  C_FILEPTR fp = C_port_file(port);
4051  int c = C_fgetc(fp);
4052
4053  C_ungetc(c, fp);
4054  return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
4055}
4056
4057
4058C_regparm C_word C_fcall C_execute_shell_command(C_word string)
4059{
4060  int n = C_header_size(string);
4061  char *buf = buffer;
4062
4063  /* Windows doc says to flush all output streams before calling system.
4064     Probably a good idea for all platforms. */
4065  (void)fflush(NULL);
4066
4067  if(n >= STRING_BUFFER_SIZE) {
4068    if((buf = (char *)C_malloc(n + 1)) == NULL)
4069      barf(C_OUT_OF_MEMORY_ERROR, "system");
4070  }
4071
4072  C_memcpy(buf, ((C_SCHEME_BLOCK *)string)->data, n);
4073  buf[ n ] = '\0';
4074
4075  n = C_system(buf);
4076
4077  if(buf != buffer) C_free(buf);
4078
4079  return C_fix(n);
4080}
4081
4082
4083C_regparm C_word C_fcall C_string_to_pbytevector(C_word s)
4084{
4085  return C_pbytevector(C_header_size(s), C_data_pointer(s));
4086}
4087
4088
4089C_regparm C_word C_fcall C_char_ready_p(C_word port)
4090{
4091#if !defined(C_NONUNIX)
4092  fd_set fs;
4093  struct timeval to;
4094  int fd = C_fileno(C_port_file(port));
4095
4096  FD_ZERO(&fs);
4097  FD_SET(fd, &fs);
4098  to.tv_sec = to.tv_usec = 0;
4099  return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
4100#else
4101  return C_SCHEME_TRUE;
4102#endif
4103}
4104
4105
4106C_regparm C_word C_fcall C_flush_output(C_word port)
4107{
4108  C_fflush(C_port_file(port));
4109  return C_SCHEME_UNDEFINED;
4110}
4111
4112
4113C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
4114{
4115  int i, j;
4116  long tgc;
4117
4118  switch(fudge_factor) {
4119  case C_fix(1): return C_SCHEME_END_OF_FILE;
4120  case C_fix(2): 
4121    /* can be considered broken (overflows into negatives), but is useful for randomize */
4122    return C_fix(C_MOST_POSITIVE_FIXNUM & time(NULL));
4123
4124  case C_fix(3):
4125#ifdef C_SIXTY_FOUR
4126    return C_SCHEME_TRUE;
4127#else
4128    return C_SCHEME_FALSE;
4129#endif
4130
4131  case C_fix(4):
4132#ifdef C_GENERIC_CONSOLE
4133    return C_SCHEME_TRUE;
4134#else
4135    return C_SCHEME_FALSE;
4136#endif
4137
4138  case C_fix(5):
4139#ifdef C_GENERIC_CONSOLE
4140    return C_fix(0);
4141#elif defined(C_WINDOWS_GUI)
4142    return C_fix(1);
4143#else
4144    return C_SCHEME_FALSE;
4145#endif
4146
4147  case C_fix(6): 
4148    return C_fix(C_MOST_POSITIVE_FIXNUM & cpu_milliseconds());
4149
4150  case C_fix(7):
4151    return C_fix(sizeof(C_word));
4152
4153  case C_fix(8):
4154    return C_fix(C_wordsperdouble(1));
4155
4156  case C_fix(9):
4157    return C_fix(last_interrupt_latency);
4158
4159  case C_fix(10):
4160    return C_fix(CLOCKS_PER_SEC);
4161
4162  case C_fix(11):
4163#if defined(C_NONUNIX) || defined(__CYGWIN__)
4164    return C_SCHEME_FALSE;
4165#else
4166    return C_SCHEME_TRUE;
4167#endif
4168
4169  case C_fix(12):
4170    return C_mk_bool(fake_tty_flag);
4171
4172  case C_fix(13):
4173    return C_mk_bool(debug_mode);
4174
4175  case C_fix(14):
4176    return C_mk_bool(C_interrupts_enabled);
4177
4178  case C_fix(15):
4179    return C_mk_bool(C_enable_gcweak);
4180
4181  case C_fix(16):
4182    return C_fix(C_MOST_POSITIVE_FIXNUM & milliseconds());
4183
4184  case C_fix(17):
4185    return(C_mk_bool(C_heap_size_is_fixed));
4186
4187  case C_fix(18):
4188    return(C_fix(C_STACK_GROWS_DOWNWARD));
4189
4190  case C_fix(19):
4191    for(i = j = 0; i < locative_table_count; ++i)
4192      if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j;
4193    return C_fix(j);
4194
4195  case C_fix(20):
4196#ifdef C_UNSAFE_RUNTIME
4197    return C_SCHEME_TRUE;
4198#else
4199    return C_SCHEME_FALSE;
4200#endif
4201
4202  case C_fix(21):
4203    return C_fix(C_MOST_POSITIVE_FIXNUM);
4204
4205    /* 22 */
4206
4207  case C_fix(23):
4208    return C_fix(C_startup_time_seconds);
4209
4210  case C_fix(24):
4211#ifdef NO_DLOAD2
4212    return C_SCHEME_FALSE;
4213#else
4214    return C_SCHEME_TRUE;
4215#endif
4216
4217  case C_fix(25):
4218    return C_mk_bool(C_enable_repl);
4219
4220  case C_fix(26):
4221    return C_fix(live_finalizer_count);
4222
4223  case C_fix(27):
4224    return C_fix(allocated_finalizer_count);
4225
4226  case C_fix(28):
4227#ifdef C_ENABLE_PTABLES
4228    return C_SCHEME_TRUE;
4229#else
4230    return C_SCHEME_FALSE;
4231#endif
4232
4233  case C_fix(29):
4234    return C_fix(C_trace_buffer_size);
4235
4236  case C_fix(30):
4237#ifdef _MSC_VER
4238    return C_fix(_MSC_VER);
4239#else
4240    return C_SCHEME_FALSE;
4241#endif
4242
4243  case C_fix(31):
4244    tgc = timer_accumulated_gc_ms;
4245    timer_accumulated_gc_ms = 0;
4246    return C_fix(tgc);
4247
4248  case C_fix(32):
4249#ifdef C_GC_HOOKS
4250    return C_SCHEME_TRUE;
4251#else
4252    return C_SCHEME_FALSE;
4253#endif
4254
4255  case C_fix(33):
4256    return C_SCHEME_TRUE;
4257
4258  case C_fix(34):
4259#ifdef C_HACKED_APPLY
4260    return C_fix(TEMPORARY_STACK_SIZE);
4261#else
4262    return C_fix(126);
4263#endif
4264
4265  case C_fix(35):
4266#ifndef C_NO_APPLY_HOOK
4267    return C_SCHEME_TRUE;
4268#else
4269    return C_SCHEME_FALSE;
4270#endif
4271   
4272  case C_fix(36):
4273    debug_mode = !debug_mode;
4274    return C_mk_bool(debug_mode);
4275
4276    /* 37 */
4277
4278  case C_fix(38):
4279#ifdef C_SVN_REVISION
4280    return C_fix(C_SVN_REVISION);
4281#else
4282    return C_fix(0);
4283#endif
4284
4285  case C_fix(39):
4286#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
4287    return C_SCHEME_TRUE;
4288#else
4289    return C_SCHEME_FALSE;
4290#endif
4291
4292  case C_fix(40):
4293#if defined(C_HACKED_APPLY)
4294    return C_SCHEME_TRUE;
4295#else
4296    return C_SCHEME_FALSE;
4297#endif
4298
4299  case C_fix(41):
4300    return C_fix(C_MAJOR_VERSION);
4301
4302  case C_fix(42):
4303#ifdef C_BINARY_VERSION
4304    return C_fix(C_BINARY_VERSION);
4305#else
4306    return C_SCHEME_FALSE;
4307#endif
4308
4309  default: return C_SCHEME_UNDEFINED;
4310  }
4311}
4312
4313
4314C_regparm void C_fcall C_paranoid_check_for_interrupt(void)
4315{
4316  if(--C_timer_interrupt_counter <= 0)
4317    C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER);
4318}
4319
4320
4321C_regparm void C_fcall C_raise_interrupt(int reason)
4322{
4323  if(C_interrupts_enabled) {
4324    saved_stack_limit = C_stack_limit;
4325
4326#if C_STACK_GROWS_DOWNWARD
4327    C_stack_limit = C_stack_pointer + 1000;
4328#else
4329    C_stack_limit = C_stack_pointer - 1000;
4330#endif
4331
4332    interrupt_reason = reason;
4333    interrupt_time = cpu_milliseconds();
4334  }
4335}
4336
4337
4338C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
4339{
4340  C_initial_timer_interrupt_period = C_unfix(n);
4341  return C_SCHEME_UNDEFINED;
4342}
4343
4344
4345C_regparm C_word C_fcall C_enable_interrupts(void)
4346{
4347  C_timer_interrupt_counter = C_initial_timer_interrupt_period;
4348  /* assert(C_timer_interrupt_counter > 0); */
4349  C_interrupts_enabled = 1;
4350  return C_SCHEME_UNDEFINED;
4351}
4352
4353
4354C_regparm C_word C_fcall C_disable_interrupts(void)
4355{
4356  C_interrupts_enabled = 0;
4357  return C_SCHEME_UNDEFINED;
4358}
4359
4360
4361C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason)
4362{
4363  int sig = C_unfix(signum);
4364
4365  if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
4366  else {
4367    signal_mapping_table[ sig ] = C_unfix(reason);
4368    C_signal(sig, global_signal_handler);
4369  }
4370
4371  return C_SCHEME_UNDEFINED;
4372}
4373
4374
4375C_regparm C_word C_fcall C_flonum_in_fixnum_range_p(C_word n)
4376{
4377  double f = C_flonum_magnitude(n);
4378
4379  return C_mk_bool(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM);
4380}
4381
4382
4383C_regparm C_word C_fcall C_double_to_number(C_word n)
4384{
4385  double m, f = C_flonum_magnitude(n);
4386
4387  if(f <= (double)C_MOST_POSITIVE_FIXNUM
4388     && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0) 
4389    return C_fix(f);
4390  else return n;
4391}
4392
4393
4394C_regparm C_word C_fcall C_fits_in_int_p(C_word x)
4395{
4396  double n, m;
4397
4398  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4399
4400  n = C_flonum_magnitude(x);
4401  return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
4402}
4403
4404
4405C_regparm C_word C_fcall C_fits_in_unsigned_int_p(C_word x)
4406{
4407  double n, m;
4408
4409  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4410
4411  n = C_flonum_magnitude(x);
4412  return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
4413}
4414
4415
4416/* Copy blocks into collected or static memory: */
4417
4418C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
4419{
4420  int n = C_header_size(from);
4421  long bytes;
4422
4423  if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
4424    bytes = n;
4425    C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4426  }
4427  else {
4428    bytes = C_wordstobytes(n);
4429    C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4430  }
4431
4432  return to;
4433}
4434
4435
4436C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
4437{
4438  int n = C_header_size(from);
4439  long bytes;
4440  C_word *p = (C_word *)C_pointer_address(ptr);
4441
4442  if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
4443  else bytes = C_wordstobytes(n);
4444
4445  C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4446  return (C_word)p;
4447}
4448
4449
4450/* Conversion routines: */
4451
4452C_regparm double C_fcall C_c_double(C_word x)
4453{
4454  if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
4455  else return C_flonum_magnitude(x);
4456}
4457
4458
4459C_regparm C_word C_fcall C_num_to_int(C_word x)
4460{
4461  if(x & C_FIXNUM_BIT) return C_unfix(x);
4462  else return (int)C_flonum_magnitude(x);
4463}
4464
4465
4466C_regparm C_s64 C_fcall C_num_to_int64(C_word x)
4467{
4468  if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
4469  else return (C_s64)C_flonum_magnitude(x);
4470}
4471
4472
4473C_regparm C_uword C_fcall C_num_to_unsigned_int(C_word x)
4474{
4475  if(x & C_FIXNUM_BIT) return C_unfix(x);
4476  else return (unsigned int)C_flonum_magnitude(x);
4477}
4478
4479
4480C_regparm C_word C_fcall C_int_to_num(C_word **ptr, C_word n)
4481{
4482  if(C_fitsinfixnump(n)) return C_fix(n);
4483  else return C_flonum(ptr, (double)n);
4484}
4485
4486
4487C_regparm C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n)
4488{
4489  if(C_ufitsinfixnump(n)) return C_fix(n);
4490  else return C_flonum(ptr, (double)n);
4491}
4492
4493
4494C_regparm C_word C_fcall C_long_to_num(C_word **ptr, long n)
4495{
4496  if(C_fitsinfixnump(n)) return C_fix(n);
4497  else return C_flonum(ptr, (double)n);
4498}
4499
4500
4501C_regparm C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n)
4502{
4503  if(C_ufitsinfixnump(n)) return C_fix(n);
4504  else return C_flonum(ptr, (double)n);
4505}
4506
4507
4508C_regparm C_word C_fcall C_flonum_in_int_range_p(C_word n)
4509{
4510  double m = C_flonum_magnitude(n);
4511
4512  return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
4513}
4514
4515
4516C_regparm C_word C_fcall C_flonum_in_uint_range_p(C_word n)
4517{
4518  double m = C_flonum_magnitude(n);
4519
4520  return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
4521}
4522
4523
4524C_regparm char *C_fcall C_string_or_null(C_word x)
4525{
4526  return C_truep(x) ? C_c_string(x) : NULL;
4527}
4528
4529
4530C_regparm void *C_fcall C_data_pointer_or_null(C_word x) 
4531{
4532  return C_truep(x) ? C_data_pointer(x) : NULL;
4533}
4534
4535
4536C_regparm void *C_fcall C_srfi_4_vector_or_null(C_word x) 
4537{
4538  return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
4539}
4540
4541
4542C_regparm void *C_fcall C_c_pointer_or_null(C_word x) 
4543{
4544  return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
4545}
4546
4547
4548C_regparm void *C_fcall C_scheme_or_c_pointer(C_word x) 
4549{
4550  return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
4551}
4552
4553
4554C_regparm long C_fcall C_num_to_long(C_word x)
4555{
4556  if(x & C_FIXNUM_BIT) return C_unfix(x);
4557  else return (long)C_flonum_magnitude(x);
4558}
4559
4560
4561C_regparm unsigned long C_fcall C_num_to_unsigned_long(C_word x)
4562{
4563  if(x & C_FIXNUM_BIT) return C_unfix(x);
4564  else return (unsigned long)C_flonum_magnitude(x);
4565}
4566
4567
4568/* Inline versions of some standard procedures: */
4569
4570C_regparm C_word C_fcall C_i_listp(C_word x)
4571{
4572  C_word fast = x, slow = x;
4573
4574  while(fast != C_SCHEME_END_OF_LIST)
4575    if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
4576      fast = C_u_i_cdr(fast);
4577     
4578      if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
4579      else if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
4580        fast = C_u_i_cdr(fast);
4581        slow = C_u_i_cdr(slow);
4582
4583        if(fast == slow) return C_SCHEME_FALSE;
4584      }
4585      else return C_SCHEME_FALSE;
4586    }
4587    else return C_SCHEME_FALSE;
4588
4589  return C_SCHEME_TRUE;
4590}
4591
4592
4593C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
4594{
4595  C_word n;
4596
4597  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
4598    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);
4599
4600  if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
4601    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);
4602
4603  n = C_header_size(x);
4604
4605  return C_mk_bool(n == C_header_size(y)
4606                   && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
4607}
4608
4609
4610C_regparm C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y)
4611{
4612  C_word n;
4613
4614  n = C_header_size(x);
4615  return C_mk_bool(n == C_header_size(y)
4616         && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
4617}
4618
4619
4620C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
4621{
4622  C_word n;
4623  char *p1, *p2;
4624
4625  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
4626    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);
4627
4628  if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
4629    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);
4630
4631  n = C_header_size(x);
4632
4633  if(n != C_header_size(y)) return C_SCHEME_FALSE;
4634
4635  p1 = (char *)C_data_pointer(x);
4636  p2 = (char *)C_data_pointer(y);
4637
4638  while(n--) 
4639    if(C_tolower(*(p1++)) != C_tolower(*(p2++))) return C_SCHEME_FALSE;
4640
4641  return C_SCHEME_TRUE;
4642}
4643
4644
4645C_regparm C_word C_fcall C_i_eqvp(C_word x, C_word y)
4646{
4647  return
4648    C_mk_bool(x == y ||
4649              (!C_immediatep(x) && !C_immediatep(y) &&
4650               C_block_header(x) == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG &&
4651               C_flonum_magnitude(x) == C_flonum_magnitude(y) ) );
4652}
4653
4654
4655C_regparm C_word C_fcall C_i_symbolp(C_word x)
4656{
4657  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG);
4658}
4659
4660
4661C_regparm C_word C_fcall C_i_pairp(C_word x)
4662{
4663  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
4664}
4665
4666
4667C_regparm C_word C_fcall C_i_stringp(C_word x)
4668{
4669  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
4670}
4671
4672
4673C_regparm C_word C_fcall C_i_locativep(C_word x)
4674{
4675  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
4676}
4677
4678
4679C_regparm C_word C_fcall C_i_vectorp(C_word x)
4680{
4681  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
4682}
4683
4684
4685C_regparm C_word C_fcall C_i_portp(C_word x)
4686{
4687  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
4688}
4689
4690
4691C_regparm C_word C_fcall C_i_closurep(C_word x)
4692{
4693  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
4694}
4695
4696
4697C_regparm C_word C_fcall C_i_numberp(C_word x)
4698{
4699  return C_mk_bool((x & C_FIXNUM_BIT)
4700         || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
4701}
4702
4703
4704C_regparm C_word C_fcall C_i_integerp(C_word x)
4705{
4706  double dummy;
4707
4708  return C_mk_bool((x & C_FIXNUM_BIT) || 
4709                   ((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
4710                    modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
4711}
4712
4713
4714C_regparm C_word C_fcall C_i_flonump(C_word x)
4715{
4716  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
4717}
4718
4719
4720C_regparm C_word C_fcall C_i_finitep(C_word x)
4721{
4722  if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
4723  else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
4724}
4725
4726
4727C_regparm C_word C_fcall C_i_fixnum_min(C_word x, C_word y)
4728{
4729  return ((C_word)x < (C_word)y) ? x : y;
4730}
4731
4732
4733C_regparm C_word C_fcall C_i_fixnum_max(C_word x, C_word y)
4734{
4735  return ((C_word)x > (C_word)y) ? x : y;
4736}
4737
4738
4739C_regparm C_word C_fcall C_i_flonum_min(C_word x, C_word y)
4740{
4741  double 
4742    xf = C_flonum_magnitude(x),
4743    yf = C_flonum_magnitude(y);
4744
4745  return xf < yf ? x : y;
4746}
4747
4748
4749C_regparm C_word C_fcall C_i_flonum_max(C_word x, C_word y)
4750{
4751  double 
4752    xf = C_flonum_magnitude(x),
4753    yf = C_flonum_magnitude(y);
4754
4755  return xf > yf ? x : y;
4756}
4757
4758
4759#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
4760
4761C_word *C_a_i(C_word **a, int n)
4762{
4763  C_word *p = *a;
4764 
4765  *a += n;
4766  return p;
4767}
4768
4769#endif
4770
4771
4772C_word C_a_i_list(C_word **a, int c, ...)
4773{
4774  va_list v;
4775  C_word x, last, current,
4776         first = C_SCHEME_END_OF_LIST;
4777
4778  va_start(v, c);
4779
4780  for(last = C_SCHEME_UNDEFINED; c--; last = current) {
4781    x = va_arg(v, C_word);
4782    current = C_pair(a, x, C_SCHEME_END_OF_LIST);
4783
4784    if(last != C_SCHEME_UNDEFINED)
4785      C_set_block_item(last, 1, current);
4786    else first = current;
4787  }
4788
4789  va_end(v);
4790  return first;
4791}
4792
4793
4794C_word C_h_list(int c, ...)
4795{
4796  /* Similar to C_a_i_list(), but put slots with nursery data into mutation stack: */
4797  va_list v;
4798  C_word x, last, current,
4799         first = C_SCHEME_END_OF_LIST;
4800
4801  va_start(v, c);
4802
4803  for(last = C_SCHEME_UNDEFINED; c--; last = current) {
4804    x = va_arg(v, C_word);
4805    current = C_pair(C_heaptop, x, C_SCHEME_END_OF_LIST);
4806
4807    if(C_in_stackp(x)) 
4808      C_mutate(&C_u_i_car(current), x);
4809
4810    if(last != C_SCHEME_UNDEFINED)
4811      C_set_block_item(last, 1, current);
4812    else first = current;
4813  }
4814
4815  va_end(v);
4816  return first;
4817}
4818
4819
4820C_word C_a_i_string(C_word **a, int c, ...)
4821{
4822  va_list v;
4823  C_word x, s = (C_word)(*a);
4824  char *p;
4825
4826  *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(c));
4827  ((C_SCHEME_BLOCK *)s)->header = C_STRING_TYPE | c;
4828  p = (char *)C_data_pointer(s);
4829  va_start(v, c);
4830
4831  while(c--) {
4832    x = va_arg(v, C_word);
4833
4834    if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
4835      *(p++) = C_character_code(x);
4836    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);
4837  }
4838
4839  return s;
4840}
4841
4842
4843C_word C_a_i_record(C_word **ptr, int n, ...)
4844{
4845  va_list v;
4846  C_word *p = *ptr,
4847         *p0 = p; 
4848
4849  *(p++) = C_STRUCTURE_TYPE | n;
4850  va_start(v, n);
4851
4852  while(n--)
4853    *(p++) = va_arg(v, C_word);
4854
4855  *ptr = p;
4856  va_end(v);
4857  return (C_word)p0;
4858}
4859
4860
4861C_word C_a_i_port(C_word **ptr, int n)
4862{
4863  C_word
4864    *p = *ptr,
4865    *p0 = p; 
4866  int i;
4867
4868  *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);
4869  *(p++) = (C_word)NULL;
4870 
4871  for(i = 0; i < C_SIZEOF_PORT - 2; ++i)
4872    *(p++) = C_SCHEME_FALSE;
4873
4874  *ptr = p;
4875  return (C_word)p0;
4876}
4877
4878
4879C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
4880{
4881  C_word *p = *ptr,
4882         *p0;
4883  int n = C_unfix(num);
4884
4885#ifndef C_SIXTY_FOUR
4886  /* Align on 8-byte boundary: */
4887  if(aligned8(p)) ++p;
4888#endif
4889
4890  p0 = p;
4891  *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);
4892  *ptr = p + n;
4893  return (C_word)p0;
4894}
4895
4896
4897C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
4898{
4899  C_word
4900    *p = *ptr,
4901    *p0 = p;
4902  void *mp;
4903
4904  if(C_immediatep(x)) mp = NULL;
4905  else if((C_header_bits(x) && C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);
4906  else mp = C_data_pointer(x);
4907
4908  *(p++) = C_POINTER_TYPE | 1;
4909  *((void **)p) = mp;
4910  *ptr = p + 1;
4911  return (C_word)p0;
4912}
4913
4914
4915C_regparm C_word C_fcall C_i_exactp(C_word x)
4916{
4917  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4918
4919  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4920    barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact?", x);
4921
4922  return C_SCHEME_FALSE;
4923}
4924
4925
4926C_regparm C_word C_fcall C_u_i_exactp(C_word x)
4927{
4928  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4929
4930  return C_SCHEME_FALSE;
4931}
4932
4933
4934C_regparm C_word C_fcall C_i_inexactp(C_word x)
4935{
4936  if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
4937
4938  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4939    barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact?", x);
4940
4941  return C_SCHEME_TRUE;
4942}
4943
4944
4945C_regparm C_word C_fcall C_u_i_inexactp(C_word x)
4946{
4947  if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
4948
4949  return C_SCHEME_TRUE;
4950}
4951
4952
4953C_regparm C_word C_fcall C_i_zerop(C_word x)
4954{
4955  if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
4956
4957  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4958    barf(C_BAD_ARGUMENT_TYPE_ERROR, "zero?", x);
4959
4960  return C_mk_bool(C_flonum_magnitude(x) == 0.0);
4961}
4962
4963
4964C_regparm C_word C_fcall C_u_i_zerop(C_word x)
4965{
4966  if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
4967
4968  return C_mk_bool(C_flonum_magnitude(x) == 0.0);
4969}
4970
4971
4972C_regparm C_word C_fcall C_i_positivep(C_word x)
4973{
4974  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
4975
4976  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4977    barf(C_BAD_ARGUMENT_TYPE_ERROR, "positive?", x);
4978
4979  return C_mk_bool(C_flonum_magnitude(x) > 0.0);
4980}
4981
4982
4983C_regparm C_word C_fcall C_u_i_positivep(C_word x)
4984{
4985  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
4986
4987  return C_mk_bool(C_flonum_magnitude(x) > 0.0);
4988}
4989
4990
4991C_regparm C_word C_fcall C_i_negativep(C_word x)
4992{
4993  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
4994
4995  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4996    barf(C_BAD_ARGUMENT_TYPE_ERROR, "negative?", x);
4997
4998  return C_mk_bool(C_flonum_magnitude(x) < 0.0);
4999}
5000
5001
5002C_regparm C_word C_fcall C_u_i_negativep(C_word x)
5003{
5004  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
5005
5006  return C_mk_bool(C_flonum_magnitude(x) < 0.0);
5007}
5008
5009
5010C_regparm C_word C_fcall C_i_evenp(C_word x)
5011{
5012  if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
5013
5014  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
5015    barf(C_BAD_ARGUMENT_TYPE_ERROR, "even?", x);
5016
5017  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
5018}
5019
5020
5021C_regparm C_word C_fcall C_u_i_evenp(C_word x)
5022{
5023  if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
5024
5025  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
5026}
5027
5028
5029C_regparm C_word C_fcall C_i_oddp(C_word x)
5030{
5031  if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
5032
5033  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
5034    barf(C_BAD_ARGUMENT_TYPE_ERROR, "odd?", x);
5035
5036  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
5037}
5038
5039
5040C_regparm C_word C_fcall C_u_i_oddp(C_word x)
5041{
5042  if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
5043
5044  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
5045}
5046
5047
5048C_regparm C_word C_fcall C_i_car(C_word x)
5049{
5050  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5051    barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);
5052
5053  return C_u_i_car(x);
5054}
5055
5056
5057C_regparm C_word C_fcall C_i_cdr(C_word x)
5058{
5059  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5060    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);
5061
5062  return C_u_i_cdr(x);
5063}
5064
5065
5066C_regparm C_word C_fcall C_i_cadr(C_word x)
5067{
5068  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5069  bad:
5070    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);
5071  }
5072
5073  x = C_u_i_cdr(x);
5074  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5075
5076  return C_u_i_car(x);
5077}
5078
5079
5080C_regparm C_word C_fcall C_i_cddr(C_word x)
5081{
5082  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5083  bad:
5084    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);
5085  }
5086
5087  x = C_u_i_cdr(x);
5088  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5089
5090  return C_u_i_cdr(x);
5091}
5092
5093
5094C_regparm C_word C_fcall C_i_caddr(C_word x)
5095{
5096  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5097  bad:
5098    barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);
5099  }
5100
5101  x = C_u_i_cdr(x);
5102  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5103  x = C_u_i_cdr(x);
5104  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5105
5106  return C_u_i_car(x);
5107}
5108
5109
5110C_regparm C_word C_fcall C_i_cdddr(C_word x)
5111{
5112  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5113  bad:
5114    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);
5115  }
5116
5117  x = C_u_i_cdr(x);
5118  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5119  x = C_u_i_cdr(x);
5120  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5121
5122  return C_u_i_cdr(x);
5123}
5124
5125
5126C_regparm C_word C_fcall C_i_cadddr(C_word x)
5127{
5128  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5129  bad:
5130    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);
5131  }
5132
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  x = C_u_i_cdr(x);
5138  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5139
5140  return C_u_i_car(x);
5141}
5142
5143
5144C_regparm C_word C_fcall C_i_cddddr(C_word x)
5145{
5146  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5147  bad:
5148    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);
5149  }
5150
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  x = C_u_i_cdr(x);
5156  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5157
5158  return C_u_i_cdr(x);
5159}
5160
5161
5162C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
5163{
5164  C_word lst0 = lst;
5165  int n;
5166
5167  if(i & C_FIXNUM_BIT) n = C_unfix(i);
5168  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);
5169
5170  while(n--) {
5171    if(C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)
5172      barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);
5173   
5174    lst = C_u_i_cdr(lst);
5175  }
5176
5177  return lst;
5178}
5179
5180
5181C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
5182{
5183  int j;
5184
5185  if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5186    barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);
5187
5188  if(i & C_FIXNUM_BIT) {
5189    j = C_unfix(i);
5190
5191    if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-ref", v, i);
5192
5193    return C_block_item(v, j);
5194  }
5195 
5196  barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);
5197  return C_SCHEME_UNDEFINED;
5198}
5199
5200
5201C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
5202{
5203  int j;
5204
5205  if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)
5206    barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);
5207
5208  if(i & C_FIXNUM_BIT) {
5209    j = C_unfix(i);
5210
5211    if(j < 0 || j >= C_header_size(x)) barf(C_OUT_OF_RANGE_ERROR, "##sys#block-ref", x, i);
5212
5213    return C_block_item(x, j);
5214  }
5215 
5216  barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);
5217  return C_SCHEME_UNDEFINED;
5218}
5219
5220
5221C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)
5222{
5223  int j;
5224
5225  if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5226    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);
5227
5228  if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5229    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);
5230
5231  if(i & C_FIXNUM_BIT) {
5232    j = C_unfix(i);
5233
5234    if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-set!", s, i);
5235
5236    return C_setsubchar(s, i, c);
5237  }
5238
5239  barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);
5240  return C_SCHEME_UNDEFINED;
5241}
5242
5243
5244C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
5245{
5246  int j;
5247
5248  if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5249    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);
5250
5251  if(i & C_FIXNUM_BIT) {
5252    j = C_unfix(i);
5253
5254    if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-ref", s, i);
5255
5256    return C_subchar(s, i);
5257  }
5258 
5259  barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);
5260  return C_SCHEME_UNDEFINED;
5261}
5262
5263
5264C_regparm C_word C_fcall C_i_vector_length(C_word v)
5265{
5266  if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5267    barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);
5268
5269  return C_fix(C_header_size(v));
5270}
5271
5272
5273C_regparm C_word C_fcall C_i_string_length(C_word s)
5274{
5275  if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5276    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);
5277
5278  return C_fix(C_header_size(s));
5279}
5280
5281
5282C_regparm C_word C_fcall C_i_length(C_word lst)
5283{
5284  C_word fast = lst, slow = lst;
5285  int n = 0;
5286
5287  while(slow != C_SCHEME_END_OF_LIST) {
5288    if(fast != C_SCHEME_END_OF_LIST) {
5289      if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
5290        fast = C_u_i_cdr(fast);
5291     
5292        if(fast != C_SCHEME_END_OF_LIST) {
5293          if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
5294            fast = C_u_i_cdr(fast);
5295          }
5296          else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
5297        }
5298
5299        if(fast == slow) 
5300          barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);
5301      }
5302    }
5303
5304    if(C_immediatep(slow) || C_block_header(lst) != C_PAIR_TAG)
5305      barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
5306
5307    slow = C_u_i_cdr(slow);
5308    ++n;
5309  }
5310
5311  return C_fix(n);
5312}
5313
5314
5315C_regparm C_word C_fcall C_u_i_length(C_word lst)
5316{
5317  int n = 0;
5318
5319  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5320    lst = C_u_i_cdr(lst);
5321    ++n;
5322  }
5323
5324  return C_fix(n);
5325}
5326
5327
5328C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
5329{
5330  double m;
5331  C_word r;
5332
5333  if(n & C_FIXNUM_BIT) return n;
5334  else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
5335    barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
5336
5337  if(modf(C_flonum_magnitude(n), &m) == 0.0) {
5338    r = (C_word)m;
5339   
5340    if(r == m && C_fitsinfixnump(r))
5341      return C_fix(r);
5342  }
5343
5344  barf(C_CANT_REPRESENT_INEXACT_ERROR, "inexact->exact", n);
5345  return 0;
5346}
5347
5348
5349C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
5350{
5351  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5352    barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);
5353
5354  C_mutate(&C_u_i_car(x), val);
5355  return C_SCHEME_UNDEFINED;
5356}
5357
5358
5359C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
5360{
5361  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5362    barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);
5363
5364  C_mutate(&C_u_i_cdr(x), val);
5365  return C_SCHEME_UNDEFINED;
5366}
5367
5368
5369C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
5370{
5371  int j;
5372
5373  if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5374    barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);
5375
5376  if(i & C_FIXNUM_BIT) {
5377    j = C_unfix(i);
5378
5379    if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-set!", v, i);
5380
5381    C_mutate(&C_block_item(v, j), x);
5382  }
5383  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);
5384
5385  return C_SCHEME_UNDEFINED;
5386}
5387
5388
5389C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
5390{
5391  if(x & C_FIXNUM_BIT) return C_fix(abs(C_unfix(x)));
5392
5393  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
5394    barf(C_BAD_ARGUMENT_TYPE_ERROR, "abs", x);
5395
5396  return C_flonum(a, fabs(C_flonum_magnitude(x)));
5397}
5398
5399
5400C_regparm C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2)
5401{
5402  return C_flonum(a, C_flonum_magnitude(n1) + C_flonum_magnitude(n2));
5403}
5404
5405
5406C_regparm C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2)
5407{
5408  return C_flonum(a, C_flonum_magnitude(n1) - C_flonum_magnitude(n2));
5409}
5410
5411
5412C_regparm C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2)
5413{
5414  return C_flonum(a, C_flonum_magnitude(n1) * C_flonum_magnitude(n2));
5415}
5416
5417
5418C_regparm C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2)
5419{
5420  return C_flonum(a, C_flonum_magnitude(n1) / C_flonum_magnitude(n2));
5421}
5422
5423
5424C_regparm C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n)
5425{
5426  return C_flonum(a, -C_flonum_magnitude(n));
5427}
5428
5429
5430C_regparm C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2)
5431{
5432  double f1, f2;
5433  C_uword nn1, nn2;
5434
5435# ifdef BITWISE_UINT_ONLY
5436  C_check_uint(n1, f1, nn1, "bitwise-and");
5437  C_check_uint(n2, f2, nn2, "bitwise-and");
5438# else
5439  C_check_uintX(n1, f1, nn1, "bitwise-and");
5440  C_check_uintX(n2, f2, nn2, "bitwise-and");
5441# endif
5442  nn1 = C_limit_fixnum(nn1 & nn2);
5443
5444  if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5445  else return C_flonum(a, nn1);
5446}
5447
5448
5449C_regparm C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2)
5450{
5451  double f1, f2;
5452  C_uword nn1, nn2;
5453
5454# ifdef BITWISE_UINT_ONLY
5455  C_check_uint(n1, f1, nn1, "bitwise-ior");
5456  C_check_uint(n2, f2, nn2, "bitwise-ior");
5457# else
5458  C_check_uintX(n1, f1, nn1, "bitwise-ior");
5459  C_check_uintX(n2, f2, nn2, "bitwise-ior");
5460# endif
5461  nn1 = C_limit_fixnum(nn1 | nn2);
5462
5463  if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5464  else return C_flonum(a, nn1);
5465}
5466
5467
5468C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2)
5469{
5470  double f1, f2;
5471  C_uword nn1, nn2;
5472
5473# ifdef BITWISE_UINT_ONLY
5474  C_check_uint(n1, f1, nn1, "bitwise-xor");
5475  C_check_uint(n2, f2, nn2, "bitwise-xor");
5476# else
5477  C_check_uintX(n1, f1, nn1, "bitwise-xor");
5478  C_check_uintX(n2, f2, nn2, "bitwise-xor");
5479# endif
5480  nn1 = C_limit_fixnum(nn1 ^ nn2);
5481
5482  if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5483  else return C_flonum(a, nn1);
5484}
5485
5486
5487C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
5488{
5489  double f1;
5490  C_uword nn1;
5491  int index;
5492
5493  if((i & C_FIXNUM_BIT) == 0) 
5494    barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "bit-set?", i);
5495
5496  index = C_unfix(i);
5497
5498  if(index < 0 || index >= C_WORD_SIZE)
5499    barf(C_OUT_OF_RANGE_ERROR, "bit-set?", n, i);
5500
5501# ifdef BITWISE_UINT_ONLY
5502  C_check_uint(n, f1, nn1, "bit-set?");
5503# else
5504  C_check_uintX(n, f1, nn1, "bit-set?");
5505# endif
5506  return C_mk_bool((nn1 & (1 << index)) != 0);
5507}
5508
5509
5510C_regparm C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n)
5511{
5512  double f;
5513  C_uword nn;
5514
5515# ifdef BITWISE_UINT_ONLY
5516  C_check_uint(n, f, nn, "bitwise-not");
5517# else
5518  C_check_uintX(n, f, nn, "bitwise-not");
5519# endif
5520  nn = C_limit_fixnum(~nn);
5521
5522  if(C_ufitsinfixnump(nn)) return C_fix(nn);
5523  else return C_flonum(a, nn);
5524}
5525
5526
5527C_regparm C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2)
5528{
5529  C_word nn;
5530  C_uword unn;
5531  C_word s;
5532  int sgn = 1;
5533
5534  if((n1 & C_FIXNUM_BIT) != 0) {
5535    nn = C_unfix(n1);
5536
5537    if((sgn = nn < 0 ? -1 : 1) >= 0) unn = nn;
5538  }
5539  else if(C_immediatep(n1) || C_block_header(n1) != C_FLONUM_TAG)
5540    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "arithmetic-shift", n1);
5541  else { 
5542    double m, f;
5543
5544    f = C_flonum_magnitude(n1);
5545   
5546    if(modf(f, &m) != 0.0)
5547      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5548
5549    if(f < C_WORD_MIN || f > C_UWORD_MAX)
5550      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5551    else if(f < 0) {
5552      if(f > C_WORD_MAX)
5553        barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5554      else {
5555        sgn = -1;
5556        nn = (C_word)f;
5557      }
5558    }
5559    else if(f > C_WORD_MAX) unn = (C_uword)f;
5560    else {
5561      nn = (C_word)f;
5562      sgn = -1;
5563    }
5564  }
5565
5566  if((n2 & C_FIXNUM_BIT) != 0) s = C_unfix(n2);
5567  else barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", n2);
5568
5569  if(sgn < 0) {
5570    if(s < 0) nn >>= -s;
5571    else nn <<= s;
5572
5573    if(C_fitsinfixnump(nn)) return C_fix(nn);
5574    else return C_flonum(a, nn);
5575  } 
5576  else {
5577    if(s < 0) unn >>= -s;
5578    else unn <<= s;
5579 
5580    if(C_ufitsinfixnump(unn)) return C_fix(unn);
5581    else return C_flonum(a, unn);
5582  }
5583}
5584
5585
5586C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
5587{
5588  double f;
5589
5590  C_check_real(n, "exp", f);
5591  return C_flonum(a, exp(f));
5592}
5593
5594
5595C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
5596{
5597  double f;
5598
5599  C_check_real(n, "log", f);
5600  return C_flonum(a, log(f));
5601}
5602
5603
5604C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
5605{
5606  double f;
5607
5608  C_check_real(n, "sin", f);
5609  return C_flonum(a, sin(f));
5610}
5611
5612
5613C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
5614{
5615  double f;
5616
5617  C_check_real(n, "cos", f);
5618  return C_flonum(a, cos(f));
5619}
5620
5621
5622C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
5623{
5624  double f;
5625
5626  C_check_real(n, "tan", f);
5627  return C_flonum(a, tan(f));
5628}
5629
5630
5631C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
5632{
5633  double f;
5634
5635  C_check_real(n, "asin", f);
5636  return C_flonum(a, asin(f));
5637}
5638
5639
5640C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
5641{
5642  double f;
5643
5644  C_check_real(n, "acos", f);
5645  return C_flonum(a, acos(f));
5646}
5647
5648
5649C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
5650{
5651  double f;
5652
5653  C_check_real(n, "atan", f);
5654  return C_flonum(a, atan(f));
5655}
5656
5657
5658C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
5659{
5660  double f1, f2;
5661
5662  C_check_real(n1, "atan", f1);
5663  C_check_real(n2, "atan", f2);
5664  return C_flonum(a, atan2(f1, f2));
5665}
5666
5667
5668C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
5669{
5670  double f;
5671
5672  C_check_real(n, "sqrt", f);
5673  return C_flonum(a, sqrt(f));
5674}
5675
5676
5677C_regparm C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c)
5678{
5679  if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
5680  else return C_fixnum_shift_left(n, c);
5681}
5682
5683
5684C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
5685{
5686  C_word a;
5687
5688  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5689    a = C_u_i_car(lst);
5690
5691    if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5692      if(C_u_i_car(a) == x) return a;
5693    }
5694    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);
5695 
5696    lst = C_u_i_cdr(lst);
5697  }
5698
5699  return C_SCHEME_FALSE;
5700}
5701
5702
5703C_regparm C_word C_fcall C_u_i_assq(C_word x, C_word lst)
5704{
5705  C_word a;
5706
5707  while(!C_immediatep(lst)) {
5708    a = C_u_i_car(lst);
5709
5710    if(C_u_i_car(a) == x) return a;
5711    else lst = C_u_i_cdr(lst);
5712  }
5713
5714  return C_SCHEME_FALSE;
5715}
5716
5717
5718C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
5719{
5720  C_word a;
5721
5722  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5723    a = C_u_i_car(lst);
5724
5725    if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5726      if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;
5727    }
5728    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);
5729 
5730    lst = C_u_i_cdr(lst);
5731  }
5732
5733  return C_SCHEME_FALSE;
5734}
5735
5736
5737C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
5738{
5739  C_word a;
5740
5741  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5742    a = C_u_i_car(lst);
5743
5744    if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5745      if(C_equalp(C_u_i_car(a), x)) return a;
5746    }
5747    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);
5748 
5749    lst = C_u_i_cdr(lst);
5750  }
5751
5752  return C_SCHEME_FALSE;
5753}
5754
5755
5756C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
5757{
5758  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5759    if(C_u_i_car(lst) == x) return lst;
5760    else lst = C_u_i_cdr(lst);
5761  }
5762
5763  return C_SCHEME_FALSE;
5764}
5765
5766
5767C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
5768{
5769  while(!C_immediatep(lst)) {
5770    if(C_u_i_car(lst) == x) return lst;
5771    else lst = C_u_i_cdr(lst);
5772  }
5773
5774  return C_SCHEME_FALSE;
5775}
5776
5777
5778C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
5779{
5780  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5781    if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;
5782    else lst = C_u_i_cdr(lst);
5783  }
5784
5785  return C_SCHEME_FALSE;
5786}
5787
5788
5789C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
5790{
5791  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5792    if(C_equalp(C_u_i_car(lst), x)) return lst;
5793    else lst = C_u_i_cdr(lst);
5794  }
5795 
5796  return C_SCHEME_FALSE;
5797}
5798
5799
5800/* Inline routines for extended bindings: */
5801
5802C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
5803{
5804  if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {
5805    error_location = loc;
5806    barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);
5807  }
5808
5809  return C_SCHEME_UNDEFINED;
5810}
5811
5812
5813C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
5814{
5815  if((x & C_FIXNUM_BIT) == 0) {
5816    error_location = loc;
5817    barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
5818  }
5819
5820  return C_SCHEME_UNDEFINED;
5821}
5822
5823
5824C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
5825{
5826  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {
5827    error_location = loc;
5828    barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
5829  }
5830
5831  return C_SCHEME_UNDEFINED;
5832}
5833
5834
5835C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
5836{
5837  if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
5838    error_location = loc;
5839    barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
5840  }
5841
5842  return C_SCHEME_UNDEFINED;
5843}
5844
5845
5846C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
5847{
5848  if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)) {
5849    error_location = loc;
5850    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
5851  }
5852
5853  return C_SCHEME_UNDEFINED;
5854}
5855
5856
5857C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
5858{
5859  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {
5860    error_location = loc;
5861    barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
5862  }
5863
5864  return C_SCHEME_UNDEFINED;
5865}
5866
5867
5868C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
5869{
5870  if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {
5871    error_location = loc;
5872    barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);
5873  }
5874
5875  return C_SCHEME_UNDEFINED;
5876}
5877
5878
5879C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
5880{
5881  if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {
5882    error_location = loc;
5883    barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);
5884  }
5885
5886  return C_SCHEME_UNDEFINED;
5887}
5888
5889
5890C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
5891{
5892  if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_u_i_car(x) != st) {
5893    error_location = loc;
5894    barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);
5895  }
5896
5897  return C_SCHEME_UNDEFINED;
5898}
5899
5900
5901C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
5902{
5903  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5904    error_location = loc;
5905    barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);
5906  }
5907
5908  return C_SCHEME_UNDEFINED;
5909}
5910
5911
5912C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
5913{
5914  if(C_immediatep(x) || C_block_header(x) != C_SYMBOL_TAG) {
5915    error_location = loc;
5916    barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
5917  }
5918
5919  return C_SCHEME_UNDEFINED;
5920}
5921
5922
5923C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
5924{
5925  if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)) {
5926    error_location = loc;
5927    barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);
5928  }
5929
5930  return C_SCHEME_UNDEFINED;
5931}
5932
5933
5934C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
5935{
5936  if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5937    barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
5938
5939  return x;
5940}
5941
5942
5943C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
5944{
5945  if((x & C_FIXNUM_BIT) == 0)
5946    barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
5947
5948  return x;
5949}
5950
5951
5952C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
5953{
5954  if((x & C_FIXNUM_BIT) != 0) return x;
5955
5956  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
5957    barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
5958
5959  return x;
5960}
5961
5962
5963C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
5964{
5965  if(C_immediatep(x))
5966    barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);
5967
5968  return x;
5969}
5970
5971
5972C_regparm C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x)
5973{
5974  if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)
5975    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR, NULL, x, t);
5976
5977  return x;
5978}
5979
5980
5981C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
5982{
5983  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
5984    barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
5985
5986  return x;
5987}
5988
5989
5990C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
5991{
5992  if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)
5993    barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
5994
5995  return x;
5996}
5997
5998
5999C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
6000{
6001  if(C_immediatep(x) || 
6002     (C_header_bits(x) != C_SWIG_POINTER_TYPE &&
6003      (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
6004    barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
6005
6006  return x;
6007}
6008
6009
6010C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
6011{
6012  if(C_immediatep(x) || 
6013     (C_header_bits(x) != C_SWIG_POINTER_TYPE &&
6014      (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
6015    barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
6016
6017  return x;
6018}
6019
6020
6021C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
6022{
6023  if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0
6024     || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
6025    barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);
6026
6027  return x;
6028}
6029
6030
6031C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
6032{
6033  double m;
6034
6035  if((x & C_FIXNUM_BIT) != 0) return x;
6036
6037  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6038    m = C_flonum_magnitude(x);
6039
6040    if(m >= C_WORD_MIN && m <= C_WORD_MAX) return x;
6041  }
6042
6043  barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
6044  return C_SCHEME_UNDEFINED;
6045}
6046
6047
6048C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
6049{
6050  double m;
6051
6052  if((x & C_FIXNUM_BIT) != 0) return x;
6053
6054  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6055    m = C_flonum_magnitude(x);
6056
6057    if(m >= 0 && m <= C_UWORD_MAX) return x;
6058  }
6059
6060  barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
6061  return C_SCHEME_UNDEFINED;
6062}
6063
6064
6065C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
6066{
6067  return C_mk_bool(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG);
6068}
6069
6070
6071C_regparm C_word C_fcall C_i_null_list_p(C_word x)
6072{
6073  if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
6074  else if(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG) return C_SCHEME_FALSE;
6075  else {
6076    barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);
6077    return C_SCHEME_FALSE;
6078  }
6079}
6080
6081
6082C_regparm C_word C_fcall C_i_string_null_p(C_word x)
6083{
6084  if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)
6085    return C_zero_length_p(x);
6086  else {
6087    barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);
6088    return C_SCHEME_FALSE;
6089  }
6090}
6091
6092
6093C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
6094{
6095  if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)
6096    return C_null_pointerp(x);
6097
6098  barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);
6099  return C_SCHEME_FALSE;
6100}
6101
6102
6103/* Primitives: */
6104
6105void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...)
6106{
6107  va_list v;
6108  int i, n = c - 3;
6109  C_word x, skip, fn2;
6110#ifdef C_HACKED_APPLY
6111  C_word *buf = C_temporary_stack_limit;
6112  void *proc;
6113#endif
6114
6115#ifndef C_UNSAFE_RUNTIME
6116  if(c < 4) C_bad_min_argc(c, 4);
6117#endif
6118
6119  fn2 = resolve_procedure(fn, "apply");
6120
6121  va_start(v, fn);
6122
6123  for(i = n; i > 1; --i) {
6124    x = va_arg(v, C_word);
6125#ifdef C_HACKED_APPLY
6126    *(buf++) = x;
6127#else
6128    C_save(x);
6129#endif
6130  }
6131
6132  x = va_arg(v, C_word);
6133
6134#ifndef C_UNSAFE_RUNTIME
6135  if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG))
6136    barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", x);
6137#endif
6138
6139  for(skip = x; !C_immediatep(skip) && C_block_header(skip) == C_PAIR_TAG; skip = C_u_i_cdr(skip)) {
6140    x = C_u_i_car(skip);
6141
6142#ifdef C_HACKED_APPLY
6143# ifndef C_UNSAFE_RUNTIME
6144    if(buf >= C_temporary_stack_bottom) barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6145# endif
6146
6147    *(buf++) = x;
6148#else
6149    C_save(x);
6150
6151# ifndef C_UNSAFE_RUNTIME
6152    if(C_temporary_stack < C_temporary_stack_limit)
6153      barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6154# endif
6155#endif
6156    ++n;
6157  }
6158
6159  va_end(v);
6160  --n;
6161
6162#ifdef C_HACKED_APPLY
6163  /* 3 additional args + 1 slot for stack-pointer + two for stack-alignment to 16 bytes */
6164  buf = alloca((n + 6) * sizeof(C_word));
6165# ifdef __x86_64__
6166  buf = (void *)C_align16((C_uword)buf);
6167# endif
6168  buf[ 0 ] = n + 2;
6169  buf[ 1 ] = fn2;
6170  buf[ 2 ] = k;
6171  C_memcpy(&buf[ 3 ], C_temporary_stack_limit, n * sizeof(C_word));
6172  proc = (void *)C_block_item(fn2, 0);
6173# ifdef _MSC_VER
6174  __asm { 
6175    mov eax, proc
6176    mov esp, buf
6177    call eax
6178  }
6179# elif defined(__GNUC__)
6180  C_do_apply_hack(proc, buf, n + 3);
6181# endif
6182#endif
6183
6184  C_do_apply(n, fn2, k);
6185}
6186
6187
6188void C_ccall C_do_apply(C_word n, C_word fn, C_word k)
6189{
6190  void *pr = (void *)C_block_item(fn, 0);
6191  C_word *ptr = C_temporary_stack = C_temporary_stack_bottom;
6192
6193/* PTR_O_p<P>_<B>(o): list of COUNT = ((2 ** P) * B) '*(ptr-I)' arguments,
6194 * with offset I in range [o, o+COUNT-1].
6195 */
6196#define PTR_O_p0_0(o)
6197#define PTR_O_p1_0(o)
6198#define PTR_O_p2_0(o)
6199#define PTR_O_p3_0(o)
6200#define PTR_O_p4_0(o)
6201#define PTR_O_p5_0(o)
6202#define PTR_O_p6_0(o)
6203#define PTR_O_p7_0(o)
6204#define PTR_O_p0_1(o)   , *(ptr-(o))
6205#define PTR_O_p1_1(o)   , *(ptr-(o)), *(ptr-(o+1))
6206#define PTR_O_p2_1(o)   PTR_O_p1_1(o) PTR_O_p1_1(o+2)
6207#define PTR_O_p3_1(o)   PTR_O_p2_1(o) PTR_O_p2_1(o+4)
6208#define PTR_O_p4_1(o)   PTR_O_p3_1(o) PTR_O_p3_1(o+8)
6209#define PTR_O_p5_1(o)   PTR_O_p4_1(o) PTR_O_p4_1(o+16)
6210#define PTR_O_p6_1(o)   PTR_O_p5_1(o) PTR_O_p5_1(o+32)
6211#define PTR_O_p7_1(o)   PTR_O_p6_1(o) PTR_O_p6_1(o+64)
6212
6213/* CASE_C_PROC_p0 (n0,  p6,p5,p4,p3,p2,p1,p0):
6214 *  let's note <N> = <n0> - 2; the macro inserts:
6215 *      case <N>: ((C_cproc<n0>)pr) (<n0>, fn, k, <rest>);
6216 *  where <rest> is:    *(ptr-1), ..., *(ptr-<N>)
6217 *  (<rest> is empty for <n0> == 2).
6218 *  We must have:   n0 = SUM (i = 7 to 0, p<i> * (1 << i)).
6219 * CASE_C_PROC_p<N+1> (...):
6220 *  like CASE_C_PROC_p<N>, but with doubled output...
6221 */
6222#define CASE_C_PROC_p0(n0,  p6,p5,p4,p3,p2,p1,p0) \
6223    case (n0-2): ((C_proc##n0)pr)(n0, fn, k \
6224PTR_O_p6_##p6(((n0-2)&0x80)+1)\
6225PTR_O_p5_##p5(((n0-2)&0xC0)+1)\
6226PTR_O_p4_##p4(((n0-2)&0xE0)+1)\
6227PTR_O_p3_##p3(((n0-2)&0xF0)+1)\
6228PTR_O_p2_##p2(((n0-2)&0xF8)+1)\
6229PTR_O_p1_##p1(((n0-2)&0xFC)+1)\
6230PTR_O_p0_##p0(((n0-2)&0xFE)+1));
6231#define CASE_C_PROC_p1( n0,n1,  p6,p5,p4,p3,p2,p1) \
6232        CASE_C_PROC_p0 (n0,  p6,p5,p4,p3,p2,p1,0) \
6233        CASE_C_PROC_p0 (n1,  p6,p5,p4,p3,p2,p1,1)
6234#define CASE_C_PROC_p2( n0,n1,n2,n3,  p6,p5,p4,p3,p2) \
6235        CASE_C_PROC_p1 (n0,n1,  p6,p5,p4,p3,p2,0) \
6236        CASE_C_PROC_p1 (n2,n3,  p6,p5,p4,p3,p2,1)
6237#define CASE_C_PROC_p3( n0,n1,n2,n3,n4,n5,n6,n7,  p6,p5,p4,p3) \
6238        CASE_C_PROC_p2 (n0,n1,n2,n3,  p6,p5,p4,p3,0) \
6239        CASE_C_PROC_p2 (n4,n5,n6,n7,  p6,p5,p4,p3,1)
6240
6241  switch(n) {
6242    CASE_C_PROC_p3 (2,3,4,5,6,7,8,9,  0,0,0,0)
6243    CASE_C_PROC_p3 (10,11,12,13,14,15,16,17,  0,0,0,1)
6244    CASE_C_PROC_p3 (18,19,20,21,22,23,24,25,  0,0,1,0)
6245    CASE_C_PROC_p3 (26,27,28,29,30,31,32,33,  0,0,1,1)
6246    CASE_C_PROC_p3 (34,35,36,37,38,39,40,41,  0,1,0,0)
6247    CASE_C_PROC_p3 (42,43,44,45,46,47,48,49,  0,1,0,1)
6248    CASE_C_PROC_p3 (50,51,52,53,54,55,56,57,  0,1,1,0)
6249    CASE_C_PROC_p3 (58,59,60,61,62,63,64,65,  0,1,1,1)
6250    CASE_C_PROC_p0 (66,  1,0,0,0,0,0,0)
6251    CASE_C_PROC_p0 (67,  1,0,0,0,0,0,1)
6252    CASE_C_PROC_p1 (68,69,  1,0,0,0,0,1)
6253    CASE_C_PROC_p2 (70,71,72,73,  1,0,0,0,1)
6254    CASE_C_PROC_p3 (74,75,76,77,78,79,80,81,  1,0,0,1)
6255    CASE_C_PROC_p3 (82,83,84,85,86,87,88,89,  1,0,1,0)
6256    CASE_C_PROC_p3 (90,91,92,93,94,95,96,97,  1,0,1,1)
6257    CASE_C_PROC_p3 (98,99,100,101,102,103,104,105,  1,1,0,0)
6258    CASE_C_PROC_p3 (106,107,108,109,110,111,112,113,  1,1,0,1)
6259    CASE_C_PROC_p3 (114,115,116,117,118,119,120,121,  1,1,1,0)
6260    CASE_C_PROC_p2 (122,123,124,125,  1,1,1,1,0)
6261    CASE_C_PROC_p1 (126,127,  1,1,1,1,1,0)
6262    CASE_C_PROC_p0 (128,  1,1,1,1,1,1,0)
6263  default: barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6264  }
6265}
6266
6267
6268void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont)
6269{
6270  C_word *a = C_alloc(3),
6271         wrapper;
6272  void *pr = (void *)C_u_i_car(cont);
6273
6274  if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)
6275    barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
6276
6277  /* Check for values-continuation: */
6278  if(C_u_i_car(k) == (C_word)values_continuation)
6279    wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);
6280  else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);
6281
6282  ((C_proc3)pr)(3, cont, k, wrapper);
6283}
6284
6285
6286void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result)
6287{
6288  C_word cont = C_u_i_cdr(closure);
6289
6290  if(c != 3) C_bad_argc(c, 3);
6291
6292  C_kontinue(cont, result);
6293}
6294
6295
6296void C_ccall call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...)
6297{
6298  va_list v;
6299  C_word cont = C_u_i_cdr(closure),
6300         x1;
6301  int n = c;
6302
6303  va_start(v, k);
6304
6305  if(c > 2) {
6306    x1 = va_arg(v, C_word);
6307    --n;
6308   
6309    while(--c > 2) C_save(va_arg(v, C_word));
6310  }
6311  else x1 = C_SCHEME_UNBOUND;
6312
6313  va_end(v);
6314  C_do_apply(n - 2, cont, x1);
6315}
6316
6317
6318void C_ccall C_continuation_graft(C_word c, C_word self, C_word k, C_word kk, C_word proc)
6319{
6320  ((C_proc2)C_retrieve_proc(proc))(2, proc, C_block_item(kk, 1));
6321}
6322
6323
6324void C_ccall C_values(C_word c, C_word closure, C_word k, ...)
6325{
6326  va_list v;
6327  C_word n = c;
6328
6329  if(c < 2) C_bad_min_argc(c, 2);
6330
6331  va_start(v, k);
6332
6333  /* Check continuation whether it receives multiple values: */
6334  if(C_block_item(k, 0) == (C_word)values_continuation) {
6335    while(c-- > 2)
6336      C_save(va_arg(v, C_word));
6337
6338    va_end(v);
6339    C_do_apply(n - 2, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
6340  }
6341 
6342  if(c != 3) {
6343#ifdef RELAX_MULTIVAL_CHECK
6344    if(c == 2) n = C_SCHEME_UNDEFINED;
6345    else n = va_arg(v, C_word);
6346#else
6347    barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
6348#endif
6349  }
6350  else n = va_arg(v, C_word);
6351
6352  va_end(v);
6353  C_kontinue(k, n);
6354}
6355
6356
6357void C_ccall C_apply_values(C_word c, C_word closure, C_word k, C_word lst)
6358{
6359  C_word n;
6360
6361#ifndef C_UNSAFE_RUNTIME
6362  if(c != 3) C_bad_argc(c, 3);
6363#endif
6364
6365  /* Check continuation wether it receives multiple values: */
6366  if(C_block_item(k, 0) == (C_word)values_continuation) {
6367    for(n = 0; !C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG; ++n) {
6368      C_save(C_u_i_car(lst));
6369      lst = C_u_i_cdr(lst);
6370    }
6371
6372    C_do_apply(n, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
6373  }
6374 
6375  if(C_immediatep(lst) || (C_block_header(lst) == C_PAIR_TAG && C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)) {
6376#ifdef RELAX_MULTIVAL_CHECK
6377    if(C_immediatep(lst)) n = C_SCHEME_UNDEFINED;
6378    else n = C_u_i_car(lst);
6379#else
6380    barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
6381#endif
6382  }
6383  else n = C_u_i_car(lst);
6384
6385  C_kontinue(k, n);
6386}
6387
6388
6389void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
6390{
6391  C_word *a = C_alloc(4),
6392         kk;
6393
6394#ifndef C_UNSAFE_RUNTIME
6395  if(c != 4) C_bad_argc(c, 4);
6396
6397  if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)
6398    barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);
6399
6400  if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)
6401    barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);
6402#endif
6403
6404  kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
6405  C_do_apply(0, thunk, kk);
6406}
6407
6408
6409void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
6410{
6411  C_word *a = C_alloc(4),
6412         kk;
6413
6414  kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
6415  C_do_apply(0, thunk, kk);
6416}
6417
6418
6419void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
6420{
6421  C_word kont = C_u_i_cdr(closure),
6422         k = C_block_item(closure, 2),
6423         n = c,
6424         *ptr;
6425  va_list v;
6426
6427  if(arg0 == C_SCHEME_UNBOUND) { /* This continuation was called by 'values'... */
6428    va_start(v, arg0);
6429
6430    for(; c-- > 2; C_save(va_arg(v, C_word)));
6431
6432    va_end(v);
6433  }
6434  else {                        /* This continuation was captured and called explicity... */
6435    ++n;
6436    c -= 1;
6437
6438    /* move temporary-stack contents upwards one slot: */
6439    for(ptr = C_temporary_stack - c; --c; ++ptr) *ptr = ptr[ 1 ];
6440
6441    C_save(arg0);
6442  }
6443
6444  C_do_apply(n - 2, kont, k);
6445}
6446
6447
6448void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
6449{
6450  va_list v;
6451  C_word x;
6452  C_word iresult = 1;
6453  int fflag = 0;
6454  double fresult = 1;
6455
6456  va_start(v, k);
6457  c -= 2;
6458
6459  while(c--) {
6460    x = va_arg(v, C_word);
6461   
6462    if(x & C_FIXNUM_BIT) {
6463        fresult *= C_unfix(x);
6464       
6465        if(!fflag) iresult *= C_unfix(x);
6466    }
6467    else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6468        fresult *= C_flonum_magnitude(x);
6469
6470        if(!fflag) fflag = 1;
6471    }
6472    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
6473  }
6474
6475  va_end(v);
6476  x = C_fix(iresult);
6477 
6478  if(fflag || (double)C_unfix(x) != fresult) {
6479      C_temporary_flonum = fresult;
6480      C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6481  }
6482
6483  C_kontinue(k, x);
6484}
6485
6486
6487C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
6488{
6489  C_word iresult;
6490  double fresult;
6491  int fflag = 0;
6492
6493  if(x & C_FIXNUM_BIT) {
6494    if(y & C_FIXNUM_BIT) {
6495      iresult = C_unfix(x) * C_unfix(y);
6496      fresult = (double)C_unfix(x) * (double)C_unfix(y);
6497    }
6498    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6499      fresult = C_unfix(x) * C_flonum_magnitude(y);
6500      fflag = 1;
6501    }
6502    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
6503  }
6504  else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6505    fflag = 1;
6506
6507    if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) * C_unfix(y);
6508    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6509      fresult = C_flonum_magnitude(x) * C_flonum_magnitude(y);
6510    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
6511  }
6512  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
6513
6514  iresult = C_fix(iresult);
6515
6516  if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6517 
6518  return iresult;
6519}
6520
6521
6522void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
6523{
6524  va_list v;
6525  C_word x;
6526  C_word iresult = 0;
6527  int fflag = 0;
6528  double fresult = 0;
6529
6530  va_start(v, k);
6531  c -= 2;
6532
6533  while(c--) {
6534    x = va_arg(v, C_word);
6535   
6536    if(x & C_FIXNUM_BIT) {
6537        fresult += C_unfix(x);
6538
6539        if(!fflag) iresult += C_unfix(x);
6540    }
6541    else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6542      fresult += C_flonum_magnitude(x);
6543
6544      if(!fflag) fflag = 1;
6545    }
6546    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
6547  }
6548
6549  va_end(v);
6550  x = C_fix(iresult);
6551
6552  if(fflag || (double)C_unfix(x) != fresult) {
6553    C_temporary_flonum = fresult;
6554    C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6555  }
6556
6557  C_kontinue(k, x);
6558}
6559
6560
6561C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
6562{
6563  C_word iresult;
6564  double fresult;
6565  int fflag = 0;
6566
6567  if(x & C_FIXNUM_BIT) {
6568    if(y & C_FIXNUM_BIT) {
6569      iresult = C_unfix(x) + C_unfix(y);
6570      fresult = (double)C_unfix(x) + (double)C_unfix(y);
6571    }
6572    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6573      fresult = C_unfix(x) + C_flonum_magnitude(y);
6574      fflag = 1;
6575    }
6576    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
6577  }
6578  else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6579    fflag = 1;
6580
6581    if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) + C_unfix(y);
6582    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6583      fresult = C_flonum_magnitude(x) + C_flonum_magnitude(y);
6584    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
6585  }
6586  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
6587 
6588  iresult = C_fix(iresult);
6589
6590  if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6591 
6592  return iresult;
6593}
6594
6595
6596void cons_flonum_trampoline(void *dummy)
6597{
6598  C_word k = C_restore,
6599         *a = C_alloc(WORDS_PER_FLONUM);
6600
6601  C_kontinue(k, C_flonum(&a, C_temporary_flonum));
6602}
6603
6604
6605void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
6606{
6607  va_list v;
6608  C_word iresult;
6609  int fflag;
6610  double fresult;
6611
6612  if(c < 3) C_bad_min_argc(c, 3);
6613
6614  if(n1 & C_FIXNUM_BIT) {
6615    fresult = iresult = C_unfix(n1);
6616    fflag = 0;
6617  }
6618  else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6619    fresult = C_flonum_magnitude(n1);
6620    fflag = 1;
6621  }
6622  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
6623
6624  if(c == 3) {
6625    if(fflag) fresult = -fresult;
6626    else fresult = iresult = -iresult;
6627
6628    goto cont;
6629  }
6630
6631  va_start(v, n1);
6632  c -= 3;
6633
6634  while(c--) {
6635    n1 = va_arg(v, C_word);
6636   
6637    if(n1 & C_FIXNUM_BIT) {
6638      fresult -= C_unfix(n1);
6639
6640      if(!fflag) iresult -= C_unfix(n1);
6641    }
6642    else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6643      fresult -= C_flonum_magnitude(n1);
6644
6645      if(!fflag) fflag = 1;
6646    }
6647    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
6648  }
6649
6650  va_end(v);
6651 
6652 cont:
6653  n1 = C_fix(iresult);
6654
6655  if(fflag || (double)C_unfix(n1) != fresult) {
6656    C_temporary_flonum = fresult;
6657    C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6658  }
6659
6660  C_kontinue(k, n1);
6661}
6662
6663
6664C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
6665{
6666  C_word iresult;
6667  double fresult;
6668  int fflag = 0;
6669