source: project/chicken/branches/prerelease/runtime.c @ 11632

Last change on this file since 11632 was 11632, checked in by Ivan Raikov, 12 years ago

Merged prerelease and trunk.

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