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

Last change on this file since 15816 was 15816, checked in by kon, 10 years ago

Begin of "module" (actually loaded .so) introspection. Reminder about 'normalize-pathname' problem with absolute pathnames.

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