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