source: project/chicken/branches/chicken-3/runtime.c @ 13178

Last change on this file since 13178 was 13178, checked in by Kon Lovett, 11 years ago

defaults.make : chking of svnrev sep from svnrev fil as a target
lolevel.scm : comment fix
runtime.c : use of C defines for platform info, reflow of some comments/code due to > 100 chars long, cl -> closure (like other procs), use of macros rather than open-coded block access, added return value testing for FreeLibrary? & shl_unlaod.
library.scm : refactored make-property-condition & condition-property-accessor so ##sy# routine available, make ##sys# routines for breakpoint condition, placed 'continuation, etc, on breakpoint condition & not exn.
chicken.h : use of C defines for platform info, added comments, C_CHAR_SHIFT.
posixunix.scm, posixwin.scm : added use of Unit ports
scheduler.scm : use of library breakpoint condition routines, placed 'continuation, etc, on breakpoint condition & not exn
srfi-18.scm : renamed some -inlines (match chicken-thread-object-inlines)

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