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

Last change on this file since 8133 was 8133, checked in by felix winkelmann, 13 years ago

svn revision is compiled into runtime

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