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

Last change on this file since 8361 was 8361, checked in by felix winkelmann, 13 years ago

probably fixed 64-bit literal bug and changed copyrights

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