source: project/chicken/runtime.c @ 2536

Last change on this file since 2536 was 2536, checked in by felix winkelmann, 15 years ago

added loopy-loop, scgi fix by pbusser

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