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

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

Fix for binary image pathname extension check on Windows. Was comparing too many chars. Added errmsg for wrong extn.

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