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

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

merged from prerelease branch rev. 7930 - release version 3.0.0; fixed wrong version numbers in some files

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