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

Last change on this file since 15901 was 15901, checked in by Kon Lovett, 10 years ago

Rmvd non-scheme procs from initial ptable.

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