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

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

Made dynld routines handle string allocation. Use of common code for dynamic-library-procedure/variable. Made dynld sym routine a noret.

File size: 224.1 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