source: project/chicken/trunk/runtime.c @ 12301

Last change on this file since 12301 was 12301, checked in by felix winkelmann, 13 years ago

merged changes from cmi branch

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