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

Last change on this file since 15819 was 15819, checked in by Kon Lovett, 10 years ago

files, path-tests Fix for "empty" but absolute pathnames
library, runtime, chicken Better names for experimental "module" introspection
files Deprecated 'make-pathname' separator argument

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