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

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

Rmvd 'C_dynamic_library_symbol' from initial ptable - not a scheme routine.

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