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

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

merged encoded literals branch

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