source: project/chicken/branches/release/runtime.c @ 7332

Last change on this file since 7332 was 7332, checked in by felix winkelmann, 12 years ago

merged from trunk rev. 7324

File size: 214.3 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  case C_fix(37):
4180#ifdef C_USE_HOST_PCRE
4181    return C_SCHEME_TRUE;
4182#else
4183    return C_SCHEME_FALSE;
4184#endif
4185
4186    /* 38 */
4187
4188  case C_fix(39):
4189#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
4190    return C_SCHEME_TRUE;
4191#else
4192    return C_SCHEME_FALSE;
4193#endif
4194
4195  case C_fix(40):
4196#if defined(C_HACKED_APPLY)
4197    return C_SCHEME_TRUE;
4198#else
4199    return C_SCHEME_FALSE;
4200#endif
4201
4202  default: return C_SCHEME_UNDEFINED;
4203  }
4204}
4205
4206
4207C_regparm void C_fcall C_paranoid_check_for_interrupt(void)
4208{
4209  if(--C_timer_interrupt_counter <= 0)
4210    C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER);
4211}
4212
4213
4214C_regparm void C_fcall C_raise_interrupt(int reason)
4215{
4216  if(C_interrupts_enabled) {
4217    saved_stack_limit = C_stack_limit;
4218
4219#if C_STACK_GROWS_DOWNWARD
4220    C_stack_limit = C_stack_pointer + 1000;
4221#else
4222    C_stack_limit = C_stack_pointer - 1000;
4223#endif
4224
4225    interrupt_reason = reason;
4226    interrupt_time = cpu_milliseconds();
4227  }
4228}
4229
4230
4231C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
4232{
4233  C_initial_timer_interrupt_period = C_unfix(n);
4234  return C_SCHEME_UNDEFINED;
4235}
4236
4237
4238C_regparm C_word C_fcall C_enable_interrupts(void)
4239{
4240  C_timer_interrupt_counter = C_initial_timer_interrupt_period;
4241  /* assert(C_timer_interrupt_counter > 0); */
4242  C_interrupts_enabled = 1;
4243  return C_SCHEME_UNDEFINED;
4244}
4245
4246
4247C_regparm C_word C_fcall C_disable_interrupts(void)
4248{
4249  C_interrupts_enabled = 0;
4250  return C_SCHEME_UNDEFINED;
4251}
4252
4253
4254C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason)
4255{
4256  int sig = C_unfix(signum);
4257
4258  if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
4259  else {
4260    signal_mapping_table[ sig ] = C_unfix(reason);
4261    C_signal(sig, global_signal_handler);
4262  }
4263
4264  return C_SCHEME_UNDEFINED;
4265}
4266
4267
4268C_regparm C_word C_fcall C_flonum_in_fixnum_range_p(C_word n)
4269{
4270  double f = C_flonum_magnitude(n);
4271
4272  return C_mk_bool(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM);
4273}
4274
4275
4276C_regparm C_word C_fcall C_double_to_number(C_word n)
4277{
4278  double m, f = C_flonum_magnitude(n);
4279
4280  if(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0) 
4281    return C_fix(f);
4282  else return n;
4283}
4284
4285
4286C_regparm C_word C_fcall C_fits_in_int_p(C_word x)
4287{
4288  double n, m;
4289
4290  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4291
4292  n = C_flonum_magnitude(x);
4293  return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
4294}
4295
4296
4297C_regparm C_word C_fcall C_fits_in_unsigned_int_p(C_word x)
4298{
4299  double n, m;
4300
4301  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4302
4303  n = C_flonum_magnitude(x);
4304  return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
4305}
4306
4307
4308/* Copy blocks into collected or static memory: */
4309
4310C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
4311{
4312  int n = C_header_size(from);
4313  long bytes;
4314
4315  if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
4316    bytes = n;
4317    C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4318  }
4319  else {
4320    bytes = C_wordstobytes(n);
4321    C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4322  }
4323
4324  return to;
4325}
4326
4327
4328C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
4329{
4330  int n = C_header_size(from);
4331  long bytes;
4332  C_word *p = (C_word *)C_pointer_address(ptr);
4333
4334  if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
4335  else bytes = C_wordstobytes(n);
4336
4337  C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
4338  return (C_word)p;
4339}
4340
4341
4342/* Conversion routines: */
4343
4344C_regparm double C_fcall C_c_double(C_word x)
4345{
4346  if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
4347  else return C_flonum_magnitude(x);
4348}
4349
4350
4351C_regparm C_word C_fcall C_num_to_int(C_word x)
4352{
4353  if(x & C_FIXNUM_BIT) return C_unfix(x);
4354  else return (int)C_flonum_magnitude(x);
4355}
4356
4357
4358C_regparm C_s64 C_fcall C_num_to_int64(C_word x)
4359{
4360  if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
4361  else return (C_s64)C_flonum_magnitude(x);
4362}
4363
4364
4365C_regparm C_uword C_fcall C_num_to_unsigned_int(C_word x)
4366{
4367  if(x & C_FIXNUM_BIT) return C_unfix(x);
4368  else return (unsigned int)C_flonum_magnitude(x);
4369}
4370
4371
4372C_regparm C_word C_fcall C_int_to_num(C_word **ptr, C_word n)
4373{
4374  if(C_fitsinfixnump(n)) return C_fix(n);
4375  else return C_flonum(ptr, (double)n);
4376}
4377
4378
4379C_regparm C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n)
4380{
4381  if(C_ufitsinfixnump(n)) return C_fix(n);
4382  else return C_flonum(ptr, (double)n);
4383}
4384
4385
4386C_regparm C_word C_fcall C_long_to_num(C_word **ptr, long n)
4387{
4388  if(C_fitsinfixnump(n)) return C_fix(n);
4389  else return C_flonum(ptr, (double)n);
4390}
4391
4392
4393C_regparm C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n)
4394{
4395  if(C_ufitsinfixnump(n)) return C_fix(n);
4396  else return C_flonum(ptr, (double)n);
4397}
4398
4399
4400C_regparm C_word C_fcall C_flonum_in_int_range_p(C_word n)
4401{
4402  double m = C_flonum_magnitude(n);
4403
4404  return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
4405}
4406
4407
4408C_regparm C_word C_fcall C_flonum_in_uint_range_p(C_word n)
4409{
4410  double m = C_flonum_magnitude(n);
4411
4412  return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
4413}
4414
4415
4416C_regparm char *C_fcall C_string_or_null(C_word x)
4417{
4418  return C_truep(x) ? C_c_string(x) : NULL;
4419}
4420
4421
4422C_regparm void *C_fcall C_data_pointer_or_null(C_word x) 
4423{
4424  return C_truep(x) ? C_data_pointer(x) : NULL;
4425}
4426
4427
4428C_regparm void *C_fcall C_srfi_4_vector_or_null(C_word x) 
4429{
4430  return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
4431}
4432
4433
4434C_regparm void *C_fcall C_c_pointer_or_null(C_word x) 
4435{
4436  return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
4437}
4438
4439
4440C_regparm void *C_fcall C_scheme_or_c_pointer(C_word x) 
4441{
4442  return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
4443}
4444
4445
4446C_regparm long C_fcall C_num_to_long(C_word x)
4447{
4448  if(x & C_FIXNUM_BIT) return C_unfix(x);
4449  else return (long)C_flonum_magnitude(x);
4450}
4451
4452
4453C_regparm unsigned long C_fcall C_num_to_unsigned_long(C_word x)
4454{
4455  if(x & C_FIXNUM_BIT) return C_unfix(x);
4456  else return (unsigned long)C_flonum_magnitude(x);
4457}
4458
4459
4460/* Inline versions of some standard procedures: */
4461
4462C_regparm C_word C_fcall C_i_listp(C_word x)
4463{
4464  C_word fast = x, slow = x;
4465
4466  while(fast != C_SCHEME_END_OF_LIST)
4467    if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
4468      fast = C_u_i_cdr(fast);
4469     
4470      if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
4471      else if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
4472        fast = C_u_i_cdr(fast);
4473        slow = C_u_i_cdr(slow);
4474
4475        if(fast == slow) return C_SCHEME_FALSE;
4476      }
4477      else return C_SCHEME_FALSE;
4478    }
4479    else return C_SCHEME_FALSE;
4480
4481  return C_SCHEME_TRUE;
4482}
4483
4484
4485C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
4486{
4487  C_word n;
4488
4489  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
4490    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);
4491
4492  if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
4493    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);
4494
4495  n = C_header_size(x);
4496
4497  return C_mk_bool(n == C_header_size(y) && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
4498}
4499
4500
4501C_regparm C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y)
4502{
4503  C_word n;
4504
4505  n = C_header_size(x);
4506  return C_mk_bool(n == C_header_size(y) && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
4507}
4508
4509
4510C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
4511{
4512  C_word n;
4513  char *p1, *p2;
4514
4515  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
4516    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);
4517
4518  if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
4519    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);
4520
4521  n = C_header_size(x);
4522
4523  if(n != C_header_size(y)) return C_SCHEME_FALSE;
4524
4525  p1 = (char *)C_data_pointer(x);
4526  p2 = (char *)C_data_pointer(y);
4527
4528  while(n--) 
4529    if(C_tolower(*(p1++)) != C_tolower(*(p2++))) return C_SCHEME_FALSE;
4530
4531  return C_SCHEME_TRUE;
4532}
4533
4534
4535C_regparm C_word C_fcall C_i_eqvp(C_word x, C_word y)
4536{
4537  return
4538    C_mk_bool(x == y ||
4539              (!C_immediatep(x) && !C_immediatep(y) &&
4540               C_block_header(x) == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG &&
4541               C_flonum_magnitude(x) == C_flonum_magnitude(y) ) );
4542}
4543
4544
4545C_regparm C_word C_fcall C_i_symbolp(C_word x)
4546{
4547  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG);
4548}
4549
4550
4551C_regparm C_word C_fcall C_i_pairp(C_word x)
4552{
4553  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
4554}
4555
4556
4557C_regparm C_word C_fcall C_i_stringp(C_word x)
4558{
4559  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
4560}
4561
4562
4563C_regparm C_word C_fcall C_i_locativep(C_word x)
4564{
4565  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
4566}
4567
4568
4569C_regparm C_word C_fcall C_i_vectorp(C_word x)
4570{
4571  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
4572}
4573
4574
4575C_regparm C_word C_fcall C_i_portp(C_word x)
4576{
4577  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
4578}
4579
4580
4581C_regparm C_word C_fcall C_i_closurep(C_word x)
4582{
4583  return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
4584}
4585
4586
4587C_regparm C_word C_fcall C_i_numberp(C_word x)
4588{
4589  return C_mk_bool((x & C_FIXNUM_BIT) || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
4590}
4591
4592
4593C_regparm C_word C_fcall C_i_integerp(C_word x)
4594{
4595  double dummy;
4596
4597  return C_mk_bool((x & C_FIXNUM_BIT) || 
4598                   ((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
4599                    modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
4600}
4601
4602
4603C_regparm C_word C_fcall C_i_flonump(C_word x)
4604{
4605  return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
4606}
4607
4608
4609C_regparm C_word C_fcall C_i_finitep(C_word x)
4610{
4611  if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
4612  else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
4613}
4614
4615
4616C_regparm C_word C_fcall C_i_fixnum_min(C_word x, C_word y)
4617{
4618  return ((C_word)x < (C_word)y) ? x : y;
4619}
4620
4621
4622C_regparm C_word C_fcall C_i_fixnum_max(C_word x, C_word y)
4623{
4624  return ((C_word)x > (C_word)y) ? x : y;
4625}
4626
4627
4628C_regparm C_word C_fcall C_i_flonum_min(C_word x, C_word y)
4629{
4630  double 
4631    xf = C_flonum_magnitude(x),
4632    yf = C_flonum_magnitude(y);
4633
4634  return xf < yf ? x : y;
4635}
4636
4637
4638C_regparm C_word C_fcall C_i_flonum_max(C_word x, C_word y)
4639{
4640  double 
4641    xf = C_flonum_magnitude(x),
4642    yf = C_flonum_magnitude(y);
4643
4644  return xf > yf ? x : y;
4645}
4646
4647
4648#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
4649
4650C_word *C_a_i(C_word **a, int n)
4651{
4652  C_word *p = *a;
4653 
4654  *a += n;
4655  return p;
4656}
4657
4658#endif
4659
4660
4661C_word C_a_i_list(C_word **a, int c, ...)
4662{
4663  va_list v;
4664  C_word x, last, current,
4665         first = C_SCHEME_END_OF_LIST;
4666
4667  va_start(v, c);
4668
4669  for(last = C_SCHEME_UNDEFINED; c--; last = current) {
4670    x = va_arg(v, C_word);
4671    current = C_pair(a, x, C_SCHEME_END_OF_LIST);
4672
4673    if(last != C_SCHEME_UNDEFINED)
4674      C_set_block_item(last, 1, current);
4675    else first = current;
4676  }
4677
4678  va_end(v);
4679  return first;
4680}
4681
4682
4683C_word C_h_list(int c, ...)
4684{
4685  /* Similar to C_a_i_list(), but put slots with nursery data into mutation stack: */
4686  va_list v;
4687  C_word x, last, current,
4688         first = C_SCHEME_END_OF_LIST;
4689
4690  va_start(v, c);
4691
4692  for(last = C_SCHEME_UNDEFINED; c--; last = current) {
4693    x = va_arg(v, C_word);
4694    current = C_pair(C_heaptop, x, C_SCHEME_END_OF_LIST);
4695
4696    if(C_in_stackp(x)) 
4697      C_mutate(&C_u_i_car(current), x);
4698
4699    if(last != C_SCHEME_UNDEFINED)
4700      C_set_block_item(last, 1, current);
4701    else first = current;
4702  }
4703
4704  va_end(v);
4705  return first;
4706}
4707
4708
4709C_word C_a_i_string(C_word **a, int c, ...)
4710{
4711  va_list v;
4712  C_word x, s = (C_word)(*a);
4713  char *p;
4714
4715  *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(c));
4716  ((C_SCHEME_BLOCK *)s)->header = C_STRING_TYPE | c;
4717  p = (char *)C_data_pointer(s);
4718  va_start(v, c);
4719
4720  while(c--) {
4721    x = va_arg(v, C_word);
4722
4723    if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
4724      *(p++) = C_character_code(x);
4725    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);
4726  }
4727
4728  return s;
4729}
4730
4731
4732C_word C_a_i_record(C_word **ptr, int n, ...)
4733{
4734  va_list v;
4735  C_word *p = *ptr,
4736         *p0 = p; 
4737
4738  *(p++) = C_STRUCTURE_TYPE | n;
4739  va_start(v, n);
4740
4741  while(n--)
4742    *(p++) = va_arg(v, C_word);
4743
4744  *ptr = p;
4745  va_end(v);
4746  return (C_word)p0;
4747}
4748
4749
4750C_word C_a_i_port(C_word **ptr, int n)
4751{
4752  C_word
4753    *p = *ptr,
4754    *p0 = p; 
4755  int i;
4756
4757  *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);
4758  *(p++) = (C_word)NULL;
4759 
4760  for(i = 0; i < C_SIZEOF_PORT - 2; ++i)
4761    *(p++) = C_SCHEME_FALSE;
4762
4763  *ptr = p;
4764  return (C_word)p0;
4765}
4766
4767
4768C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
4769{
4770  C_word *p = *ptr,
4771         *p0;
4772  int n = C_unfix(num);
4773
4774#ifndef C_SIXTY_FOUR
4775  /* Align on 8-byte boundary: */
4776  if(aligned8(p)) ++p;
4777#endif
4778
4779  p0 = p;
4780  *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);
4781  *ptr = p + n;
4782  return (C_word)p0;
4783}
4784
4785
4786C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
4787{
4788  C_word
4789    *p = *ptr,
4790    *p0 = p;
4791  void *mp;
4792
4793  if(C_immediatep(x)) mp = NULL;
4794  else if((C_header_bits(x) && C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);
4795  else mp = C_data_pointer(x);
4796
4797  *(p++) = C_POINTER_TYPE | 1;
4798  *((void **)p) = mp;
4799  *ptr = p + 1;
4800  return (C_word)p0;
4801}
4802
4803
4804C_regparm C_word C_fcall C_i_exactp(C_word x)
4805{
4806  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4807
4808  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4809    barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact?", x);
4810
4811  return C_SCHEME_FALSE;
4812}
4813
4814
4815C_regparm C_word C_fcall C_u_i_exactp(C_word x)
4816{
4817  if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
4818
4819  return C_SCHEME_FALSE;
4820}
4821
4822
4823C_regparm C_word C_fcall C_i_inexactp(C_word x)
4824{
4825  if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
4826
4827  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4828    barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact?", x);
4829
4830  return C_SCHEME_TRUE;
4831}
4832
4833
4834C_regparm C_word C_fcall C_u_i_inexactp(C_word x)
4835{
4836  if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
4837
4838  return C_SCHEME_TRUE;
4839}
4840
4841
4842C_regparm C_word C_fcall C_i_zerop(C_word x)
4843{
4844  if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
4845
4846  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4847    barf(C_BAD_ARGUMENT_TYPE_ERROR, "zero?", x);
4848
4849  return C_mk_bool(C_flonum_magnitude(x) == 0.0);
4850}
4851
4852
4853C_regparm C_word C_fcall C_u_i_zerop(C_word x)
4854{
4855  if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
4856
4857  return C_mk_bool(C_flonum_magnitude(x) == 0.0);
4858}
4859
4860
4861C_regparm C_word C_fcall C_i_positivep(C_word x)
4862{
4863  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
4864
4865  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4866    barf(C_BAD_ARGUMENT_TYPE_ERROR, "positive?", x);
4867
4868  return C_mk_bool(C_flonum_magnitude(x) > 0.0);
4869}
4870
4871
4872C_regparm C_word C_fcall C_u_i_positivep(C_word x)
4873{
4874  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
4875
4876  return C_mk_bool(C_flonum_magnitude(x) > 0.0);
4877}
4878
4879
4880C_regparm C_word C_fcall C_i_negativep(C_word x)
4881{
4882  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
4883
4884  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4885    barf(C_BAD_ARGUMENT_TYPE_ERROR, "negative?", x);
4886
4887  return C_mk_bool(C_flonum_magnitude(x) < 0.0);
4888}
4889
4890
4891C_regparm C_word C_fcall C_u_i_negativep(C_word x)
4892{
4893  if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
4894
4895  return C_mk_bool(C_flonum_magnitude(x) < 0.0);
4896}
4897
4898
4899C_regparm C_word C_fcall C_i_evenp(C_word x)
4900{
4901  if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
4902
4903  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4904    barf(C_BAD_ARGUMENT_TYPE_ERROR, "even?", x);
4905
4906  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
4907}
4908
4909
4910C_regparm C_word C_fcall C_u_i_evenp(C_word x)
4911{
4912  if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
4913
4914  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
4915}
4916
4917
4918C_regparm C_word C_fcall C_i_oddp(C_word x)
4919{
4920  if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
4921
4922  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
4923    barf(C_BAD_ARGUMENT_TYPE_ERROR, "odd?", x);
4924
4925  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
4926}
4927
4928
4929C_regparm C_word C_fcall C_u_i_oddp(C_word x)
4930{
4931  if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
4932
4933  return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
4934}
4935
4936
4937C_regparm C_word C_fcall C_i_car(C_word x)
4938{
4939  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
4940    barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);
4941
4942  return C_u_i_car(x);
4943}
4944
4945
4946C_regparm C_word C_fcall C_i_cdr(C_word x)
4947{
4948  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
4949    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);
4950
4951  return C_u_i_cdr(x);
4952}
4953
4954
4955C_regparm C_word C_fcall C_i_cadr(C_word x)
4956{
4957  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
4958  bad:
4959    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);
4960  }
4961
4962  x = C_u_i_cdr(x);
4963  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
4964
4965  return C_u_i_car(x);
4966}
4967
4968
4969C_regparm C_word C_fcall C_i_cddr(C_word x)
4970{
4971  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
4972  bad:
4973    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);
4974  }
4975
4976  x = C_u_i_cdr(x);
4977  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
4978
4979  return C_u_i_cdr(x);
4980}
4981
4982
4983C_regparm C_word C_fcall C_i_caddr(C_word x)
4984{
4985  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
4986  bad:
4987    barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);
4988  }
4989
4990  x = C_u_i_cdr(x);
4991  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
4992  x = C_u_i_cdr(x);
4993  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
4994
4995  return C_u_i_car(x);
4996}
4997
4998
4999C_regparm C_word C_fcall C_i_cdddr(C_word x)
5000{
5001  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5002  bad:
5003    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);
5004  }
5005
5006  x = C_u_i_cdr(x);
5007  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5008  x = C_u_i_cdr(x);
5009  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5010
5011  return C_u_i_cdr(x);
5012}
5013
5014
5015C_regparm C_word C_fcall C_i_cadddr(C_word x)
5016{
5017  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5018  bad:
5019    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);
5020  }
5021
5022  x = C_u_i_cdr(x);
5023  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5024  x = C_u_i_cdr(x);
5025  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5026  x = C_u_i_cdr(x);
5027  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5028
5029  return C_u_i_car(x);
5030}
5031
5032
5033C_regparm C_word C_fcall C_i_cddddr(C_word x)
5034{
5035  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5036  bad:
5037    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);
5038  }
5039
5040  x = C_u_i_cdr(x);
5041  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5042  x = C_u_i_cdr(x);
5043  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5044  x = C_u_i_cdr(x);
5045  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5046
5047  return C_u_i_cdr(x);
5048}
5049
5050
5051C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
5052{
5053  C_word lst0 = lst;
5054  int n;
5055
5056  if(i & C_FIXNUM_BIT) n = C_unfix(i);
5057  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);
5058
5059  while(n--) {
5060    if(C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)
5061      barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);
5062   
5063    lst = C_u_i_cdr(lst);
5064  }
5065
5066  return lst;
5067}
5068
5069
5070C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
5071{
5072  int j;
5073
5074  if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5075    barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);
5076
5077  if(i & C_FIXNUM_BIT) {
5078    j = C_unfix(i);
5079
5080    if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-ref", v, i);
5081
5082    return C_block_item(v, j);
5083  }
5084 
5085  barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);
5086  return C_SCHEME_UNDEFINED;
5087}
5088
5089
5090C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
5091{
5092  int j;
5093
5094  if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)
5095    barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);
5096
5097  if(i & C_FIXNUM_BIT) {
5098    j = C_unfix(i);
5099
5100    if(j < 0 || j >= C_header_size(x)) barf(C_OUT_OF_RANGE_ERROR, "##sys#block-ref", x, i);
5101
5102    return C_block_item(x, j);
5103  }
5104 
5105  barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);
5106  return C_SCHEME_UNDEFINED;
5107}
5108
5109
5110C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)
5111{
5112  int j;
5113
5114  if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5115    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);
5116
5117  if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5118    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);
5119
5120  if(i & C_FIXNUM_BIT) {
5121    j = C_unfix(i);
5122
5123    if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-set!", s, i);
5124
5125    return C_setsubchar(s, i, c);
5126  }
5127
5128  barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);
5129  return C_SCHEME_UNDEFINED;
5130}
5131
5132
5133C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
5134{
5135  int j;
5136
5137  if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5138    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);
5139
5140  if(i & C_FIXNUM_BIT) {
5141    j = C_unfix(i);
5142
5143    if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-ref", s, i);
5144
5145    return C_subchar(s, i);
5146  }
5147 
5148  barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);
5149  return C_SCHEME_UNDEFINED;
5150}
5151
5152
5153C_regparm C_word C_fcall C_i_vector_length(C_word v)
5154{
5155  if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5156    barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);
5157
5158  return C_fix(C_header_size(v));
5159}
5160
5161
5162C_regparm C_word C_fcall C_i_string_length(C_word s)
5163{
5164  if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5165    barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);
5166
5167  return C_fix(C_header_size(s));
5168}
5169
5170
5171C_regparm C_word C_fcall C_i_length(C_word lst)
5172{
5173  int n = 0;
5174
5175  if(lst != C_SCHEME_END_OF_LIST) {
5176    if(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5177      do {
5178        lst = C_u_i_cdr(lst);
5179        ++n;
5180      } while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG);
5181    }
5182    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "length", lst);
5183  }
5184
5185  return C_fix(n);
5186}
5187
5188
5189C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
5190{
5191  double m;
5192  C_word r;
5193
5194  if(n & C_FIXNUM_BIT) return n;
5195  else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
5196    barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
5197
5198  if(modf(C_flonum_magnitude(n), &m) == 0.0) {
5199    r = (C_word)m;
5200   
5201    if(r == m && C_fitsinfixnump(r))
5202      return C_fix(r);
5203  }
5204
5205  barf(C_CANT_REPRESENT_INEXACT_ERROR, "inexact->exact", n);
5206  return 0;
5207}
5208
5209
5210C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
5211{
5212  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5213    barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);
5214
5215  C_mutate(&C_u_i_car(x), val);
5216  return C_SCHEME_UNDEFINED;
5217}
5218
5219
5220C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
5221{
5222  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5223    barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);
5224
5225  C_mutate(&C_u_i_cdr(x), val);
5226  return C_SCHEME_UNDEFINED;
5227}
5228
5229
5230C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
5231{
5232  int j;
5233
5234  if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5235    barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);
5236
5237  if(i & C_FIXNUM_BIT) {
5238    j = C_unfix(i);
5239
5240    if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-set!", v, i);
5241
5242    C_mutate(&C_block_item(v, j), x);
5243  }
5244  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);
5245
5246  return C_SCHEME_UNDEFINED;
5247}
5248
5249
5250C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
5251{
5252  if(x & C_FIXNUM_BIT) return C_fix(abs(C_unfix(x)));
5253
5254  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
5255    barf(C_BAD_ARGUMENT_TYPE_ERROR, "abs", x);
5256
5257  return C_flonum(a, fabs(C_flonum_magnitude(x)));
5258}
5259
5260
5261C_regparm C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2)
5262{
5263  return C_flonum(a, C_flonum_magnitude(n1) + C_flonum_magnitude(n2));
5264}
5265
5266
5267C_regparm C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2)
5268{
5269  return C_flonum(a, C_flonum_magnitude(n1) - C_flonum_magnitude(n2));
5270}
5271
5272
5273C_regparm C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2)
5274{
5275  return C_flonum(a, C_flonum_magnitude(n1) * C_flonum_magnitude(n2));
5276}
5277
5278
5279C_regparm C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2)
5280{
5281  return C_flonum(a, C_flonum_magnitude(n1) / C_flonum_magnitude(n2));
5282}
5283
5284
5285C_regparm C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n)
5286{
5287  return C_flonum(a, -C_flonum_magnitude(n));
5288}
5289
5290
5291C_regparm C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2)
5292{
5293  double f1, f2;
5294  C_uword nn1, nn2;
5295
5296  C_check_uint(n1, f1, nn1, "bitwise-and");
5297  C_check_uint(n2, f2, nn2, "bitwise-and");
5298  nn1 = C_limit_fixnum(nn1 & nn2);
5299
5300  if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5301  else return C_flonum(a, nn1);
5302}
5303
5304
5305C_regparm C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2)
5306{
5307  double f1, f2;
5308  C_uword nn1, nn2;
5309
5310  C_check_uint(n1, f1, nn1, "bitwise-ior");
5311  C_check_uint(n2, f2, nn2, "bitwise-ior");
5312  nn1 = C_limit_fixnum(nn1 | nn2);
5313
5314  if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5315  else return C_flonum(a, nn1);
5316}
5317
5318
5319C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2)
5320{
5321  double f1, f2;
5322  C_uword nn1, nn2;
5323
5324  C_check_uint(n1, f1, nn1, "bitwise-xor");
5325  C_check_uint(n2, f2, nn2, "bitwise-xor");
5326  nn1 = C_limit_fixnum(nn1 ^ nn2);
5327
5328  if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
5329  else return C_flonum(a, nn1);
5330}
5331
5332
5333C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
5334{
5335  double f1;
5336  C_uword nn1;
5337  int index;
5338
5339  if((i & C_FIXNUM_BIT) == 0) 
5340    barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "bit-set?", i);
5341
5342  index = C_unfix(i);
5343
5344  if(index < 0 || index >= C_WORD_SIZE)
5345    barf(C_OUT_OF_RANGE_ERROR, "bit-set?", n, i);
5346
5347  C_check_uint(n, f1, nn1, "bit-set?");
5348  return C_mk_bool((nn1 & (1 << index)) != 0);
5349}
5350
5351
5352C_regparm C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n)
5353{
5354  double f;
5355  C_uword nn;
5356
5357  C_check_uint(n, f, nn, "bitwise-not");
5358  nn = C_limit_fixnum(~nn);
5359
5360  if(C_ufitsinfixnump(nn)) return C_fix(nn);
5361  else return C_flonum(a, nn);
5362}
5363
5364
5365C_regparm C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2)
5366{
5367  C_word nn;
5368  C_uword unn;
5369  C_word s;
5370  int sgn = 1;
5371
5372  if((n1 & C_FIXNUM_BIT) != 0) {
5373    nn = C_unfix(n1);
5374
5375    if((sgn = nn < 0 ? -1 : 1) >= 0) unn = nn;
5376  }
5377  else if(C_immediatep(n1) || C_block_header(n1) != C_FLONUM_TAG)
5378    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "arithmetic-shift", n1);
5379  else { 
5380    double m, f;
5381
5382    f = C_flonum_magnitude(n1);
5383   
5384    if(modf(f, &m) != 0.0)
5385      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5386
5387    if(f < C_WORD_MIN || f > C_UWORD_MAX)
5388      barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5389    else if(f < 0) {
5390      if(f > C_WORD_MAX)
5391        barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
5392      else {
5393        sgn = -1;
5394        nn = (C_word)f;
5395      }
5396    }
5397    else if(f > C_WORD_MAX) unn = (C_uword)f;
5398    else {
5399      nn = (C_word)f;
5400      sgn = -1;
5401    }
5402  }
5403
5404  if((n2 & C_FIXNUM_BIT) != 0) s = C_unfix(n2);
5405  else barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", n2);
5406
5407  if(sgn < 0) {
5408    if(s < 0) nn >>= -s;
5409    else nn <<= s;
5410
5411    if(C_fitsinfixnump(nn)) return C_fix(nn);
5412    else return C_flonum(a, nn);
5413  } 
5414  else {
5415    if(s < 0) unn >>= -s;
5416    else unn <<= s;
5417 
5418    if(C_ufitsinfixnump(unn)) return C_fix(unn);
5419    else return C_flonum(a, unn);
5420  }
5421}
5422
5423
5424C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
5425{
5426  double f;
5427
5428  C_check_real(n, "exp", f);
5429  return C_flonum(a, exp(f));
5430}
5431
5432
5433C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
5434{
5435  double f;
5436
5437  C_check_real(n, "log", f);
5438  return C_flonum(a, log(f));
5439}
5440
5441
5442C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
5443{
5444  double f;
5445
5446  C_check_real(n, "sin", f);
5447  return C_flonum(a, sin(f));
5448}
5449
5450
5451C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
5452{
5453  double f;
5454
5455  C_check_real(n, "cos", f);
5456  return C_flonum(a, cos(f));
5457}
5458
5459
5460C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
5461{
5462  double f;
5463
5464  C_check_real(n, "tan", f);
5465  return C_flonum(a, tan(f));
5466}
5467
5468
5469C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
5470{
5471  double f;
5472
5473  C_check_real(n, "asin", f);
5474  return C_flonum(a, asin(f));
5475}
5476
5477
5478C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
5479{
5480  double f;
5481
5482  C_check_real(n, "acos", f);
5483  return C_flonum(a, acos(f));
5484}
5485
5486
5487C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
5488{
5489  double f;
5490
5491  C_check_real(n, "atan", f);
5492  return C_flonum(a, atan(f));
5493}
5494
5495
5496C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
5497{
5498  double f1, f2;
5499
5500  C_check_real(n1, "atan", f1);
5501  C_check_real(n2, "atan", f2);
5502  return C_flonum(a, atan2(f1, f2));
5503}
5504
5505
5506C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
5507{
5508  double f;
5509
5510  C_check_real(n, "sqrt", f);
5511  return C_flonum(a, sqrt(f));
5512}
5513
5514
5515C_regparm C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c)
5516{
5517  if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
5518  else return C_fixnum_shift_left(n, c);
5519}
5520
5521
5522C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
5523{
5524  C_word a;
5525
5526  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5527    a = C_u_i_car(lst);
5528
5529    if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5530      if(C_u_i_car(a) == x) return a;
5531    }
5532    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);
5533 
5534    lst = C_u_i_cdr(lst);
5535  }
5536
5537  return C_SCHEME_FALSE;
5538}
5539
5540
5541C_regparm C_word C_fcall C_u_i_assq(C_word x, C_word lst)
5542{
5543  C_word a;
5544
5545  while(!C_immediatep(lst)) {
5546    a = C_u_i_car(lst);
5547
5548    if(C_u_i_car(a) == x) return a;
5549    else lst = C_u_i_cdr(lst);
5550  }
5551
5552  return C_SCHEME_FALSE;
5553}
5554
5555
5556C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
5557{
5558  C_word a;
5559
5560  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5561    a = C_u_i_car(lst);
5562
5563    if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5564      if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;
5565    }
5566    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);
5567 
5568    lst = C_u_i_cdr(lst);
5569  }
5570
5571  return C_SCHEME_FALSE;
5572}
5573
5574
5575C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
5576{
5577  C_word a;
5578
5579  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5580    a = C_u_i_car(lst);
5581
5582    if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
5583      if(C_equalp(C_u_i_car(a), x)) return a;
5584    }
5585    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);
5586 
5587    lst = C_u_i_cdr(lst);
5588  }
5589
5590  return C_SCHEME_FALSE;
5591}
5592
5593
5594C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
5595{
5596  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5597    if(C_u_i_car(lst) == x) return lst;
5598    else lst = C_u_i_cdr(lst);
5599  }
5600
5601  return C_SCHEME_FALSE;
5602}
5603
5604
5605C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
5606{
5607  while(!C_immediatep(lst)) {
5608    if(C_u_i_car(lst) == x) return lst;
5609    else lst = C_u_i_cdr(lst);
5610  }
5611
5612  return C_SCHEME_FALSE;
5613}
5614
5615
5616C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
5617{
5618  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5619    if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;
5620    else lst = C_u_i_cdr(lst);
5621  }
5622
5623  return C_SCHEME_FALSE;
5624}
5625
5626
5627C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
5628{
5629  while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
5630    if(C_equalp(C_u_i_car(lst), x)) return lst;
5631    else lst = C_u_i_cdr(lst);
5632  }
5633 
5634  return C_SCHEME_FALSE;
5635}
5636
5637
5638/* Inline routines for extended bindings: */
5639
5640C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
5641{
5642  if((x & C_FIXNUM_BIT) == 0) {
5643    error_location = loc;
5644    barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
5645  }
5646
5647  return C_SCHEME_UNDEFINED;
5648}
5649
5650
5651C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
5652{
5653  if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
5654    error_location = loc;
5655    barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
5656  }
5657
5658  return C_SCHEME_UNDEFINED;
5659}
5660
5661
5662C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
5663{
5664  if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)) {
5665    error_location = loc;
5666    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
5667  }
5668
5669  return C_SCHEME_UNDEFINED;
5670}
5671
5672
5673C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
5674{
5675  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {
5676    error_location = loc;
5677    barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
5678  }
5679
5680  return C_SCHEME_UNDEFINED;
5681}
5682
5683
5684C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
5685{
5686  if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {
5687    error_location = loc;
5688    barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);
5689  }
5690
5691  return C_SCHEME_UNDEFINED;
5692}
5693
5694
5695C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
5696{
5697  if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {
5698    error_location = loc;
5699    barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);
5700  }
5701
5702  return C_SCHEME_UNDEFINED;
5703}
5704
5705
5706C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
5707{
5708  if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_u_i_car(x) != st) {
5709    error_location = loc;
5710    barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);
5711  }
5712
5713  return C_SCHEME_UNDEFINED;
5714}
5715
5716
5717C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
5718{
5719  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5720    error_location = loc;
5721    barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);
5722  }
5723
5724  return C_SCHEME_UNDEFINED;
5725}
5726
5727
5728C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
5729{
5730  if(C_immediatep(x) || C_block_header(x) != C_SYMBOL_TAG) {
5731    error_location = loc;
5732    barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
5733  }
5734
5735  return C_SCHEME_UNDEFINED;
5736}
5737
5738
5739C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
5740{
5741  if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)) {
5742    error_location = loc;
5743    barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);
5744  }
5745
5746  return C_SCHEME_UNDEFINED;
5747}
5748
5749
5750C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
5751{
5752  if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5753    barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
5754
5755  return x;
5756}
5757
5758
5759C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
5760{
5761  if((x & C_FIXNUM_BIT) == 0)
5762    barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
5763
5764  return x;
5765}
5766
5767
5768C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
5769{
5770  if((x & C_FIXNUM_BIT) != 0) return x;
5771
5772  if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
5773    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
5774
5775  return x;
5776}
5777
5778
5779C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
5780{
5781  if(C_immediatep(x))
5782    barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);
5783
5784  return x;
5785}
5786
5787
5788C_regparm C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x)
5789{
5790  if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)
5791    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR, NULL, x, t);
5792
5793  return x;
5794}
5795
5796
5797C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
5798{
5799  if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
5800    barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
5801
5802  return x;
5803}
5804
5805
5806C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
5807{
5808  if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)
5809    barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
5810
5811  return x;
5812}
5813
5814
5815C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
5816{
5817  if(C_immediatep(x) || 
5818     (C_header_bits(x) != C_SWIG_POINTER_TYPE &&
5819      (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
5820    barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
5821
5822  return x;
5823}
5824
5825
5826C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
5827{
5828  if(C_immediatep(x) || 
5829     (C_header_bits(x) != C_SWIG_POINTER_TYPE &&
5830      (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
5831    barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
5832
5833  return x;
5834}
5835
5836
5837C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
5838{
5839  if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
5840    barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);
5841
5842  return x;
5843}
5844
5845
5846C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
5847{
5848  double m;
5849
5850  if((x & C_FIXNUM_BIT) != 0) return x;
5851
5852  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
5853    m = C_flonum_magnitude(x);
5854
5855    if(m >= C_WORD_MIN && m <= C_WORD_MAX) return x;
5856  }
5857
5858  barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
5859  return C_SCHEME_UNDEFINED;
5860}
5861
5862
5863C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
5864{
5865  double m;
5866
5867  if((x & C_FIXNUM_BIT) != 0) return x;
5868
5869  if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
5870    m = C_flonum_magnitude(x);
5871
5872    if(m >= 0 && m <= C_UWORD_MAX) return x;
5873  }
5874
5875  barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
5876  return C_SCHEME_UNDEFINED;
5877}
5878
5879
5880C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
5881{
5882  return C_mk_bool(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG);
5883}
5884
5885
5886C_regparm C_word C_fcall C_i_null_list_p(C_word x)
5887{
5888  if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
5889  else if(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG) return C_SCHEME_FALSE;
5890  else {
5891    barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);
5892    return C_SCHEME_FALSE;
5893  }
5894}
5895
5896
5897C_regparm C_word C_fcall C_i_string_null_p(C_word x)
5898{
5899  if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)
5900    return C_zero_length_p(x);
5901  else {
5902    barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);
5903    return C_SCHEME_FALSE;
5904  }
5905}
5906
5907
5908C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
5909{
5910  if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)
5911    return C_null_pointerp(x);
5912
5913  barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);
5914  return C_SCHEME_FALSE;
5915}
5916
5917
5918/* Primitives: */
5919
5920void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...)
5921{
5922  va_list v;
5923  int i, n = c - 3;
5924  C_word x, skip, fn2;
5925#ifdef C_HACKED_APPLY
5926  C_word *buf = C_temporary_stack_limit;
5927  void *proc;
5928#endif
5929
5930#ifndef C_UNSAFE_RUNTIME
5931  if(c < 4) C_bad_min_argc(c, 4);
5932#endif
5933
5934  fn2 = resolve_procedure(fn, "apply");
5935
5936  va_start(v, fn);
5937
5938  for(i = n; i > 1; --i) {
5939    x = va_arg(v, C_word);
5940#ifdef C_HACKED_APPLY
5941    *(buf++) = x;
5942#else
5943    C_save(x);
5944#endif
5945  }
5946
5947  x = va_arg(v, C_word);
5948
5949#ifndef C_UNSAFE_RUNTIME
5950  if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG))
5951    barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", x);
5952#endif
5953
5954  for(skip = x; !C_immediatep(skip) && C_block_header(skip) == C_PAIR_TAG; skip = C_u_i_cdr(skip)) {
5955    x = C_u_i_car(skip);
5956
5957#ifdef C_HACKED_APPLY
5958# ifndef C_UNSAFE_RUNTIME
5959    if(buf >= C_temporary_stack_bottom) barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
5960# endif
5961
5962    *(buf++) = x;
5963#else
5964    C_save(x);
5965
5966# ifndef C_UNSAFE_RUNTIME
5967    if(C_temporary_stack < C_temporary_stack_limit)
5968      barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
5969# endif
5970#endif
5971    ++n;
5972  }
5973
5974  va_end(v);
5975  --n;
5976
5977#ifdef C_HACKED_APPLY
5978  /* 3 additional args + 1 slot for stack-pointer + two for stack-alignment to 16 bytes */
5979  buf = alloca((n + 6) * sizeof(C_word));
5980# ifdef __x86_64__
5981  buf = (void *)C_align16((C_uword)buf);
5982# endif
5983  buf[ 0 ] = n + 2;
5984  buf[ 1 ] = fn2;
5985  buf[ 2 ] = k;
5986  C_memcpy(&buf[ 3 ], C_temporary_stack_limit, n * sizeof(C_word));
5987  proc = (void *)C_block_item(fn2, 0);
5988# ifdef _MSC_VER
5989  __asm { 
5990    mov eax, proc
5991    mov esp, buf
5992    call eax
5993  }
5994# elif defined(__GNUC__)
5995  C_do_apply_hack(proc, buf, n + 3);
5996# endif
5997#endif
5998
5999  C_do_apply(n, fn2, k);
6000}
6001
6002
6003void C_ccall C_do_apply(C_word n, C_word fn, C_word k)
6004{
6005  void *pr = (void *)C_block_item(fn, 0);
6006  C_word *ptr = C_temporary_stack = C_temporary_stack_bottom;
6007
6008/* PTR_O_p<P>_<B>(o): list of COUNT = ((2 ** P) * B) '*(ptr-I)' arguments,
6009 * with offset I in range [o, o+COUNT-1].
6010 */
6011#define PTR_O_p0_0(o)
6012#define PTR_O_p1_0(o)
6013#define PTR_O_p2_0(o)
6014#define PTR_O_p3_0(o)
6015#define PTR_O_p4_0(o)
6016#define PTR_O_p5_0(o)
6017#define PTR_O_p6_0(o)
6018#define PTR_O_p7_0(o)
6019#define PTR_O_p0_1(o)   , *(ptr-(o))
6020#define PTR_O_p1_1(o)   , *(ptr-(o)), *(ptr-(o+1))
6021#define PTR_O_p2_1(o)   PTR_O_p1_1(o) PTR_O_p1_1(o+2)
6022#define PTR_O_p3_1(o)   PTR_O_p2_1(o) PTR_O_p2_1(o+4)
6023#define PTR_O_p4_1(o)   PTR_O_p3_1(o) PTR_O_p3_1(o+8)
6024#define PTR_O_p5_1(o)   PTR_O_p4_1(o) PTR_O_p4_1(o+16)
6025#define PTR_O_p6_1(o)   PTR_O_p5_1(o) PTR_O_p5_1(o+32)
6026#define PTR_O_p7_1(o)   PTR_O_p6_1(o) PTR_O_p6_1(o+64)
6027
6028/* CASE_C_PROC_p0 (n0,  p6,p5,p4,p3,p2,p1,p0):
6029 *  let's note <N> = <n0> - 2; the macro inserts:
6030 *      case <N>: ((C_cproc<n0>)pr) (<n0>, fn, k, <rest>);
6031 *  where <rest> is:    *(ptr-1), ..., *(ptr-<N>)
6032 *  (<rest> is empty for <n0> == 2).
6033 *  We must have:   n0 = SUM (i = 7 to 0, p<i> * (1 << i)).
6034 * CASE_C_PROC_p<N+1> (...):
6035 *  like CASE_C_PROC_p<N>, but with doubled output...
6036 */
6037#define CASE_C_PROC_p0(n0,  p6,p5,p4,p3,p2,p1,p0) \
6038    case (n0-2): ((C_proc##n0)pr)(n0, fn, k \
6039PTR_O_p6_##p6(((n0-2)&0x80)+1)\
6040PTR_O_p5_##p5(((n0-2)&0xC0)+1)\
6041PTR_O_p4_##p4(((n0-2)&0xE0)+1)\
6042PTR_O_p3_##p3(((n0-2)&0xF0)+1)\
6043PTR_O_p2_##p2(((n0-2)&0xF8)+1)\
6044PTR_O_p1_##p1(((n0-2)&0xFC)+1)\
6045PTR_O_p0_##p0(((n0-2)&0xFE)+1));
6046#define CASE_C_PROC_p1( n0,n1,  p6,p5,p4,p3,p2,p1) \
6047        CASE_C_PROC_p0 (n0,  p6,p5,p4,p3,p2,p1,0) \
6048        CASE_C_PROC_p0 (n1,  p6,p5,p4,p3,p2,p1,1)
6049#define CASE_C_PROC_p2( n0,n1,n2,n3,  p6,p5,p4,p3,p2) \
6050        CASE_C_PROC_p1 (n0,n1,  p6,p5,p4,p3,p2,0) \
6051        CASE_C_PROC_p1 (n2,n3,  p6,p5,p4,p3,p2,1)
6052#define CASE_C_PROC_p3( n0,n1,n2,n3,n4,n5,n6,n7,  p6,p5,p4,p3) \
6053        CASE_C_PROC_p2 (n0,n1,n2,n3,  p6,p5,p4,p3,0) \
6054        CASE_C_PROC_p2 (n4,n5,n6,n7,  p6,p5,p4,p3,1)
6055
6056  switch(n) {
6057    CASE_C_PROC_p3 (2,3,4,5,6,7,8,9,  0,0,0,0)
6058    CASE_C_PROC_p3 (10,11,12,13,14,15,16,17,  0,0,0,1)
6059    CASE_C_PROC_p3 (18,19,20,21,22,23,24,25,  0,0,1,0)
6060    CASE_C_PROC_p3 (26,27,28,29,30,31,32,33,  0,0,1,1)
6061    CASE_C_PROC_p3 (34,35,36,37,38,39,40,41,  0,1,0,0)
6062    CASE_C_PROC_p3 (42,43,44,45,46,47,48,49,  0,1,0,1)
6063    CASE_C_PROC_p3 (50,51,52,53,54,55,56,57,  0,1,1,0)
6064    CASE_C_PROC_p3 (58,59,60,61,62,63,64,65,  0,1,1,1)
6065    CASE_C_PROC_p0 (66,  1,0,0,0,0,0,0)
6066    CASE_C_PROC_p0 (67,  1,0,0,0,0,0,1)
6067    CASE_C_PROC_p1 (68,69,  1,0,0,0,0,1)
6068    CASE_C_PROC_p2 (70,71,72,73,  1,0,0,0,1)
6069    CASE_C_PROC_p3 (74,75,76,77,78,79,80,81,  1,0,0,1)
6070    CASE_C_PROC_p3 (82,83,84,85,86,87,88,89,  1,0,1,0)
6071    CASE_C_PROC_p3 (90,91,92,93,94,95,96,97,  1,0,1,1)
6072    CASE_C_PROC_p3 (98,99,100,101,102,103,104,105,  1,1,0,0)
6073    CASE_C_PROC_p3 (106,107,108,109,110,111,112,113,  1,1,0,1)
6074    CASE_C_PROC_p3 (114,115,116,117,118,119,120,121,  1,1,1,0)
6075    CASE_C_PROC_p2 (122,123,124,125,  1,1,1,1,0)
6076    CASE_C_PROC_p1 (126,127,  1,1,1,1,1,0)
6077    CASE_C_PROC_p0 (128,  1,1,1,1,1,1,0)
6078  default: barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
6079  }
6080}
6081
6082
6083void C_ccall C_call_cc(C_word c, C_word cl, C_word k, C_word cont)
6084{
6085  C_word *a = C_alloc(3),
6086         wrapper;
6087  void *pr = (void *)C_u_i_car(cont);
6088
6089  if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)
6090    barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
6091
6092  /* Check for values-continuation: */
6093  if(C_u_i_car(k) == (C_word)values_continuation)
6094    wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);
6095  else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);
6096
6097  ((C_proc3)pr)(3, cont, k, wrapper);
6098}
6099
6100
6101void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result)
6102{
6103  C_word cont = C_u_i_cdr(closure);
6104
6105  if(c != 3) C_bad_argc(c, 3);
6106
6107  C_kontinue(cont, result);
6108}
6109
6110
6111void C_ccall call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...)
6112{
6113  va_list v;
6114  C_word cont = C_u_i_cdr(closure),
6115         x1;
6116  int n = c;
6117
6118  va_start(v, k);
6119
6120  if(c > 2) {
6121    x1 = va_arg(v, C_word);
6122    --n;
6123   
6124    while(--c > 2) C_save(va_arg(v, C_word));
6125  }
6126  else x1 = C_SCHEME_UNBOUND;
6127
6128  va_end(v);
6129  C_do_apply(n - 2, cont, x1);
6130}
6131
6132
6133void C_ccall C_continuation_graft(C_word c, C_word self, C_word k, C_word kk, C_word proc)
6134{
6135  ((C_proc2)C_retrieve_proc(proc))(2, proc, C_block_item(kk, 1));
6136}
6137
6138
6139void C_ccall C_values(C_word c, C_word closure, C_word k, ...)
6140{
6141  va_list v;
6142  C_word n = c;
6143
6144  if(c < 2) C_bad_min_argc(c, 2);
6145
6146  va_start(v, k);
6147
6148  /* Check continuation whether it receives multiple values: */
6149  if(C_block_item(k, 0) == (C_word)values_continuation) {
6150    while(c-- > 2)
6151      C_save(va_arg(v, C_word));
6152
6153    va_end(v);
6154    C_do_apply(n - 2, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
6155  }
6156 
6157  if(c != 3) {
6158#ifdef RELAX_MULTIVAL_CHECK
6159    if(c == 2) n = C_SCHEME_UNDEFINED;
6160    else n = va_arg(v, C_word);
6161#else
6162    barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
6163#endif
6164  }
6165  else n = va_arg(v, C_word);
6166
6167  va_end(v);
6168  C_kontinue(k, n);
6169}
6170
6171
6172void C_ccall C_apply_values(C_word c, C_word closure, C_word k, C_word lst)
6173{
6174  C_word n;
6175
6176#ifndef C_UNSAFE_RUNTIME
6177  if(c != 3) C_bad_argc(c, 3);
6178#endif
6179
6180  /* Check continuation wether it receives multiple values: */
6181  if(C_block_item(k, 0) == (C_word)values_continuation) {
6182    for(n = 0; !C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG; ++n) {
6183      C_save(C_u_i_car(lst));
6184      lst = C_u_i_cdr(lst);
6185    }
6186
6187    C_do_apply(n, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
6188  }
6189 
6190  if(C_immediatep(lst) || (C_block_header(lst) == C_PAIR_TAG && C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)) {
6191#ifdef RELAX_MULTIVAL_CHECK
6192    if(C_immediatep(lst)) n = C_SCHEME_UNDEFINED;
6193    else n = C_u_i_car(lst);
6194#else
6195    barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
6196#endif
6197  }
6198  else n = C_u_i_car(lst);
6199
6200  C_kontinue(k, n);
6201}
6202
6203
6204void C_ccall C_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
6205{
6206  C_word *a = C_alloc(4),
6207         kk;
6208
6209#ifndef C_UNSAFE_RUNTIME
6210  if(c != 4) C_bad_argc(c, 4);
6211
6212  if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)
6213    barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);
6214
6215  if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)
6216    barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);
6217#endif
6218
6219  kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
6220  C_do_apply(0, thunk, kk);
6221}
6222
6223
6224void C_ccall C_u_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
6225{
6226  C_word *a = C_alloc(4),
6227         kk;
6228
6229  kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
6230  C_do_apply(0, thunk, kk);
6231}
6232
6233
6234void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
6235{
6236  C_word kont = ((C_SCHEME_BLOCK *)closure)->data[ 1 ],
6237         k = ((C_SCHEME_BLOCK *)closure)->data[ 2 ],
6238         n = c,
6239         *ptr;
6240  va_list v;
6241
6242  if(arg0 == C_SCHEME_UNBOUND) { /* This continuation was called by 'values'... */
6243    va_start(v, arg0);
6244
6245    for(; c-- > 2; C_save(va_arg(v, C_word)));
6246
6247    va_end(v);
6248  }
6249  else {                        /* This continuation was captured and called explicity... */
6250    ++n;
6251    c -= 1;
6252
6253    /* move temporary-stack contents upwards one slot: */
6254    for(ptr = C_temporary_stack - c; --c; ++ptr) *ptr = ptr[ 1 ];
6255
6256    C_save(arg0);
6257  }
6258
6259  C_do_apply(n - 2, kont, k);
6260}
6261
6262
6263void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
6264{
6265  va_list v;
6266  C_word x;
6267  C_word iresult = 1;
6268  int fflag = 0;
6269  double fresult = 1;
6270
6271  va_start(v, k);
6272  c -= 2;
6273
6274  while(c--) {
6275    x = va_arg(v, C_word);
6276   
6277    if(x & C_FIXNUM_BIT) {
6278        fresult *= C_unfix(x);
6279       
6280        if(!fflag) iresult *= C_unfix(x);
6281    }
6282    else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6283        fresult *= C_flonum_magnitude(x);
6284
6285        if(!fflag) fflag = 1;
6286    }
6287    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
6288  }
6289
6290  va_end(v);
6291  x = C_fix(iresult);
6292 
6293  if(fflag || (double)C_unfix(x) != fresult) {
6294      C_temporary_flonum = fresult;
6295      C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6296  }
6297
6298  C_kontinue(k, x);
6299}
6300
6301
6302C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
6303{
6304  C_word iresult;
6305  double fresult;
6306  int fflag = 0;
6307
6308  if(x & C_FIXNUM_BIT) {
6309    if(y & C_FIXNUM_BIT) {
6310      iresult = C_unfix(x) * C_unfix(y);
6311      fresult = (double)C_unfix(x) * (double)C_unfix(y);
6312    }
6313    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6314      fresult = C_unfix(x) * C_flonum_magnitude(y);
6315      fflag = 1;
6316    }
6317    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
6318  }
6319  else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6320    fflag = 1;
6321
6322    if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) * C_unfix(y);
6323    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6324      fresult = C_flonum_magnitude(x) * C_flonum_magnitude(y);
6325    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
6326  }
6327  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
6328
6329  iresult = C_fix(iresult);
6330
6331  if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6332 
6333  return iresult;
6334}
6335
6336
6337void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
6338{
6339  va_list v;
6340  C_word x;
6341  C_word iresult = 0;
6342  int fflag = 0;
6343  double fresult = 0;
6344
6345  va_start(v, k);
6346  c -= 2;
6347
6348  while(c--) {
6349    x = va_arg(v, C_word);
6350   
6351    if(x & C_FIXNUM_BIT) {
6352        fresult += C_unfix(x);
6353
6354        if(!fflag) iresult += C_unfix(x);
6355    }
6356    else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6357      fresult += C_flonum_magnitude(x);
6358
6359      if(!fflag) fflag = 1;
6360    }
6361    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
6362  }
6363
6364  va_end(v);
6365  x = C_fix(iresult);
6366
6367  if(fflag || (double)C_unfix(x) != fresult) {
6368    C_temporary_flonum = fresult;
6369    C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6370  }
6371
6372  C_kontinue(k, x);
6373}
6374
6375
6376C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
6377{
6378  C_word iresult;
6379  double fresult;
6380  int fflag = 0;
6381
6382  if(x & C_FIXNUM_BIT) {
6383    if(y & C_FIXNUM_BIT) {
6384      iresult = C_unfix(x) + C_unfix(y);
6385      fresult = (double)C_unfix(x) + (double)C_unfix(y);
6386    }
6387    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6388      fresult = C_unfix(x) + C_flonum_magnitude(y);
6389      fflag = 1;
6390    }
6391    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
6392  }
6393  else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6394    fflag = 1;
6395
6396    if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) + C_unfix(y);
6397    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6398      fresult = C_flonum_magnitude(x) + C_flonum_magnitude(y);
6399    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
6400  }
6401  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
6402 
6403  iresult = C_fix(iresult);
6404
6405  if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6406 
6407  return iresult;
6408}
6409
6410
6411void cons_flonum_trampoline(void *dummy)
6412{
6413  C_word k = C_restore,
6414         *a = C_alloc(WORDS_PER_FLONUM);
6415
6416  C_kontinue(k, C_flonum(&a, C_temporary_flonum));
6417}
6418
6419
6420void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
6421{
6422  va_list v;
6423  C_word iresult;
6424  int fflag;
6425  double fresult;
6426
6427  if(c < 3) C_bad_min_argc(c, 3);
6428
6429  if(n1 & C_FIXNUM_BIT) {
6430    fresult = iresult = C_unfix(n1);
6431    fflag = 0;
6432  }
6433  else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6434    fresult = C_flonum_magnitude(n1);
6435    fflag = 1;
6436  }
6437  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
6438
6439  if(c == 3) {
6440    if(fflag) fresult = -fresult;
6441    else fresult = iresult = -iresult;
6442
6443    goto cont;
6444  }
6445
6446  va_start(v, n1);
6447  c -= 3;
6448
6449  while(c--) {
6450    n1 = va_arg(v, C_word);
6451   
6452    if(n1 & C_FIXNUM_BIT) {
6453      fresult -= C_unfix(n1);
6454
6455      if(!fflag) iresult -= C_unfix(n1);
6456    }
6457    else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6458      fresult -= C_flonum_magnitude(n1);
6459
6460      if(!fflag) fflag = 1;
6461    }
6462    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
6463  }
6464
6465  va_end(v);
6466 
6467 cont:
6468  n1 = C_fix(iresult);
6469
6470  if(fflag || (double)C_unfix(n1) != fresult) {
6471    C_temporary_flonum = fresult;
6472    C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6473  }
6474
6475  C_kontinue(k, n1);
6476}
6477
6478
6479C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
6480{
6481  C_word iresult;
6482  double fresult;
6483  int fflag = 0;
6484
6485  if(x & C_FIXNUM_BIT) {
6486    if(y & C_FIXNUM_BIT) {
6487      iresult = C_unfix(x) - C_unfix(y);
6488      fresult = (double)C_unfix(x) - (double)C_unfix(y);
6489    }
6490    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6491      fresult = C_unfix(x) - C_flonum_magnitude(y);
6492      fflag = 1;
6493    }
6494    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
6495  }
6496  else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6497    fflag = 1;
6498
6499    if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) - C_unfix(y);
6500    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
6501      fresult = C_flonum_magnitude(x) - C_flonum_magnitude(y);
6502    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
6503  }
6504  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", x);
6505 
6506  iresult = C_fix(iresult);
6507
6508  if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
6509 
6510  return iresult;
6511}
6512
6513
6514void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...)
6515{
6516  va_list v;
6517  C_word n2;
6518  C_word iresult;
6519  int fflag;
6520  double fresult, f2;
6521
6522  if(c < 3) C_bad_min_argc(c, 3);
6523
6524  if(n1 & C_FIXNUM_BIT) {
6525    iresult = C_unfix(n1);
6526    fflag = 0;
6527  }
6528  else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6529    fresult = C_flonum_magnitude(n1);
6530    fflag = 1;
6531  }
6532  else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", n1);
6533
6534  if(c == 3) {
6535    if(fflag) {
6536      if(fresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
6537
6538      fresult = 1.0 / fresult;
6539    }
6540    else {
6541      if(iresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
6542
6543      fresult = 1.0 / (double)iresult;
6544      fflag = 1;
6545    }
6546
6547    goto cont;
6548  }
6549
6550  va_start(v, n1);
6551  c -= 3;
6552
6553  while(c--) {
6554    n1 = va_arg(v, C_word);
6555   
6556    if(n1 & C_FIXNUM_BIT) {
6557      if(fflag) {
6558        if((n1 = C_unfix(n1)) == 0) 
6559          barf(C_DIVISION_BY_ZERO_ERROR, "/");
6560
6561        fresult /= n1;
6562      }
6563      else {
6564        if((n2 = C_unfix(n1)) == 0)
6565          barf(C_DIVISION_BY_ZERO_ERROR, "/");
6566
6567        if((fresult = (double)iresult / (double)n2) != (iresult /= n2))
6568          fflag = 1;
6569      }
6570    }
6571    else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
6572      if(fflag) {
6573        if((f2 = C_flonum_magnitude(n1)) == 0)
6574          barf(C_DIVISION_BY_ZERO_ERROR, "/");
6575
6576        fresult /= f2;
6577      }
6578      else {
6579        fflag = 1;
6580
6581        if((f2 = C_flonum_magnitude(n1)) == 0)
6582          barf(C_DIVISION_BY_ZERO_ERROR, "/");
6583
6584        fresult = (double)iresult / f2;
6585      }
6586    }
6587    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", n1);
6588  }
6589
6590  va_end(v);
6591 
6592 cont:
6593  if(fflag) {
6594    C_temporary_flonum = fresult;
6595    C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
6596  }
6597  else n1 = C_fix(iresult);
6598
6599  C_kontinue(k, n1);
6600}
6601
6602
6603C_regparm C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y)
6604{
6605  C_word iresult;
6606  double fresult;
6607  int fflag = 0;
6608
6609  if(x & C_FIXNUM_BIT) {
6610    if(y & C_FIXNUM_BIT) {
6611      if((iresult = C_unfix(y)) == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
6612
6613      fresult = (double)C_unfix(x) / (double)iresult;
6614      iresult = C_unfix(x) / iresult;
6615    }
6616    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6617      if((fresult = C_flonum_magnitude(y)) == 0.0)
6618        barf(C_DIVISION_BY_ZERO_ERROR, "/");
6619
6620      fresult = (double)C_unfix(x) / fresult;
6621      fflag = 1;
6622    }
6623    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", y);
6624  }
6625  else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
6626    fflag = 1;
6627
6628    if(y & C_FIXNUM_BIT) {
6629      fresult = C_flonum_magnitude(x);
6630
6631      if((iresult = C_unfix(y)) == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
6632
6633      fresult = fresult / (double)iresult;
6634    }
6635    else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
6636      if((fresult = C_flonum_magnitude(y)) == 0.0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
6637     
6638      fresult = C_flonum_magnitude(x) / fresult;
6639    }
6640    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", y);
6641