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

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

Merged trunk and prerelease.

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