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

Last change on this file since 15869 was 15869, checked in by kon, 10 years ago

library Added new dynamic library sys namespace procedures
runtime Added support for non-chicken dynload, "folded" 'C_dload2' into platform indep routine
chicken Added new dynload procs
eval Made dynload flags a parameter, added new dynload routines (only a subset is "public", i.e. non-sys namespace)

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