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

Last change on this file since 15869 was 15869, checked in by Kon Lovett, 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);