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

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

handling uninitialized panic_hook while parsing command line

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