1 /* runtime.c - Runtime code for compiler generated executables
2 ;
3 ; Copyright (c) 2008-2021, The CHICKEN Team
4 ; Copyright (c) 2000-2007, Felix L. Winkelmann
5 ; All rights reserved.
6 ;
7 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8 ; conditions are met:
9 ;
10 ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11 ; disclaimer.
12 ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13 ; disclaimer in the documentation and/or other materials provided with the distribution.
14 ; Neither the name of the author nor the names of its contributors may be used to endorse or promote
15 ; products derived from this software without specific prior written permission.
16 ;
17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18 ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19 ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20 ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21 ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22 ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23 ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24 ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 ; POSSIBILITY OF SUCH DAMAGE.
26 */
27
28
29 #include "chicken.h"
30 #include <assert.h>
31 #include <float.h>
32 #include <signal.h>
33 #include <sys/stat.h>
34 #include <strings.h>
35
36 #ifdef HAVE_SYSEXITS_H
37 # include <sysexits.h>
38 #endif
39
40 #ifdef __ANDROID__
41 # include <android/log.h>
42 #endif
43
44 #if !defined(PIC)
45 # define NO_DLOAD2
46 #endif
47
48 #ifndef NO_DLOAD2
49 # ifdef HAVE_DLFCN_H
50 # include <dlfcn.h>
51 # endif
52
53 # ifdef HAVE_DL_H
54 # include <dl.h>
55 # endif
56 #endif
57
58 #ifndef EX_SOFTWARE
59 # define EX_SOFTWARE 70
60 #endif
61
62 #ifndef EOVERFLOW
63 # define EOVERFLOW 0
64 #endif
65
66 /* TODO: Include sys/select.h? Windows doesn't seem to have it... */
67 #ifndef NO_POSIX_POLL
68 # include <poll.h>
69 #endif
70
71 #if !defined(C_NONUNIX)
72
73 # include <sys/time.h>
74 # include <sys/resource.h>
75 # include <sys/wait.h>
76 # include <fcntl.h>
77
78 /* ITIMER_PROF is more precise, but Cygwin doesn't support it... */
79 # ifdef __CYGWIN__
80 # define C_PROFILE_SIGNAL SIGALRM
81 # define C_PROFILE_TIMER ITIMER_REAL
82 # else
83 # define C_PROFILE_SIGNAL SIGPROF
84 # define C_PROFILE_TIMER ITIMER_PROF
85 # endif
86
87 #else
88
89 # define C_PROFILE_SIGNAL -1 /* Stupid way to avoid error */
90
91 #ifdef ECOS
92 #include <cyg/kernel/kapi.h>
93 static C_TLS int timezone;
94 #define NSIG 32
95 #endif
96
97 #endif
98
99 #ifndef RTLD_GLOBAL
100 # define RTLD_GLOBAL 0
101 #endif
102
103 #ifndef RTLD_NOW
104 # define RTLD_NOW 0
105 #endif
106
107 #ifndef RTLD_LOCAL
108 # define RTLD_LOCAL 0
109 #endif
110
111 #ifndef RTLD_LAZY
112 # define RTLD_LAZY 0
113 #endif
114
115 #if defined(_WIN32) && !defined(__CYGWIN__)
116 /* Include winsock2 to get select() for check_fd_ready() */
117 # include <winsock2.h>
118 # include <windows.h>
119 /* Needed for ERROR_OPERATION_ABORTED */
120 # include <winerror.h>
121 #endif
122
123 /* For image_info retrieval */
124 #if defined(__HAIKU__)
125 # include <kernel/image.h>
126 #endif
127
128 /* For _NSGetExecutablePath */
129 #if defined(C_MACOSX)
130 # include <mach-o/dyld.h>
131 #endif
132
133 #ifdef HAVE_CONFIG_H
134 # ifdef PACKAGE
135 # undef PACKAGE
136 # endif
137 # ifdef VERSION
138 # undef VERSION
139 # endif
140 # include <chicken-config.h>
141
142 # ifndef HAVE_ALLOCA
143 # error this package requires "alloca()"
144 # endif
145 #endif
146
147 /* Parameters: */
148
149 #define RELAX_MULTIVAL_CHECK
150
151 #ifdef C_SIXTY_FOUR
152 # define DEFAULT_STACK_SIZE (1024 * 1024)
153 # define DEFAULT_MAXIMAL_HEAP_SIZE 0x7ffffffffffffff0
154 #else
155 # define DEFAULT_STACK_SIZE (256 * 1024)
156 # define DEFAULT_MAXIMAL_HEAP_SIZE 0x7ffffff0
157 #endif
158
159 #define DEFAULT_SYMBOL_TABLE_SIZE 2999
160 #define DEFAULT_KEYWORD_TABLE_SIZE 499
161 #define DEFAULT_HEAP_SIZE DEFAULT_STACK_SIZE
162 #define MINIMAL_HEAP_SIZE DEFAULT_STACK_SIZE
163 #define DEFAULT_SCRATCH_SPACE_SIZE 256
164 #define DEFAULT_HEAP_GROWTH 200
165 #define DEFAULT_HEAP_SHRINKAGE 50
166 #define DEFAULT_HEAP_SHRINKAGE_USED 25
167 #define DEFAULT_HEAP_MIN_FREE (4 * 1024 * 1024)
168 #define HEAP_SHRINK_COUNTS 10
169 #define DEFAULT_FORWARDING_TABLE_SIZE 32
170 #define DEFAULT_LOCATIVE_TABLE_SIZE 32
171 #define DEFAULT_COLLECTIBLES_SIZE 1024
172 #define DEFAULT_TRACE_BUFFER_SIZE 16
173 #define MIN_TRACE_BUFFER_SIZE 3
174
175 #define MAX_HASH_PREFIX 64
176
177 #define DEFAULT_TEMPORARY_STACK_SIZE 256
178 #define STRING_BUFFER_SIZE 4096
179 #define DEFAULT_MUTATION_STACK_SIZE 1024
180 #define PROFILE_TABLE_SIZE 1024
181
182 #define MAX_PENDING_INTERRUPTS 100
183
184 #ifdef C_DOUBLE_IS_32_BITS
185 # define FLONUM_PRINT_PRECISION 7
186 #else
187 # define FLONUM_PRINT_PRECISION 15
188 #endif
189
190 #define WORDS_PER_FLONUM C_SIZEOF_FLONUM
191 #define INITIAL_TIMER_INTERRUPT_PERIOD 10000
192 #define HDUMP_TABLE_SIZE 1001
193
194 /* only for relevant for Windows: */
195
196 #define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 256
197
198
199 /* Constants: */
200
201 #ifdef C_SIXTY_FOUR
202 # ifdef C_LLP
203 # define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffffffffffeLL)
204 # define UWORD_FORMAT_STRING "0x%016llx"
205 # define UWORD_COUNT_FORMAT_STRING "%llu"
206 # else
207 # define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffffffffffeL)
208 # define UWORD_FORMAT_STRING "0x%016lx"
209 # define UWORD_COUNT_FORMAT_STRING "%lu"
210 # endif
211 #else
212 # define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffe)
213 # define UWORD_FORMAT_STRING "0x%08x"
214 # define UWORD_COUNT_FORMAT_STRING "%u"
215 #endif
216
217 #ifdef C_LLP
218 # define LONG_FORMAT_STRING "%lld"
219 #else
220 # define LONG_FORMAT_STRING "%ld"
221 #endif
222
223 #define GC_MINOR 0
224 #define GC_MAJOR 1
225 #define GC_REALLOC 2
226
227
228 /* Macros: */
229
230 #define nmax(x, y) ((x) > (y) ? (x) : (y))
231 #define nmin(x, y) ((x) < (y) ? (x) : (y))
232 #define percentage(n, p) ((C_long)(((double)(n) * (double)p) / 100))
233
234 #define clear_buffer_object(buf, obj) C_migrate_buffer_object(NULL, (C_word *)(buf), C_buf_end(buf), (obj))
235 #define move_buffer_object(ptr, buf, obj) C_migrate_buffer_object(ptr, (C_word *)(buf), C_buf_end(buf), (obj))
236
237 /* The bignum digit representation is fullword- little endian, so on
238 * LE machines the halfdigits are numbered in the same order. On BE
239 * machines, we must swap the odd and even positions.
240 */
241 #ifdef C_BIG_ENDIAN
242 #define C_uhword_ref(x, p) ((C_uhword *)(x))[(p)^1]
243 #else
244 #define C_uhword_ref(x, p) ((C_uhword *)(x))[(p)]
245 #endif
246 #define C_uhword_set(x, p, d) (C_uhword_ref(x,p) = (d))
247
248 #define free_tmp_bignum(b) C_free((void *)(b))
249
250 /* Forwarding pointers abuse the fact that objects must be
251 * word-aligned, so we can just drop the lowest bit.
252 */
253 #define is_fptr(x) (((x) & C_GC_FORWARDING_BIT) != 0)
254 #define ptr_to_fptr(x) (((C_uword)(x) >> 1) | C_GC_FORWARDING_BIT)
255 #define fptr_to_ptr(x) ((C_uword)(x) << 1)
256
257 #define C_check_real(x, w, v) if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
258 else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
259 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
260 else v = C_flonum_magnitude(x);
261
262
263 #define C_pte(name) pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;
264
265 #ifndef SIGBUS
266 # define SIGBUS 0
267 #endif
268
269 #define C_thread_id(x) C_block_item((x), 14)
270
271
272 /* Type definitions: */
273
274 typedef C_regparm C_word C_fcall (*integer_plusmin_op) (C_word **ptr, C_word n, C_word x, C_word y);
275
276 typedef struct lf_list_struct
277 {
278 C_word *lf;
279 int count;
280 struct lf_list_struct *next, *prev;
281 C_PTABLE_ENTRY *ptable;
282 void *module_handle;
283 char *module_name;
284 } LF_LIST;
285
286 typedef struct finalizer_node_struct
287 {
288 struct finalizer_node_struct
289 *next,
290 *previous;
291 C_word
292 item,
293 finalizer;
294 } FINALIZER_NODE;
295
296 typedef struct trace_info_struct
297 {
298 C_char *raw;
299 C_word cooked1, cooked2, thread;
300 } TRACE_INFO;
301
302 typedef struct hdump_bucket_struct
303 {
304 C_word key;
305 int count, total;
306 struct hdump_bucket_struct *next;
307 } HDUMP_BUCKET;
308
309 typedef struct profile_bucket_struct
310 {
311 C_char *key;
312 C_uword sample_count; /* Multiplied by profile freq = time spent */
313 C_uword call_count; /* Distinct calls seen while sampling */
314 struct profile_bucket_struct *next;
315 } PROFILE_BUCKET;
316
317
318 /* Variables: */
319
320 C_TLS C_word
321 *C_temporary_stack,
322 *C_temporary_stack_bottom,
323 *C_temporary_stack_limit,
324 *C_stack_limit, /* "Soft" limit, may be reset to force GC */
325 *C_stack_hard_limit, /* Actual stack limit */
326 *C_scratchspace_start,
327 *C_scratchspace_top,
328 *C_scratchspace_limit,
329 C_scratch_usage;
330 C_TLS C_long
331 C_timer_interrupt_counter,
332 C_initial_timer_interrupt_period;
333 C_TLS C_byte
334 *C_fromspace_top,
335 *C_fromspace_limit;
336 #ifdef HAVE_SIGSETJMP
337 C_TLS sigjmp_buf C_restart;
338 #else
339 C_TLS jmp_buf C_restart;
340 #endif
341 C_TLS void *C_restart_trampoline;
342 C_TLS C_word C_restart_c;
343 C_TLS int C_entry_point_status;
344 C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
345 C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
346 C_TLS void (*C_panic_hook)(C_char *msg) = NULL;
347 C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
348 C_TLS void (*C_post_gc_hook)(int mode, C_long ms) = NULL;
349 C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc) = NULL;
350
351 C_TLS int
352 C_gui_mode = 0,
353 C_abort_on_thread_exceptions,
354 C_enable_repl,
355 C_interrupts_enabled,
356 C_disable_overflow_check,
357 C_heap_size_is_fixed,
358 C_trace_buffer_size = DEFAULT_TRACE_BUFFER_SIZE,
359 C_max_pending_finalizers = C_DEFAULT_MAX_PENDING_FINALIZERS,
360 C_debugging = 0,
361 C_main_argc;
362 C_TLS C_uword
363 C_heap_growth = DEFAULT_HEAP_GROWTH,
364 C_heap_shrinkage = DEFAULT_HEAP_SHRINKAGE,
365 C_heap_shrinkage_used = DEFAULT_HEAP_SHRINKAGE_USED,
366 C_heap_half_min_free = DEFAULT_HEAP_MIN_FREE,
367 C_maximal_heap_size = DEFAULT_MAXIMAL_HEAP_SIZE,
368 heap_shrink_counter = 0;
369 C_TLS time_t
370 C_startup_time_sec,
371 C_startup_time_msec,
372 profile_frequency = 10000;
373 C_TLS char
374 **C_main_argv,
375 #ifdef SEARCH_EXE_PATH
376 *C_main_exe = NULL,
377 #endif
378 *C_dlerror;
379
380 static C_TLS TRACE_INFO
381 *trace_buffer,
382 *trace_buffer_limit,
383 *trace_buffer_top;
384
385 static C_TLS C_byte
386 *heapspace1,
387 *heapspace2,
388 *fromspace_start,
389 *tospace_start,
390 *tospace_top,
391 *tospace_limit,
392 *new_tospace_start,
393 *new_tospace_top,
394 *new_tospace_limit;
395 static C_TLS C_uword
396 heapspace1_size,
397 heapspace2_size,
398 heap_size,
399 scratchspace_size,
400 temporary_stack_size,
401 fixed_temporary_stack_size = 0,
402 maximum_heap_usage;
403 static C_TLS C_char
404 buffer[ STRING_BUFFER_SIZE ],
405 *private_repository = NULL,
406 *current_module_name,
407 *save_string;
408 static C_TLS C_SYMBOL_TABLE
409 *symbol_table,
410 *symbol_table_list,
411 *keyword_table;
412 static C_TLS C_word
413 **collectibles,
414 **collectibles_top,
415 **collectibles_limit,
416 **mutation_stack_bottom,
417 **mutation_stack_limit,
418 **mutation_stack_top,
419 *stack_bottom,
420 *locative_table,
421 error_location,
422 interrupt_hook_symbol,
423 current_thread_symbol,
424 error_hook_symbol,
425 pending_finalizers_symbol,
426 callback_continuation_stack_symbol,
427 core_provided_symbol,
428 u8vector_symbol,
429 s8vector_symbol,
430 u16vector_symbol,
431 s16vector_symbol,
432 u32vector_symbol,
433 s32vector_symbol,
434 u64vector_symbol,
435 s64vector_symbol,
436 f32vector_symbol,
437 f64vector_symbol,
438 *forwarding_table;
439 static C_TLS int
440 trace_buffer_full,
441 forwarding_table_size,
442 return_to_host,
443 page_size,
444 show_trace,
445 fake_tty_flag,
446 debug_mode,
447 dump_heap_on_exit,
448 gc_bell,
449 gc_report_flag = 0,
450 gc_mode,
451 gc_count_1,
452 gc_count_1_total,
453 gc_count_2,
454 stack_size_changed,
455 dlopen_flags,
456 heap_size_changed,
457 random_state_initialized = 0,
458 chicken_is_running,
459 chicken_ran_once,
460 pass_serious_signals = 1,
461 callback_continuation_level;
462 static volatile C_TLS int
463 serious_signal_occurred = 0,
464 profiling = 0;
465 static C_TLS unsigned int
466 mutation_count,
467 tracked_mutation_count,
468 stack_check_demand,
469 stack_size;
470 static C_TLS int chicken_is_initialized;
471 #ifdef HAVE_SIGSETJMP
472 static C_TLS sigjmp_buf gc_restart;
473 #else
474 static C_TLS jmp_buf gc_restart;
475 #endif
476 static C_TLS double
477 timer_start_ms,
478 gc_ms,
479 timer_accumulated_gc_ms,
480 interrupt_time,
481 last_interrupt_latency;
482 static C_TLS LF_LIST *lf_list;
483 static C_TLS int signal_mapping_table[ NSIG ];
484 static C_TLS int
485 locative_table_size,
486 locative_table_count,
487 live_finalizer_count,
488 allocated_finalizer_count,
489 pending_finalizer_count,
490 callback_returned_flag;
491 static C_TLS C_GC_ROOT *gc_root_list = NULL;
492 static C_TLS FINALIZER_NODE
493 *finalizer_list,
494 *finalizer_free_list,
495 **pending_finalizer_indices;
496 static C_TLS void *current_module_handle;
497 static C_TLS int flonum_print_precision = FLONUM_PRINT_PRECISION;
498 static C_TLS HDUMP_BUCKET **hdump_table;
499 static C_TLS PROFILE_BUCKET
500 *next_profile_bucket = NULL,
501 **profile_table = NULL;
502 static C_TLS int
503 pending_interrupts[ MAX_PENDING_INTERRUPTS ],
504 pending_interrupts_count,
505 handling_interrupts;
506 static C_TLS C_uword random_state[ C_RANDOM_STATE_SIZE / sizeof(C_uword) ];
507 static C_TLS int random_state_index = 0;
508
509
510 /* Prototypes: */
511
512 static void parse_argv(C_char *cmds);
513 static void initialize_symbol_table(void);
514 static void global_signal_handler(int signum);
515 static C_word arg_val(C_char *arg);
516 static void barf(int code, char *loc, ...) C_noret;
517 static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_noret;
518 static void panic(C_char *msg) C_noret;
519 static void usual_panic(C_char *msg) C_noret;
520 static void horror(C_char *msg) C_noret;
521 static void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
522 static C_cpsproc(values_continuation) C_noret;
523 static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
524 static C_regparm int C_fcall C_in_new_heapp(C_word x);
525 static C_regparm C_word bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);
526 static C_regparm C_word bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end);
527
528 static C_regparm C_word bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp);
529 static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);
530 static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op);
531 static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat);
532 static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op);
533 static C_word rat_times_integer(C_word **ptr, C_word x, C_word y);
534 static C_word rat_times_rat(C_word **ptr, C_word x, C_word y);
535 static C_word cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy);
536 static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y);
537 static C_regparm void integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);
538 static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y);
539 static C_regparm void bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);
540 static C_regparm C_word bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);
541 static C_regparm void burnikel_ziegler_3n_div_2n(C_word **ptr, C_word a12, C_word a3, C_word b, C_word b1, C_word b2, C_word n, C_word *q, C_word *r);
542 static C_regparm void burnikel_ziegler_2n_div_1n(C_word **ptr, C_word a, C_word b, C_word b1, C_word b2, C_word n, C_word *q, C_word *r);
543 static C_word rat_cmp(C_word x, C_word y);
544 static void fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan);
545 static C_word int_flo_cmp(C_word intnum, C_word flonum);
546 static C_word flo_int_cmp(C_word flonum, C_word intnum);
547 static C_word rat_flo_cmp(C_word ratnum, C_word flonum);
548 static C_word flo_rat_cmp(C_word flonum, C_word ratnum);
549 static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp);
550 static int bignum_cmp_unsigned(C_word x, C_word y);
551 static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci) C_regparm;
552 static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
553 static C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm;
554 static double compute_symbol_table_load(double *avg_bucket_len, int *total);
555 static double C_fcall decode_flonum_literal(C_char *str) C_regparm;
556 static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);
557 static void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
558 static void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
559 static void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
560 static C_word C_fcall intern0(C_char *name) C_regparm;
561 static void C_fcall update_locative_table(int mode) C_regparm;
562 static void C_fcall update_symbol_tables(int mode) C_regparm;
563 static LF_LIST *find_module_handle(C_char *name);
564 static void set_profile_timer(C_uword freq);
565 static void take_profile_sample();
566
567 static C_cpsproc(call_cc_wrapper) C_noret;
568 static C_cpsproc(call_cc_values_wrapper) C_noret;
569 static C_cpsproc(gc_2) C_noret;
570 static C_cpsproc(allocate_vector_2) C_noret;
571 static C_cpsproc(generic_trampoline) C_noret;
572 static void handle_interrupt(void *trampoline) C_noret;
573 static C_cpsproc(callback_return_continuation) C_noret;
574 static C_cpsproc(termination_continuation) C_noret;
575 static C_cpsproc(become_2) C_noret;
576 static C_cpsproc(copy_closure_2) C_noret;
577 static C_cpsproc(dump_heap_state_2) C_noret;
578 static C_cpsproc(sigsegv_trampoline) C_noret;
579 static C_cpsproc(sigill_trampoline) C_noret;
580 static C_cpsproc(sigfpe_trampoline) C_noret;
581 static C_cpsproc(sigbus_trampoline) C_noret;
582 static C_cpsproc(bignum_to_str_2) C_noret;
583
584 static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp);
585 static C_word allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp);
586 static void bignum_digits_destructive_negate(C_word bignum);
587 static C_uword bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry);
588 static C_uword bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator);
589 static C_uword bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp);
590 static C_uword bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left);
591 static C_regparm void bignum_digits_multiply(C_word x, C_word y, C_word result);
592 static void bignum_divide_unsigned(C_word **ptr, C_word num, C_word denom, C_word *q, C_word q_negp, C_word *r, C_word r_negp);
593 static C_regparm void bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);
594 static C_regparm void bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder);
595 static C_regparm void bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q);
596
597 static C_PTABLE_ENTRY *create_initial_ptable();
598
599 #if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
600 static void C_ccall dload_2(C_word, C_word *) C_noret;
601 #endif
602
603 static void
C_dbg(C_char * prefix,C_char * fstr,...)604 C_dbg(C_char *prefix, C_char *fstr, ...)
605 {
606 va_list va;
607
608 va_start(va, fstr);
609 #ifdef __ANDROID__
610 __android_log_vprint(ANDROID_LOG_DEBUG, prefix, fstr, va);
611 #else
612 C_fflush(C_stdout);
613 C_fprintf(C_stderr, "[%s] ", prefix);
614 C_vfprintf(C_stderr, fstr, va);
615 C_fflush(C_stderr);
616 #endif
617 va_end(va);
618 }
619
620 /* Startup code: */
621
CHICKEN_main(int argc,char * argv[],void * toplevel)622 int CHICKEN_main(int argc, char *argv[], void *toplevel)
623 {
624 C_word h, s, n;
625
626 if(C_gui_mode) {
627 #ifdef _WIN32
628 parse_argv(GetCommandLine());
629 argc = C_main_argc;
630 argv = C_main_argv;
631 #else
632 /* ??? */
633 #endif
634 }
635
636 pass_serious_signals = 0;
637 CHICKEN_parse_command_line(argc, argv, &h, &s, &n);
638
639 if(!CHICKEN_initialize(h, s, n, toplevel))
640 panic(C_text("cannot initialize - out of memory"));
641
642 CHICKEN_run(NULL);
643 return 0;
644 }
645
646
647 /* Custom argv parser for Windoze: */
648
parse_argv(C_char * cmds)649 void parse_argv(C_char *cmds)
650 {
651 C_char *ptr = cmds,
652 *bptr0, *bptr, *aptr;
653 int n = 0;
654
655 C_main_argv = (C_char **)malloc(MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS * sizeof(C_char *));
656
657 if(C_main_argv == NULL)
658 panic(C_text("cannot allocate argument-list buffer"));
659
660 C_main_argc = 0;
661
662 for(;;) {
663 while(isspace((int)(*ptr))) ++ptr;
664
665 if(*ptr == '\0') break;
666
667 for(bptr0 = bptr = buffer; !isspace((int)(*ptr)) && *ptr != '\0'; *(bptr++) = *(ptr++))
668 ++n;
669
670 *bptr = '\0';
671
672 aptr = (C_char*) malloc(sizeof(C_char) * (n + 1));
673 if (!aptr)
674 panic(C_text("cannot allocate argument buffer"));
675
676 C_strlcpy(aptr, bptr0, sizeof(C_char) * (n + 1));
677
678 C_main_argv[ C_main_argc++ ] = aptr;
679 }
680 }
681
682
683 /* Initialize runtime system: */
684
CHICKEN_initialize(int heap,int stack,int symbols,void * toplevel)685 int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
686 {
687 C_SCHEME_BLOCK *k0;
688 int i;
689 #ifdef HAVE_SIGACTION
690 struct sigaction sa;
691 #endif
692
693 /* FIXME Should have C_tzset in chicken.h? */
694 #if defined(__MINGW32__)
695 # if defined(__MINGW64_VERSION_MAJOR)
696 ULONGLONG tick_count = GetTickCount64();
697 # else
698 /* mingw32 doesn't yet have GetTickCount64 support */
699 ULONGLONG tick_count = GetTickCount();
700 # endif
701 C_startup_time_sec = tick_count / 1000;
702 C_startup_time_msec = tick_count % 1000;
703 /* Make sure _tzname, _timezone, and _daylight are set */
704 _tzset();
705 #else
706 struct timeval tv;
707 C_gettimeofday(&tv, NULL);
708 C_startup_time_sec = tv.tv_sec;
709 C_startup_time_msec = tv.tv_usec / 1000;
710 /* Make sure tzname, timezone, and daylight are set */
711 tzset();
712 #endif
713
714 if(chicken_is_initialized) return 1;
715 else chicken_is_initialized = 1;
716
717 #if defined(__ANDROID__) && defined(DEBUGBUILD)
718 debug_mode = 2;
719 #endif
720
721 if(debug_mode)
722 C_dbg(C_text("debug"), C_text("application startup...\n"));
723
724 C_panic_hook = usual_panic;
725 symbol_table_list = NULL;
726
727 symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE);
728
729 if(symbol_table == NULL)
730 return 0;
731
732 keyword_table = C_new_symbol_table("kw", symbols ? symbols / 4 : DEFAULT_KEYWORD_TABLE_SIZE);
733
734 if(keyword_table == NULL)
735 return 0;
736
737 page_size = 0;
738 stack_size = stack ? stack : DEFAULT_STACK_SIZE;
739 C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);
740
741 /* Allocate temporary stack: */
742 temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;
743 if((C_temporary_stack_limit = (C_word *)C_malloc(temporary_stack_size * sizeof(C_word))) == NULL)
744 return 0;
745
746 C_temporary_stack_bottom = C_temporary_stack_limit + temporary_stack_size;
747 C_temporary_stack = C_temporary_stack_bottom;
748
749 /* Allocate mutation stack: */
750 mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));
751
752 if(mutation_stack_bottom == NULL) return 0;
753
754 mutation_stack_top = mutation_stack_bottom;
755 mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;
756 C_gc_mutation_hook = NULL;
757 C_gc_trace_hook = NULL;
758
759 /* Initialize finalizer lists: */
760 finalizer_list = NULL;
761 finalizer_free_list = NULL;
762 pending_finalizer_indices =
763 (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));
764
765 if(pending_finalizer_indices == NULL) return 0;
766
767 /* Initialize forwarding table: */
768 forwarding_table =
769 (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));
770
771 if(forwarding_table == NULL) return 0;
772
773 *forwarding_table = 0;
774 forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;
775
776 /* Initialize locative table: */
777 locative_table = (C_word *)C_malloc(DEFAULT_LOCATIVE_TABLE_SIZE * sizeof(C_word));
778
779 if(locative_table == NULL) return 0;
780
781 locative_table_size = DEFAULT_LOCATIVE_TABLE_SIZE;
782 locative_table_count = 0;
783
784 /* Setup collectibles: */
785 collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);
786
787 if(collectibles == NULL) return 0;
788
789 collectibles_top = collectibles;
790 collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;
791 gc_root_list = NULL;
792
793 #if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
794 dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;
795 #else
796 dlopen_flags = 0;
797 #endif
798
799 #ifdef HAVE_SIGACTION
800 sa.sa_flags = 0;
801 sigfillset(&sa.sa_mask); /* See note in C_establish_signal_handler() */
802 sa.sa_handler = global_signal_handler;
803 #endif
804
805 /* setup signal handlers */
806 if(!pass_serious_signals) {
807 #ifdef HAVE_SIGACTION
808 C_sigaction(SIGBUS, &sa, NULL);
809 C_sigaction(SIGFPE, &sa, NULL);
810 C_sigaction(SIGILL, &sa, NULL);
811 C_sigaction(SIGSEGV, &sa, NULL);
812 #else
813 C_signal(SIGBUS, global_signal_handler);
814 C_signal(SIGILL, global_signal_handler);
815 C_signal(SIGFPE, global_signal_handler);
816 C_signal(SIGSEGV, global_signal_handler);
817 #endif
818 }
819
820 tracked_mutation_count = mutation_count = gc_count_1 = gc_count_1_total = gc_count_2 = maximum_heap_usage = 0;
821 lf_list = NULL;
822 C_register_lf2(NULL, 0, create_initial_ptable());
823 C_restart_trampoline = (void *)toplevel;
824 trace_buffer = NULL;
825 C_clear_trace_buffer();
826 chicken_is_running = chicken_ran_once = 0;
827 pending_interrupts_count = 0;
828 handling_interrupts = 0;
829 last_interrupt_latency = 0;
830 C_interrupts_enabled = 1;
831 C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;
832 C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;
833 memset(signal_mapping_table, 0, sizeof(int) * NSIG);
834 C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";
835 error_location = C_SCHEME_FALSE;
836 C_pre_gc_hook = NULL;
837 C_post_gc_hook = NULL;
838 C_scratchspace_start = NULL;
839 C_scratchspace_top = NULL;
840 C_scratchspace_limit = NULL;
841 C_scratch_usage = 0;
842 scratchspace_size = 0;
843 live_finalizer_count = 0;
844 allocated_finalizer_count = 0;
845 current_module_name = NULL;
846 current_module_handle = NULL;
847 callback_continuation_level = 0;
848 gc_ms = 0;
849 if (!random_state_initialized) {
850 srand(time(NULL));
851 random_state_initialized = 1;
852 }
853
854 for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_uword); ++i)
855 random_state[ i ] = rand();
856
857 initialize_symbol_table();
858
859 if (profiling) {
860 #ifndef C_NONUNIX
861 # ifdef HAVE_SIGACTION
862 C_sigaction(C_PROFILE_SIGNAL, &sa, NULL);
863 # else
864 C_signal(C_PROFILE_SIGNAL, global_signal_handler);
865 # endif
866 #endif
867
868 profile_table = (PROFILE_BUCKET **)C_malloc(PROFILE_TABLE_SIZE * sizeof(PROFILE_BUCKET *));
869
870 if(profile_table == NULL)
871 panic(C_text("out of memory - can not allocate profile table"));
872
873 C_memset(profile_table, 0, sizeof(PROFILE_BUCKET *) * PROFILE_TABLE_SIZE);
874 }
875
876 /* create k to invoke code for system-startup: */
877 k0 = (C_SCHEME_BLOCK *)C_align((C_word)C_fromspace_top);
878 C_fromspace_top += C_align(2 * sizeof(C_word));
879 k0->header = C_CLOSURE_TYPE | 1;
880 C_set_block_item(k0, 0, (C_word)termination_continuation);
881 C_save(k0);
882 C_save(C_SCHEME_UNDEFINED);
883 C_restart_c = 2;
884 return 1;
885 }
886
887
C_get_statistics(void)888 void *C_get_statistics(void) {
889 static void *stats[ 8 ];
890
891 stats[ 0 ] = fromspace_start;
892 stats[ 1 ] = C_fromspace_limit;
893 stats[ 2 ] = C_scratchspace_start;
894 stats[ 3 ] = C_scratchspace_limit;
895 stats[ 4 ] = C_stack_limit;
896 stats[ 5 ] = stack_bottom;
897 stats[ 6 ] = C_fromspace_top;
898 stats[ 7 ] = C_scratchspace_top;
899 return stats;
900 }
901
902
create_initial_ptable()903 static C_PTABLE_ENTRY *create_initial_ptable()
904 {
905 /* IMPORTANT: hardcoded table size -
906 this must match the number of C_pte calls + 1 (NULL terminator)! */
907 C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 63);
908 int i = 0;
909
910 if(pt == NULL)
911 panic(C_text("out of memory - cannot create initial ptable"));
912
913 C_pte(termination_continuation);
914 C_pte(callback_return_continuation);
915 C_pte(values_continuation);
916 C_pte(call_cc_values_wrapper);
917 C_pte(call_cc_wrapper);
918 C_pte(C_gc);
919 C_pte(C_allocate_vector);
920 C_pte(C_make_structure);
921 C_pte(C_ensure_heap_reserve);
922 C_pte(C_return_to_host);
923 C_pte(C_get_symbol_table_info);
924 C_pte(C_get_memory_info);
925 C_pte(C_decode_seconds);
926 C_pte(C_stop_timer);
927 C_pte(C_dload);
928 C_pte(C_set_dlopen_flags);
929 C_pte(C_become);
930 C_pte(C_apply_values);
931 C_pte(C_times);
932 C_pte(C_minus);
933 C_pte(C_plus);
934 C_pte(C_nequalp);
935 C_pte(C_greaterp);
936 /* IMPORTANT: have you read the comments at the start and the end of this function? */
937 C_pte(C_lessp);
938 C_pte(C_greater_or_equal_p);
939 C_pte(C_less_or_equal_p);
940 C_pte(C_number_to_string);
941 C_pte(C_make_symbol);
942 C_pte(C_string_to_symbol);
943 C_pte(C_string_to_keyword);
944 C_pte(C_apply);
945 C_pte(C_call_cc);
946 C_pte(C_values);
947 C_pte(C_call_with_values);
948 C_pte(C_continuation_graft);
949 C_pte(C_open_file_port);
950 C_pte(C_software_type);
951 C_pte(C_machine_type);
952 C_pte(C_machine_byte_order);
953 C_pte(C_software_version);
954 C_pte(C_build_platform);
955 C_pte(C_make_pointer);
956 /* IMPORTANT: have you read the comments at the start and the end of this function? */
957 C_pte(C_make_tagged_pointer);
958 C_pte(C_peek_signed_integer);
959 C_pte(C_peek_unsigned_integer);
960 C_pte(C_peek_int64);
961 C_pte(C_peek_uint64);
962 C_pte(C_context_switch);
963 C_pte(C_register_finalizer);
964 C_pte(C_copy_closure);
965 C_pte(C_dump_heap_state);
966 C_pte(C_filter_heap_objects);
967 C_pte(C_fixnum_to_string);
968 C_pte(C_integer_to_string);
969 C_pte(C_flonum_to_string);
970 C_pte(C_signum);
971 C_pte(C_quotient_and_remainder);
972 C_pte(C_u_integer_quotient_and_remainder);
973 C_pte(C_bitwise_and);
974 C_pte(C_bitwise_ior);
975 C_pte(C_bitwise_xor);
976
977 /* IMPORTANT: did you remember the hardcoded pte table size? */
978 pt[ i ].id = NULL;
979 return pt;
980 }
981
982
CHICKEN_new_gc_root_2(int finalizable)983 void *CHICKEN_new_gc_root_2(int finalizable)
984 {
985 C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));
986
987 if(r == NULL)
988 panic(C_text("out of memory - cannot allocate GC root"));
989
990 r->value = C_SCHEME_UNDEFINED;
991 r->next = gc_root_list;
992 r->prev = NULL;
993 r->finalizable = finalizable;
994
995 if(gc_root_list != NULL) gc_root_list->prev = r;
996
997 gc_root_list = r;
998 return (void *)r;
999 }
1000
1001
CHICKEN_new_gc_root()1002 void *CHICKEN_new_gc_root()
1003 {
1004 return CHICKEN_new_gc_root_2(0);
1005 }
1006
1007
CHICKEN_new_finalizable_gc_root()1008 void *CHICKEN_new_finalizable_gc_root()
1009 {
1010 return CHICKEN_new_gc_root_2(1);
1011 }
1012
1013
CHICKEN_delete_gc_root(void * root)1014 void CHICKEN_delete_gc_root(void *root)
1015 {
1016 C_GC_ROOT *r = (C_GC_ROOT *)root;
1017
1018 if(r->prev == NULL) gc_root_list = r->next;
1019 else r->prev->next = r->next;
1020
1021 if(r->next != NULL) r->next->prev = r->prev;
1022
1023 C_free(root);
1024 }
1025
1026
CHICKEN_global_lookup(char * name)1027 void *CHICKEN_global_lookup(char *name)
1028 {
1029 int
1030 len = C_strlen(name),
1031 key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
1032 C_word s;
1033 void *root = CHICKEN_new_gc_root();
1034
1035 if(C_truep(s = lookup(key, len, name, symbol_table))) {
1036 if(C_block_item(s, 0) != C_SCHEME_UNBOUND) {
1037 CHICKEN_gc_root_set(root, s);
1038 return root;
1039 }
1040 }
1041
1042 return NULL;
1043 }
1044
1045
CHICKEN_is_running()1046 int CHICKEN_is_running()
1047 {
1048 return chicken_is_running;
1049 }
1050
1051
CHICKEN_interrupt()1052 void CHICKEN_interrupt()
1053 {
1054 C_timer_interrupt_counter = 0;
1055 }
1056
1057
C_new_symbol_table(char * name,unsigned int size)1058 C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)
1059 {
1060 C_SYMBOL_TABLE *stp;
1061 int i;
1062
1063 if((stp = C_find_symbol_table(name)) != NULL) return stp;
1064
1065 if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)
1066 return NULL;
1067
1068 stp->name = name;
1069 stp->size = size;
1070 stp->next = symbol_table_list;
1071 stp->rand = rand();
1072
1073 if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)
1074 return NULL;
1075
1076 for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);
1077
1078 symbol_table_list = stp;
1079 return stp;
1080 }
1081
1082
C_find_symbol_table(char * name)1083 C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)
1084 {
1085 C_SYMBOL_TABLE *stp;
1086
1087 for(stp = symbol_table_list; stp != NULL; stp = stp->next)
1088 if(!C_strcmp(name, stp->name)) return stp;
1089
1090 return NULL;
1091 }
1092
1093
C_find_symbol(C_word str,C_SYMBOL_TABLE * stable)1094 C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)
1095 {
1096 C_char *sptr = C_c_string(str);
1097 int len = C_header_size(str);
1098 int key;
1099 C_word s;
1100
1101 if(stable == NULL) stable = symbol_table;
1102
1103 key = hash_string(len, sptr, stable->size, stable->rand, 0);
1104
1105 if(C_truep(s = lookup(key, len, sptr, stable))) return s;
1106 else return C_SCHEME_FALSE;
1107 }
1108
1109
1110 /* Setup symbol-table with internally used symbols; */
1111
initialize_symbol_table(void)1112 void initialize_symbol_table(void)
1113 {
1114 int i;
1115
1116 for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);
1117
1118 /* Obtain reference to hooks for later: */
1119 core_provided_symbol = C_intern2(C_heaptop, C_text("##core#provided"));
1120 interrupt_hook_symbol = C_intern2(C_heaptop, C_text("##sys#interrupt-hook"));
1121 error_hook_symbol = C_intern2(C_heaptop, C_text("##sys#error-hook"));
1122 callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);
1123 pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));
1124 current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);
1125
1126 /* SRFI-4 tags */
1127 u8vector_symbol = C_intern2(C_heaptop, C_text("u8vector"));
1128 s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));
1129 u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));
1130 s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));
1131 u32vector_symbol = C_intern2(C_heaptop, C_text("u32vector"));
1132 s32vector_symbol = C_intern2(C_heaptop, C_text("s32vector"));
1133 u64vector_symbol = C_intern2(C_heaptop, C_text("u64vector"));
1134 s64vector_symbol = C_intern2(C_heaptop, C_text("s64vector"));
1135 f32vector_symbol = C_intern2(C_heaptop, C_text("f32vector"));
1136 f64vector_symbol = C_intern2(C_heaptop, C_text("f64vector"));
1137 }
1138
1139
C_find_keyword(C_word str,C_SYMBOL_TABLE * kwtable)1140 C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)
1141 {
1142 C_char *sptr = C_c_string(str);
1143 int len = C_header_size(str);
1144 int key;
1145 C_word s;
1146
1147 if(kwtable == NULL) kwtable = keyword_table;
1148
1149 key = hash_string(len, sptr, kwtable->size, kwtable->rand, 0);
1150
1151 if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;
1152 else return C_SCHEME_FALSE;
1153 }
1154
1155
sigsegv_trampoline(C_word c,C_word * av)1156 void C_ccall sigsegv_trampoline(C_word c, C_word *av)
1157 {
1158 barf(C_MEMORY_VIOLATION_ERROR, NULL);
1159 }
1160
1161
sigbus_trampoline(C_word c,C_word * av)1162 void C_ccall sigbus_trampoline(C_word c, C_word *av)
1163 {
1164 barf(C_BUS_ERROR, NULL);
1165 }
1166
1167
sigfpe_trampoline(C_word c,C_word * av)1168 void C_ccall sigfpe_trampoline(C_word c, C_word *av)
1169 {
1170 barf(C_FLOATING_POINT_EXCEPTION_ERROR, NULL);
1171 }
1172
1173
sigill_trampoline(C_word c,C_word * av)1174 void C_ccall sigill_trampoline(C_word c, C_word *av)
1175 {
1176 barf(C_ILLEGAL_INSTRUCTION_ERROR, NULL);
1177 }
1178
1179
1180 /* This is called from POSIX signals: */
1181
global_signal_handler(int signum)1182 void global_signal_handler(int signum)
1183 {
1184 #if defined(HAVE_SIGPROCMASK)
1185 if(signum == SIGSEGV || signum == SIGFPE || signum == SIGILL || signum == SIGBUS) {
1186 sigset_t sset;
1187
1188 if(serious_signal_occurred || !chicken_is_running) {
1189 switch(signum) {
1190 case SIGSEGV: panic(C_text("unrecoverable segmentation violation"));
1191 case SIGFPE: panic(C_text("unrecoverable floating-point exception"));
1192 case SIGILL: panic(C_text("unrecoverable illegal instruction error"));
1193 case SIGBUS: panic(C_text("unrecoverable bus error"));
1194 default: panic(C_text("unrecoverable serious condition"));
1195 }
1196 }
1197 else serious_signal_occurred = 1;
1198
1199 /* unblock signal to avoid nested invocation of the handler */
1200 sigemptyset(&sset);
1201 sigaddset(&sset, signum);
1202 C_sigprocmask(SIG_UNBLOCK, &sset, NULL);
1203
1204 switch(signum) {
1205 case SIGSEGV: C_reclaim(sigsegv_trampoline, 0);
1206 case SIGFPE: C_reclaim(sigfpe_trampoline, 0);
1207 case SIGILL: C_reclaim(sigill_trampoline, 0);
1208 case SIGBUS: C_reclaim(sigbus_trampoline, 0);
1209 default: panic(C_text("invalid serious signal"));
1210 }
1211 }
1212 #endif
1213
1214 /* TODO: Make full use of sigaction: check that /our/ timer expired */
1215 if (signum == C_PROFILE_SIGNAL && profiling) take_profile_sample();
1216 else C_raise_interrupt(signal_mapping_table[ signum ]);
1217
1218 #ifndef HAVE_SIGACTION
1219 /* not necessarily needed, but older UNIXen may not leave the handler installed: */
1220 C_signal(signum, global_signal_handler);
1221 #endif
1222 }
1223
1224
1225 /* Align memory to page boundary */
1226
align_to_page(void * mem)1227 static void *align_to_page(void *mem)
1228 {
1229 return (void *)C_align((C_uword)mem);
1230 }
1231
1232
1233 static C_byte *
heap_alloc(size_t size,C_byte ** page_aligned)1234 heap_alloc (size_t size, C_byte **page_aligned)
1235 {
1236 C_byte *p;
1237 p = (C_byte *)C_malloc (size + page_size);
1238
1239 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
1240
1241 return p;
1242 }
1243
1244
1245 static void
heap_free(C_byte * ptr,size_t size)1246 heap_free (C_byte *ptr, size_t size)
1247 {
1248 C_free (ptr);
1249 }
1250
1251
1252 static C_byte *
heap_realloc(C_byte * ptr,size_t old_size,size_t new_size,C_byte ** page_aligned)1253 heap_realloc (C_byte *ptr, size_t old_size,
1254 size_t new_size, C_byte **page_aligned)
1255 {
1256 C_byte *p;
1257 p = (C_byte *)C_realloc (ptr, new_size + page_size);
1258
1259 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
1260
1261 return p;
1262 }
1263
1264
1265 /* Modify heap size at runtime: */
1266
C_set_or_change_heap_size(C_word heap,int reintern)1267 void C_set_or_change_heap_size(C_word heap, int reintern)
1268 {
1269 C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;
1270 C_word size = heap / 2;
1271
1272 if(heap_size_changed && fromspace_start) return;
1273
1274 if(fromspace_start && heap_size >= heap) return;
1275
1276 if(debug_mode)
1277 C_dbg(C_text("debug"), C_text("heap resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), heap);
1278
1279 heap_size = heap;
1280
1281 if((ptr1 = heap_realloc (fromspace_start,
1282 C_fromspace_limit - fromspace_start,
1283 size, &ptr1a)) == NULL ||
1284 (ptr2 = heap_realloc (tospace_start,
1285 tospace_limit - tospace_start,
1286 size, &ptr2a)) == NULL)
1287 panic(C_text("out of memory - cannot allocate heap"));
1288
1289 heapspace1 = ptr1;
1290 heapspace1_size = size;
1291 heapspace2 = ptr2;
1292 heapspace2_size = size;
1293 fromspace_start = ptr1a;
1294 C_fromspace_top = fromspace_start;
1295 C_fromspace_limit = fromspace_start + size;
1296 tospace_start = ptr2a;
1297 tospace_top = tospace_start;
1298 tospace_limit = tospace_start + size;
1299 mutation_stack_top = mutation_stack_bottom;
1300
1301 if(reintern) initialize_symbol_table();
1302 }
1303
1304
1305 /* Modify stack-size at runtime: */
1306
C_do_resize_stack(C_word stack)1307 void C_do_resize_stack(C_word stack)
1308 {
1309 C_uword old = stack_size,
1310 diff = stack - old;
1311
1312 if(diff != 0 && !stack_size_changed) {
1313 if(debug_mode)
1314 C_dbg(C_text("debug"), C_text("stack resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), stack);
1315
1316 stack_size = stack;
1317
1318 #if C_STACK_GROWS_DOWNWARD
1319 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit - diff);
1320 #else
1321 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit + diff);
1322 #endif
1323 C_stack_limit = C_stack_hard_limit;
1324 }
1325 }
1326
1327
1328 /* Check whether nursery is sufficiently big: */
1329
C_check_nursery_minimum(C_word words)1330 void C_check_nursery_minimum(C_word words)
1331 {
1332 if(words >= C_bytestowords(stack_size))
1333 panic(C_text("nursery is too small - try higher setting using the `-:s' option"));
1334 }
1335
C_resize_pending_finalizers(C_word size)1336 C_word C_resize_pending_finalizers(C_word size) {
1337 int sz = C_num_to_int(size);
1338
1339 FINALIZER_NODE **newmem =
1340 (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));
1341
1342 if (newmem == NULL)
1343 return C_SCHEME_FALSE;
1344
1345 pending_finalizer_indices = newmem;
1346 C_max_pending_finalizers = sz;
1347 return C_SCHEME_TRUE;
1348 }
1349
1350
1351 /* Parse runtime options from command-line: */
1352
CHICKEN_parse_command_line(int argc,char * argv[],C_word * heap,C_word * stack,C_word * symbols)1353 void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols)
1354 {
1355 int i;
1356 char *ptr;
1357 C_word x;
1358
1359 C_main_argc = argc;
1360 C_main_argv = argv;
1361
1362 *heap = DEFAULT_HEAP_SIZE;
1363 *stack = DEFAULT_STACK_SIZE;
1364 *symbols = DEFAULT_SYMBOL_TABLE_SIZE;
1365
1366 for(i = 1; i < C_main_argc; ++i)
1367 if(!strncmp(C_main_argv[ i ], C_text("-:"), 2)) {
1368 for(ptr = &C_main_argv[ i ][ 2 ]; *ptr != '\0';) {
1369 switch(*(ptr++)) {
1370 case '?':
1371 C_dbg("Runtime options", "\n\n"
1372 " -:? display this text\n"
1373 " -:c always treat stdin as console\n"
1374 " -:d enable debug output\n"
1375 " -:D enable more debug output\n"
1376 " -:g show GC information\n"
1377 " -:o disable stack overflow checks\n"
1378 " -:hiSIZE set initial heap size\n"
1379 " -:hmSIZE set maximal heap size\n"
1380 " -:hfSIZE set minimum unused heap size\n"
1381 " -:hgPERCENTAGE set heap growth percentage\n"
1382 " -:hsPERCENTAGE set heap shrink percentage\n"
1383 " -:huPERCENTAGE set percentage of memory used at which heap will be shrunk\n"
1384 " -:hSIZE set fixed heap size\n"
1385 " -:r write trace output to stderr\n"
1386 " -:RSEED initialize rand() seed with SEED (helpful for benchmark stability)\n"
1387 " -:p collect statistical profile and write to file at exit\n"
1388 " -:PFREQUENCY like -:p, specifying sampling frequency in us (default: 10000)\n"
1389 " -:sSIZE set nursery (stack) size\n"
1390 " -:tSIZE set symbol-table size\n"
1391 " -:fSIZE set maximal number of pending finalizers\n"
1392 " -:x deliver uncaught exceptions of other threads to primordial one\n"
1393 " -:b enter REPL on error\n"
1394 " -:B sound bell on major GC\n"
1395 " -:G force GUI mode\n"
1396 " -:aSIZE set trace-buffer/call-chain size\n"
1397 " -:ASIZE set fixed temporary stack size\n"
1398 " -:H dump heap state on exit\n"
1399 " -:S do not handle segfaults or other serious conditions\n"
1400 "\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"
1401 " times 1024, 1048576, and 1073741824, respectively.\n\n");
1402 C_exit_runtime(C_fix(0));
1403
1404 case 'h':
1405 switch(*ptr) {
1406 case 'i':
1407 *heap = arg_val(ptr + 1);
1408 heap_size_changed = 1;
1409 goto next;
1410 case 'f':
1411 C_heap_half_min_free = arg_val(ptr + 1);
1412 goto next;
1413 case 'g':
1414 C_heap_growth = arg_val(ptr + 1);
1415 goto next;
1416 case 'm':
1417 C_maximal_heap_size = arg_val(ptr + 1);
1418 goto next;
1419 case 's':
1420 C_heap_shrinkage = arg_val(ptr + 1);
1421 goto next;
1422 case 'u':
1423 C_heap_shrinkage_used = arg_val(ptr + 1);
1424 goto next;
1425 default:
1426 *heap = arg_val(ptr);
1427 heap_size_changed = 1;
1428 C_heap_size_is_fixed = 1;
1429 goto next;
1430 }
1431
1432 case 'o':
1433 C_disable_overflow_check = 1;
1434 break;
1435
1436 case 'B':
1437 gc_bell = 1;
1438 break;
1439
1440 case 'G':
1441 C_gui_mode = 1;
1442 break;
1443
1444 case 'H':
1445 dump_heap_on_exit = 1;
1446 break;
1447
1448 case 'S':
1449 pass_serious_signals = 1;
1450 break;
1451
1452 case 's':
1453 *stack = arg_val(ptr);
1454 stack_size_changed = 1;
1455 goto next;
1456
1457 case 'f':
1458 C_max_pending_finalizers = arg_val(ptr);
1459 goto next;
1460
1461 case 'a':
1462 C_trace_buffer_size = arg_val(ptr);
1463 goto next;
1464
1465 case 'A':
1466 fixed_temporary_stack_size = arg_val(ptr);
1467 goto next;
1468
1469 case 't':
1470 *symbols = arg_val(ptr);
1471 goto next;
1472
1473 case 'c':
1474 fake_tty_flag = 1;
1475 break;
1476
1477 case 'd':
1478 debug_mode = 1;
1479 break;
1480
1481 case 'D':
1482 debug_mode = 2;
1483 break;
1484
1485 case 'g':
1486 gc_report_flag = 2;
1487 break;
1488
1489 case 'P':
1490 profiling = 1;
1491 profile_frequency = arg_val(ptr);
1492 goto next;
1493
1494 case 'p':
1495 profiling = 1;
1496 break;
1497
1498 case 'r':
1499 show_trace = 1;
1500 break;
1501
1502 case 'R':
1503 srand((unsigned int)arg_val(ptr));
1504 random_state_initialized = 1;
1505 goto next;
1506
1507 case 'x':
1508 C_abort_on_thread_exceptions = 1;
1509 break;
1510
1511 case 'b':
1512 C_enable_repl = 1;
1513 break;
1514
1515 default: panic(C_text("illegal runtime option"));
1516 }
1517 }
1518
1519 next:;
1520 }
1521 }
1522
1523
arg_val(C_char * arg)1524 C_word arg_val(C_char *arg)
1525 {
1526 int len;
1527 C_char *end;
1528 C_long val, mul = 1;
1529
1530 if (arg == NULL) panic(C_text("illegal runtime-option argument"));
1531
1532 len = C_strlen(arg);
1533
1534 if(len < 1) panic(C_text("illegal runtime-option argument"));
1535
1536 switch(arg[ len - 1 ]) {
1537 case 'k':
1538 case 'K': mul = 1024; break;
1539
1540 case 'm':
1541 case 'M': mul = 1024 * 1024; break;
1542
1543 case 'g':
1544 case 'G': mul = 1024 * 1024 * 1024; break;
1545
1546 default: mul = 1;
1547 }
1548
1549 val = C_strtow(arg, &end, 10);
1550
1551 if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))
1552 panic(C_text("invalid runtime-option argument suffix"));
1553
1554 return val * mul;
1555 }
1556
1557
1558 /* Run embedded code with arguments: */
1559
CHICKEN_run(void * toplevel)1560 C_word CHICKEN_run(void *toplevel)
1561 {
1562 if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))
1563 panic(C_text("could not initialize"));
1564
1565 if(chicken_is_running)
1566 panic(C_text("re-invocation of Scheme world while process is already running"));
1567
1568 chicken_is_running = chicken_ran_once = 1;
1569 return_to_host = 0;
1570
1571 if(profiling) set_profile_timer(profile_frequency);
1572
1573 #if C_STACK_GROWS_DOWNWARD
1574 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);
1575 #else
1576 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);
1577 #endif
1578 C_stack_limit = C_stack_hard_limit;
1579
1580 stack_bottom = C_stack_pointer;
1581
1582 if(debug_mode)
1583 C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx\n"), (C_word)stack_bottom);
1584
1585 /* The point of (usually) no return... */
1586 #ifdef HAVE_SIGSETJMP
1587 C_sigsetjmp(C_restart, 0);
1588 #else
1589 C_setjmp(C_restart);
1590 #endif
1591
1592 serious_signal_occurred = 0;
1593
1594 if(!return_to_host) {
1595 /* We must copy the argvector onto the stack, because
1596 * any subsequent save() will otherwise clobber it.
1597 */
1598 C_word *p = C_alloc(C_restart_c);
1599 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));
1600 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));
1601 C_temporary_stack = C_temporary_stack_bottom;
1602 ((C_proc)C_restart_trampoline)(C_restart_c, p);
1603 }
1604
1605 if(profiling) set_profile_timer(0);
1606
1607 chicken_is_running = 0;
1608 return C_restore;
1609 }
1610
1611
CHICKEN_continue(C_word k)1612 C_word CHICKEN_continue(C_word k)
1613 {
1614 if(C_temporary_stack_bottom != C_temporary_stack)
1615 panic(C_text("invalid temporary stack level"));
1616
1617 if(!chicken_is_initialized)
1618 panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));
1619
1620 C_save(k);
1621 return CHICKEN_run(NULL);
1622 }
1623
1624
1625 /* The final continuation: */
1626
termination_continuation(C_word c,C_word * av)1627 void C_ccall termination_continuation(C_word c, C_word *av)
1628 {
1629 if(debug_mode) {
1630 C_dbg(C_text("debug"), C_text("application terminated normally\n"));
1631 }
1632
1633 C_exit_runtime(C_fix(0));
1634 }
1635
1636
1637 /* Signal unrecoverable runtime error: */
1638
panic(C_char * msg)1639 void panic(C_char *msg)
1640 {
1641 if(C_panic_hook != NULL) C_panic_hook(msg);
1642
1643 usual_panic(msg);
1644 }
1645
1646
usual_panic(C_char * msg)1647 void usual_panic(C_char *msg)
1648 {
1649 C_char *dmp = C_dump_trace(0);
1650
1651 C_dbg_hook(C_SCHEME_UNDEFINED);
1652
1653 if(C_gui_mode) {
1654 C_snprintf(buffer, sizeof(buffer), C_text("%s\n\n%s"), msg, dmp);
1655 #if defined(_WIN32) && !defined(__CYGWIN__)
1656 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);
1657 ExitProcess(1);
1658 #endif
1659 } /* fall through if not WIN32 GUI app */
1660
1661 C_dbg("panic", C_text("%s - execution terminated\n\n%s"), msg, dmp);
1662 C_exit_runtime(C_fix(1));
1663 }
1664
1665
horror(C_char * msg)1666 void horror(C_char *msg)
1667 {
1668 C_dbg_hook(C_SCHEME_UNDEFINED);
1669
1670 if(C_gui_mode) {
1671 C_snprintf(buffer, sizeof(buffer), C_text("%s"), msg);
1672 #if defined(_WIN32) && !defined(__CYGWIN__)
1673 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);
1674 ExitProcess(1);
1675 #endif
1676 } /* fall through */
1677
1678 C_dbg("horror", C_text("\n%s - execution terminated"), msg);
1679 C_exit_runtime(C_fix(1));
1680 }
1681
1682
1683 /* Error-hook, called from C-level runtime routines: */
1684
barf(int code,char * loc,...)1685 void barf(int code, char *loc, ...)
1686 {
1687 C_char *msg;
1688 C_word err = error_hook_symbol;
1689 int c, i;
1690 va_list v;
1691 C_word *av;
1692
1693 C_dbg_hook(C_SCHEME_UNDEFINED);
1694
1695 C_temporary_stack = C_temporary_stack_bottom;
1696 err = C_block_item(err, 0);
1697
1698 switch(code) {
1699 case C_BAD_ARGUMENT_COUNT_ERROR:
1700 msg = C_text("bad argument count");
1701 c = 3;
1702 break;
1703
1704 case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
1705 msg = C_text("too few arguments");
1706 c = 3;
1707 break;
1708
1709 case C_BAD_ARGUMENT_TYPE_ERROR:
1710 msg = C_text("bad argument type");
1711 c = 1;
1712 break;
1713
1714 case C_UNBOUND_VARIABLE_ERROR:
1715 msg = C_text("unbound variable");
1716 c = 1;
1717 break;
1718
1719 case C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR:
1720 msg = C_text("bad argument type - not a keyword");
1721 c = 1;
1722 break;
1723
1724 case C_OUT_OF_MEMORY_ERROR:
1725 msg = C_text("not enough memory");
1726 c = 0;
1727 break;
1728
1729 case C_DIVISION_BY_ZERO_ERROR:
1730 msg = C_text("division by zero");
1731 c = 0;
1732 break;
1733
1734 case C_OUT_OF_RANGE_ERROR:
1735 msg = C_text("out of range");
1736 c = 2;
1737 break;
1738
1739 case C_NOT_A_CLOSURE_ERROR:
1740 msg = C_text("call of non-procedure");
1741 c = 1;
1742 break;
1743
1744 case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:
1745 msg = C_text("continuation cannot receive multiple values");
1746 c = 1;
1747 break;
1748
1749 case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:
1750 msg = C_text("bad argument type - not a non-cyclic list");
1751 c = 1;
1752 break;
1753
1754 case C_TOO_DEEP_RECURSION_ERROR:
1755 msg = C_text("recursion too deep");
1756 c = 0;
1757 break;
1758
1759 case C_CANT_REPRESENT_INEXACT_ERROR:
1760 msg = C_text("inexact number cannot be represented as an exact number");
1761 c = 1;
1762 break;
1763
1764 case C_NOT_A_PROPER_LIST_ERROR:
1765 msg = C_text("bad argument type - not a proper list");
1766 c = 1;
1767 break;
1768
1769 case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:
1770 msg = C_text("bad argument type - not a fixnum");
1771 c = 1;
1772 break;
1773
1774 case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:
1775 msg = C_text("bad argument type - not a string");
1776 c = 1;
1777 break;
1778
1779 case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:
1780 msg = C_text("bad argument type - not a pair");
1781 c = 1;
1782 break;
1783
1784 case C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR:
1785 msg = C_text("bad argument type - not a boolean");
1786 c = 1;
1787 break;
1788
1789 case C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR:
1790 msg = C_text("bad argument type - not a locative");
1791 c = 1;
1792 break;
1793
1794 case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:
1795 msg = C_text("bad argument type - not a list");
1796 c = 1;
1797 break;
1798
1799 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:
1800 msg = C_text("bad argument type - not a number");
1801 c = 1;
1802 break;
1803
1804 case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:
1805 msg = C_text("bad argument type - not a symbol");
1806 c = 1;
1807 break;
1808
1809 case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:
1810 msg = C_text("bad argument type - not a vector");
1811 c = 1;
1812 break;
1813
1814 case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:
1815 msg = C_text("bad argument type - not a character");
1816 c = 1;
1817 break;
1818
1819 case C_STACK_OVERFLOW_ERROR:
1820 msg = C_text("stack overflow");
1821 c = 0;
1822 break;
1823
1824 case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:
1825 msg = C_text("bad argument type - not a structure of the required type");
1826 c = 2;
1827 break;
1828
1829 case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:
1830 msg = C_text("bad argument type - not a blob");
1831 c = 1;
1832 break;
1833
1834 case C_LOST_LOCATIVE_ERROR:
1835 msg = C_text("locative refers to reclaimed object");
1836 c = 1;
1837 break;
1838
1839 case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:
1840 msg = C_text("bad argument type - not a object");
1841 c = 1;
1842 break;
1843
1844 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:
1845 msg = C_text("bad argument type - not a number vector");
1846 c = 2;
1847 break;
1848
1849 case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
1850 msg = C_text("bad argument type - not an integer");
1851 c = 1;
1852 break;
1853
1854 case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
1855 msg = C_text("bad argument type - not an unsigned integer");
1856 c = 1;
1857 break;
1858
1859 case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:
1860 msg = C_text("bad argument type - not a pointer");
1861 c = 1;
1862 break;
1863
1864 case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:
1865 msg = C_text("bad argument type - not a tagged pointer");
1866 c = 2;
1867 break;
1868
1869 case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
1870 msg = C_text("bad argument type - not a flonum");
1871 c = 1;
1872 break;
1873
1874 case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:
1875 msg = C_text("bad argument type - not a procedure");
1876 c = 1;
1877 break;
1878
1879 case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:
1880 msg = C_text("bad argument type - invalid base");
1881 c = 1;
1882 break;
1883
1884 case C_CIRCULAR_DATA_ERROR:
1885 msg = C_text("recursion too deep or circular data encountered");
1886 c = 0;
1887 break;
1888
1889 case C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR:
1890 msg = C_text("bad argument type - not a port");
1891 c = 1;
1892 break;
1893
1894 case C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR:
1895 msg = C_text("bad argument type - not a port of the correct type");
1896 c = 1;
1897 break;
1898
1899 case C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR:
1900 msg = C_text("bad argument type - not an input-port");
1901 c = 1;
1902 break;
1903
1904 case C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR:
1905 msg = C_text("bad argument type - not an output-port");
1906 c = 1;
1907 break;
1908
1909 case C_PORT_CLOSED_ERROR:
1910 msg = C_text("port already closed");
1911 c = 1;
1912 break;
1913
1914 case C_ASCIIZ_REPRESENTATION_ERROR:
1915 msg = C_text("cannot represent string with NUL bytes as C string");
1916 c = 1;
1917 break;
1918
1919 case C_MEMORY_VIOLATION_ERROR:
1920 msg = C_text("segmentation violation");
1921 c = 0;
1922 break;
1923
1924 case C_FLOATING_POINT_EXCEPTION_ERROR:
1925 msg = C_text("floating point exception");
1926 c = 0;
1927 break;
1928
1929 case C_ILLEGAL_INSTRUCTION_ERROR:
1930 msg = C_text("illegal instruction");
1931 c = 0;
1932 break;
1933
1934 case C_BUS_ERROR:
1935 msg = C_text("bus error");
1936 c = 0;
1937 break;
1938
1939 case C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR:
1940 msg = C_text("bad argument type - not an exact number");
1941 c = 1;
1942 break;
1943
1944 case C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR:
1945 msg = C_text("bad argument type - not an inexact number");
1946 c = 1;
1947 break;
1948
1949 case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:
1950 msg = C_text("bad argument type - not an real");
1951 c = 1;
1952 break;
1953
1954 case C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR:
1955 msg = C_text("bad argument type - complex number has no ordering");
1956 c = 1;
1957 break;
1958
1959 case C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR:
1960 msg = C_text("bad argument type - not an exact integer");
1961 c = 1;
1962 break;
1963
1964 case C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION:
1965 msg = C_text("number does not fit in foreign type");
1966 c = 1;
1967 break;
1968
1969 case C_BAD_ARGUMENT_TYPE_COMPLEX_ABS:
1970 msg = C_text("cannot compute absolute value of complex number");
1971 c = 1;
1972 break;
1973
1974 case C_REST_ARG_OUT_OF_BOUNDS_ERROR:
1975 msg = C_text("attempted rest argument access beyond end of list");
1976 c = 3;
1977 break;
1978
1979 default: panic(C_text("illegal internal error code"));
1980 }
1981
1982 if(C_immediatep(err)) {
1983 C_dbg(C_text("error"), C_text("%s\n"), msg);
1984 panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));
1985 } else {
1986 av = C_alloc(c + 4);
1987 va_start(v, loc);
1988 av[ 0 ] = err;
1989 /* No continuation is passed: '##sys#error-hook' may not return: */
1990 av[ 1 ] = C_SCHEME_UNDEFINED;
1991 av[ 2 ] = C_fix(code);
1992
1993 if(loc != NULL)
1994 av[ 3 ] = intern0(loc);
1995 else {
1996 av[ 3 ] = error_location;
1997 error_location = C_SCHEME_FALSE;
1998 }
1999
2000 for(i = 0; i < c; ++i)
2001 av[ i + 4 ] = va_arg(v, C_word);
2002
2003 va_end(v);
2004 C_do_apply(c + 4, av);
2005 }
2006 }
2007
2008
2009 /* Never use extended number hook procedure names longer than this! */
2010 /* Current longest name: ##sys#integer->string/recursive */
2011 #define MAX_EXTNUM_HOOK_NAME 32
2012
2013 /* This exists so that we don't have to create any extra closures */
try_extended_number(char * ext_proc_name,C_word c,C_word k,...)2014 static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)
2015 {
2016 static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];
2017 int i;
2018 va_list v;
2019 C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;
2020
2021 ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));
2022
2023 if(!C_immediatep(ext_proc_sym))
2024 ext_proc = C_block_item(ext_proc_sym, 0);
2025
2026 if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {
2027 C_word *av = C_alloc(c + 1);
2028 av[ 0 ] = ext_proc;
2029 av[ 1 ] = k;
2030 va_start(v, k);
2031
2032 for(i = 0; i < c - 1; ++i)
2033 av[ i + 2 ] = va_arg(v, C_word);
2034
2035 va_end(v);
2036 C_do_apply(c + 1, av);
2037 } else {
2038 barf(C_UNBOUND_VARIABLE_ERROR, NULL, ext_proc_sym);
2039 }
2040 }
2041
2042
2043 /* Hook for setting breakpoints */
2044
C_dbg_hook(C_word dummy)2045 C_word C_dbg_hook(C_word dummy)
2046 {
2047 return dummy;
2048 }
2049
2050
2051 /* Timing routines: */
2052
2053 /* DEPRECATED */
C_milliseconds(void)2054 C_regparm C_u64 C_fcall C_milliseconds(void)
2055 {
2056 return C_current_process_milliseconds();
2057 }
2058
C_current_process_milliseconds(void)2059 C_regparm C_u64 C_fcall C_current_process_milliseconds(void)
2060 {
2061 #if defined(__MINGW32__)
2062 # if defined(__MINGW64_VERSION_MAJOR)
2063 ULONGLONG tick_count = GetTickCount64();
2064 # else
2065 ULONGLONG tick_count = GetTickCount();
2066 # endif
2067 return tick_count - (C_startup_time_sec * 1000) - C_startup_time_msec;
2068 #else
2069 struct timeval tv;
2070
2071 if(C_gettimeofday(&tv, NULL) == -1) return 0;
2072 else return (tv.tv_sec - C_startup_time_sec) * 1000 + tv.tv_usec / 1000 - C_startup_time_msec;
2073 #endif
2074 }
2075
2076
C_seconds(C_long * ms)2077 C_regparm time_t C_fcall C_seconds(C_long *ms)
2078 {
2079 #ifdef C_NONUNIX
2080 if(ms != NULL) *ms = 0;
2081
2082 return (time_t)(clock() / CLOCKS_PER_SEC);
2083 #else
2084 struct timeval tv;
2085
2086 if(C_gettimeofday(&tv, NULL) == -1) {
2087 if(ms != NULL) *ms = 0;
2088
2089 return (time_t)0;
2090 }
2091 else {
2092 if(ms != NULL) *ms = tv.tv_usec / 1000;
2093
2094 return tv.tv_sec;
2095 }
2096 #endif
2097 }
2098
2099
C_cpu_milliseconds(void)2100 C_regparm C_u64 C_fcall C_cpu_milliseconds(void)
2101 {
2102 #if defined(C_NONUNIX) || defined(__CYGWIN__)
2103 if(CLOCKS_PER_SEC == 1000) return clock();
2104 else return ((C_u64)clock() / CLOCKS_PER_SEC) * 1000;
2105 #else
2106 struct rusage ru;
2107
2108 if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;
2109 else return (((C_u64)ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 1000
2110 + ((C_u64)ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000);
2111 #endif
2112 }
2113
2114
2115 /* Support code for callbacks: */
2116
C_save_callback_continuation(C_word ** ptr,C_word k)2117 int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)
2118 {
2119 C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
2120
2121 C_mutate_slot(&C_block_item(callback_continuation_stack_symbol, 0), p);
2122 return ++callback_continuation_level;
2123 }
2124
2125
C_restore_callback_continuation(void)2126 C_word C_fcall C_restore_callback_continuation(void)
2127 {
2128 /* obsolete, but retained for keeping old code working */
2129 C_word p = C_block_item(callback_continuation_stack_symbol, 0),
2130 k;
2131
2132 assert(!C_immediatep(p) && C_block_header(p) == C_PAIR_TAG);
2133 k = C_u_i_car(p);
2134
2135 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
2136 --callback_continuation_level;
2137 return k;
2138 }
2139
2140
C_restore_callback_continuation2(int level)2141 C_word C_fcall C_restore_callback_continuation2(int level)
2142 {
2143 C_word p = C_block_item(callback_continuation_stack_symbol, 0),
2144 k;
2145
2146 if(level != callback_continuation_level || C_immediatep(p) || C_block_header(p) != C_PAIR_TAG)
2147 panic(C_text("unbalanced callback continuation stack"));
2148
2149 k = C_u_i_car(p);
2150
2151 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
2152 --callback_continuation_level;
2153 return k;
2154 }
2155
2156
C_callback(C_word closure,int argc)2157 C_word C_fcall C_callback(C_word closure, int argc)
2158 {
2159 #ifdef HAVE_SIGSETJMP
2160 sigjmp_buf prev;
2161 #else
2162 jmp_buf prev;
2163 #endif
2164 C_word
2165 *a = C_alloc(C_SIZEOF_CLOSURE(2)),
2166 k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE),
2167 *av;
2168 int old = chicken_is_running;
2169
2170 if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)
2171 panic(C_text("callback invoked in non-safe context"));
2172
2173 C_memcpy(&prev, &C_restart, sizeof(C_restart));
2174 callback_returned_flag = 0;
2175 chicken_is_running = 1;
2176 av = C_alloc(argc + 2);
2177 av[ 0 ] = closure;
2178 av[ 1 ] = k;
2179 /*XXX is the order of arguments an issue? */
2180 C_memcpy(av + 2, C_temporary_stack, argc * sizeof(C_word));
2181 C_temporary_stack = C_temporary_stack_bottom;
2182
2183 #ifdef HAVE_SIGSETJMP
2184 if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc + 2, av);
2185 #else
2186 if(!C_setjmp(C_restart)) C_do_apply(argc + 2, av);
2187 #endif
2188
2189 serious_signal_occurred = 0;
2190
2191 if(!callback_returned_flag) {
2192 /* We must copy the argvector onto the stack, because
2193 * any subsequent save() will otherwise clobber it.
2194 */
2195 C_word *p = C_alloc(C_restart_c);
2196 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));
2197 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));
2198 C_temporary_stack = C_temporary_stack_bottom;
2199 ((C_proc)C_restart_trampoline)(C_restart_c, p);
2200 }
2201 else {
2202 C_memcpy(&C_restart, &prev, sizeof(C_restart));
2203 callback_returned_flag = 0;
2204 }
2205
2206 chicken_is_running = old;
2207 return C_restore;
2208 }
2209
2210
C_callback_adjust_stack(C_word * a,int size)2211 void C_fcall C_callback_adjust_stack(C_word *a, int size)
2212 {
2213 if(!chicken_is_running && !C_in_stackp((C_word)a)) {
2214 if(debug_mode)
2215 C_dbg(C_text("debug"),
2216 C_text("callback invoked in lower stack region - adjusting limits:\n"
2217 "[debug] current: \t%p\n"
2218 "[debug] previous: \t%p (bottom) - %p (limit)\n"),
2219 a, stack_bottom, C_stack_limit);
2220
2221 #if C_STACK_GROWS_DOWNWARD
2222 C_stack_hard_limit = (C_word *)((C_byte *)a - stack_size);
2223 stack_bottom = a + size;
2224 #else
2225 C_stack_hard_limit = (C_word *)((C_byte *)a + stack_size);
2226 stack_bottom = a;
2227 #endif
2228 C_stack_limit = C_stack_hard_limit;
2229
2230 if(debug_mode)
2231 C_dbg(C_text("debug"), C_text("new: \t%p (bottom) - %p (limit)\n"),
2232 stack_bottom, C_stack_limit);
2233 }
2234 }
2235
2236
C_callback_wrapper(void * proc,int argc)2237 C_word C_fcall C_callback_wrapper(void *proc, int argc)
2238 {
2239 C_word
2240 *a = C_alloc(C_SIZEOF_CLOSURE(1)),
2241 closure = C_closure(&a, 1, (C_word)proc),
2242 result;
2243
2244 result = C_callback(closure, argc);
2245 assert(C_temporary_stack == C_temporary_stack_bottom);
2246 return result;
2247 }
2248
2249
callback_return_continuation(C_word c,C_word * av)2250 void C_ccall callback_return_continuation(C_word c, C_word *av)
2251 {
2252 C_word self = av[0];
2253 C_word r = av[1];
2254
2255 if(C_block_item(self, 1) == C_SCHEME_TRUE)
2256 panic(C_text("callback returned twice"));
2257
2258 assert(callback_returned_flag == 0);
2259 callback_returned_flag = 1;
2260 C_set_block_item(self, 1, C_SCHEME_TRUE);
2261 C_save(r);
2262 C_reclaim(NULL, 0);
2263 }
2264
2265
2266 /* Register/unregister literal frame: */
2267
C_initialize_lf(C_word * lf,int count)2268 void C_initialize_lf(C_word *lf, int count)
2269 {
2270 while(count-- > 0)
2271 *(lf++) = C_SCHEME_UNBOUND;
2272 }
2273
2274
C_register_lf(C_word * lf,int count)2275 void *C_register_lf(C_word *lf, int count)
2276 {
2277 return C_register_lf2(lf, count, NULL);
2278 }
2279
2280
C_register_lf2(C_word * lf,int count,C_PTABLE_ENTRY * ptable)2281 void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
2282 {
2283 LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));
2284 LF_LIST *np;
2285 int status = 0;
2286
2287 node->lf = lf;
2288 node->count = count;
2289 node->ptable = ptable;
2290 node->module_name = current_module_name;
2291 node->module_handle = current_module_handle;
2292 current_module_handle = NULL;
2293
2294 if(lf_list) lf_list->prev = node;
2295
2296 node->next = lf_list;
2297 node->prev = NULL;
2298 lf_list = node;
2299 return (void *)node;
2300 }
2301
2302
find_module_handle(char * name)2303 LF_LIST *find_module_handle(char *name)
2304 {
2305 LF_LIST *np;
2306
2307 for(np = lf_list; np != NULL; np = np->next) {
2308 if(np->module_name != NULL && !C_strcmp(np->module_name, name))
2309 return np;
2310 }
2311
2312 return NULL;
2313 }
2314
2315
C_unregister_lf(void * handle)2316 void C_unregister_lf(void *handle)
2317 {
2318 LF_LIST *node = (LF_LIST *) handle;
2319
2320 if (node->next) node->next->prev = node->prev;
2321
2322 if (node->prev) node->prev->next = node->next;
2323
2324 if (lf_list == node) lf_list = node->next;
2325
2326 C_free(node->module_name);
2327 C_free(node);
2328 }
2329
2330
2331 /* Intern symbol into symbol-table: */
2332
C_intern(C_word ** ptr,int len,C_char * str)2333 C_regparm C_word C_fcall C_intern(C_word **ptr, int len, C_char *str)
2334 {
2335 return C_intern_in(ptr, len, str, symbol_table);
2336 }
2337
2338
C_h_intern(C_word * slot,int len,C_char * str)2339 C_regparm C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str)
2340 {
2341 return C_h_intern_in(slot, len, str, symbol_table);
2342 }
2343
2344
C_intern_kw(C_word ** ptr,int len,C_char * str)2345 C_regparm C_word C_fcall C_intern_kw(C_word **ptr, int len, C_char *str)
2346 {
2347 C_word kw = C_intern_in(ptr, len, str, keyword_table);
2348 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */
2349 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */
2350 return kw;
2351 }
2352
2353
C_h_intern_kw(C_word * slot,int len,C_char * str)2354 C_regparm C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str)
2355 {
2356 C_word kw = C_h_intern_in(slot, len, str, keyword_table);
2357 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */
2358 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */
2359 return kw;
2360 }
2361
C_intern_in(C_word ** ptr,int len,C_char * str,C_SYMBOL_TABLE * stable)2362 C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)
2363 {
2364 int key;
2365 C_word s;
2366
2367 if(stable == NULL) stable = symbol_table;
2368
2369 key = hash_string(len, str, stable->size, stable->rand, 0);
2370
2371 if(C_truep(s = lookup(key, len, str, stable))) return s;
2372
2373 s = C_string(ptr, len, str);
2374 return add_symbol(ptr, key, s, stable);
2375 }
2376
2377
C_h_intern_in(C_word * slot,int len,C_char * str,C_SYMBOL_TABLE * stable)2378 C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)
2379 {
2380 /* Intern as usual, but remember slot, and allocate in static
2381 * memory. If symbol already exists, replace its string by a fresh
2382 * statically allocated string to ensure it never gets collected, as
2383 * lf[] entries are not tracked by the GC.
2384 */
2385 int key;
2386 C_word s;
2387
2388 if(stable == NULL) stable = symbol_table;
2389
2390 key = hash_string(len, str, stable->size, stable->rand, 0);
2391
2392 if(C_truep(s = lookup(key, len, str, stable))) {
2393 if(C_in_stackp(s)) C_mutate_slot(slot, s);
2394
2395 if(!C_truep(C_permanentp(C_symbol_name(s)))) {
2396 /* Replace by statically allocated string, and persist it */
2397 C_set_block_item(s, 1, C_static_string(C_heaptop, len, str));
2398 C_i_persist_symbol(s);
2399 }
2400 return s;
2401 }
2402
2403 s = C_static_string(C_heaptop, len, str);
2404 return add_symbol(C_heaptop, key, s, stable);
2405 }
2406
2407
intern0(C_char * str)2408 C_regparm C_word C_fcall intern0(C_char *str)
2409 {
2410 int len = C_strlen(str);
2411 int key = hash_string(len, str, symbol_table->size, symbol_table->rand, 0);
2412 C_word s;
2413
2414 if(C_truep(s = lookup(key, len, str, symbol_table))) return s;
2415 else return C_SCHEME_FALSE;
2416 }
2417
2418
C_lookup_symbol(C_word sym)2419 C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
2420 {
2421 int key;
2422 C_word str = C_block_item(sym, 1);
2423 int len = C_header_size(str);
2424
2425 key = hash_string(len, C_c_string(str), symbol_table->size, symbol_table->rand, 0);
2426
2427 return lookup(key, len, C_c_string(str), symbol_table);
2428 }
2429
2430
C_intern2(C_word ** ptr,C_char * str)2431 C_regparm C_word C_fcall C_intern2(C_word **ptr, C_char *str)
2432 {
2433 return C_intern_in(ptr, C_strlen(str), str, symbol_table);
2434 }
2435
2436
C_intern3(C_word ** ptr,C_char * str,C_word value)2437 C_regparm C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value)
2438 {
2439 C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);
2440
2441 C_mutate(&C_block_item(s,0), value);
2442 C_i_persist_symbol(s); /* Symbol has a value now; persist it */
2443 return s;
2444 }
2445
2446
hash_string(int len,C_char * str,C_word m,C_word r,int ci)2447 C_regparm C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci)
2448 {
2449 C_uword key = r;
2450
2451 if (ci)
2452 while(len--) key ^= (key << 6) + (key >> 2) + C_tolower((int)(*str++));
2453 else
2454 while(len--) key ^= (key << 6) + (key >> 2) + *(str++);
2455
2456 return (C_word)(key % (C_uword)m);
2457 }
2458
2459
lookup(C_word key,int len,C_char * str,C_SYMBOL_TABLE * stable)2460 C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)
2461 {
2462 C_word bucket, sym, s;
2463
2464 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
2465 bucket = C_block_item(bucket,1)) {
2466 sym = C_block_item(bucket,0);
2467 s = C_block_item(sym, 1);
2468
2469 if(C_header_size(s) == (C_word)len
2470 && !C_memcmp(str, (C_char *)C_data_pointer(s), len))
2471 return sym;
2472 }
2473
2474 return C_SCHEME_FALSE;
2475 }
2476
2477 /* Mark a symbol as "persistent", to prevent it from being GC'ed */
C_i_persist_symbol(C_word sym)2478 C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)
2479 {
2480 C_word bucket;
2481 C_SYMBOL_TABLE *stp;
2482
2483 /* Normally, this will get called with a symbol, but in
2484 * C_h_intern_kw we may call it with keywords too.
2485 */
2486 if(!C_truep(C_i_symbolp(sym)) && !C_truep(C_i_keywordp(sym))) {
2487 error_location = C_SCHEME_FALSE;
2488 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, sym);
2489 }
2490
2491 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
2492 bucket = lookup_bucket(sym, stp);
2493
2494 if (C_truep(bucket)) {
2495 /* Change weak to strong ref to ensure long-term survival */
2496 C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;
2497 /* Ensure survival on next minor GC */
2498 if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);
2499 }
2500 }
2501 return C_SCHEME_UNDEFINED;
2502 }
2503
2504 /* Possibly remove "persistence" of symbol, to allowed it to be GC'ed.
2505 * This is only done if the symbol is unbound, has an empty plist and
2506 * is allocated in managed memory.
2507 */
C_i_unpersist_symbol(C_word sym)2508 C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym)
2509 {
2510 C_word bucket;
2511 C_SYMBOL_TABLE *stp;
2512
2513 C_i_check_symbol(sym);
2514
2515 if (C_persistable_symbol(sym) ||
2516 C_truep(C_permanentp(C_symbol_name(sym)))) {
2517 return C_SCHEME_FALSE;
2518 }
2519
2520 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
2521 bucket = lookup_bucket(sym, NULL);
2522
2523 if (C_truep(bucket)) {
2524 /* Turn it into a weak ref */
2525 C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;
2526 return C_SCHEME_TRUE;
2527 }
2528 }
2529 return C_SCHEME_FALSE;
2530 }
2531
lookup_bucket(C_word sym,C_SYMBOL_TABLE * stable)2532 C_regparm C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)
2533 {
2534 C_word bucket, str = C_block_item(sym, 1);
2535 int key, len = C_header_size(str);
2536
2537 if (stable == NULL) stable = symbol_table;
2538
2539 key = hash_string(len, C_c_string(str), stable->size, stable->rand, 0);
2540
2541 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
2542 bucket = C_block_item(bucket,1)) {
2543 if (C_block_item(bucket,0) == sym) return bucket;
2544 }
2545 return C_SCHEME_FALSE;
2546 }
2547
2548
compute_symbol_table_load(double * avg_bucket_len,int * total_n)2549 double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
2550 {
2551 C_word bucket;
2552 int i, j, alen = 0, bcount = 0, total = 0;
2553
2554 for(i = 0; i < symbol_table->size; ++i) {
2555 bucket = symbol_table->table[ i ];
2556
2557 for(j = 0; bucket != C_SCHEME_END_OF_LIST; ++j)
2558 bucket = C_block_item(bucket,1);
2559
2560 if(j > 0) {
2561 alen += j;
2562 ++bcount;
2563 }
2564
2565 total += j;
2566 }
2567
2568 if(avg_bucket_len != NULL)
2569 *avg_bucket_len = (double)alen / (double)bcount;
2570
2571 *total_n = total;
2572
2573 /* return load: */
2574 return (double)total / (double)symbol_table->size;
2575 }
2576
2577
add_symbol(C_word ** ptr,C_word key,C_word string,C_SYMBOL_TABLE * stable)2578 C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable)
2579 {
2580 C_word bucket, sym, b2, *p;
2581
2582 p = *ptr;
2583 sym = (C_word)p;
2584 p += C_SIZEOF_SYMBOL;
2585 C_block_header_init(sym, C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1));
2586 C_set_block_item(sym, 0, C_SCHEME_UNBOUND);
2587 C_set_block_item(sym, 1, string);
2588 C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
2589 *ptr = p;
2590 b2 = stable->table[ key ]; /* previous bucket */
2591
2592 /* Create new weak or strong bucket depending on persistability */
2593 if (C_truep(C_permanentp(string))) {
2594 bucket = C_a_pair(ptr, sym, b2);
2595 } else {
2596 bucket = C_a_weak_pair(ptr, sym, b2);
2597 }
2598
2599 if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);
2600 else {
2601 /* If a stack-allocated bucket was here, and we allocate from
2602 heap-top (say, in a toplevel literal frame allocation) then we have
2603 to inform the memory manager that a 2nd gen. block points to a
2604 1st gen. block, hence the mutation: */
2605 C_mutate(&C_block_item(bucket,1), b2);
2606 stable->table[ key ] = bucket;
2607 }
2608
2609 return sym;
2610 }
2611
2612
C_in_stackp(C_word x)2613 C_regparm int C_in_stackp(C_word x)
2614 {
2615 C_word *ptr = (C_word *)(C_uword)x;
2616
2617 #if C_STACK_GROWS_DOWNWARD
2618 return ptr >= C_stack_pointer_test && ptr <= stack_bottom;
2619 #else
2620 return ptr < C_stack_pointer_test && ptr >= stack_bottom;
2621 #endif
2622 }
2623
2624
C_in_heapp(C_word x)2625 C_regparm int C_fcall C_in_heapp(C_word x)
2626 {
2627 C_byte *ptr = (C_byte *)(C_uword)x;
2628 return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||
2629 (ptr >= tospace_start && ptr < tospace_limit);
2630 }
2631
2632 /* Only used during major GC (heap realloc) */
C_in_new_heapp(C_word x)2633 static C_regparm int C_fcall C_in_new_heapp(C_word x)
2634 {
2635 C_byte *ptr = (C_byte *)(C_uword)x;
2636 return (ptr >= new_tospace_start && ptr < new_tospace_limit);
2637 }
2638
C_in_fromspacep(C_word x)2639 C_regparm int C_fcall C_in_fromspacep(C_word x)
2640 {
2641 C_byte *ptr = (C_byte *)(C_uword)x;
2642 return (ptr >= fromspace_start && ptr < C_fromspace_limit);
2643 }
2644
C_in_scratchspacep(C_word x)2645 C_regparm int C_fcall C_in_scratchspacep(C_word x)
2646 {
2647 C_word *ptr = (C_word *)(C_uword)x;
2648 return (ptr >= C_scratchspace_start && ptr < C_scratchspace_limit);
2649 }
2650
2651 /* Cons the rest-aguments together: */
2652
C_build_rest(C_word ** ptr,C_word c,C_word n,C_word * av)2653 C_regparm C_word C_fcall C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)
2654 {
2655 C_word
2656 x = C_SCHEME_END_OF_LIST,
2657 *p = *ptr;
2658 C_SCHEME_BLOCK *node;
2659
2660 av += c;
2661
2662 while(--c >= n) {
2663 node = (C_SCHEME_BLOCK *)p;
2664 p += 3;
2665 node->header = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
2666 node->data[ 0 ] = *(--av);
2667 node->data[ 1 ] = x;
2668 x = (C_word)node;
2669 }
2670
2671 *ptr = p;
2672 return x;
2673 }
2674
2675
2676 /* Print error messages and exit: */
2677
C_bad_memory(void)2678 void C_bad_memory(void)
2679 {
2680 panic(C_text("there is not enough stack-space to run this executable"));
2681 }
2682
2683
C_bad_memory_2(void)2684 void C_bad_memory_2(void)
2685 {
2686 panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));
2687 }
2688
2689
2690 /* The following two can be thrown out in the next release... */
2691
C_bad_argc(int c,int n)2692 void C_bad_argc(int c, int n)
2693 {
2694 C_bad_argc_2(c, n, C_SCHEME_FALSE);
2695 }
2696
2697
C_bad_min_argc(int c,int n)2698 void C_bad_min_argc(int c, int n)
2699 {
2700 C_bad_min_argc_2(c, n, C_SCHEME_FALSE);
2701 }
2702
2703
C_bad_argc_2(int c,int n,C_word closure)2704 void C_bad_argc_2(int c, int n, C_word closure)
2705 {
2706 barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);
2707 }
2708
2709
C_bad_min_argc_2(int c,int n,C_word closure)2710 void C_bad_min_argc_2(int c, int n, C_word closure)
2711 {
2712 barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);
2713 }
2714
2715
C_stack_overflow(C_char * loc)2716 void C_stack_overflow(C_char *loc)
2717 {
2718 barf(C_STACK_OVERFLOW_ERROR, loc);
2719 }
2720
2721
C_unbound_error(C_word sym)2722 void C_unbound_error(C_word sym)
2723 {
2724 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
2725 }
2726
2727
C_no_closure_error(C_word x)2728 void C_no_closure_error(C_word x)
2729 {
2730 barf(C_NOT_A_CLOSURE_ERROR, NULL, x);
2731 }
2732
2733
C_div_by_zero_error(char * loc)2734 void C_div_by_zero_error(char *loc)
2735 {
2736 barf(C_DIVISION_BY_ZERO_ERROR, loc);
2737 }
2738
C_not_an_integer_error(char * loc,C_word x)2739 void C_not_an_integer_error(char *loc, C_word x)
2740 {
2741 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);
2742 }
2743
C_not_an_uinteger_error(char * loc,C_word x)2744 void C_not_an_uinteger_error(char *loc, C_word x)
2745 {
2746 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x);
2747 }
2748
C_rest_arg_out_of_bounds_error(C_word c,C_word n,C_word ka)2749 void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka)
2750 {
2751 C_rest_arg_out_of_bounds_error_2(c, n, ka, C_SCHEME_FALSE);
2752 }
2753
C_rest_arg_out_of_bounds_error_2(C_word c,C_word n,C_word ka,C_word closure)2754 void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure)
2755 {
2756 barf(C_REST_ARG_OUT_OF_BOUNDS_ERROR, NULL, C_u_fixnum_difference(c, ka), C_u_fixnum_difference(n, ka), closure);
2757 }
2758
2759 /* Allocate and initialize record: */
2760
C_string(C_word ** ptr,int len,C_char * str)2761 C_regparm C_word C_fcall C_string(C_word **ptr, int len, C_char *str)
2762 {
2763 C_word strblock = (C_word)(*ptr);
2764
2765 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
2766 C_block_header_init(strblock, C_STRING_TYPE | len);
2767 C_memcpy(C_data_pointer(strblock), str, len);
2768 return strblock;
2769 }
2770
2771
C_static_string(C_word ** ptr,int len,C_char * str)2772 C_regparm C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str)
2773 {
2774 C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len));
2775 C_word strblock;
2776
2777 if(dptr == NULL)
2778 panic(C_text("out of memory - cannot allocate static string"));
2779
2780 strblock = (C_word)dptr;
2781 C_block_header_init(strblock, C_STRING_TYPE | len);
2782 C_memcpy(C_data_pointer(strblock), str, len);
2783 return strblock;
2784 }
2785
C_static_bignum(C_word ** ptr,int len,C_char * str)2786 C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)
2787 {
2788 C_word *dptr, bignum, bigvec, retval, size, negp = 0;
2789
2790 if (*str == '+' || *str == '-') {
2791 negp = ((*str++) == '-') ? 1 : 0;
2792 --len;
2793 }
2794 size = C_BIGNUM_BITS_TO_DIGITS((unsigned int)len << 2);
2795
2796 dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(size)));
2797 if(dptr == NULL)
2798 panic(C_text("out of memory - cannot allocate static bignum"));
2799
2800 bigvec = (C_word)dptr;
2801 C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(size + 1));
2802 C_set_block_item(bigvec, 0, negp);
2803 /* This needs to be allocated at ptr, not dptr, because GC moves type tag */
2804 bignum = C_a_i_bignum_wrapper(ptr, bigvec);
2805
2806 retval = str_to_bignum(bignum, str, str + len, 16);
2807 if (retval & C_FIXNUM_BIT)
2808 C_free(dptr); /* Might have been simplified */
2809 return retval;
2810 }
2811
C_static_lambda_info(C_word ** ptr,int len,C_char * str)2812 C_regparm C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str)
2813 {
2814 int dlen = sizeof(C_header) + C_align(len);
2815 void *dptr = C_malloc(dlen);
2816 C_word strblock;
2817
2818 if(dptr == NULL)
2819 panic(C_text("out of memory - cannot allocate static lambda info"));
2820
2821 strblock = (C_word)dptr;
2822 C_block_header_init(strblock, C_LAMBDA_INFO_TYPE | len);
2823 C_memcpy(C_data_pointer(strblock), str, len);
2824 return strblock;
2825 }
2826
2827
C_bytevector(C_word ** ptr,int len,C_char * str)2828 C_regparm C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str)
2829 {
2830 C_word strblock = C_string(ptr, len, str);
2831
2832 (void)C_string_to_bytevector(strblock);
2833 return strblock;
2834 }
2835
2836
C_static_bytevector(C_word ** ptr,int len,C_char * str)2837 C_regparm C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str)
2838 {
2839 C_word strblock = C_static_string(ptr, len, str);
2840
2841 C_block_header_init(strblock, C_BYTEVECTOR_TYPE | len);
2842 return strblock;
2843 }
2844
2845
C_pbytevector(int len,C_char * str)2846 C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)
2847 {
2848 C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));
2849
2850 if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent blob"));
2851
2852 pbv->header = C_BYTEVECTOR_TYPE | len;
2853 C_memcpy(pbv->data, str, len);
2854 return (C_word)pbv;
2855 }
2856
2857
C_string_aligned8(C_word ** ptr,int len,C_char * str)2858 C_regparm C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str)
2859 {
2860 C_word *p = *ptr,
2861 *p0;
2862
2863 #ifndef C_SIXTY_FOUR
2864 /* Align on 8-byte boundary: */
2865 if(C_aligned8(p)) ++p;
2866 #endif
2867
2868 p0 = p;
2869 *ptr = p + 1 + C_bytestowords(len);
2870 *(p++) = C_STRING_TYPE | C_8ALIGN_BIT | len;
2871 C_memcpy(p, str, len);
2872 return (C_word)p0;
2873 }
2874
2875
C_string2(C_word ** ptr,C_char * str)2876 C_regparm C_word C_fcall C_string2(C_word **ptr, C_char *str)
2877 {
2878 C_word strblock = (C_word)(*ptr);
2879 int len;
2880
2881 if(str == NULL) return C_SCHEME_FALSE;
2882
2883 len = C_strlen(str);
2884 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
2885 C_block_header_init(strblock, C_STRING_TYPE | len);
2886 C_memcpy(C_data_pointer(strblock), str, len);
2887 return strblock;
2888 }
2889
2890
C_string2_safe(C_word ** ptr,int max,C_char * str)2891 C_regparm C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str)
2892 {
2893 C_word strblock = (C_word)(*ptr);
2894 int len;
2895
2896 if(str == NULL) return C_SCHEME_FALSE;
2897
2898 len = C_strlen(str);
2899
2900 if(len >= max) {
2901 C_snprintf(buffer, sizeof(buffer), C_text("foreign string result exceeded maximum of %d bytes"), max);
2902 panic(buffer);
2903 }
2904
2905 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
2906 C_block_header_init(strblock, C_STRING_TYPE | len);
2907 C_memcpy(C_data_pointer(strblock), str, len);
2908 return strblock;
2909 }
2910
2911
C_closure(C_word ** ptr,int cells,C_word proc,...)2912 C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)
2913 {
2914 va_list va;
2915 C_word *p = *ptr,
2916 *p0 = p;
2917
2918 *p = C_CLOSURE_TYPE | cells;
2919 *(++p) = proc;
2920
2921 for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));
2922
2923 va_end(va);
2924 *ptr = p + 1;
2925 return (C_word)p0;
2926 }
2927
2928
2929 /* obsolete: replaced by C_a_pair in chicken.h */
C_pair(C_word ** ptr,C_word car,C_word cdr)2930 C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)
2931 {
2932 C_word *p = *ptr,
2933 *p0 = p;
2934
2935 *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
2936 *(p++) = car;
2937 *(p++) = cdr;
2938 *ptr = p;
2939 return (C_word)p0;
2940 }
2941
2942
C_number(C_word ** ptr,double n)2943 C_regparm C_word C_fcall C_number(C_word **ptr, double n)
2944 {
2945 C_word
2946 *p = *ptr,
2947 *p0;
2948 double m;
2949
2950 if(n <= (double)C_MOST_POSITIVE_FIXNUM
2951 && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0) {
2952 return C_fix(n);
2953 }
2954
2955 #ifndef C_SIXTY_FOUR
2956 #ifndef C_DOUBLE_IS_32_BITS
2957 /* Align double on 8-byte boundary: */
2958 if(C_aligned8(p)) ++p;
2959 #endif
2960 #endif
2961
2962 p0 = p;
2963 *(p++) = C_FLONUM_TAG;
2964 *((double *)p) = n;
2965 *ptr = p + sizeof(double) / sizeof(C_word);
2966 return (C_word)p0;
2967 }
2968
2969
C_mpointer(C_word ** ptr,void * mp)2970 C_regparm C_word C_fcall C_mpointer(C_word **ptr, void *mp)
2971 {
2972 C_word
2973 *p = *ptr,
2974 *p0 = p;
2975
2976 *(p++) = C_POINTER_TYPE | 1;
2977 *((void **)p) = mp;
2978 *ptr = p + 1;
2979 return (C_word)p0;
2980 }
2981
2982
C_mpointer_or_false(C_word ** ptr,void * mp)2983 C_regparm C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp)
2984 {
2985 C_word
2986 *p = *ptr,
2987 *p0 = p;
2988
2989 if(mp == NULL) return C_SCHEME_FALSE;
2990
2991 *(p++) = C_POINTER_TYPE | 1;
2992 *((void **)p) = mp;
2993 *ptr = p + 1;
2994 return (C_word)p0;
2995 }
2996
2997
C_taggedmpointer(C_word ** ptr,C_word tag,void * mp)2998 C_regparm C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp)
2999 {
3000 C_word
3001 *p = *ptr,
3002 *p0 = p;
3003
3004 *(p++) = C_TAGGED_POINTER_TAG;
3005 *((void **)p) = mp;
3006 *(++p) = tag;
3007 *ptr = p + 1;
3008 return (C_word)p0;
3009 }
3010
3011
C_taggedmpointer_or_false(C_word ** ptr,C_word tag,void * mp)3012 C_regparm C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)
3013 {
3014 C_word
3015 *p = *ptr,
3016 *p0 = p;
3017
3018 if(mp == NULL) return C_SCHEME_FALSE;
3019
3020 *(p++) = C_TAGGED_POINTER_TAG;
3021 *((void **)p) = mp;
3022 *(++p) = tag;
3023 *ptr = p + 1;
3024 return (C_word)p0;
3025 }
3026
3027
C_vector(C_word ** ptr,int n,...)3028 C_word C_vector(C_word **ptr, int n, ...)
3029 {
3030 va_list v;
3031 C_word
3032 *p = *ptr,
3033 *p0 = p;
3034
3035 *(p++) = C_VECTOR_TYPE | n;
3036 va_start(v, n);
3037
3038 while(n--)
3039 *(p++) = va_arg(v, C_word);
3040
3041 *ptr = p;
3042 va_end(v);
3043 return (C_word)p0;
3044 }
3045
3046
C_structure(C_word ** ptr,int n,...)3047 C_word C_structure(C_word **ptr, int n, ...)
3048 {
3049 va_list v;
3050 C_word *p = *ptr,
3051 *p0 = p;
3052
3053 *(p++) = C_STRUCTURE_TYPE | n;
3054 va_start(v, n);
3055
3056 while(n--)
3057 *(p++) = va_arg(v, C_word);
3058
3059 *ptr = p;
3060 va_end(v);
3061 return (C_word)p0;
3062 }
3063
3064
3065 C_regparm C_word C_fcall
C_mutate_slot(C_word * slot,C_word val)3066 C_mutate_slot(C_word *slot, C_word val)
3067 {
3068 unsigned int mssize, newmssize, bytes;
3069
3070 ++mutation_count;
3071 /* Mutation stack exists to track mutations pointing from elsewhere
3072 * into nursery. Stuff pointing anywhere else can be skipped, as
3073 * well as mutations on nursery objects.
3074 */
3075 if(!C_in_stackp(val) || C_in_stackp((C_word)slot))
3076 return *slot = val;
3077
3078 #ifdef C_GC_HOOKS
3079 if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;
3080 #endif
3081
3082 if(mutation_stack_top >= mutation_stack_limit) {
3083 assert(mutation_stack_top == mutation_stack_limit);
3084 mssize = mutation_stack_top - mutation_stack_bottom;
3085 newmssize = mssize * 2;
3086 bytes = newmssize * sizeof(C_word *);
3087
3088 if(debug_mode)
3089 C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),
3090 (mssize * sizeof(C_word *)) / 1024, bytes / 1024);
3091
3092 mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, bytes);
3093
3094 if(mutation_stack_bottom == NULL)
3095 panic(C_text("out of memory - cannot re-allocate mutation stack"));
3096
3097 mutation_stack_limit = mutation_stack_bottom + newmssize;
3098 mutation_stack_top = mutation_stack_bottom + mssize;
3099 }
3100
3101 *(mutation_stack_top++) = slot;
3102 ++tracked_mutation_count;
3103 return *slot = val;
3104 }
3105
3106 /* Allocate memory in scratch space, "size" is in words, like C_alloc.
3107 * The memory in the scratch space is laid out as follows: First,
3108 * there's a count that indicates how big the object originally was,
3109 * followed by a pointer to the slot in the object which points to the
3110 * object in scratch space, finally followed by the object itself.
3111 * The reason we store the slot pointer is so that we can figure out
3112 * whether the object is still "live" when reallocating; that's
3113 * because we don't have a saved continuation from where we can trace
3114 * the live data. The reason we store the total length of the object
3115 * is because we may be mutating in-place the lengths of the stored
3116 * objects, and we need to know how much to skip over while scanning.
3117 *
3118 * If the allocating function returns, it *must* first mark all the
3119 * values in scratch space as reclaimable. This is needed because
3120 * there is no way to distinguish between a stale pointer into scratch
3121 * space that's still somewhere on the stack in "uninitialized" memory
3122 * versus a word that's been recycled by the next called function,
3123 * which now holds a value that happens to have the same bit pattern
3124 * but represents another thing entirely.
3125 */
C_scratch_alloc(C_uword size)3126 C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
3127 {
3128 C_word result;
3129
3130 if (C_scratchspace_top + size + 2 >= C_scratchspace_limit) {
3131 C_word *new_scratch_start, *new_scratch_top, *new_scratch_limit;
3132 C_uword needed = C_scratch_usage + size + 2,
3133 new_size = nmax(scratchspace_size << 1, 2UL << C_ilen(needed));
3134
3135 /* Shrink if the needed size is much smaller, but not below minimum */
3136 if (needed < (new_size >> 4)) new_size >>= 1;
3137 new_size = nmax(new_size, DEFAULT_SCRATCH_SPACE_SIZE);
3138
3139 /* TODO: Maybe we should work with two semispaces to reduce mallocs? */
3140 new_scratch_start = (C_word *)C_malloc(C_wordstobytes(new_size));
3141 if (new_scratch_start == NULL)
3142 panic(C_text("out of memory - cannot (re-)allocate scratch space"));
3143 new_scratch_top = new_scratch_start;
3144 new_scratch_limit = new_scratch_start + new_size;
3145
3146 if(debug_mode) {
3147 C_dbg(C_text("debug"), C_text("resizing scratchspace dynamically from "
3148 UWORD_COUNT_FORMAT_STRING "k to "
3149 UWORD_COUNT_FORMAT_STRING "k ...\n"),
3150 C_wordstobytes(scratchspace_size) / 1024,
3151 C_wordstobytes(new_size) / 1024);
3152 }
3153
3154 if(gc_report_flag) {
3155 C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING
3156 ", \tlimit=" UWORD_FORMAT_STRING "\n"),
3157 (C_word)C_scratchspace_start, (C_word)C_scratchspace_limit);
3158 C_dbg(C_text("GC"), C_text("(new) scratchspace: \tstart=" UWORD_FORMAT_STRING
3159 ", \tlimit=" UWORD_FORMAT_STRING "\n"),
3160 (C_word)new_scratch_start, (C_word)new_scratch_limit);
3161 }
3162
3163 /* Move scratch data into new space and mutate slots pointing there.
3164 * This is basically a much-simplified version of really_mark.
3165 */
3166 if (C_scratchspace_start != NULL) {
3167 C_word val, *sscan, *slot;
3168 C_uword n, words;
3169 C_header h;
3170 C_SCHEME_BLOCK *p, *p2;
3171
3172 sscan = C_scratchspace_start;
3173
3174 while (sscan < C_scratchspace_top) {
3175 words = *sscan;
3176 slot = (C_word *)*(sscan+1);
3177
3178 if (*(sscan+2) == ALIGNMENT_HOLE_MARKER) val = (C_word)(sscan+3);
3179 else val = (C_word)(sscan+2);
3180
3181 sscan += words + 2;
3182
3183 p = (C_SCHEME_BLOCK *)val;
3184 h = p->header;
3185 if (is_fptr(h)) /* TODO: Support scratch->scratch pointers? */
3186 panic(C_text("Unexpected forwarding pointer in scratch space"));
3187
3188 p2 = (C_SCHEME_BLOCK *)(new_scratch_top+2);
3189
3190 #ifndef C_SIXTY_FOUR
3191 if ((h & C_8ALIGN_BIT) && C_aligned8(p2) &&
3192 (C_word *)p2 < new_scratch_limit) {
3193 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
3194 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
3195 }
3196 #endif
3197
3198 /* If orig slot still points here, copy data and update it */
3199 if (slot != NULL) {
3200 assert(C_in_stackp((C_word)slot) && *slot == val);
3201 n = C_header_size(p);
3202 n = (h & C_BYTEBLOCK_BIT) ? C_bytestowords(n) : n;
3203
3204 *slot = (C_word)p2;
3205 /* size = header plus block size plus optional alignment hole */
3206 *new_scratch_top = ((C_word *)p2-(C_word *)new_scratch_top-2) + n + 1;
3207 *(new_scratch_top+1) = (C_word)slot;
3208
3209 new_scratch_top = (C_word *)p2 + n + 1;
3210 if(new_scratch_top > new_scratch_limit)
3211 panic(C_text("out of memory - scratch space full while resizing"));
3212
3213 p2->header = h;
3214 p->header = ptr_to_fptr((C_uword)p2);
3215 C_memcpy(p2->data, p->data, C_wordstobytes(n));
3216 }
3217 }
3218 free(C_scratchspace_start);
3219 }
3220 C_scratchspace_start = new_scratch_start;
3221 C_scratchspace_top = new_scratch_top;
3222 C_scratchspace_limit = new_scratch_limit;
3223 /* Scratch space is now tightly packed */
3224 C_scratch_usage = (new_scratch_top - new_scratch_start);
3225 scratchspace_size = new_size;
3226 }
3227 assert(C_scratchspace_top + size + 2 <= C_scratchspace_limit);
3228
3229 *C_scratchspace_top = size;
3230 *(C_scratchspace_top+1) = (C_word)NULL; /* Nothing points here 'til mutated */
3231 result = (C_word)(C_scratchspace_top+2);
3232 C_scratchspace_top += size + 2;
3233 /* This will only be marked as "used" when it's claimed by a pointer */
3234 /* C_scratch_usage += size + 2; */
3235 return result;
3236 }
3237
3238 /* Given a root object, scan its slots recursively (the objects
3239 * themselves should be shallow and non-recursive), and migrate every
3240 * object stored between the memory boundaries to the supplied
3241 * pointer. Scratch data pointed to by objects between the memory
3242 * boundaries is updated to point to the new memory region. If the
3243 * supplied pointer is NULL, the scratch memory is marked reclaimable.
3244 */
3245 C_regparm C_word C_fcall
C_migrate_buffer_object(C_word ** ptr,C_word * start,C_word * end,C_word obj)3246 C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)
3247 {
3248 C_word size, header, *data, *p = NULL, obj_in_buffer;
3249
3250 if (C_immediatep(obj)) return obj;
3251
3252 size = C_header_size(obj);
3253 header = C_block_header(obj);
3254 data = C_data_pointer(obj);
3255 obj_in_buffer = (obj >= (C_word)start && obj < (C_word)end);
3256
3257 /* Only copy object if we have a target pointer and it's in the buffer */
3258 if (ptr != NULL && obj_in_buffer) {
3259 p = *ptr;
3260 obj = (C_word)p; /* Return the object's new location at the end */
3261 }
3262
3263 if (p != NULL) *p++ = header;
3264
3265 if (header & C_BYTEBLOCK_BIT) {
3266 if (p != NULL) {
3267 *ptr = (C_word *)((C_byte *)(*ptr) + sizeof(C_header) + C_align(size));
3268 C_memcpy(p, data, size);
3269 }
3270 } else {
3271 if (p != NULL) *ptr += size + 1;
3272
3273 if(header & C_SPECIALBLOCK_BIT) {
3274 if (p != NULL) *(p++) = *data;
3275 size--;
3276 data++;
3277 }
3278
3279 /* TODO: See if we can somehow make this use Cheney's algorithm */
3280 while(size--) {
3281 C_word slot = *data;
3282
3283 if(!C_immediatep(slot)) {
3284 if (C_in_scratchspacep(slot)) {
3285 if (obj_in_buffer) { /* Otherwise, don't touch scratch backpointer */
3286 /* TODO: Support recursing into objects in scratch space? */
3287 C_word *sp = (C_word *)slot;
3288
3289 if (*(sp-1) == ALIGNMENT_HOLE_MARKER) --sp;
3290 if (*(sp-1) != (C_word)NULL && p == NULL)
3291 C_scratch_usage -= *(sp-2) + 2;
3292 *(sp-1) = (C_word)p; /* This is why we traverse even if p = NULL */
3293
3294 *data = C_SCHEME_UNBOUND; /* Ensure old reference is killed dead */
3295 }
3296 } else { /* Slot is not a scratchspace object: check sub-objects */
3297 slot = C_migrate_buffer_object(ptr, start, end, slot);
3298 }
3299 }
3300 if (p != NULL) *(p++) = slot;
3301 else *data = slot; /* Sub-object may have moved! */
3302 data++;
3303 }
3304 }
3305 return obj; /* Should be NULL if ptr was NULL */
3306 }
3307
3308 /* Register an object's slot as holding data to scratch space. Only
3309 * one slot can point to a scratch space object; the object in scratch
3310 * space is preceded by a pointer that points to this slot (or NULL).
3311 */
C_mutate_scratch_slot(C_word * slot,C_word val)3312 C_regparm C_word C_fcall C_mutate_scratch_slot(C_word *slot, C_word val)
3313 {
3314 C_word *ptr = (C_word *)val;
3315 assert(C_in_scratchspacep(val));
3316 assert(slot == NULL || C_in_stackp((C_word)slot));
3317 if (*(ptr-1) == ALIGNMENT_HOLE_MARKER) --ptr;
3318 if (*(ptr-1) == (C_word)NULL && slot != NULL)
3319 C_scratch_usage += *(ptr-2) + 2;
3320 if (*(ptr-1) != (C_word)NULL && slot == NULL)
3321 C_scratch_usage -= *(ptr-2) + 2;
3322 *(ptr-1) = (C_word)slot; /* Remember the slot pointing here, for realloc */
3323 if (slot != NULL) *slot = val;
3324 return val;
3325 }
3326
3327 /* Initiate garbage collection: */
3328
3329
C_save_and_reclaim(void * trampoline,int n,C_word * av)3330 void C_save_and_reclaim(void *trampoline, int n, C_word *av)
3331 {
3332 C_word new_size = nmax((C_word)1 << C_ilen(n), DEFAULT_TEMPORARY_STACK_SIZE);
3333
3334 assert(av > C_temporary_stack_bottom || av < C_temporary_stack_limit);
3335 assert(C_temporary_stack == C_temporary_stack_bottom);
3336
3337 /* Don't *immediately* slam back to default size */
3338 if (new_size < temporary_stack_size / 4)
3339 new_size = temporary_stack_size >> 1;
3340
3341 if (new_size != temporary_stack_size) {
3342
3343 if(fixed_temporary_stack_size)
3344 panic(C_text("fixed temporary stack overflow (\"apply\" called with too many arguments?)"));
3345
3346 if(gc_report_flag) {
3347 C_dbg(C_text("GC"), C_text("resizing temporary stack dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),
3348 C_wordstobytes(temporary_stack_size) / 1024,
3349 C_wordstobytes(new_size) / 1024);
3350 }
3351
3352 C_free(C_temporary_stack_limit);
3353
3354 if((C_temporary_stack_limit = (C_word *)C_malloc(new_size * sizeof(C_word))) == NULL)
3355 panic(C_text("out of memory - could not resize temporary stack"));
3356
3357 C_temporary_stack_bottom = C_temporary_stack_limit + new_size;
3358 C_temporary_stack = C_temporary_stack_bottom;
3359 temporary_stack_size = new_size;
3360 }
3361
3362 C_temporary_stack = C_temporary_stack_bottom - n;
3363
3364 assert(C_temporary_stack >= C_temporary_stack_limit);
3365
3366 C_memmove(C_temporary_stack, av, n * sizeof(C_word));
3367 C_reclaim(trampoline, n);
3368 }
3369
3370
C_save_and_reclaim_args(void * trampoline,int n,...)3371 void C_save_and_reclaim_args(void *trampoline, int n, ...)
3372 {
3373 va_list v;
3374 int i;
3375
3376 va_start(v, n);
3377
3378 for(i = 0; i < n; ++i)
3379 C_save(va_arg(v, C_word));
3380
3381 va_end(v);
3382 C_reclaim(trampoline, n);
3383 }
3384
3385
3386 #ifdef __SUNPRO_C
_mark(C_word * x,C_byte * s,C_byte ** t,C_byte * l)3387 static void _mark(C_word *x, C_byte *s, C_byte **t, C_byte *l) { \
3388 C_word *_x = (x), _val = *_x; \
3389 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \
3390 }
3391 #else
3392 # define _mark(x,s,t,l) \
3393 C_cblock \
3394 C_word *_x = (x), _val = *_x; \
3395 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \
3396 C_cblockend
3397 #endif
3398
3399 /* NOTE: This macro is particularly unhygienic! */
3400 #define mark(x) _mark(x, tgt_space_start, tgt_space_top, tgt_space_limit)
3401
C_reclaim(void * trampoline,C_word c)3402 C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
3403 {
3404 int i, j, fcount;
3405 C_uword count;
3406 C_word **msp, last;
3407 C_byte *tmp, *start;
3408 C_GC_ROOT *gcrp;
3409 double tgc = 0;
3410 volatile int finalizers_checked;
3411 FINALIZER_NODE *flist;
3412 C_DEBUG_INFO cell;
3413 C_byte *tgt_space_start, **tgt_space_top, *tgt_space_limit;
3414
3415 /* assert(C_timer_interrupt_counter >= 0); */
3416
3417 if(pending_interrupts_count > 0 && C_interrupts_enabled) {
3418 stack_check_demand = 0; /* forget demand: we're not going to gc yet */
3419 handle_interrupt(trampoline);
3420 }
3421
3422 cell.enabled = 0;
3423 cell.event = C_DEBUG_GC;
3424 cell.loc = "<runtime>";
3425 cell.val = "GC_MINOR";
3426 C_debugger(&cell, 0, NULL);
3427
3428 /* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */
3429 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);
3430
3431 finalizers_checked = 0;
3432 C_restart_trampoline = trampoline;
3433 C_restart_c = c;
3434 gc_mode = GC_MINOR;
3435 tgt_space_start = fromspace_start;
3436 tgt_space_top = &C_fromspace_top;
3437 tgt_space_limit = C_fromspace_limit;
3438
3439 start = C_fromspace_top;
3440
3441 /* Entry point for second-level GC (on explicit request or because of full fromspace): */
3442 #ifdef HAVE_SIGSETJMP
3443 if(C_sigsetjmp(gc_restart, 0) || start >= C_fromspace_limit) {
3444 #else
3445 if(C_setjmp(gc_restart) || start >= C_fromspace_limit) {
3446 #endif
3447 if(gc_bell) {
3448 C_putchar(7);
3449 C_fflush(stdout);
3450 }
3451
3452 tgc = C_cpu_milliseconds();
3453
3454 if(gc_mode == GC_REALLOC) {
3455 cell.val = "GC_REALLOC";
3456 C_debugger(&cell, 0, NULL);
3457 C_rereclaim2(percentage(heap_size, C_heap_growth), 0);
3458 gc_mode = GC_MAJOR;
3459
3460 tgt_space_start = tospace_start;
3461 tgt_space_top = &tospace_top;
3462 tgt_space_limit= tospace_limit;
3463
3464 count = (C_uword)tospace_top - (C_uword)tospace_start;
3465 goto never_mind_edsger;
3466 }
3467
3468 start = (C_byte *)C_align((C_uword)tospace_top);
3469 gc_mode = GC_MAJOR;
3470 tgt_space_start = tospace_start;
3471 tgt_space_top = &tospace_top;
3472 tgt_space_limit= tospace_limit;
3473
3474 cell.val = "GC_MAJOR";
3475 C_debugger(&cell, 0, NULL);
3476
3477 mark_live_heap_only_objects(tgt_space_start, tgt_space_top, tgt_space_limit);
3478
3479 /* mark normal GC roots (see below for finalizer handling): */
3480 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
3481 if(!gcrp->finalizable) mark(&gcrp->value);
3482 }
3483 }
3484 else {
3485 /* Mark mutated slots: */
3486 for(msp = mutation_stack_bottom; msp < mutation_stack_top; ++msp)
3487 mark(*msp);
3488 }
3489
3490 mark_live_objects(tgt_space_start, tgt_space_top, tgt_space_limit);
3491
3492 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);
3493 start = *tgt_space_top;
3494
3495 if(gc_mode == GC_MINOR) {
3496 count = (C_uword)C_fromspace_top - (C_uword)start;
3497 ++gc_count_1;
3498 ++gc_count_1_total;
3499 update_locative_table(GC_MINOR);
3500 }
3501 else {
3502 /* Mark finalizer list and remember pointers to non-forwarded items: */
3503 last = C_block_item(pending_finalizers_symbol, 0);
3504
3505 if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {
3506 /* still finalizers pending: just mark table items... */
3507 if(gc_report_flag)
3508 C_dbg(C_text("GC"), C_text("%d finalized item(s) still pending\n"), j);
3509
3510 j = fcount = 0;
3511
3512 for(flist = finalizer_list; flist != NULL; flist = flist->next) {
3513 mark(&flist->item);
3514 mark(&flist->finalizer);
3515 ++fcount;
3516 }
3517
3518 /* mark finalizable GC roots: */
3519 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
3520 if(gcrp->finalizable) mark(&gcrp->value);
3521 }
3522
3523 if(gc_report_flag && fcount > 0)
3524 C_dbg(C_text("GC"), C_text("%d finalizer value(s) marked\n"), fcount);
3525 }
3526 else {
3527 j = fcount = 0;
3528
3529 /* move into pending */
3530 for(flist = finalizer_list; flist != NULL; flist = flist->next) {
3531 if(j < C_max_pending_finalizers) {
3532 if(!is_fptr(C_block_header(flist->item)))
3533 pending_finalizer_indices[ j++ ] = flist;
3534 }
3535 }
3536
3537 /* mark */
3538 for(flist = finalizer_list; flist != NULL; flist = flist->next) {
3539 mark(&flist->item);
3540 mark(&flist->finalizer);
3541 }
3542
3543 /* mark finalizable GC roots: */
3544 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
3545 if(gcrp->finalizable) mark(&gcrp->value);
3546 }
3547 }
3548
3549 pending_finalizer_count = j;
3550 finalizers_checked = 1;
3551
3552 if(pending_finalizer_count > 0 && gc_report_flag)
3553 C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),
3554 pending_finalizer_count, live_finalizer_count);
3555
3556 /* Once more mark nested objects after (maybe) copying finalizer objects: */
3557 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);
3558
3559 /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
3560 (and release finalizer node): */
3561 if(pending_finalizer_count > 0) {
3562 if(gc_report_flag)
3563 C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count);
3564
3565 last = C_block_item(pending_finalizers_symbol, 0);
3566 assert(C_block_item(last, 0) == C_fix(0));
3567 C_set_block_item(last, 0, C_fix(pending_finalizer_count));
3568
3569 for(i = 0; i < pending_finalizer_count; ++i) {
3570 flist = pending_finalizer_indices[ i ];
3571 C_set_block_item(last, 1 + i * 2, flist->item);
3572 C_set_block_item(last, 2 + i * 2, flist->finalizer);
3573
3574 if(flist->previous != NULL) flist->previous->next = flist->next;
3575 else finalizer_list = flist->next;
3576
3577 if(flist->next != NULL) flist->next->previous = flist->previous;
3578
3579 flist->next = finalizer_free_list;
3580 flist->previous = NULL;
3581 finalizer_free_list = flist;
3582 --live_finalizer_count;
3583 }
3584 }
3585
3586 update_locative_table(gc_mode);
3587 count = (C_uword)tospace_top - (C_uword)tospace_start; // Actual used, < heap_size/2
3588
3589 {
3590 C_uword min_half = count + C_heap_half_min_free;
3591 C_uword low_half = percentage(heap_size/2, C_heap_shrinkage_used);
3592 C_uword grown = percentage(heap_size, C_heap_growth);
3593 C_uword shrunk = percentage(heap_size, C_heap_shrinkage);
3594
3595 if (count < low_half) {
3596 heap_shrink_counter++;
3597 } else {
3598 heap_shrink_counter = 0;
3599 }
3600
3601 /*** isn't gc_mode always GC_MAJOR here? */
3602 if(gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&
3603 C_heap_shrinkage > 0 &&
3604 // This prevents grow, shrink, grow, shrink... spam
3605 HEAP_SHRINK_COUNTS < heap_shrink_counter &&
3606 (min_half * 2) <= shrunk && // Min. size trumps shrinkage
3607 heap_size > MINIMAL_HEAP_SIZE) {
3608 if(gc_report_flag) {
3609 C_dbg(C_text("GC"), C_text("Heap low water mark hit (%d%%), shrinking...\n"),
3610 C_heap_shrinkage_used);
3611 }
3612 heap_shrink_counter = 0;
3613 C_rereclaim2(shrunk, 0);
3614 } else if (gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&
3615 (heap_size / 2) < min_half) {
3616 if(gc_report_flag) {
3617 C_dbg(C_text("GC"), C_text("Heap high water mark hit, growing...\n"));
3618 }
3619 heap_shrink_counter = 0;
3620 C_rereclaim2(grown, 0);
3621 } else {
3622 C_fromspace_top = tospace_top;
3623 tmp = fromspace_start;
3624 fromspace_start = tospace_start;
3625 tospace_start = tospace_top = tmp;
3626 tmp = C_fromspace_limit;
3627 C_fromspace_limit = tospace_limit;
3628 tospace_limit = tmp;
3629 }
3630 }
3631
3632 never_mind_edsger:
3633 ++gc_count_2;
3634 }
3635
3636 if(gc_mode == GC_MAJOR) {
3637 update_symbol_tables(gc_mode);
3638
3639 tgc = C_cpu_milliseconds() - tgc;
3640 gc_ms += tgc;
3641 timer_accumulated_gc_ms += tgc;
3642 }
3643
3644 /* Display GC report:
3645 Note: stubbornly writes to stderr - there is no provision for other output-ports */
3646 if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {
3647 C_dbg(C_text("GC"), C_text("level %d\tgcs(minor) %d\tgcs(major) %d\n"),
3648 gc_mode, gc_count_1, gc_count_2);
3649 i = (C_uword)C_stack_pointer;
3650
3651 #if C_STACK_GROWS_DOWNWARD
3652 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
3653 (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);
3654 #else
3655 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
3656 (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);
3657 #endif
3658
3659 if(gc_mode == GC_MINOR)
3660 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);
3661
3662 C_fputc('\n', C_stderr);
3663 C_dbg("GC", C_text(" from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
3664 (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);
3665
3666 if(gc_mode == GC_MAJOR)
3667 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);
3668
3669 C_fputc('\n', C_stderr);
3670 C_dbg("GC", C_text(" to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),
3671 (C_uword)tospace_start, (C_uword)tospace_top,
3672 (C_uword)tospace_limit);
3673
3674 C_dbg("GC", C_text("%d locatives (from %d)\n"), locative_table_count, locative_table_size);
3675 }
3676
3677 /* GC will have copied any live objects out of scratch space: clear it */
3678 if (C_scratchspace_start != NULL) {
3679 C_free(C_scratchspace_start);
3680 C_scratchspace_start = NULL;
3681 C_scratchspace_top = NULL;
3682 C_scratchspace_limit = NULL;
3683 C_scratch_usage = 0;
3684 scratchspace_size = 0;
3685 }
3686
3687 if(gc_mode == GC_MAJOR) {
3688 gc_count_1 = 0;
3689 maximum_heap_usage = count > maximum_heap_usage ? count : maximum_heap_usage;
3690 }
3691
3692 if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);
3693
3694 /* Unwind stack completely */
3695 #ifdef HAVE_SIGSETJMP
3696 C_siglongjmp(C_restart, 1);
3697 #else
3698 C_longjmp(C_restart, 1);
3699 #endif
3700 }
3701
3702
3703 /* Mark live objects which can exist in the nursery and/or the heap */
3704 static C_regparm void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
3705 {
3706 C_word *p;
3707 TRACE_INFO *tinfo;
3708
3709 assert(C_temporary_stack >= C_temporary_stack_limit);
3710
3711 /* Mark live values from the currently running closure: */
3712 for(p = C_temporary_stack; p < C_temporary_stack_bottom; ++p)
3713 mark(p);
3714
3715 /* Clear the mutated slot stack: */
3716 mutation_stack_top = mutation_stack_bottom;
3717
3718 /* Mark trace-buffer: */
3719 for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
3720 mark(&tinfo->cooked1);
3721 mark(&tinfo->cooked2);
3722 mark(&tinfo->thread);
3723 }
3724 }
3725
3726
3727 /*
3728 * Mark all live *heap* objects that don't need GC mode-specific
3729 * treatment. Thus, no finalizers, GC roots or locative tables.
3730 *
3731 * Locative tables are excluded because these need to chase forwarding
3732 * chains to update the corresponding pointer, while dead objects must
3733 * be zeroed out with NULL pointers.
3734 *
3735 * Finalizers are excluded because these need special handling:
3736 * finalizers referring to dead objects must be marked and queued.
3737 *
3738 * This function does not need to be called on a minor GC, since these
3739 * objects won't ever exist in the nursery.
3740 */
3741 static C_regparm void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
3742 {
3743 LF_LIST *lfn;
3744 C_word *p, **msp, last;
3745 unsigned int i;
3746 C_SYMBOL_TABLE *stp;
3747
3748 /* Mark items in forwarding table: */
3749 for(p = forwarding_table; *p != 0; p += 2) {
3750 last = p[ 1 ];
3751 mark(&p[ 1 ]);
3752 C_block_header(p[ 0 ]) = C_block_header(last);
3753 }
3754
3755 /* Mark literal frames: */
3756 for(lfn = lf_list; lfn != NULL; lfn = lfn->next)
3757 for(i = 0; i < (unsigned int)lfn->count; ++i)
3758 mark(&lfn->lf[i]);
3759
3760 /* Mark symbol tables: */
3761 for(stp = symbol_table_list; stp != NULL; stp = stp->next)
3762 for(i = 0; i < stp->size; ++i)
3763 mark(&stp->table[i]);
3764
3765 /* Mark collectibles: */
3766 for(msp = collectibles; msp < collectibles_top; ++msp)
3767 if(*msp != NULL) mark(*msp);
3768
3769 /* Mark system globals */
3770 mark(&core_provided_symbol);
3771 mark(&interrupt_hook_symbol);
3772 mark(&error_hook_symbol);
3773 mark(&callback_continuation_stack_symbol);
3774 mark(&pending_finalizers_symbol);
3775 mark(¤t_thread_symbol);
3776
3777 mark(&u8vector_symbol);
3778 mark(&s8vector_symbol);
3779 mark(&u16vector_symbol);
3780 mark(&s16vector_symbol);
3781 mark(&u32vector_symbol);
3782 mark(&s32vector_symbol);
3783 mark(&u64vector_symbol);
3784 mark(&s64vector_symbol);
3785 mark(&f32vector_symbol);
3786 mark(&f64vector_symbol);
3787 }
3788
3789
3790 /*
3791 * Mark nested values in already moved (i.e., marked) blocks in
3792 * breadth-first manner (Cheney's algorithm).
3793 */
3794 static C_regparm void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
3795 {
3796 int n;
3797 C_word bytes;
3798 C_word *p;
3799 C_header h;
3800 C_SCHEME_BLOCK *bp;
3801
3802 while(heap_scan_top < *tgt_space_top) {
3803 bp = (C_SCHEME_BLOCK *)heap_scan_top;
3804
3805 if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)
3806 bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
3807
3808 n = C_header_size(bp);
3809 h = bp->header;
3810 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3811 p = bp->data;
3812
3813 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
3814 if(h & C_SPECIALBLOCK_BIT) {
3815 /* Minor GC needs to be fast; always mark weakly held symbols */
3816 if (gc_mode != GC_MINOR || h != C_WEAK_PAIR_TAG) {
3817 --n;
3818 ++p;
3819 }
3820 }
3821
3822 while(n--) mark(p++);
3823 }
3824
3825 heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
3826 }
3827 }
3828
3829
3830 static C_regparm void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
3831 {
3832 C_word val;
3833 C_uword n, bytes;
3834 C_header h;
3835 C_SCHEME_BLOCK *p, *p2;
3836
3837 val = *x;
3838
3839 if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_scratchspacep(val)) {
3840 #ifdef C_GC_HOOKS
3841 if(C_gc_trace_hook != NULL)
3842 C_gc_trace_hook(x, gc_mode);
3843 #endif
3844 return;
3845 }
3846
3847 p = (C_SCHEME_BLOCK *)val;
3848 h = p->header;
3849
3850 while(is_fptr(h)) { /* TODO: Pass in fptr chain limit? */
3851 val = fptr_to_ptr(h);
3852 p = (C_SCHEME_BLOCK *)val;
3853 h = p->header;
3854 }
3855
3856 /* Already in target space, probably as result of chasing fptrs */
3857 if ((C_uword)val >= (C_uword)tgt_space_start && (C_uword)val < (C_uword)*tgt_space_top) {
3858 *x = val;
3859 return;
3860 }
3861
3862 p2 = (C_SCHEME_BLOCK *)C_align((C_uword)*tgt_space_top);
3863
3864 #ifndef C_SIXTY_FOUR
3865 if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tgt_space_limit) {
3866 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
3867 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
3868 }
3869 #endif
3870
3871 n = C_header_size(p);
3872 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
3873
3874 if(C_unlikely(((C_byte *)p2 + bytes + sizeof(C_word)) > tgt_space_limit)) {
3875 if (gc_mode == GC_MAJOR) {
3876 /* Detect impossibilities before GC_REALLOC to preserve state: */
3877 if (C_in_stackp((C_word)p) && bytes > stack_size)
3878 panic(C_text("Detected corrupted data in stack"));
3879 if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))
3880 panic(C_text("Detected corrupted data in heap"));
3881 if(C_heap_size_is_fixed)
3882 panic(C_text("out of memory - heap full"));
3883
3884 gc_mode = GC_REALLOC;
3885 } else if (gc_mode == GC_REALLOC) {
3886 if (new_tospace_top > new_tospace_limit) {
3887 panic(C_text("out of memory - heap full while resizing"));
3888 }
3889 }
3890 #ifdef HAVE_SIGSETJMP
3891 C_siglongjmp(gc_restart, 1);
3892 #else
3893 C_longjmp(gc_restart, 1);
3894 #endif
3895 }
3896
3897 *tgt_space_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
3898
3899 *x = (C_word)p2;
3900 p2->header = h;
3901 p->header = ptr_to_fptr((C_uword)p2);
3902 C_memcpy(p2->data, p->data, bytes);
3903 }
3904
3905
3906 /* Do a major GC into a freshly allocated heap: */
3907
3908 #define remark(x) _mark(x, new_tospace_start, &new_tospace_top, new_tospace_limit)
3909
3910 C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
3911 {
3912 int i;
3913 C_GC_ROOT *gcrp;
3914 FINALIZER_NODE *flist;
3915 C_byte *new_heapspace, *start;
3916 size_t new_heapspace_size;
3917
3918 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);
3919
3920 /*
3921 * Normally, size is "absolute": it indicates the desired size of
3922 * the entire new heap. With relative_resize, size is a demanded
3923 * increase of the heap, so we'll have to add it. This calculation
3924 * doubles the current heap size because heap_size is already both
3925 * halves. We add size*2 because we'll eventually divide the size
3926 * by 2 for both halves. We also add stack_size*2 because all the
3927 * nursery data is also copied to the heap on GC, and the requested
3928 * memory "size" must be available after the GC.
3929 */
3930 if(relative_resize) size = (heap_size + size + stack_size) * 2;
3931
3932 if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;
3933
3934 /*
3935 * When heap grows, ensure it's enough to accommodate first
3936 * generation (nursery). Because we're calculating the total heap
3937 * size here (fromspace *AND* tospace), we have to double the stack
3938 * size, otherwise we'd accommodate only half the stack in the tospace.
3939 */
3940 if(size > heap_size && size - heap_size < stack_size * 2)
3941 size = heap_size + stack_size * 2;
3942
3943 /*
3944 * The heap has grown but we've already hit the maximal size with the current
3945 * heap, we can't do anything else but panic.
3946 */
3947 if(size > heap_size && heap_size >= C_maximal_heap_size)
3948 panic(C_text("out of memory - heap has reached its maximum size"));
3949
3950 if(size > C_maximal_heap_size) size = C_maximal_heap_size;
3951
3952 if(debug_mode) {
3953 C_dbg(C_text("debug"), C_text("resizing heap dynamically from "
3954 UWORD_COUNT_FORMAT_STRING "k to "
3955 UWORD_COUNT_FORMAT_STRING "k ...\n"),
3956 heap_size / 1024, size / 1024);
3957 }
3958
3959 if(gc_report_flag) {
3960 C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING
3961 ", \tlimit=" UWORD_FORMAT_STRING "\n"),
3962 (C_word)fromspace_start, (C_word)C_fromspace_limit);
3963 C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING
3964 ", \tlimit=" UWORD_FORMAT_STRING "\n"),
3965 (C_word)tospace_start, (C_word)tospace_limit);
3966 }
3967
3968 heap_size = size; /* Total heap size of the two halves... */
3969 size /= 2; /* ...each half is this big */
3970
3971 /*
3972 * Start by allocating the new heap's fromspace. After remarking,
3973 * allocate the other half of the new heap (its tospace).
3974 *
3975 * To clarify: what we call "new_space" here is what will eventually
3976 * be cycled over to "fromspace" when re-reclamation has finished
3977 * (that is, after the old one has been freed).
3978 */
3979 if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)
3980 panic(C_text("out of memory - cannot allocate heap segment"));
3981 new_heapspace_size = size;
3982
3983 new_tospace_top = new_tospace_start;
3984 new_tospace_limit = new_tospace_start + size;
3985 start = new_tospace_top;
3986
3987 /* Mark standard live objects in nursery and heap */
3988 mark_live_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);
3989 mark_live_heap_only_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);
3990
3991 /* Mark finalizer table: */
3992 for(flist = finalizer_list; flist != NULL; flist = flist->next) {
3993 remark(&flist->item);
3994 remark(&flist->finalizer);
3995 }
3996
3997 /* Mark *all* GC roots */
3998 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
3999 remark(&gcrp->value);
4000 }
4001
4002 /* Mark locative table (like finalizers, all objects are kept alive in GC_REALLOC): */
4003 for(i = 0; i < locative_table_count; ++i)
4004 remark(&locative_table[ i ]);
4005
4006 update_locative_table(GC_REALLOC);
4007
4008 /* Mark nested values in already moved (marked) blocks in breadth-first manner: */
4009 mark_nested_objects(start, new_tospace_start, &new_tospace_top, new_tospace_limit);
4010 update_symbol_tables(GC_REALLOC);
4011
4012 heap_free (heapspace1, heapspace1_size);
4013 heap_free (heapspace2, heapspace2_size);
4014
4015 if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)
4016 panic(C_text("out of memory - cannot allocate next heap segment"));
4017 heapspace2_size = size;
4018
4019 heapspace1 = new_heapspace;
4020 heapspace1_size = new_heapspace_size;
4021 tospace_limit = tospace_start + size;
4022 tospace_top = tospace_start;
4023 fromspace_start = new_tospace_start;
4024 C_fromspace_top = new_tospace_top;
4025 C_fromspace_limit = new_tospace_limit;
4026
4027 if(gc_report_flag) {
4028 C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);
4029 C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING
4030 ", \tlimit=" UWORD_FORMAT_STRING "\n"),
4031 (C_word)fromspace_start, (C_word)C_fromspace_limit);
4032 C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING
4033 ", \tlimit=" UWORD_FORMAT_STRING "\n"),
4034 (C_word)tospace_start, (C_word)tospace_limit);
4035 }
4036
4037 if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);
4038 }
4039
4040
4041 C_regparm void C_fcall update_locative_table(int mode)
4042 {
4043 int i, hi = 0, invalidated = 0;
4044 C_header h;
4045 C_word loc, obj, obj2, offset, loc2, ptr;
4046 C_uword ptr2;
4047
4048 for(i = 0; i < locative_table_count; ++i) {
4049 loc = locative_table[ i ];
4050
4051 if(loc != C_SCHEME_UNDEFINED) {
4052 h = C_block_header(loc);
4053
4054 switch(mode) {
4055 case GC_MINOR:
4056 if(is_fptr(h)) /* forwarded? update l-table entry */
4057 loc = locative_table[ i ] = fptr_to_ptr(h);
4058 /* otherwise it must have been GC'd (since this is a minor one) */
4059 else if(C_in_stackp(loc)) {
4060 locative_table[ i ] = C_SCHEME_UNDEFINED;
4061 C_set_block_item(loc, 0, 0);
4062 ++invalidated;
4063 break;
4064 }
4065
4066 /* forwarded. fix up ptr and check pointed-at object for being forwarded... */
4067 ptr = C_block_item(loc, 0);
4068 offset = C_unfix(C_block_item(loc, 1));
4069 obj = ptr - offset;
4070 h = C_block_header(obj);
4071
4072 if(is_fptr(h)) { /* pointed-at object forwarded? update */
4073 C_set_block_item(loc, 0, (C_uword)fptr_to_ptr(h) + offset);
4074 hi = i + 1;
4075 }
4076 else if(C_in_stackp(obj)) { /* pointed-at object GC'd, locative is invalid */
4077 locative_table[ i ] = C_SCHEME_UNDEFINED;
4078 C_set_block_item(loc, 0, 0);
4079 }
4080 else hi = i + 1;
4081
4082 break;
4083
4084 case GC_MAJOR:
4085 if(is_fptr(h)) /* forwarded? update l-table entry */
4086 loc = locative_table[ i ] = fptr_to_ptr(h);
4087 else { /* otherwise, throw away */
4088 locative_table[ i ] = C_SCHEME_UNDEFINED;
4089 C_set_block_item(loc, 0, 0);
4090 ++invalidated;
4091 break;
4092 }
4093
4094 h = C_block_header(loc);
4095
4096 if(is_fptr(h)) /* new instance is forwarded itself? update again */
4097 loc = locative_table[ i ] = fptr_to_ptr(h);
4098
4099 ptr = C_block_item(loc, 0); /* fix up ptr */
4100 offset = C_unfix(C_block_item(loc, 1));
4101 obj = ptr - offset;
4102 h = C_block_header(obj);
4103
4104 if(is_fptr(h)) { /* pointed-at object has been forwarded? */
4105 ptr2 = (C_uword)fptr_to_ptr(h);
4106 h = C_block_header(ptr2);
4107
4108 if(is_fptr(h)) { /* secondary forwarding check for pointed-at object */
4109 ptr2 = (C_uword)fptr_to_ptr(h) + offset;
4110 C_set_block_item(loc, 0, ptr2);
4111 }
4112 else C_set_block_item(loc, 0, ptr2 + offset); /* everything's fine, fixup pointer */
4113
4114 hi = i + 1;
4115 }
4116 else {
4117 locative_table[ i ] = C_SCHEME_UNDEFINED; /* pointed-at object is dead */
4118 C_set_block_item(loc, 0, 0);
4119 ++invalidated;
4120 }
4121
4122 break;
4123
4124 case GC_REALLOC:
4125 ptr = C_block_item(loc, 0); /* just update ptr's pointed-at objects */
4126 offset = C_unfix(C_block_item(loc, 1));
4127 obj = ptr - offset;
4128 remark(&obj);
4129 C_set_block_item(loc, 0, obj + offset);
4130 break;
4131 }
4132 }
4133 }
4134
4135 if(gc_report_flag && invalidated > 0)
4136 C_dbg(C_text("GC"), C_text("locative-table entries reclaimed: %d\n"), invalidated);
4137
4138 if(mode != GC_REALLOC) locative_table_count = hi;
4139 }
4140
4141 static C_regparm void fixup_symbol_forwards(C_word sym)
4142 {
4143 C_word val, h;
4144 int i, s = C_header_size(sym); /* 3 */
4145
4146 for (i = 0; i < s; i++) {
4147 val = C_block_item(sym, i);
4148 if (!C_immediatep(val)) {
4149 h = C_block_header(val);
4150
4151 while(is_fptr(h)) {
4152 val = fptr_to_ptr(h);
4153 h = C_block_header(val);
4154 }
4155 C_set_block_item(sym, i, val);
4156 }
4157 }
4158 }
4159
4160 C_regparm void C_fcall update_symbol_tables(int mode)
4161 {
4162 int weakn = 0, i;
4163 C_word bucket, last, sym, h;
4164 C_SYMBOL_TABLE *stp;
4165
4166 assert(mode != GC_MINOR); /* Call only in major or realloc mode */
4167 /* Update symbol locations through fptrs or drop if unreferenced */
4168 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
4169 for(i = 0; i < stp->size; ++i) {
4170 last = 0;
4171
4172 for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_block_item(bucket,1)) {
4173
4174 sym = C_block_item(bucket, 0);
4175 h = C_block_header(sym);
4176
4177 /* Resolve any forwarding pointers */
4178 while(is_fptr(h)) {
4179 sym = fptr_to_ptr(h);
4180 h = C_block_header(sym);
4181 }
4182
4183 assert((h & C_HEADER_TYPE_BITS) == C_SYMBOL_TYPE);
4184
4185 #ifdef DEBUGBUILD
4186 /* Detect inconsistencies before dropping / keeping the symbol */
4187 fixup_symbol_forwards(sym);
4188 {
4189 C_word str = C_symbol_name(sym);
4190 int str_perm;
4191
4192 str_perm = !C_in_stackp(str) && !C_in_heapp(str) &&
4193 !C_in_scratchspacep(str) &&
4194 (mode == GC_REALLOC ? !C_in_new_heapp(str) : 1);
4195
4196 if ((C_persistable_symbol(sym) || str_perm) &&
4197 (C_block_header(bucket) == C_WEAK_PAIR_TAG)) {
4198 C_dbg(C_text("GC"), C_text("Offending symbol: `%.*s'\n"),
4199 (int)C_header_size(str), C_c_string(str));
4200 panic(C_text("Persistable symbol found in weak pair"));
4201 } else if (!C_persistable_symbol(sym) && !str_perm &&
4202 (C_block_header(bucket) == C_PAIR_TAG)) {
4203 C_dbg(C_text("GC"), C_text("Offending symbol: `%.*s'...\n"),
4204 (int)C_header_size(str), C_c_string(str));
4205 panic(C_text("Unpersistable symbol found in strong pair"));
4206 }
4207 }
4208 #endif
4209
4210 /* If the symbol is unreferenced, drop it: */
4211 if(mode == GC_REALLOC ?
4212 !C_in_new_heapp(sym) :
4213 !C_in_fromspacep(sym)) {
4214
4215 if(last) C_set_block_item(last, 1, C_block_item(bucket,1));
4216 else stp->table[ i ] = C_block_item(bucket,1);
4217
4218 #ifndef NDEBUG
4219 fixup_symbol_forwards(sym);
4220 assert(!C_persistable_symbol(sym));
4221 #endif
4222 ++weakn;
4223 } else {
4224 C_set_block_item(bucket,0,sym); /* Might have moved */
4225 last = bucket;
4226 }
4227 }
4228 }
4229 }
4230 if(gc_report_flag && weakn)
4231 C_dbg("GC", C_text("%d recoverable weakly held items found\n"), weakn);
4232 }
4233
4234
4235 void handle_interrupt(void *trampoline)
4236 {
4237 C_word *p, h, reason, state, proc, n;
4238 double c;
4239 C_word av[ 4 ];
4240
4241 /* Build vector with context information: */
4242 n = C_temporary_stack_bottom - C_temporary_stack;
4243 p = C_alloc(C_SIZEOF_VECTOR(2) + C_SIZEOF_VECTOR(n));
4244 proc = (C_word)p;
4245 *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | sizeof(C_word);
4246 *(p++) = (C_word)trampoline;
4247 state = (C_word)p;
4248 *(p++) = C_VECTOR_TYPE | (n + 1);
4249 *(p++) = proc;
4250 C_memcpy(p, C_temporary_stack, n * sizeof(C_word));
4251
4252 /* Restore state to the one at the time of the interrupt: */
4253 C_temporary_stack = C_temporary_stack_bottom;
4254 C_stack_limit = C_stack_hard_limit;
4255
4256 /* Invoke high-level interrupt handler: */
4257 reason = C_fix(pending_interrupts[ --pending_interrupts_count ]);
4258 proc = C_block_item(interrupt_hook_symbol, 0);
4259
4260 if(C_immediatep(proc))
4261 panic(C_text("`##sys#interrupt-hook' is not defined"));
4262
4263 c = C_cpu_milliseconds() - interrupt_time;
4264 last_interrupt_latency = c;
4265 C_timer_interrupt_counter = C_initial_timer_interrupt_period;
4266 /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
4267 av[ 0 ] = proc;
4268 av[ 1 ] = C_SCHEME_UNDEFINED;
4269 av[ 2 ] = reason;
4270 av[ 3 ] = state;
4271 C_do_apply(4, av);
4272 }
4273
4274
4275 void
4276 C_unbound_variable(C_word sym)
4277 {
4278 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
4279 }
4280
4281
4282 /* XXX: This needs to be given a better name.
4283 C_retrieve used to exist but it just called C_fast_retrieve */
4284 C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
4285 {
4286 C_word *p;
4287 int len;
4288
4289 if(val == C_SCHEME_UNBOUND) {
4290 len = C_strlen(name);
4291 /* this is ok: we won't return from `C_retrieve2'
4292 * (or the value isn't needed). */
4293 p = C_alloc(C_SIZEOF_STRING(len));
4294 C_unbound_variable(C_string2(&p, name));
4295 }
4296
4297 return val;
4298 }
4299
4300
4301 void C_ccall C_invalid_procedure(C_word c, C_word *av)
4302 {
4303 C_word self = av[0];
4304 barf(C_NOT_A_CLOSURE_ERROR, NULL, self);
4305 }
4306
4307
4308 C_regparm void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name)
4309 {
4310 C_word *p;
4311 int len;
4312
4313 if(val == C_SCHEME_UNBOUND) {
4314 len = C_strlen(name);
4315 /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */
4316 p = C_alloc(C_SIZEOF_STRING(len));
4317 barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));
4318 }
4319
4320 return C_fast_retrieve_proc(val);
4321 }
4322
4323 #ifdef C_NONUNIX
4324 VOID CALLBACK win_timer(PVOID data_ignored, BOOLEAN wait_or_fired)
4325 {
4326 if (profiling) take_profile_sample();
4327 }
4328 #endif
4329
4330 static void set_profile_timer(C_uword freq)
4331 {
4332 #ifdef C_NONUNIX
4333 static HANDLE timer = NULL;
4334
4335 if (freq == 0) {
4336 assert(timer != NULL);
4337 if (!DeleteTimerQueueTimer(NULL, timer, NULL)) goto error;
4338 timer = NULL;
4339 } else if (freq < 1000) {
4340 panic(C_text("On Windows, sampling can only be done in milliseconds"));
4341 } else {
4342 if (!CreateTimerQueueTimer(&timer, NULL, win_timer, NULL, 0, freq/1000, 0))
4343 goto error;
4344 }
4345 #else
4346 struct itimerval itv;
4347
4348 itv.it_value.tv_sec = freq / 1000000;
4349 itv.it_value.tv_usec = freq % 1000000;
4350 itv.it_interval.tv_sec = itv.it_value.tv_sec;
4351 itv.it_interval.tv_usec = itv.it_value.tv_usec;
4352
4353 if (setitimer(C_PROFILE_TIMER, &itv, NULL) == -1) goto error;
4354 #endif
4355
4356 return;
4357
4358 error:
4359 if (freq == 0) panic(C_text("error clearing timer for profiling"));
4360 else panic(C_text("error setting timer for profiling"));
4361 }
4362
4363 /* Bump profile count for current top of trace buffer */
4364 static void take_profile_sample()
4365 {
4366 PROFILE_BUCKET **bp, *b;
4367 C_char *key;
4368 TRACE_INFO *tb;
4369 /* To count distinct calls of a procedure, remember last call */
4370 static C_char *prev_key = NULL;
4371 static TRACE_INFO *prev_tb = NULL;
4372
4373 /* trace_buffer_top points *beyond* the topmost entry: Go back one */
4374 if (trace_buffer_top == trace_buffer) {
4375 if (!trace_buffer_full) return; /* No data yet */
4376 tb = trace_buffer_limit - 1;
4377 } else {
4378 tb = trace_buffer_top - 1;
4379 }
4380
4381 /* We could also just hash the pointer but that's a bit trickier */
4382 key = tb->raw;
4383 bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0, 0);
4384 b = *bp;
4385
4386 /* First try to find pre-existing item in hash table */
4387 while(b != NULL) {
4388 if(b->key == key) {
4389 b->sample_count++;
4390 if (prev_key != key && prev_tb != tb)
4391 b->call_count++;
4392 goto done;
4393 }
4394 else b = b->next;
4395 }
4396
4397 /* Not found, allocate a new item and use it as bucket's new head */
4398 b = next_profile_bucket;
4399 next_profile_bucket = NULL;
4400
4401 assert(b != NULL);
4402
4403 b->next = *bp;
4404 b->key = key;
4405 *bp = b;
4406 b->sample_count = 1;
4407 b->call_count = 1;
4408
4409 done:
4410 prev_tb = tb;
4411 prev_key = key;
4412 }
4413
4414
4415 C_regparm void C_fcall C_trace(C_char *name)
4416 {
4417 C_word thread;
4418
4419 if(show_trace) {
4420 C_fputs(name, C_stderr);
4421 C_fputc('\n', C_stderr);
4422 }
4423
4424 /*
4425 * When profiling, pre-allocate profile bucket if necessary. This
4426 * is used in the signal handler, because it may not malloc.
4427 */
4428 if(profiling && next_profile_bucket == NULL) {
4429 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));
4430 if (next_profile_bucket == NULL) {
4431 panic(C_text("out of memory - cannot allocate profile table-bucket"));
4432 }
4433 }
4434
4435 if(trace_buffer_top >= trace_buffer_limit) {
4436 trace_buffer_top = trace_buffer;
4437 trace_buffer_full = 1;
4438 }
4439
4440 trace_buffer_top->raw = name;
4441 trace_buffer_top->cooked1 = C_SCHEME_FALSE;
4442 trace_buffer_top->cooked2 = C_SCHEME_FALSE;
4443 thread = C_block_item(current_thread_symbol, 0);
4444 trace_buffer_top->thread = C_and(C_blockp(thread), C_thread_id(thread));
4445 ++trace_buffer_top;
4446 }
4447
4448
4449 C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t)
4450 {
4451 /* See above */
4452 if(profiling && next_profile_bucket == NULL) {
4453 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));
4454 if (next_profile_bucket == NULL) {
4455 panic(C_text("out of memory - cannot allocate profile table-bucket"));
4456 }
4457 }
4458
4459 if(trace_buffer_top >= trace_buffer_limit) {
4460 trace_buffer_top = trace_buffer;
4461 trace_buffer_full = 1;
4462 }
4463
4464 trace_buffer_top->raw = raw;
4465 trace_buffer_top->cooked1 = x;
4466 trace_buffer_top->cooked2 = y;
4467 trace_buffer_top->thread = t;
4468 ++trace_buffer_top;
4469 return x;
4470 }
4471
4472
4473 C_char *C_dump_trace(int start)
4474 {
4475 TRACE_INFO *ptr;
4476 C_char *result;
4477 int i, result_len;
4478
4479 result_len = STRING_BUFFER_SIZE;
4480 if((result = (char *)C_malloc(result_len)) == NULL)
4481 horror(C_text("out of memory - cannot allocate trace-dump buffer"));
4482
4483 *result = '\0';
4484
4485 if(trace_buffer_top > trace_buffer || trace_buffer_full) {
4486 if(trace_buffer_full) {
4487 i = C_trace_buffer_size;
4488 C_strlcat(result, C_text("...more...\n"), result_len);
4489 }
4490 else i = trace_buffer_top - trace_buffer;
4491
4492 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
4493 ptr += start;
4494 i -= start;
4495
4496 for(;i--; ++ptr) {
4497 if(ptr >= trace_buffer_limit) ptr = trace_buffer;
4498
4499 if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {
4500 result_len = C_strlen(result) * 2;
4501 result = C_realloc(result, result_len);
4502 if(result == NULL)
4503 horror(C_text("out of memory - cannot reallocate trace-dump buffer"));
4504 }
4505
4506 C_strlcat(result, ptr->raw, result_len);
4507
4508 if(i > 0) C_strlcat(result, "\n", result_len);
4509 else C_strlcat(result, " \t<--\n", result_len);
4510 }
4511 }
4512
4513 return result;
4514 }
4515
4516
4517 C_regparm void C_fcall C_clear_trace_buffer(void)
4518 {
4519 int i, old_profiling = profiling;
4520
4521 profiling = 0;
4522
4523 if(trace_buffer == NULL) {
4524 if(C_trace_buffer_size < MIN_TRACE_BUFFER_SIZE)
4525 C_trace_buffer_size = MIN_TRACE_BUFFER_SIZE;
4526
4527 trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);
4528
4529 if(trace_buffer == NULL)
4530 panic(C_text("out of memory - cannot allocate trace-buffer"));
4531 }
4532
4533 trace_buffer_top = trace_buffer;
4534 trace_buffer_limit = trace_buffer + C_trace_buffer_size;
4535 trace_buffer_full = 0;
4536
4537 for(i = 0; i < C_trace_buffer_size; ++i) {
4538 trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;
4539 trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;
4540 trace_buffer[ i ].thread = C_SCHEME_FALSE;
4541 }
4542
4543 profiling = old_profiling;
4544 }
4545
4546 C_word C_resize_trace_buffer(C_word size) {
4547 int old_size = C_trace_buffer_size, old_profiling = profiling;
4548 assert(trace_buffer);
4549 profiling = 0;
4550 free(trace_buffer);
4551 trace_buffer = NULL;
4552 C_trace_buffer_size = C_unfix(size);
4553 C_clear_trace_buffer();
4554 profiling = old_profiling;
4555 return(C_fix(old_size));
4556 }
4557
4558 C_word C_fetch_trace(C_word starti, C_word buffer)
4559 {
4560 TRACE_INFO *ptr;
4561 int i, p = 0, start = C_unfix(starti);
4562
4563 if(trace_buffer_top > trace_buffer || trace_buffer_full) {
4564 if(trace_buffer_full) i = C_trace_buffer_size;
4565 else i = trace_buffer_top - trace_buffer;
4566
4567 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
4568 ptr += start;
4569 i -= start;
4570
4571 if(C_header_size(buffer) < i * 4)
4572 panic(C_text("destination buffer too small for call-chain"));
4573
4574 for(;i--; ++ptr) {
4575 if(ptr >= trace_buffer_limit) ptr = trace_buffer;
4576
4577 /* outside-pointer, will be ignored by GC */
4578 C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw);
4579
4580 /* subject to GC */
4581 C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
4582 C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
4583 C_mutate(&C_block_item(buffer, p++), ptr->thread);
4584 }
4585 }
4586
4587 return C_fix(p);
4588 }
4589
4590 C_regparm C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd)
4591 {
4592 int len = C_header_size(str);
4593 C_char *ptr = C_data_pointer(str);
4594 return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 0));
4595 }
4596
4597 C_regparm C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd)
4598 {
4599 int len = C_header_size(str);
4600 C_char *ptr = C_data_pointer(str);
4601 return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 1));
4602 }
4603
4604 C_regparm void C_fcall C_toplevel_entry(C_char *name)
4605 {
4606 if(debug_mode)
4607 C_dbg(C_text("debug"), C_text("entering %s...\n"), name);
4608 }
4609
4610 C_regparm C_word C_fcall C_a_i_provide(C_word **a, int c, C_word id)
4611 {
4612 if (debug_mode == 2) {
4613 C_word str = C_block_item(id, 1);
4614 C_snprintf(buffer, C_header_size(str) + 1, C_text("%s"), (C_char *) C_data_pointer(str));
4615 C_dbg(C_text("debug"), C_text("providing %s...\n"), buffer);
4616 }
4617 return C_a_i_putprop(a, 3, core_provided_symbol, id, C_SCHEME_TRUE);
4618 }
4619
4620 C_regparm C_word C_fcall C_i_providedp(C_word id)
4621 {
4622 return C_i_getprop(core_provided_symbol, id, C_SCHEME_FALSE);
4623 }
4624
4625 C_word C_halt(C_word msg)
4626 {
4627 C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;
4628
4629 if(C_gui_mode) {
4630 if(msg != C_SCHEME_FALSE) {
4631 int n = C_header_size(msg);
4632
4633 if (n >= sizeof(buffer))
4634 n = sizeof(buffer) - 1;
4635 C_strlcpy(buffer, (C_char *)C_data_pointer(msg), n);
4636 /* XXX msg isn't checked for NUL bytes, but we can't barf here either! */
4637 }
4638 else C_strlcpy(buffer, C_text("(aborted)"), sizeof(buffer));
4639
4640 C_strlcat(buffer, C_text("\n\n"), sizeof(buffer));
4641
4642 if(dmp != NULL) C_strlcat(buffer, dmp, sizeof(buffer));
4643
4644 #if defined(_WIN32) && !defined(__CYGWIN__)
4645 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);
4646 ExitProcess(1);
4647 #endif
4648 } /* otherwise fall through */
4649
4650 if(msg != C_SCHEME_FALSE) {
4651 C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);
4652 C_fputc('\n', C_stderr);
4653 }
4654
4655 if(dmp != NULL)
4656 C_dbg("", C_text("\n%s"), dmp);
4657
4658 C_exit_runtime(C_fix(EX_SOFTWARE));
4659 return 0;
4660 }
4661
4662
4663 C_word C_message(C_word msg)
4664 {
4665 unsigned int n = C_header_size(msg);
4666 /*
4667 * Strictly speaking this isn't necessary for the non-gui-mode,
4668 * but let's try and keep this consistent across modes.
4669 */
4670 if (C_memchr(C_c_string(msg), '\0', n) != NULL)
4671 barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);
4672
4673 if(C_gui_mode) {
4674 if (n >= sizeof(buffer))
4675 n = sizeof(buffer) - 1;
4676 C_strncpy(buffer, C_c_string(msg), n);
4677 buffer[ n ] = '\0';
4678 #if defined(_WIN32) && !defined(__CYGWIN__)
4679 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONEXCLAMATION);
4680 return C_SCHEME_UNDEFINED;
4681 #endif
4682 } /* fall through */
4683
4684 C_fwrite(C_c_string(msg), n, sizeof(C_char), stdout);
4685 C_putchar('\n');
4686 return C_SCHEME_UNDEFINED;
4687 }
4688
4689
4690 C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
4691 {
4692 C_header header;
4693 C_word bits, n, i;
4694
4695 C_stack_check1(barf(C_CIRCULAR_DATA_ERROR, "equal?"));
4696
4697 loop:
4698 if(x == y) return 1;
4699
4700 if(C_immediatep(x) || C_immediatep(y)) return 0;
4701
4702 if((header = C_block_header(x)) != C_block_header(y)) return 0;
4703 else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {
4704 if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)
4705 return C_ub_i_flonum_eqvp(C_flonum_magnitude(x),
4706 C_flonum_magnitude(y));
4707 else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);
4708 }
4709 else if(header == C_SYMBOL_TAG) return 0;
4710 else {
4711 i = 0;
4712 n = header & C_HEADER_SIZE_MASK;
4713
4714 if(bits & C_SPECIALBLOCK_BIT) {
4715 /* do not recurse into closures */
4716 if(C_header_bits(x) == C_CLOSURE_TYPE)
4717 return !C_memcmp(C_data_pointer(x), C_data_pointer(y), n * sizeof(C_word));
4718 else if(C_block_item(x, 0) != C_block_item(y, 0)) return 0;
4719 else ++i;
4720
4721 if(n == 1) return 1;
4722 }
4723
4724 if(--n < 0) return 1;
4725
4726 while(i < n)
4727 if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;
4728 else ++i;
4729
4730 x = C_block_item(x, i);
4731 y = C_block_item(y, i);
4732 goto loop;
4733 }
4734 }
4735
4736
4737 C_regparm C_word C_fcall C_set_gc_report(C_word flag)
4738 {
4739 if(flag == C_SCHEME_FALSE) gc_report_flag = 0;
4740 else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;
4741 else gc_report_flag = 1;
4742
4743 return C_SCHEME_UNDEFINED;
4744 }
4745
4746 C_regparm C_word C_fcall C_i_accumulated_gc_time(void)
4747 {
4748 double tgc;
4749
4750 tgc = timer_accumulated_gc_ms;
4751 timer_accumulated_gc_ms = 0;
4752 return C_fix(tgc);
4753 }
4754
4755 C_regparm C_word C_fcall C_start_timer(void)
4756 {
4757 tracked_mutation_count = 0;
4758 mutation_count = 0;
4759 gc_count_1_total = 0;
4760 gc_count_2 = 0;
4761 timer_start_ms = C_cpu_milliseconds();
4762 gc_ms = 0;
4763 maximum_heap_usage = 0;
4764 return C_SCHEME_UNDEFINED;
4765 }
4766
4767
4768 void C_ccall C_stop_timer(C_word c, C_word *av)
4769 {
4770 C_word
4771 closure = av[ 0 ],
4772 k = av[ 1 ];
4773 double t0 = C_cpu_milliseconds() - timer_start_ms;
4774 C_word
4775 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_BIGNUM(1) + C_SIZEOF_VECTOR(7) ],
4776 *a = ab,
4777 elapsed = C_flonum(&a, t0 / 1000.0),
4778 gc_time = C_flonum(&a, gc_ms / 1000.0),
4779 heap_usage = C_unsigned_int_to_num(&a, maximum_heap_usage),
4780 info;
4781
4782 info = C_vector(&a, 7, elapsed, gc_time, C_fix(mutation_count),
4783 C_fix(tracked_mutation_count), C_fix(gc_count_1_total),
4784 C_fix(gc_count_2), heap_usage);
4785 C_kontinue(k, info);
4786 }
4787
4788
4789 C_word C_exit_runtime(C_word code)
4790 {
4791 C_fflush(NULL);
4792 C__exit(C_unfix(code));
4793 }
4794
4795
4796 C_regparm C_word C_fcall C_set_print_precision(C_word n)
4797 {
4798 flonum_print_precision = C_unfix(n);
4799 return C_SCHEME_UNDEFINED;
4800 }
4801
4802
4803 C_regparm C_word C_fcall C_get_print_precision(void)
4804 {
4805 return C_fix(flonum_print_precision);
4806 }
4807
4808
4809 C_regparm C_word C_fcall C_read_char(C_word port)
4810 {
4811 C_FILEPTR fp = C_port_file(port);
4812 int c = C_getc(fp);
4813
4814 if(c == EOF) {
4815 if(ferror(fp)) {
4816 clearerr(fp);
4817 return C_fix(-1);
4818 }
4819 /* Found here:
4820 http://mail.python.org/pipermail/python-bugs-list/2002-July/012579.html */
4821 #if defined(_WIN32) && !defined(__CYGWIN__)
4822 else if(GetLastError() == ERROR_OPERATION_ABORTED) return C_fix(-1);
4823 #endif
4824 else return C_SCHEME_END_OF_FILE;
4825 }
4826
4827 return C_make_character(c);
4828 }
4829
4830
4831 C_regparm C_word C_fcall C_peek_char(C_word port)
4832 {
4833 C_FILEPTR fp = C_port_file(port);
4834 int c = C_getc(fp);
4835
4836 if(c == EOF) {
4837 if(ferror(fp)) {
4838 clearerr(fp);
4839 return C_fix(-1);
4840 }
4841 /* see above */
4842 #if defined(_WIN32) && !defined(__CYGWIN__)
4843 else if(GetLastError() == ERROR_OPERATION_ABORTED) return C_fix(-1);
4844 #endif
4845 else return C_SCHEME_END_OF_FILE;
4846 }
4847
4848 C_ungetc(c, fp);
4849 return C_make_character(c);
4850 }
4851
4852
4853 C_regparm C_word C_fcall C_execute_shell_command(C_word string)
4854 {
4855 int n = C_header_size(string);
4856 char *buf = buffer;
4857
4858 /* Windows doc says to flush all output streams before calling system.
4859 Probably a good idea for all platforms. */
4860 (void)fflush(NULL);
4861
4862 if(n >= STRING_BUFFER_SIZE) {
4863 if((buf = (char *)C_malloc(n + 1)) == NULL)
4864 barf(C_OUT_OF_MEMORY_ERROR, "system");
4865 }
4866
4867 C_memcpy(buf, C_data_pointer(string), n);
4868 buf[ n ] = '\0';
4869 if (n != strlen(buf))
4870 barf(C_ASCIIZ_REPRESENTATION_ERROR, "system", string);
4871
4872 n = C_system(buf);
4873
4874 if(buf != buffer) C_free(buf);
4875
4876 return C_fix(n);
4877 }
4878
4879 /*
4880 * TODO: Implement something for Windows that supports selecting on
4881 * arbitrary fds (there, select() only works on network sockets and
4882 * poll() is not available at all).
4883 */
4884 C_regparm int C_fcall C_check_fd_ready(int fd)
4885 {
4886 #ifdef NO_POSIX_POLL
4887 fd_set in;
4888 struct timeval tm;
4889 int rv;
4890 FD_ZERO(&in);
4891 FD_SET(fd, &in);
4892 tm.tv_sec = tm.tv_usec = 0;
4893 rv = select(fd + 1, &in, NULL, NULL, &tm);
4894 if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
4895 return rv;
4896 #else
4897 struct pollfd ps;
4898 ps.fd = fd;
4899 ps.events = POLLIN;
4900 return poll(&ps, 1, 0);
4901 #endif
4902 }
4903
4904 C_regparm C_word C_fcall C_char_ready_p(C_word port)
4905 {
4906 #if defined(C_NONUNIX)
4907 /* The best we can currently do on Windows... */
4908 return C_SCHEME_TRUE;
4909 #else
4910 int fd = C_fileno(C_port_file(port));
4911 return C_mk_bool(C_check_fd_ready(fd) == 1);
4912 #endif
4913 }
4914
4915 C_regparm C_word C_fcall C_i_tty_forcedp(void)
4916 {
4917 return C_mk_bool(fake_tty_flag);
4918 }
4919
4920 C_regparm C_word C_fcall C_i_debug_modep(void)
4921 {
4922 return C_mk_bool(debug_mode);
4923 }
4924
4925 C_regparm C_word C_fcall C_i_dump_heap_on_exitp(void)
4926 {
4927 return C_mk_bool(dump_heap_on_exit);
4928 }
4929
4930 C_regparm C_word C_fcall C_i_profilingp(void)
4931 {
4932 return C_mk_bool(profiling);
4933 }
4934
4935 C_regparm C_word C_fcall C_i_live_finalizer_count(void)
4936 {
4937 return C_fix(live_finalizer_count);
4938 }
4939
4940 C_regparm C_word C_fcall C_i_allocated_finalizer_count(void)
4941 {
4942 return C_fix(allocated_finalizer_count);
4943 }
4944
4945
4946 C_regparm void C_fcall C_raise_interrupt(int reason)
4947 {
4948 if(C_interrupts_enabled) {
4949 if(pending_interrupts_count == 0 && !handling_interrupts) {
4950 pending_interrupts[ pending_interrupts_count++ ] = reason;
4951 /*
4952 * Force the next "soft" stack check to fail by faking a "full"
4953 * stack. This causes save_and_reclaim() to be called, which
4954 * invokes handle_interrupt(), which restores the stack limit.
4955 */
4956 C_stack_limit = stack_bottom;
4957 interrupt_time = C_cpu_milliseconds();
4958 } else if(pending_interrupts_count < MAX_PENDING_INTERRUPTS) {
4959 int i;
4960 /*
4961 * Drop signals if too many, but don't queue up multiple entries
4962 * for the same signal.
4963 */
4964 for (i = 0; i < pending_interrupts_count; ++i) {
4965 if (pending_interrupts[i] == reason)
4966 return;
4967 }
4968 pending_interrupts[ pending_interrupts_count++ ] = reason;
4969 }
4970 }
4971 }
4972
4973
4974 C_regparm C_word C_fcall C_enable_interrupts(void)
4975 {
4976 C_timer_interrupt_counter = C_initial_timer_interrupt_period;
4977 /* assert(C_timer_interrupt_counter > 0); */
4978 C_interrupts_enabled = 1;
4979 return C_SCHEME_UNDEFINED;
4980 }
4981
4982
4983 C_regparm C_word C_fcall C_disable_interrupts(void)
4984 {
4985 C_interrupts_enabled = 0;
4986 return C_SCHEME_UNDEFINED;
4987 }
4988
4989
4990 C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason)
4991 {
4992 int sig = C_unfix(signum);
4993 #if defined(HAVE_SIGACTION)
4994 struct sigaction newsig;
4995 #endif
4996
4997 if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
4998 else {
4999 signal_mapping_table[ sig ] = C_unfix(reason);
5000 #if defined(HAVE_SIGACTION)
5001 newsig.sa_flags = 0;
5002 /* The global signal handler is used for all signals, and
5003 manipulates a single queue. Don't allow other signals to
5004 concurrently arrive while it's doing this, to avoid races. */
5005 sigfillset(&newsig.sa_mask);
5006 newsig.sa_handler = global_signal_handler;
5007 C_sigaction(sig, &newsig, NULL);
5008 #else
5009 C_signal(sig, global_signal_handler);
5010 #endif
5011 }
5012
5013 return C_SCHEME_UNDEFINED;
5014 }
5015
5016
5017 /* Copy blocks into collected or static memory: */
5018
5019 C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
5020 {
5021 int n = C_header_size(from);
5022 C_long bytes;
5023
5024 if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
5025 bytes = n;
5026 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
5027 }
5028 else {
5029 bytes = C_wordstobytes(n);
5030 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
5031 }
5032
5033 return to;
5034 }
5035
5036
5037 C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
5038 {
5039 int n = C_header_size(from);
5040 C_long bytes;
5041 C_word *p = (C_word *)C_pointer_address(ptr);
5042
5043 if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
5044 else bytes = C_wordstobytes(n);
5045
5046 C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
5047 return (C_word)p;
5048 }
5049
5050
5051 /* Inline versions of some standard procedures: */
5052
5053 C_regparm C_word C_fcall C_i_listp(C_word x)
5054 {
5055 C_word fast = x, slow = x;
5056
5057 while(fast != C_SCHEME_END_OF_LIST)
5058 if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
5059 fast = C_u_i_cdr(fast);
5060
5061 if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
5062 else if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
5063 fast = C_u_i_cdr(fast);
5064 slow = C_u_i_cdr(slow);
5065
5066 if(fast == slow) return C_SCHEME_FALSE;
5067 }
5068 else return C_SCHEME_FALSE;
5069 }
5070 else return C_SCHEME_FALSE;
5071
5072 return C_SCHEME_TRUE;
5073 }
5074
5075 C_regparm C_word C_fcall C_i_u8vectorp(C_word x)
5076 {
5077 return C_i_structurep(x, u8vector_symbol);
5078 }
5079
5080 C_regparm C_word C_fcall C_i_s8vectorp(C_word x)
5081 {
5082 return C_i_structurep(x, s8vector_symbol);
5083 }
5084
5085 C_regparm C_word C_fcall C_i_u16vectorp(C_word x)
5086 {
5087 return C_i_structurep(x, u16vector_symbol);
5088 }
5089
5090 C_regparm C_word C_fcall C_i_s16vectorp(C_word x)
5091 {
5092 return C_i_structurep(x, s16vector_symbol);
5093 }
5094
5095 C_regparm C_word C_fcall C_i_u32vectorp(C_word x)
5096 {
5097 return C_i_structurep(x, u32vector_symbol);
5098 }
5099
5100 C_regparm C_word C_fcall C_i_s32vectorp(C_word x)
5101 {
5102 return C_i_structurep(x, s32vector_symbol);
5103 }
5104
5105 C_regparm C_word C_fcall C_i_u64vectorp(C_word x)
5106 {
5107 return C_i_structurep(x, u64vector_symbol);
5108 }
5109
5110 C_regparm C_word C_fcall C_i_s64vectorp(C_word x)
5111 {
5112 return C_i_structurep(x, s64vector_symbol);
5113 }
5114
5115 C_regparm C_word C_fcall C_i_f32vectorp(C_word x)
5116 {
5117 return C_i_structurep(x, f32vector_symbol);
5118 }
5119
5120 C_regparm C_word C_fcall C_i_f64vectorp(C_word x)
5121 {
5122 return C_i_structurep(x, f64vector_symbol);
5123 }
5124
5125
5126 C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
5127 {
5128 C_word n;
5129
5130 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
5131 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);
5132
5133 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
5134 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);
5135
5136 n = C_header_size(x);
5137
5138 return C_mk_bool(n == C_header_size(y)
5139 && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
5140 }
5141
5142
5143 C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
5144 {
5145 C_word n;
5146 char *p1, *p2;
5147
5148 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
5149 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);
5150
5151 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
5152 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);
5153
5154 n = C_header_size(x);
5155
5156 if(n != C_header_size(y)) return C_SCHEME_FALSE;
5157
5158 p1 = (char *)C_data_pointer(x);
5159 p2 = (char *)C_data_pointer(y);
5160
5161 while(n--) {
5162 if(C_tolower((int)(*(p1++))) != C_tolower((int)(*(p2++))))
5163 return C_SCHEME_FALSE;
5164 }
5165
5166 return C_SCHEME_TRUE;
5167 }
5168
5169
5170 C_word C_a_i_list(C_word **a, int c, ...)
5171 {
5172 va_list v;
5173 C_word x, last, current,
5174 first = C_SCHEME_END_OF_LIST;
5175
5176 va_start(v, c);
5177
5178 for(last = C_SCHEME_UNDEFINED; c--; last = current) {
5179 x = va_arg(v, C_word);
5180 current = C_a_pair(a, x, C_SCHEME_END_OF_LIST);
5181
5182 if(last != C_SCHEME_UNDEFINED)
5183 C_set_block_item(last, 1, current);
5184 else first = current;
5185 }
5186
5187 va_end(v);
5188 return first;
5189 }
5190
5191
5192 C_word C_a_i_string(C_word **a, int c, ...)
5193 {
5194 va_list v;
5195 C_word x, s = (C_word)(*a);
5196 char *p;
5197
5198 *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(c));
5199 C_block_header_init(s, C_STRING_TYPE | c);
5200 p = (char *)C_data_pointer(s);
5201 va_start(v, c);
5202
5203 for(; c; c--) {
5204 x = va_arg(v, C_word);
5205
5206 if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
5207 *(p++) = C_character_code(x);
5208 else break;
5209 }
5210
5211 va_end(v);
5212 if (c) barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);
5213 return s;
5214 }
5215
5216
5217 C_word C_a_i_record(C_word **ptr, int n, ...)
5218 {
5219 va_list v;
5220 C_word *p = *ptr,
5221 *p0 = p;
5222
5223 *(p++) = C_STRUCTURE_TYPE | n;
5224 va_start(v, n);
5225
5226 while(n--)
5227 *(p++) = va_arg(v, C_word);
5228
5229 *ptr = p;
5230 va_end(v);
5231 return (C_word)p0;
5232 }
5233
5234
5235 C_word C_a_i_port(C_word **ptr, int n)
5236 {
5237 C_word
5238 *p = *ptr,
5239 *p0 = p;
5240 int i;
5241
5242 *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);
5243 *(p++) = (C_word)NULL;
5244
5245 for(i = 0; i < C_SIZEOF_PORT - 2; ++i)
5246 *(p++) = C_SCHEME_FALSE;
5247
5248 *ptr = p;
5249 return (C_word)p0;
5250 }
5251
5252
5253 C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
5254 {
5255 C_word *p = *ptr,
5256 *p0;
5257 int n = C_unfix(num);
5258
5259 #ifndef C_SIXTY_FOUR
5260 /* Align on 8-byte boundary: */
5261 if(C_aligned8(p)) ++p;
5262 #endif
5263
5264 p0 = p;
5265 *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);
5266 *ptr = p + n;
5267 return (C_word)p0;
5268 }
5269
5270
5271 C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
5272 {
5273 C_word
5274 *p = *ptr,
5275 *p0 = p;
5276 void *mp;
5277
5278 if(C_immediatep(x)) mp = NULL;
5279 else if((C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);
5280 else mp = C_data_pointer(x);
5281
5282 *(p++) = C_POINTER_TYPE | 1;
5283 *((void **)p) = mp;
5284 *ptr = p + 1;
5285 return (C_word)p0;
5286 }
5287
5288 C_regparm C_word C_fcall C_i_nanp(C_word x)
5289 {
5290 if (x & C_FIXNUM_BIT) {
5291 return C_SCHEME_FALSE;
5292 } else if (C_immediatep(x)) {
5293 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
5294 } else if (C_block_header(x) == C_FLONUM_TAG) {
5295 return C_u_i_flonum_nanp(x);
5296 } else if (C_truep(C_bignump(x))) {
5297 return C_SCHEME_FALSE;
5298 } else if (C_block_header(x) == C_RATNUM_TAG) {
5299 return C_SCHEME_FALSE;
5300 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
5301 return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) ||
5302 C_truep(C_i_nanp(C_u_i_cplxnum_imag(x))));
5303 } else {
5304 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
5305 }
5306 }
5307
5308 C_regparm C_word C_fcall C_i_finitep(C_word x)
5309 {
5310 if (x & C_FIXNUM_BIT) {
5311 return C_SCHEME_TRUE;
5312 } else if (C_immediatep(x)) {
5313 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
5314 } else if (C_block_header(x) == C_FLONUM_TAG) {
5315 return C_u_i_flonum_finitep(x);
5316 } else if (C_truep(C_bignump(x))) {
5317 return C_SCHEME_TRUE;
5318 } else if (C_block_header(x) == C_RATNUM_TAG) {
5319 return C_SCHEME_TRUE;
5320 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
5321 return C_and(C_i_finitep(C_u_i_cplxnum_real(x)),
5322 C_i_finitep(C_u_i_cplxnum_imag(x)));
5323 } else {
5324 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
5325 }
5326 }
5327
5328 C_regparm C_word C_fcall C_i_infinitep(C_word x)
5329 {
5330 if (x & C_FIXNUM_BIT) {
5331 return C_SCHEME_FALSE;
5332 } else if (C_immediatep(x)) {
5333 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
5334 } else if (C_block_header(x) == C_FLONUM_TAG) {
5335 return C_u_i_flonum_infinitep(x);
5336 } else if (C_truep(C_bignump(x))) {
5337 return C_SCHEME_FALSE;
5338 } else if (C_block_header(x) == C_RATNUM_TAG) {
5339 return C_SCHEME_FALSE;
5340 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
5341 return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) ||
5342 C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x))));
5343 } else {
5344 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
5345 }
5346 }
5347
5348 C_regparm C_word C_fcall C_i_exactp(C_word x)
5349 {
5350 if (x & C_FIXNUM_BIT) {
5351 return C_SCHEME_TRUE;
5352 } else if (C_immediatep(x)) {
5353 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);
5354 } else if (C_block_header(x) == C_FLONUM_TAG) {
5355 return C_SCHEME_FALSE;
5356 } else if (C_truep(C_bignump(x))) {
5357 return C_SCHEME_TRUE;
5358 } else if (C_block_header(x) == C_RATNUM_TAG) {
5359 return C_SCHEME_TRUE;
5360 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
5361 return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */
5362 } else {
5363 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);
5364 }
5365 }
5366
5367
5368 C_regparm C_word C_fcall C_i_inexactp(C_word x)
5369 {
5370 if (x & C_FIXNUM_BIT) {
5371 return C_SCHEME_FALSE;
5372 } else if (C_immediatep(x)) {
5373 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);
5374 } else if (C_block_header(x) == C_FLONUM_TAG) {
5375 return C_SCHEME_TRUE;
5376 } else if (C_truep(C_bignump(x))) {
5377 return C_SCHEME_FALSE;
5378 } else if (C_block_header(x) == C_RATNUM_TAG) {
5379 return C_SCHEME_FALSE;
5380 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
5381 return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */
5382 } else {
5383 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);
5384 }
5385 }
5386
5387
5388 C_regparm C_word C_fcall C_i_zerop(C_word x)
5389 {
5390 if (x & C_FIXNUM_BIT) {
5391 return C_mk_bool(x == C_fix(0));
5392 } else if (C_immediatep(x)) {
5393 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);
5394 } else if (C_block_header(x) == C_FLONUM_TAG) {
5395 return C_mk_bool(C_flonum_magnitude(x) == 0.0);
5396 } else if (C_block_header(x) == C_BIGNUM_TAG ||
5397 C_block_header(x) == C_RATNUM_TAG ||
5398 C_block_header(x) == C_CPLXNUM_TAG) {
5399 return C_SCHEME_FALSE;
5400 } else {
5401 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);
5402 }
5403 }
5404
5405 /* DEPRECATED */
5406 C_regparm C_word C_fcall C_u_i_zerop(C_word x)
5407 {
5408 return C_mk_bool(x == C_fix(0) ||
5409 (!C_immediatep(x) &&
5410 C_block_header(x) == C_FLONUM_TAG &&
5411 C_flonum_magnitude(x) == 0.0));
5412 }
5413
5414
5415 C_regparm C_word C_fcall C_i_positivep(C_word x)
5416 {
5417 if (x & C_FIXNUM_BIT)
5418 return C_i_fixnum_positivep(x);
5419 else if (C_immediatep(x))
5420 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);
5421 else if (C_block_header(x) == C_FLONUM_TAG)
5422 return C_mk_bool(C_flonum_magnitude(x) > 0.0);
5423 else if (C_truep(C_bignump(x)))
5424 return C_mk_nbool(C_bignum_negativep(x));
5425 else if (C_block_header(x) == C_RATNUM_TAG)
5426 return C_i_integer_positivep(C_u_i_ratnum_num(x));
5427 else if (C_block_header(x) == C_CPLXNUM_TAG)
5428 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x);
5429 else
5430 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);
5431 }
5432
5433 C_regparm C_word C_fcall C_i_integer_positivep(C_word x)
5434 {
5435 if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);
5436 else return C_mk_nbool(C_bignum_negativep(x));
5437 }
5438
5439 C_regparm C_word C_fcall C_i_negativep(C_word x)
5440 {
5441 if (x & C_FIXNUM_BIT)
5442 return C_i_fixnum_negativep(x);
5443 else if (C_immediatep(x))
5444 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);
5445 else if (C_block_header(x) == C_FLONUM_TAG)
5446 return C_mk_bool(C_flonum_magnitude(x) < 0.0);
5447 else if (C_truep(C_bignump(x)))
5448 return C_mk_bool(C_bignum_negativep(x));
5449 else if (C_block_header(x) == C_RATNUM_TAG)
5450 return C_i_integer_negativep(C_u_i_ratnum_num(x));
5451 else if (C_block_header(x) == C_CPLXNUM_TAG)
5452 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x);
5453 else
5454 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);
5455 }
5456
5457
5458 C_regparm C_word C_fcall C_i_integer_negativep(C_word x)
5459 {
5460 if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);
5461 else return C_mk_bool(C_bignum_negativep(x));
5462 }
5463
5464
5465 C_regparm C_word C_fcall C_i_evenp(C_word x)
5466 {
5467 if(x & C_FIXNUM_BIT) {
5468 return C_i_fixnumevenp(x);
5469 } else if(C_immediatep(x)) {
5470 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
5471 } else if (C_block_header(x) == C_FLONUM_TAG) {
5472 double val, dummy;
5473 val = C_flonum_magnitude(x);
5474 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
5475 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
5476 else
5477 return C_mk_bool(fmod(val, 2.0) == 0.0);
5478 } else if (C_truep(C_bignump(x))) {
5479 return C_mk_nbool(C_bignum_digits(x)[0] & 1);
5480 } else { /* No need to try extended number */
5481 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
5482 }
5483 }
5484
5485 C_regparm C_word C_fcall C_i_integer_evenp(C_word x)
5486 {
5487 if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);
5488 return C_mk_nbool(C_bignum_digits(x)[0] & 1);
5489 }
5490
5491
5492 C_regparm C_word C_fcall C_i_oddp(C_word x)
5493 {
5494 if(x & C_FIXNUM_BIT) {
5495 return C_i_fixnumoddp(x);
5496 } else if(C_immediatep(x)) {
5497 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
5498 } else if(C_block_header(x) == C_FLONUM_TAG) {
5499 double val, dummy;
5500 val = C_flonum_magnitude(x);
5501 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)
5502 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
5503 else
5504 return C_mk_bool(fmod(val, 2.0) != 0.0);
5505 } else if (C_truep(C_bignump(x))) {
5506 return C_mk_bool(C_bignum_digits(x)[0] & 1);
5507 } else {
5508 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
5509 }
5510 }
5511
5512
5513 C_regparm C_word C_fcall C_i_integer_oddp(C_word x)
5514 {
5515 if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);
5516 return C_mk_bool(C_bignum_digits(x)[0] & 1);
5517 }
5518
5519
5520 C_regparm C_word C_fcall C_i_car(C_word x)
5521 {
5522 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5523 barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);
5524
5525 return C_u_i_car(x);
5526 }
5527
5528
5529 C_regparm C_word C_fcall C_i_cdr(C_word x)
5530 {
5531 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
5532 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);
5533
5534 return C_u_i_cdr(x);
5535 }
5536
5537
5538 C_regparm C_word C_fcall C_i_caar(C_word x)
5539 {
5540 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5541 bad:
5542 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x);
5543 }
5544
5545 x = C_u_i_car(x);
5546
5547 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5548
5549 return C_u_i_car(x);
5550 }
5551
5552
5553 C_regparm C_word C_fcall C_i_cadr(C_word x)
5554 {
5555 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5556 bad:
5557 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);
5558 }
5559
5560 x = C_u_i_cdr(x);
5561
5562 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5563
5564 return C_u_i_car(x);
5565 }
5566
5567
5568 C_regparm C_word C_fcall C_i_cdar(C_word x)
5569 {
5570 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5571 bad:
5572 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x);
5573 }
5574
5575 x = C_u_i_car(x);
5576
5577 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5578
5579 return C_u_i_cdr(x);
5580 }
5581
5582
5583 C_regparm C_word C_fcall C_i_cddr(C_word x)
5584 {
5585 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5586 bad:
5587 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);
5588 }
5589
5590 x = C_u_i_cdr(x);
5591 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5592
5593 return C_u_i_cdr(x);
5594 }
5595
5596
5597 C_regparm C_word C_fcall C_i_caddr(C_word x)
5598 {
5599 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5600 bad:
5601 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);
5602 }
5603
5604 x = C_u_i_cdr(x);
5605 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5606 x = C_u_i_cdr(x);
5607 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5608
5609 return C_u_i_car(x);
5610 }
5611
5612
5613 C_regparm C_word C_fcall C_i_cdddr(C_word x)
5614 {
5615 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5616 bad:
5617 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);
5618 }
5619
5620 x = C_u_i_cdr(x);
5621 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5622 x = C_u_i_cdr(x);
5623 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5624
5625 return C_u_i_cdr(x);
5626 }
5627
5628
5629 C_regparm C_word C_fcall C_i_cadddr(C_word x)
5630 {
5631 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5632 bad:
5633 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);
5634 }
5635
5636 x = C_u_i_cdr(x);
5637 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5638 x = C_u_i_cdr(x);
5639 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5640 x = C_u_i_cdr(x);
5641 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5642
5643 return C_u_i_car(x);
5644 }
5645
5646
5647 C_regparm C_word C_fcall C_i_cddddr(C_word x)
5648 {
5649 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
5650 bad:
5651 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);
5652 }
5653
5654 x = C_u_i_cdr(x);
5655 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5656 x = C_u_i_cdr(x);
5657 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5658 x = C_u_i_cdr(x);
5659 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
5660
5661 return C_u_i_cdr(x);
5662 }
5663
5664
5665 C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
5666 {
5667 C_word lst0 = lst;
5668 int n;
5669
5670 if(lst != C_SCHEME_END_OF_LIST &&
5671 (C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG))
5672 barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst);
5673
5674 if(i & C_FIXNUM_BIT) n = C_unfix(i);
5675 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);
5676
5677 while(n--) {
5678 if(C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)
5679 barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);
5680
5681 lst = C_u_i_cdr(lst);
5682 }
5683
5684 return lst;
5685 }
5686
5687
5688 C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
5689 {
5690 int j;
5691
5692 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5693 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);
5694
5695 if(i & C_FIXNUM_BIT) {
5696 j = C_unfix(i);
5697
5698 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-ref", v, i);
5699
5700 return C_block_item(v, j);
5701 }
5702
5703 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);
5704 return C_SCHEME_UNDEFINED;
5705 }
5706
5707
5708 C_regparm C_word C_fcall C_i_u8vector_ref(C_word v, C_word i)
5709 {
5710 int j;
5711
5712 if(!C_truep(C_i_u8vectorp(v)))
5713 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", v);
5714
5715 if(i & C_FIXNUM_BIT) {
5716 j = C_unfix(i);
5717
5718 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-ref", v, i);
5719
5720 return C_fix(((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j]);
5721 }
5722
5723 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", i);
5724 return C_SCHEME_UNDEFINED;
5725 }
5726
5727 C_regparm C_word C_fcall C_i_s8vector_ref(C_word v, C_word i)
5728 {
5729 int j;
5730
5731 if(!C_truep(C_i_s8vectorp(v)))
5732 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", v);
5733
5734 if(i & C_FIXNUM_BIT) {
5735 j = C_unfix(i);
5736
5737 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-ref", v, i);
5738
5739 return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);
5740 }
5741
5742 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);
5743 return C_SCHEME_UNDEFINED;
5744 }
5745
5746 C_regparm C_word C_fcall C_i_u16vector_ref(C_word v, C_word i)
5747 {
5748 int j;
5749
5750 if(!C_truep(C_i_u16vectorp(v)))
5751 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", v);
5752
5753 if(i & C_FIXNUM_BIT) {
5754 j = C_unfix(i);
5755
5756 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);
5757
5758 return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);
5759 }
5760
5761 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);
5762 return C_SCHEME_UNDEFINED;
5763 }
5764
5765 C_regparm C_word C_fcall C_i_s16vector_ref(C_word v, C_word i)
5766 {
5767 C_word size;
5768 int j;
5769
5770 if(C_immediatep(v) || C_header_bits(v) != C_STRUCTURE_TYPE ||
5771 C_header_size(v) != 2 || C_block_item(v, 0) != s16vector_symbol)
5772 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", v);
5773
5774 if(i & C_FIXNUM_BIT) {
5775 j = C_unfix(i);
5776
5777 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);
5778
5779 return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);
5780 }
5781
5782 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);
5783 return C_SCHEME_UNDEFINED;
5784 }
5785
5786 C_regparm C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
5787 {
5788 int j;
5789
5790 if(!C_truep(C_i_u32vectorp(v)))
5791 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", v);
5792
5793 if(i & C_FIXNUM_BIT) {
5794 j = C_unfix(i);
5795
5796 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-ref", v, i);
5797
5798 return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);
5799 }
5800
5801 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);
5802 return C_SCHEME_UNDEFINED;
5803 }
5804
5805 C_regparm C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
5806 {
5807 int j;
5808
5809 if(!C_truep(C_i_s32vectorp(v)))
5810 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", v);
5811
5812 if(i & C_FIXNUM_BIT) {
5813 j = C_unfix(i);
5814
5815 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-ref", v, i);
5816
5817 return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);
5818 }
5819
5820 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);
5821 return C_SCHEME_UNDEFINED;
5822 }
5823
5824 C_regparm C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
5825 {
5826 int j;
5827
5828 if(!C_truep(C_i_u64vectorp(v)))
5829 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", v);
5830
5831 if(i & C_FIXNUM_BIT) {
5832 j = C_unfix(i);
5833
5834 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-ref", v, i);
5835
5836 return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);
5837 }
5838
5839 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);
5840 return C_SCHEME_UNDEFINED;
5841 }
5842
5843 C_regparm C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
5844 {
5845 int j;
5846
5847 if(!C_truep(C_i_s64vectorp(v)))
5848 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", v);
5849
5850 if(i & C_FIXNUM_BIT) {
5851 j = C_unfix(i);
5852
5853 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-ref", v, i);
5854
5855 return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);
5856 }
5857
5858 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);
5859 return C_SCHEME_UNDEFINED;
5860 }
5861
5862 C_regparm C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
5863 {
5864 int j;
5865
5866 if(!C_truep(C_i_f32vectorp(v)))
5867 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", v);
5868
5869 if(i & C_FIXNUM_BIT) {
5870 j = C_unfix(i);
5871
5872 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-ref", v, i);
5873
5874 return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);
5875 }
5876
5877 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);
5878 return C_SCHEME_UNDEFINED;
5879 }
5880
5881 C_regparm C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
5882 {
5883 C_word size;
5884 int j;
5885
5886 if(!C_truep(C_i_f64vectorp(v)))
5887 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", v);
5888
5889 if(i & C_FIXNUM_BIT) {
5890 j = C_unfix(i);
5891
5892 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-ref", v, i);
5893
5894 return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);
5895 }
5896
5897 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);
5898 return C_SCHEME_UNDEFINED;
5899 }
5900
5901
5902 C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
5903 {
5904 int j;
5905
5906 if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)
5907 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);
5908
5909 if(i & C_FIXNUM_BIT) {
5910 j = C_unfix(i);
5911
5912 if(j < 0 || j >= C_header_size(x)) barf(C_OUT_OF_RANGE_ERROR, "##sys#block-ref", x, i);
5913
5914 return C_block_item(x, j);
5915 }
5916
5917 barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);
5918 return C_SCHEME_UNDEFINED;
5919 }
5920
5921
5922 C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)
5923 {
5924 int j;
5925
5926 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5927 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);
5928
5929 if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
5930 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);
5931
5932 if(i & C_FIXNUM_BIT) {
5933 j = C_unfix(i);
5934
5935 if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-set!", s, i);
5936
5937 return C_setsubchar(s, i, c);
5938 }
5939
5940 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);
5941 return C_SCHEME_UNDEFINED;
5942 }
5943
5944
5945 C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
5946 {
5947 int j;
5948
5949 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
5950 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);
5951
5952 if(i & C_FIXNUM_BIT) {
5953 j = C_unfix(i);
5954
5955 if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-ref", s, i);
5956
5957 return C_subchar(s, i);
5958 }
5959
5960 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);
5961 return C_SCHEME_UNDEFINED;
5962 }
5963
5964
5965 C_regparm C_word C_fcall C_i_vector_length(C_word v)
5966 {
5967 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
5968 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);
5969
5970 return C_fix(C_header_size(v));
5971 }
5972
5973 C_regparm C_word C_fcall C_i_u8vector_length(C_word v)
5974 {
5975 if(!C_truep(C_i_u8vectorp(v)))
5976 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-length", v);
5977
5978 return C_fix(C_header_size(C_block_item(v, 1)));
5979 }
5980
5981 C_regparm C_word C_fcall C_i_s8vector_length(C_word v)
5982 {
5983 if(!C_truep(C_i_s8vectorp(v)))
5984 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);
5985
5986 return C_fix(C_header_size(C_block_item(v, 1)));
5987 }
5988
5989 C_regparm C_word C_fcall C_i_u16vector_length(C_word v)
5990 {
5991 if(!C_truep(C_i_u16vectorp(v)))
5992 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);
5993
5994 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);
5995 }
5996
5997 C_regparm C_word C_fcall C_i_s16vector_length(C_word v)
5998 {
5999 if(!C_truep(C_i_s16vectorp(v)))
6000 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);
6001
6002 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);
6003 }
6004
6005 C_regparm C_word C_fcall C_i_u32vector_length(C_word v)
6006 {
6007 if(!C_truep(C_i_u32vectorp(v)))
6008 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);
6009
6010 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
6011 }
6012
6013 C_regparm C_word C_fcall C_i_s32vector_length(C_word v)
6014 {
6015 if(!C_truep(C_i_s32vectorp(v)))
6016 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);
6017
6018 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
6019 }
6020
6021 C_regparm C_word C_fcall C_i_u64vector_length(C_word v)
6022 {
6023 if(!C_truep(C_i_u64vectorp(v)))
6024 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);
6025
6026 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
6027 }
6028
6029 C_regparm C_word C_fcall C_i_s64vector_length(C_word v)
6030 {
6031 if(!C_truep(C_i_s64vectorp(v)))
6032 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);
6033
6034 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
6035 }
6036
6037
6038 C_regparm C_word C_fcall C_i_f32vector_length(C_word v)
6039 {
6040 if(!C_truep(C_i_f32vectorp(v)))
6041 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);
6042
6043 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
6044 }
6045
6046 C_regparm C_word C_fcall C_i_f64vector_length(C_word v)
6047 {
6048 if(!C_truep(C_i_f64vectorp(v)))
6049 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);
6050
6051 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
6052 }
6053
6054
6055 C_regparm C_word C_fcall C_i_string_length(C_word s)
6056 {
6057 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
6058 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);
6059
6060 return C_fix(C_header_size(s));
6061 }
6062
6063
6064 C_regparm C_word C_fcall C_i_length(C_word lst)
6065 {
6066 C_word fast = lst, slow = lst;
6067 int n = 0;
6068
6069 while(slow != C_SCHEME_END_OF_LIST) {
6070 if(fast != C_SCHEME_END_OF_LIST) {
6071 if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
6072 fast = C_u_i_cdr(fast);
6073
6074 if(fast != C_SCHEME_END_OF_LIST) {
6075 if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
6076 fast = C_u_i_cdr(fast);
6077 }
6078 else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
6079 }
6080
6081 if(fast == slow)
6082 barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);
6083 }
6084 }
6085
6086 if(C_immediatep(slow) || C_block_header(slow) != C_PAIR_TAG)
6087 barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
6088
6089 slow = C_u_i_cdr(slow);
6090 ++n;
6091 }
6092
6093 return C_fix(n);
6094 }
6095
6096
6097 C_regparm C_word C_fcall C_u_i_length(C_word lst)
6098 {
6099 int n = 0;
6100
6101 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
6102 lst = C_u_i_cdr(lst);
6103 ++n;
6104 }
6105
6106 return C_fix(n);
6107 }
6108
6109 C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
6110 {
6111 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
6112 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);
6113
6114 C_mutate(&C_u_i_car(x), val);
6115 return C_SCHEME_UNDEFINED;
6116 }
6117
6118
6119 C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
6120 {
6121 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
6122 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);
6123
6124 C_mutate(&C_u_i_cdr(x), val);
6125 return C_SCHEME_UNDEFINED;
6126 }
6127
6128
6129 C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
6130 {
6131 int j;
6132
6133 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
6134 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);
6135
6136 if(i & C_FIXNUM_BIT) {
6137 j = C_unfix(i);
6138
6139 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-set!", v, i);
6140
6141 C_mutate(&C_block_item(v, j), x);
6142 }
6143 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);
6144
6145 return C_SCHEME_UNDEFINED;
6146 }
6147
6148
6149 C_regparm C_word C_fcall C_i_u8vector_set(C_word v, C_word i, C_word x)
6150 {
6151 int j;
6152 C_word n;
6153
6154 if(!C_truep(C_i_u8vectorp(v)))
6155 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", v);
6156
6157 if(i & C_FIXNUM_BIT) {
6158 j = C_unfix(i);
6159
6160 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", v, i);
6161
6162 if(x & C_FIXNUM_BIT) {
6163 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 8) n = C_unfix(x);
6164 else barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", x);
6165 }
6166 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", x);
6167 }
6168 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", i);
6169
6170 ((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6171 return C_SCHEME_UNDEFINED;
6172 }
6173
6174 C_regparm C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x)
6175 {
6176 int j;
6177 C_word n;
6178
6179 if(!C_truep(C_i_s8vectorp(v)))
6180 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", v);
6181
6182 if(i & C_FIXNUM_BIT) {
6183 j = C_unfix(i);
6184
6185 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-set!", v, i);
6186
6187 if(x & C_FIXNUM_BIT) {
6188 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);
6189 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);
6190 }
6191 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);
6192 }
6193 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", i);
6194
6195 ((signed char *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6196 return C_SCHEME_UNDEFINED;
6197 }
6198
6199 C_regparm C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x)
6200 {
6201 int j;
6202 C_word n;
6203
6204 if(!C_truep(C_i_u16vectorp(v)))
6205 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", v);
6206
6207 if(i & C_FIXNUM_BIT) {
6208 j = C_unfix(i);
6209
6210 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);
6211
6212 if(x & C_FIXNUM_BIT) {
6213 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);
6214 else barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", x);
6215 }
6216 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);
6217 }
6218 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", i);
6219
6220 ((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6221 return C_SCHEME_UNDEFINED;
6222 }
6223
6224 C_regparm C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x)
6225 {
6226 int j;
6227 C_word n;
6228
6229 if(!C_truep(C_i_s16vectorp(v)))
6230 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", v);
6231
6232 if(i & C_FIXNUM_BIT) {
6233 j = C_unfix(i);
6234
6235 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);
6236
6237 if(x & C_FIXNUM_BIT) {
6238 if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);
6239 else barf(C_OUT_OF_RANGE_ERROR, "s16vector-set!", x);
6240 }
6241 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);
6242 }
6243 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", i);
6244
6245 ((short *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6246 return C_SCHEME_UNDEFINED;
6247 }
6248
6249 C_regparm C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x)
6250 {
6251 int j;
6252 C_u32 n;
6253
6254 if(!C_truep(C_i_u32vectorp(v)))
6255 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", v);
6256
6257 if(i & C_FIXNUM_BIT) {
6258 j = C_unfix(i);
6259
6260 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", v, i);
6261
6262 if(C_truep(C_i_exact_integerp(x))) {
6263 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);
6264 else barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", x);
6265 }
6266 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);
6267 }
6268 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", i);
6269
6270 ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6271 return C_SCHEME_UNDEFINED;
6272 }
6273
6274 C_regparm C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x)
6275 {
6276 int j;
6277 C_s32 n;
6278
6279 if(!C_truep(C_i_s32vectorp(v)))
6280 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", v);
6281
6282 if(i & C_FIXNUM_BIT) {
6283 j = C_unfix(i);
6284
6285 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", v, i);
6286
6287 if(C_truep(C_i_exact_integerp(x))) {
6288 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);
6289 else barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", x);
6290 }
6291 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);
6292 }
6293 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", i);
6294
6295 ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6296 return C_SCHEME_UNDEFINED;
6297 }
6298
6299 C_regparm C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x)
6300 {
6301 int j;
6302 C_u64 n;
6303
6304 if(!C_truep(C_i_u64vectorp(v)))
6305 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", v);
6306
6307 if(i & C_FIXNUM_BIT) {
6308 j = C_unfix(i);
6309
6310 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", v, i);
6311
6312 if(C_truep(C_i_exact_integerp(x))) {
6313 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);
6314 else barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", x);
6315 }
6316 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);
6317 }
6318 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", i);
6319
6320 ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6321 return C_SCHEME_UNDEFINED;
6322 }
6323
6324 C_regparm C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x)
6325 {
6326 int j;
6327 C_s64 n;
6328
6329 if(!C_truep(C_i_s64vectorp(v)))
6330 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", v);
6331
6332 if(i & C_FIXNUM_BIT) {
6333 j = C_unfix(i);
6334
6335 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", v, i);
6336
6337 if(C_truep(C_i_exact_integerp(x))) {
6338 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);
6339 else barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", x);
6340 }
6341 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);
6342 }
6343 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", i);
6344
6345 ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;
6346 return C_SCHEME_UNDEFINED;
6347 }
6348
6349 C_regparm C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x)
6350 {
6351 int j;
6352 double f;
6353
6354 if(!C_truep(C_i_f32vectorp(v)))
6355 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", v);
6356
6357 if(i & C_FIXNUM_BIT) {
6358 j = C_unfix(i);
6359
6360 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-set!", v, i);
6361
6362 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);
6363 else if(x & C_FIXNUM_BIT) f = C_unfix(x);
6364 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);
6365 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", x);
6366 }
6367 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);
6368
6369 ((float *)C_data_pointer(C_block_item(v, 1)))[j] = (float)f;
6370 return C_SCHEME_UNDEFINED;
6371 }
6372
6373 C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x)
6374 {
6375 int j;
6376 double f;
6377
6378 if(!C_truep(C_i_f64vectorp(v)))
6379 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", v);
6380
6381 if(i & C_FIXNUM_BIT) {
6382 j = C_unfix(i);
6383
6384 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-set!", v, i);
6385
6386 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);
6387 else if(x & C_FIXNUM_BIT) f = C_unfix(x);
6388 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);
6389 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", x);
6390
6391 }
6392 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);
6393
6394 ((double *)C_data_pointer(C_block_item(v, 1)))[j] = f;
6395 return C_SCHEME_UNDEFINED;
6396 }
6397
6398
6399 /* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */
6400 C_regparm C_word C_fcall
6401 C_s_a_i_abs(C_word **ptr, C_word n, C_word x)
6402 {
6403 if (x & C_FIXNUM_BIT) {
6404 return C_a_i_fixnum_abs(ptr, 1, x);
6405 } else if (C_immediatep(x)) {
6406 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);
6407 } else if (C_block_header(x) == C_FLONUM_TAG) {
6408 return C_a_i_flonum_abs(ptr, 1, x);
6409 } else if (C_truep(C_bignump(x))) {
6410 return C_s_a_u_i_integer_abs(ptr, 1, x);
6411 } else if (C_block_header(x) == C_RATNUM_TAG) {
6412 return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)),
6413 C_u_i_ratnum_denom(x));
6414 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
6415 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x);
6416 } else {
6417 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);
6418 }
6419 }
6420
6421 void C_ccall C_signum(C_word c, C_word *av)
6422 {
6423 C_word k = av[ 1 ], x, y;
6424
6425 if (c != 3) C_bad_argc_2(c, 3, av[ 0 ]);
6426
6427 x = av[ 2 ];
6428 y = av[ 3 ];
6429
6430 if (x & C_FIXNUM_BIT) {
6431 C_kontinue(k, C_i_fixnum_signum(x));
6432 } else if (C_immediatep(x)) {
6433 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);
6434 } else if (C_block_header(x) == C_FLONUM_TAG) {
6435 C_word *a = C_alloc(C_SIZEOF_FLONUM);
6436 C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));
6437 } else if (C_truep(C_bignump(x))) {
6438 C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));
6439 } else {
6440 try_extended_number("##sys#extended-signum", 2, k, x);
6441 }
6442 }
6443
6444
6445 /* The maximum this can allocate is a cplxnum which consists of two
6446 * ratnums that consist of 2 fix bignums each. So that's
6447 * C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!
6448 */
6449 C_regparm C_word C_fcall
6450 C_s_a_i_negate(C_word **ptr, C_word n, C_word x)
6451 {
6452 if (x & C_FIXNUM_BIT) {
6453 return C_a_i_fixnum_negate(ptr, 1, x);
6454 } else if (C_immediatep(x)) {
6455 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
6456 } else if (C_block_header(x) == C_FLONUM_TAG) {
6457 return C_a_i_flonum_negate(ptr, 1, x);
6458 } else if (C_truep(C_bignump(x))) {
6459 return C_s_a_u_i_integer_negate(ptr, 1, x);
6460 } else if (C_block_header(x) == C_RATNUM_TAG) {
6461 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)),
6462 C_u_i_ratnum_denom(x));
6463 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
6464 return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)),
6465 C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x)));
6466 } else {
6467 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
6468 }
6469 }
6470
6471 /* Copy all the digits from source to target, obliterating what was
6472 * there. If target is larger than source, the most significant
6473 * digits will remain untouched.
6474 */
6475 inline static void bignum_digits_destructive_copy(C_word target, C_word source)
6476 {
6477 C_memcpy(C_bignum_digits(target), C_bignum_digits(source),
6478 C_wordstobytes(C_bignum_size(source)));
6479 }
6480
6481 C_regparm C_word C_fcall
6482 C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)
6483 {
6484 if (x & C_FIXNUM_BIT) {
6485 return C_a_i_fixnum_negate(ptr, 1, x);
6486 } else {
6487 if (C_bignum_negated_fitsinfixnump(x)) {
6488 return C_fix(C_MOST_NEGATIVE_FIXNUM);
6489 } else {
6490 C_word res, negp = C_mk_nbool(C_bignum_negativep(x)),
6491 size = C_fix(C_bignum_size(x));
6492 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);
6493 bignum_digits_destructive_copy(res, x);
6494 return C_bignum_simplify(res);
6495 }
6496 }
6497 }
6498
6499
6500 /* Faster version that ignores sign */
6501 inline static int integer_length_abs(C_word x)
6502 {
6503 if (x & C_FIXNUM_BIT) {
6504 return C_ilen(C_wabs(C_unfix(x)));
6505 } else {
6506 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,
6507 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,
6508 last_digit_length = C_ilen(*last_digit);
6509 return result + last_digit_length;
6510 }
6511 }
6512
6513 C_regparm C_word C_fcall C_i_integer_length(C_word x)
6514 {
6515 if (x & C_FIXNUM_BIT) {
6516 return C_i_fixnum_length(x);
6517 } else if (C_truep(C_i_bignump(x))) {
6518 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,
6519 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,
6520 last_digit_length = C_ilen(*last_digit);
6521
6522 /* If *only* the highest bit is set, negating will give one less bit */
6523 if (C_bignum_negativep(x) &&
6524 *last_digit == ((C_uword)1 << (last_digit_length-1))) {
6525 C_uword *startx = C_bignum_digits(x);
6526 while (startx < last_digit && *startx == 0) ++startx;
6527 if (startx == last_digit) result--;
6528 }
6529 return C_fix(result + last_digit_length);
6530 } else {
6531 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "integer-length", x);
6532 }
6533 }
6534
6535 /* This is currently only used by Karatsuba multiplication and
6536 * Burnikel-Ziegler division. */
6537 static C_regparm C_word
6538 bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end)
6539 {
6540 if (x & C_FIXNUM_BIT) { /* Needed? */
6541 if (C_unfix(start) == 0 && (end == C_SCHEME_FALSE || C_unfix(end) > 0))
6542 return x;
6543 else
6544 return C_fix(0);
6545 } else {
6546 C_word negp, size;
6547
6548 negp = C_mk_bool(C_bignum_negativep(x)); /* Always false */
6549
6550 start = C_unfix(start);
6551 /* We might get passed larger values than actually fits; pad w/ zeroes */
6552 if (end == C_SCHEME_FALSE) end = C_bignum_size(x);
6553 else end = nmin(C_unfix(end), C_bignum_size(x));
6554 assert(start >= 0);
6555
6556 size = end - start;
6557
6558 if (size == 0 || start >= C_bignum_size(x)) {
6559 return C_fix(0);
6560 } else {
6561 C_uword res, *res_digits, *x_digits;
6562 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
6563 res_digits = C_bignum_digits(res);
6564 x_digits = C_bignum_digits(x);
6565 /* Can't use bignum_digits_destructive_copy because that assumes
6566 * target is at least as big as source.
6567 */
6568 C_memcpy(res_digits, x_digits + start, C_wordstobytes(end - start));
6569 return C_bignum_simplify(res);
6570 }
6571 }
6572 }
6573
6574 /* This returns a tmp bignum negated copy of X (must be freed!) when
6575 * the number is negative, or #f if it doesn't need to be negated.
6576 * The size can be larger or smaller than X (it may be 1-padded).
6577 */
6578 inline static C_word maybe_negate_bignum_for_bitwise_op(C_word x, C_word size)
6579 {
6580 C_word nx = C_SCHEME_FALSE, xsize;
6581 if (C_bignum_negativep(x)) {
6582 nx = allocate_tmp_bignum(C_fix(size), C_SCHEME_FALSE, C_SCHEME_FALSE);
6583 xsize = C_bignum_size(x);
6584 /* Copy up until requested size, and init any remaining upper digits */
6585 C_memcpy(C_bignum_digits(nx), C_bignum_digits(x),
6586 C_wordstobytes(nmin(size, xsize)));
6587 if (size > xsize)
6588 C_memset(C_bignum_digits(nx)+xsize, 0, C_wordstobytes(size-xsize));
6589 bignum_digits_destructive_negate(nx);
6590 }
6591 return nx;
6592 }
6593
6594 /* DEPRECATED */
6595 C_regparm C_word C_fcall C_i_bit_to_bool(C_word n, C_word i)
6596 {
6597 if (!C_truep(C_i_exact_integerp(n))) {
6598 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit->boolean", n);
6599 } else if (!(i & C_FIXNUM_BIT)) {
6600 if (!C_immediatep(i) && C_truep(C_bignump(i)) && !C_bignum_negativep(i)) {
6601 return C_i_integer_negativep(n); /* A bit silly, but strictly correct */
6602 } else {
6603 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);
6604 }
6605 } else if (i & C_INT_SIGN_BIT) {
6606 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);
6607 } else {
6608 i = C_unfix(i);
6609 if (n & C_FIXNUM_BIT) {
6610 if (i >= C_WORD_SIZE) return C_mk_bool(n & C_INT_SIGN_BIT);
6611 else return C_mk_bool((C_unfix(n) & ((C_word)1 << i)) != 0);
6612 } else {
6613 C_word nn, d;
6614 d = i / C_BIGNUM_DIGIT_LENGTH;
6615 if (d >= C_bignum_size(n)) return C_mk_bool(C_bignum_negativep(n));
6616
6617 /* TODO: this isn't necessary, is it? */
6618 if (C_truep(nn = maybe_negate_bignum_for_bitwise_op(n, d))) n = nn;
6619
6620 i %= C_BIGNUM_DIGIT_LENGTH;
6621 d = C_mk_bool((C_bignum_digits(n)[d] & (C_uword)1 << i) != 0);
6622 if (C_truep(nn)) free_tmp_bignum(nn);
6623 return d;
6624 }
6625 }
6626 }
6627
6628 C_regparm C_word C_fcall
6629 C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)
6630 {
6631 if ((x & y) & C_FIXNUM_BIT) {
6632 return C_u_fixnum_and(x, y);
6633 } else if (!C_truep(C_i_exact_integerp(x))) {
6634 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", x);
6635 } else if (!C_truep(C_i_exact_integerp(y))) {
6636 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", y);
6637 } else {
6638 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;
6639 C_uword *scanr, *endr, *scans1, *ends1, *scans2;
6640
6641 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
6642 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
6643
6644 negp = C_mk_bool(C_bignum_negativep(x) && C_bignum_negativep(y));
6645 /* Allow negative 1-bits to propagate */
6646 if (C_bignum_negativep(x) || C_bignum_negativep(y))
6647 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;
6648 else
6649 size = nmin(C_bignum_size(x), C_bignum_size(y));
6650
6651 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
6652 scanr = C_bignum_digits(res);
6653 endr = scanr + C_bignum_size(res);
6654
6655 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
6656 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
6657
6658 if (C_bignum_size(x) < C_bignum_size(y)) {
6659 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
6660 scans2 = C_bignum_digits(y);
6661 } else {
6662 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
6663 scans2 = C_bignum_digits(x);
6664 }
6665
6666 while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;
6667 C_memset(scanr, 0, C_wordstobytes(endr - scanr));
6668
6669 if (C_truep(nx)) free_tmp_bignum(nx);
6670 if (C_truep(ny)) free_tmp_bignum(ny);
6671 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
6672
6673 return C_bignum_simplify(res);
6674 }
6675 }
6676
6677 void C_ccall C_bitwise_and(C_word c, C_word *av)
6678 {
6679 /* C_word closure = av[ 0 ]; */
6680 C_word k = av[ 1 ];
6681 C_word next_val, result, prev_result;
6682 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
6683
6684 c -= 2;
6685 av += 2;
6686
6687 if (c == 0) C_kontinue(k, C_fix(-1));
6688
6689 prev_result = result = *(av++);
6690
6691 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))
6692 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", result);
6693
6694 while (c--) {
6695 next_val = *(av++);
6696 a = ab[c&1]; /* One may hold last iteration result, the other is unused */
6697 result = C_s_a_i_bitwise_and(&a, 2, result, next_val);
6698 result = move_buffer_object(&a, ab[(c+1)&1], result);
6699 clear_buffer_object(ab[(c+1)&1], prev_result);
6700 prev_result = result;
6701 }
6702
6703 C_kontinue(k, result);
6704 }
6705
6706 C_regparm C_word C_fcall
6707 C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)
6708 {
6709 if ((x & y) & C_FIXNUM_BIT) {
6710 return C_u_fixnum_or(x, y);
6711 } else if (!C_truep(C_i_exact_integerp(x))) {
6712 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", x);
6713 } else if (!C_truep(C_i_exact_integerp(y))) {
6714 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", y);
6715 } else {
6716 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;
6717 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;
6718
6719 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
6720 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
6721
6722 negp = C_mk_bool(C_bignum_negativep(x) || C_bignum_negativep(y));
6723 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;
6724 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
6725 scanr = C_bignum_digits(res);
6726 endr = scanr + C_bignum_size(res);
6727
6728 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
6729 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
6730
6731 if (C_bignum_size(x) < C_bignum_size(y)) {
6732 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
6733 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);
6734 } else {
6735 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
6736 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);
6737 }
6738
6739 while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;
6740 while (scans2 < ends2) *scanr++ = *scans2++;
6741 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */
6742 assert(scanr == endr);
6743
6744 if (C_truep(nx)) free_tmp_bignum(nx);
6745 if (C_truep(ny)) free_tmp_bignum(ny);
6746 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
6747
6748 return C_bignum_simplify(res);
6749 }
6750 }
6751
6752 void C_ccall C_bitwise_ior(C_word c, C_word *av)
6753 {
6754 /* C_word closure = av[ 0 ]; */
6755 C_word k = av[ 1 ];
6756 C_word next_val, result, prev_result;
6757 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
6758
6759 c -= 2;
6760 av += 2;
6761
6762 if (c == 0) C_kontinue(k, C_fix(0));
6763
6764 prev_result = result = *(av++);
6765
6766 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))
6767 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", result);
6768
6769 while (c--) {
6770 next_val = *(av++);
6771 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */
6772 result = C_s_a_i_bitwise_ior(&a, 2, result, next_val);
6773 result = move_buffer_object(&a, ab[(c+1)&1], result);
6774 clear_buffer_object(ab[(c+1)&1], prev_result);
6775 prev_result = result;
6776 }
6777
6778 C_kontinue(k, result);
6779 }
6780
6781 C_regparm C_word C_fcall
6782 C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)
6783 {
6784 if ((x & y) & C_FIXNUM_BIT) {
6785 return C_fixnum_xor(x, y);
6786 } else if (!C_truep(C_i_exact_integerp(x))) {
6787 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", x);
6788 } else if (!C_truep(C_i_exact_integerp(y))) {
6789 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", y);
6790 } else {
6791 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;
6792 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;
6793
6794 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
6795 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
6796
6797 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;
6798 negp = C_mk_bool(C_bignum_negativep(x) != C_bignum_negativep(y));
6799 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
6800 scanr = C_bignum_digits(res);
6801 endr = scanr + C_bignum_size(res);
6802
6803 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
6804 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
6805
6806 if (C_bignum_size(x) < C_bignum_size(y)) {
6807 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
6808 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);
6809 } else {
6810 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
6811 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);
6812 }
6813
6814 while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;
6815 while (scans2 < ends2) *scanr++ = *scans2++;
6816 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */
6817 assert(scanr == endr);
6818
6819 if (C_truep(nx)) free_tmp_bignum(nx);
6820 if (C_truep(ny)) free_tmp_bignum(ny);
6821 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
6822
6823 return C_bignum_simplify(res);
6824 }
6825 }
6826
6827 void C_ccall C_bitwise_xor(C_word c, C_word *av)
6828 {
6829 /* C_word closure = av[ 0 ]; */
6830 C_word k = av[ 1 ];
6831 C_word next_val, result, prev_result;
6832 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
6833
6834 c -= 2;
6835 av += 2;
6836
6837 if (c == 0) C_kontinue(k, C_fix(0));
6838
6839 prev_result = result = *(av++);
6840
6841 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))
6842 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", result);
6843
6844 while (c--) {
6845 next_val = *(av++);
6846 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */
6847 result = C_s_a_i_bitwise_xor(&a, 2, result, next_val);
6848 result = move_buffer_object(&a, ab[(c+1)&1], result);
6849 clear_buffer_object(ab[(c+1)&1], prev_result);
6850 prev_result = result;
6851 }
6852
6853 C_kontinue(k, result);
6854 }
6855
6856 C_regparm C_word C_fcall
6857 C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)
6858 {
6859 if (!C_truep(C_i_exact_integerp(x))) {
6860 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-not", x);
6861 } else {
6862 return C_s_a_u_i_integer_minus(ptr, 2, C_fix(-1), x);
6863 }
6864 }
6865
6866 C_regparm C_word C_fcall
6867 C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)
6868 {
6869 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, size, negp, res,
6870 digit_offset, bit_offset;
6871
6872 if (!(y & C_FIXNUM_BIT))
6873 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", y);
6874
6875 y = C_unfix(y);
6876 if (y == 0 || x == C_fix(0)) { /* Done (no shift) */
6877 return x;
6878 } else if (x & C_FIXNUM_BIT) {
6879 if (y < 0) {
6880 /* Don't shift more than a word's length (that's undefined in C!) */
6881 if (-y < C_WORD_SIZE) {
6882 return C_fix(C_unfix(x) >> -y);
6883 } else {
6884 return (x < 0) ? C_fix(-1) : C_fix(0);
6885 }
6886 } else if (y > 0 && y < C_WORD_SIZE-2 &&
6887 /* After shifting, the length still fits a fixnum */
6888 (C_ilen(C_unfix(x)) + y) < C_WORD_SIZE-2) {
6889 return C_fix((C_uword)C_unfix(x) << y);
6890 } else {
6891 x = C_a_u_i_fix_to_big(&a, x);
6892 }
6893 } else if (!C_truep(C_i_bignump(x))) {
6894 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "arithmetic-shift", x);
6895 }
6896
6897 negp = C_mk_bool(C_bignum_negativep(x));
6898
6899 if (y > 0) { /* Shift left */
6900 C_uword *startr, *startx, *endx, *endr;
6901
6902 digit_offset = y / C_BIGNUM_DIGIT_LENGTH;
6903 bit_offset = y % C_BIGNUM_DIGIT_LENGTH;
6904
6905 size = C_fix(C_bignum_size(x) + digit_offset + 1);
6906 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);
6907
6908 startr = C_bignum_digits(res);
6909 endr = startr + C_bignum_size(res);
6910
6911 startx = C_bignum_digits(x);
6912 endx = startx + C_bignum_size(x);
6913
6914 /* Initialize only the lower digits we're skipping and the MSD */
6915 C_memset(startr, 0, C_wordstobytes(digit_offset));
6916 *(endr-1) = 0;
6917 startr += digit_offset;
6918 /* Can't use bignum_digits_destructive_copy because it assumes
6919 * we want to copy from the start.
6920 */
6921 C_memcpy(startr, startx, C_wordstobytes(endx-startx));
6922 if(bit_offset > 0)
6923 bignum_digits_destructive_shift_left(startr, endr, bit_offset);
6924
6925 return C_bignum_simplify(res);
6926 } else if (-y >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) {
6927 /* All bits are shifted out, just return 0 or -1 */
6928 return C_truep(negp) ? C_fix(-1) : C_fix(0);
6929 } else { /* Shift right */
6930 C_uword *startr, *startx, *endr;
6931 C_word nx;
6932
6933 digit_offset = -y / C_BIGNUM_DIGIT_LENGTH;
6934 bit_offset = -y % C_BIGNUM_DIGIT_LENGTH;
6935
6936 size = C_fix(C_bignum_size(x) - digit_offset);
6937 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);
6938
6939 startr = C_bignum_digits(res);
6940 endr = startr + C_bignum_size(res);
6941
6942 size = C_bignum_size(x) + 1;
6943 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) {
6944 startx = C_bignum_digits(nx) + digit_offset;
6945 } else {
6946 startx = C_bignum_digits(x) + digit_offset;
6947 }
6948 /* Can't use bignum_digits_destructive_copy because that assumes
6949 * target is at least as big as source.
6950 */
6951 C_memcpy(startr, startx, C_wordstobytes(endr-startr));
6952 if(bit_offset > 0)
6953 bignum_digits_destructive_shift_right(startr,endr,bit_offset,C_truep(nx));
6954
6955 if (C_truep(nx)) {
6956 free_tmp_bignum(nx);
6957 bignum_digits_destructive_negate(res);
6958 }
6959 return C_bignum_simplify(res);
6960 }
6961 }
6962
6963
6964 C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
6965 {
6966 double f;
6967
6968 C_check_real(n, "exp", f);
6969 return C_flonum(a, exp(f));
6970 }
6971
6972
6973 C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
6974 {
6975 double f;
6976
6977 C_check_real(n, "log", f);
6978 return C_flonum(a, log(f));
6979 }
6980
6981
6982 C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
6983 {
6984 double f;
6985
6986 C_check_real(n, "sin", f);
6987 return C_flonum(a, sin(f));
6988 }
6989
6990
6991 C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
6992 {
6993 double f;
6994
6995 C_check_real(n, "cos", f);
6996 return C_flonum(a, cos(f));
6997 }
6998
6999
7000 C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
7001 {
7002 double f;
7003
7004 C_check_real(n, "tan", f);
7005 return C_flonum(a, tan(f));
7006 }
7007
7008
7009 C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
7010 {
7011 double f;
7012
7013 C_check_real(n, "asin", f);
7014 return C_flonum(a, asin(f));
7015 }
7016
7017
7018 C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
7019 {
7020 double f;
7021
7022 C_check_real(n, "acos", f);
7023 return C_flonum(a, acos(f));
7024 }
7025
7026
7027 C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
7028 {
7029 double f;
7030
7031 C_check_real(n, "atan", f);
7032 return C_flonum(a, atan(f));
7033 }
7034
7035
7036 C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
7037 {
7038 double f1, f2;
7039
7040 C_check_real(n1, "atan", f1);
7041 C_check_real(n2, "atan", f2);
7042 return C_flonum(a, atan2(f1, f2));
7043 }
7044
7045
7046 C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
7047 {
7048 double f;
7049
7050 C_check_real(n, "sqrt", f);
7051 return C_flonum(a, sqrt(f));
7052 }
7053
7054
7055 C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
7056 {
7057 C_word a;
7058
7059 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
7060 a = C_u_i_car(lst);
7061
7062 if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
7063 if(C_u_i_car(a) == x) return a;
7064 }
7065 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);
7066
7067 lst = C_u_i_cdr(lst);
7068 }
7069
7070 if(lst!=C_SCHEME_END_OF_LIST)
7071 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", lst);
7072
7073 return C_SCHEME_FALSE;
7074 }
7075
7076
7077 C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
7078 {
7079 C_word a;
7080
7081 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
7082 a = C_u_i_car(lst);
7083
7084 if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
7085 if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;
7086 }
7087 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);
7088
7089 lst = C_u_i_cdr(lst);
7090 }
7091
7092 if(lst!=C_SCHEME_END_OF_LIST)
7093 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", lst);
7094
7095 return C_SCHEME_FALSE;
7096 }
7097
7098
7099 C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
7100 {
7101 C_word a;
7102
7103 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
7104 a = C_u_i_car(lst);
7105
7106 if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
7107 if(C_equalp(C_u_i_car(a), x)) return a;
7108 }
7109 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);
7110
7111 lst = C_u_i_cdr(lst);
7112 }
7113
7114 if(lst!=C_SCHEME_END_OF_LIST)
7115 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", lst);
7116
7117 return C_SCHEME_FALSE;
7118 }
7119
7120
7121 C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
7122 {
7123 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
7124 if(C_u_i_car(lst) == x) return lst;
7125 else lst = C_u_i_cdr(lst);
7126 }
7127
7128 if(lst!=C_SCHEME_END_OF_LIST)
7129 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memq", lst);
7130
7131 return C_SCHEME_FALSE;
7132 }
7133
7134
7135 C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
7136 {
7137 while(!C_immediatep(lst)) {
7138 if(C_u_i_car(lst) == x) return lst;
7139 else lst = C_u_i_cdr(lst);
7140 }
7141
7142 return C_SCHEME_FALSE;
7143 }
7144
7145
7146 C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
7147 {
7148 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
7149 if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;
7150 else lst = C_u_i_cdr(lst);
7151 }
7152
7153 if(lst!=C_SCHEME_END_OF_LIST)
7154 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);
7155
7156 return C_SCHEME_FALSE;
7157 }
7158
7159
7160 C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
7161 {
7162 while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
7163 if(C_equalp(C_u_i_car(lst), x)) return lst;
7164 else lst = C_u_i_cdr(lst);
7165 }
7166
7167 if(lst!=C_SCHEME_END_OF_LIST)
7168 barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", lst);
7169
7170 return C_SCHEME_FALSE;
7171 }
7172
7173
7174 /* Inline routines for extended bindings: */
7175
7176 C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
7177 {
7178 if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {
7179 error_location = loc;
7180 barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);
7181 }
7182
7183 return C_SCHEME_UNDEFINED;
7184 }
7185
7186 C_regparm C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc)
7187 {
7188 if(!(x & C_FIXNUM_BIT)) {
7189 error_location = loc;
7190 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
7191 }
7192
7193 return C_SCHEME_UNDEFINED;
7194 }
7195
7196 /* DEPRECATED */
7197 C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
7198 {
7199 if(C_u_i_exactp(x) == C_SCHEME_FALSE) {
7200 error_location = loc;
7201 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR, NULL, x);
7202 }
7203
7204 return C_SCHEME_UNDEFINED;
7205 }
7206
7207
7208 C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
7209 {
7210 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {
7211 error_location = loc;
7212 barf(C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR, NULL, x);
7213 }
7214
7215 return C_SCHEME_UNDEFINED;
7216 }
7217
7218
7219 C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
7220 {
7221 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
7222 error_location = loc;
7223 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
7224 }
7225
7226 return C_SCHEME_UNDEFINED;
7227 }
7228
7229
7230 C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
7231 {
7232 if (C_i_numberp(x) == C_SCHEME_FALSE) {
7233 error_location = loc;
7234 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
7235 }
7236
7237 return C_SCHEME_UNDEFINED;
7238 }
7239
7240
7241 C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
7242 {
7243 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {
7244 error_location = loc;
7245 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
7246 }
7247
7248 return C_SCHEME_UNDEFINED;
7249 }
7250
7251
7252 C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
7253 {
7254 if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {
7255 error_location = loc;
7256 barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);
7257 }
7258
7259 return C_SCHEME_UNDEFINED;
7260 }
7261
7262
7263 C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
7264 {
7265 if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {
7266 error_location = loc;
7267 barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);
7268 }
7269
7270 return C_SCHEME_UNDEFINED;
7271 }
7272
7273
7274 C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
7275 {
7276 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) {
7277 error_location = loc;
7278 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);
7279 }
7280
7281 return C_SCHEME_UNDEFINED;
7282 }
7283
7284
7285 C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
7286 {
7287 if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
7288 error_location = loc;
7289 barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);
7290 }
7291
7292 return C_SCHEME_UNDEFINED;
7293 }
7294
7295
7296 C_regparm C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc)
7297 {
7298 if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {
7299 error_location = loc;
7300 barf(C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR, NULL, x);
7301 }
7302
7303 return C_SCHEME_UNDEFINED;
7304 }
7305
7306
7307 C_regparm C_word C_fcall C_i_check_locative_2(C_word x, C_word loc)
7308 {
7309 if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {
7310 error_location = loc;
7311 barf(C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR, NULL, x);
7312 }
7313
7314 return C_SCHEME_UNDEFINED;
7315 }
7316
7317
7318 C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
7319 {
7320 if(!C_truep(C_i_symbolp(x))) {
7321 error_location = loc;
7322 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
7323 }
7324
7325 return C_SCHEME_UNDEFINED;
7326 }
7327
7328
7329 C_regparm C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc)
7330 {
7331 if(!C_truep(C_i_keywordp(x))) {
7332 error_location = loc;
7333 barf(C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR, NULL, x);
7334 }
7335
7336 return C_SCHEME_UNDEFINED;
7337 }
7338
7339 C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
7340 {
7341 if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)) {
7342 error_location = loc;
7343 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);
7344 }
7345
7346 return C_SCHEME_UNDEFINED;
7347 }
7348
7349
7350 C_regparm C_word C_fcall C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)
7351 {
7352
7353 if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {
7354 error_location = loc;
7355 barf(C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR, NULL, x);
7356 }
7357
7358 if((C_block_item(x, 1) & dir) != dir) { /* slot #1: I/O direction mask */
7359 error_location = loc;
7360 switch (dir) {
7361 case C_fix(1):
7362 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR, NULL, x);
7363 case C_fix(2):
7364 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR, NULL, x);
7365 default:
7366 barf(C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR, NULL, x);
7367 }
7368 }
7369
7370 if(open == C_SCHEME_TRUE) {
7371 if(C_block_item(x, 8) == C_FIXNUM_BIT) { /* slot #8: closed mask */
7372 error_location = loc;
7373 barf(C_PORT_CLOSED_ERROR, NULL, x);
7374 }
7375 }
7376
7377 return C_SCHEME_UNDEFINED;
7378 }
7379
7380
7381 /*XXX these are not correctly named */
7382 C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
7383 {
7384 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
7385 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
7386
7387 return x;
7388 }
7389
7390
7391 C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
7392 {
7393 if((x & C_FIXNUM_BIT) == 0)
7394 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
7395
7396 return x;
7397 }
7398
7399
7400 C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
7401 {
7402 if((x & C_FIXNUM_BIT) != 0) return x;
7403
7404 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
7405 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
7406
7407 return x;
7408 }
7409
7410
7411 C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
7412 {
7413 if(C_immediatep(x))
7414 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);
7415
7416 return x;
7417 }
7418
7419
7420 C_regparm C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)
7421 {
7422 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)
7423 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, t, x);
7424
7425 return x;
7426 }
7427
7428
7429 C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
7430 {
7431 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
7432 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
7433
7434 return x;
7435 }
7436
7437
7438 C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
7439 {
7440 if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)
7441 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
7442
7443 return x;
7444 }
7445
7446
7447 C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
7448 {
7449 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)
7450 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
7451
7452 return x;
7453 }
7454
7455
7456 /* TODO: Is this used? */
7457 C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
7458 {
7459 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)
7460 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
7461
7462 return x;
7463 }
7464
7465
7466 C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
7467 {
7468 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0
7469 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
7470 barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);
7471
7472 return x;
7473 }
7474
7475 C_regparm C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)
7476 {
7477 if((x & C_FIXNUM_BIT) != 0) {
7478 if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;
7479 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
7480 } else if (C_truep(C_i_bignump(x))) {
7481 if (C_truep(C_fixnum_lessp(C_i_integer_length(x), bits))) return x;
7482 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
7483 } else {
7484 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
7485 }
7486 }
7487
7488 C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)
7489 {
7490 if((x & C_FIXNUM_BIT) != 0) {
7491 if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
7492 else if(C_ilen(C_unfix(x)) <= C_unfix(bits)) return x;
7493 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
7494 } else if(C_truep(C_i_bignump(x))) {
7495 if(C_bignum_negativep(x)) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
7496 else if(integer_length_abs(x) <= C_unfix(bits)) return x;
7497 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
7498 } else {
7499 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
7500 }
7501 }
7502
7503 /* I */
7504 C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
7505 {
7506 return C_mk_bool(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG);
7507 }
7508
7509
7510 C_regparm C_word C_fcall C_i_null_list_p(C_word x)
7511 {
7512 if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
7513 else if(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG) return C_SCHEME_FALSE;
7514 else {
7515 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);
7516 return C_SCHEME_FALSE;
7517 }
7518 }
7519
7520
7521 C_regparm C_word C_fcall C_i_string_null_p(C_word x)
7522 {
7523 if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)
7524 return C_zero_length_p(x);
7525 else {
7526 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);
7527 return C_SCHEME_FALSE;
7528 }
7529 }
7530
7531
7532 C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
7533 {
7534 if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)
7535 return C_null_pointerp(x);
7536
7537 barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);
7538 return C_SCHEME_FALSE;
7539 }
7540
7541 C_regparm C_word C_i_char_equalp(C_word x, C_word y)
7542 {
7543 C_i_check_char_2(x, intern0("char=?"));
7544 C_i_check_char_2(y, intern0("char=?"));
7545 return C_u_i_char_equalp(x, y);
7546 }
7547
7548 C_regparm C_word C_i_char_greaterp(C_word x, C_word y)
7549 {
7550 C_i_check_char_2(x, intern0("char>?"));
7551 C_i_check_char_2(y, intern0("char>?"));
7552 return C_u_i_char_greaterp(x, y);
7553 }
7554
7555 C_regparm C_word C_i_char_lessp(C_word x, C_word y)
7556 {
7557 C_i_check_char_2(x, intern0("char<?"));
7558 C_i_check_char_2(y, intern0("char<?"));
7559 return C_u_i_char_lessp(x, y);
7560 }
7561
7562 C_regparm C_word C_i_char_greater_or_equal_p(C_word x, C_word y)
7563 {
7564 C_i_check_char_2(x, intern0("char>=?"));
7565 C_i_check_char_2(y, intern0("char>=?"));
7566 return C_u_i_char_greater_or_equal_p(x, y);
7567 }
7568
7569 C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y)
7570 {
7571 C_i_check_char_2(x, intern0("char<=?"));
7572 C_i_check_char_2(y, intern0("char<=?"));
7573 return C_u_i_char_less_or_equal_p(x, y);
7574 }
7575
7576
7577 /* Primitives: */
7578
7579 void C_ccall C_apply(C_word c, C_word *av)
7580 {
7581 C_word
7582 /* closure = av[ 0 ] */
7583 k = av[ 1 ],
7584 fn = av[ 2 ];
7585 int av2_size, i, n = c - 3;
7586 int non_list_args = n - 1;
7587 C_word lst, len, *ptr, *av2;
7588
7589 if(c < 4) C_bad_min_argc(c, 4);
7590
7591 if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE)
7592 barf(C_NOT_A_CLOSURE_ERROR, "apply", fn);
7593
7594 lst = av[ c - 1 ];
7595 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG))
7596 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);
7597
7598 len = C_unfix(C_u_i_length(lst));
7599 av2_size = 2 + non_list_args + len;
7600
7601 if(C_demand(av2_size))
7602 stack_check_demand = 0;
7603 else if(stack_check_demand)
7604 C_stack_overflow("apply");
7605 else {
7606 stack_check_demand = av2_size;
7607 C_save_and_reclaim((void *)C_apply, c, av);
7608 }
7609
7610 av2 = ptr = C_alloc(av2_size);
7611 *(ptr++) = fn;
7612 *(ptr++) = k;
7613
7614 if(non_list_args > 0) {
7615 C_memcpy(ptr, av + 3, non_list_args * sizeof(C_word));
7616 ptr += non_list_args;
7617 }
7618
7619 while(len--) {
7620 *(ptr++) = C_u_i_car(lst);
7621 lst = C_u_i_cdr(lst);
7622 }
7623
7624 assert((ptr - av2) == av2_size);
7625
7626 ((C_proc)(void *)C_block_item(fn, 0))(av2_size, av2);
7627 }
7628
7629
7630 void C_ccall C_call_cc(C_word c, C_word *av)
7631 {
7632 C_word
7633 /* closure = av[ 0 ] */
7634 k = av[ 1 ],
7635 cont = av[ 2 ],
7636 *a = C_alloc(C_SIZEOF_CLOSURE(2)),
7637 wrapper;
7638 void *pr = (void *)C_block_item(cont,0);
7639 C_word av2[ 3 ];
7640
7641 if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)
7642 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
7643
7644 /* Check for values-continuation: */
7645 if(C_block_item(k, 0) == (C_word)values_continuation)
7646 wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);
7647 else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);
7648
7649 av2[ 0 ] = cont;
7650 av2[ 1 ] = k;
7651 av2[ 2 ] = wrapper;
7652 ((C_proc)pr)(3, av2);
7653 }
7654
7655
7656 void C_ccall call_cc_wrapper(C_word c, C_word *av)
7657 {
7658 C_word
7659 closure = av[ 0 ],
7660 /* av[ 1 ] is current k and ignored */
7661 result,
7662 k = C_block_item(closure, 1);
7663
7664 if(c != 3) C_bad_argc(c, 3);
7665
7666 result = av[ 2 ];
7667 C_kontinue(k, result);
7668 }
7669
7670
7671 void C_ccall call_cc_values_wrapper(C_word c, C_word *av)
7672 {
7673 C_word
7674 closure = av[ 0 ],
7675 /* av[ 1 ] is current k and ignored */
7676 k = C_block_item(closure, 1),
7677 x1,
7678 n = c;
7679
7680 av[ 0 ] = k; /* reuse av */
7681 C_memmove(av + 1, av + 2, (n - 1) * sizeof(C_word));
7682 C_do_apply(n - 1, av);
7683 }
7684
7685
7686 void C_ccall C_continuation_graft(C_word c, C_word *av)
7687 {
7688 C_word
7689 /* self = av[ 0 ] */
7690 /* k = av[ 1 ] */
7691 kk = av[ 2 ],
7692 proc = av[ 3 ];
7693
7694 av[ 0 ] = proc; /* reuse av */
7695 av[ 1 ] = C_block_item(kk, 1);
7696 ((C_proc)C_fast_retrieve_proc(proc))(2, av);
7697 }
7698
7699
7700 void C_ccall C_values(C_word c, C_word *av)
7701 {
7702 C_word
7703 /* closure = av[ 0 ] */
7704 k = av[ 1 ],
7705 n = c;
7706
7707 if(c < 2) C_bad_min_argc(c, 2);
7708
7709 /* Check continuation whether it receives multiple values: */
7710 if(C_block_item(k, 0) == (C_word)values_continuation) {
7711 av[ 0 ] = k; /* reuse av */
7712 C_memmove(av + 1, av + 2, (c - 2) * sizeof(C_word));
7713 C_do_apply(c - 1, av);
7714 }
7715
7716 if(c != 3) {
7717 #ifdef RELAX_MULTIVAL_CHECK
7718 if(c == 2) n = C_SCHEME_UNDEFINED;
7719 else n = av[ 2 ];
7720 #else
7721 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
7722 #endif
7723 }
7724 else n = av[ 2 ];
7725
7726 C_kontinue(k, n);
7727 }
7728
7729
7730 void C_ccall C_apply_values(C_word c, C_word *av)
7731 {
7732 C_word
7733 /* closure = av[ 0 ] */
7734 k = av[ 1 ],
7735 lst, len, n;
7736
7737 if(c != 3) C_bad_argc(c, 3);
7738
7739 lst = av[ 2 ];
7740
7741 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG))
7742 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);
7743
7744 /* Check whether continuation receives multiple values: */
7745 if(C_block_item(k, 0) == (C_word)values_continuation) {
7746 C_word *av2, *ptr;
7747
7748 len = C_unfix(C_u_i_length(lst));
7749 n = len + 1;
7750
7751 if(C_demand(n))
7752 stack_check_demand = 0;
7753 else if(stack_check_demand)
7754 C_stack_overflow("apply");
7755 else {
7756 stack_check_demand = n;
7757 C_save_and_reclaim((void *)C_apply_values, c, av);
7758 }
7759
7760 av2 = C_alloc(n);
7761 av2[ 0 ] = k;
7762 ptr = av2 + 1;
7763 while(len--) {
7764 *(ptr++) = C_u_i_car(lst);
7765 lst = C_u_i_cdr(lst);
7766 }
7767
7768 C_do_apply(n, av2);
7769 }
7770
7771 if(C_immediatep(lst)) {
7772 #ifdef RELAX_MULTIVAL_CHECK
7773 n = C_SCHEME_UNDEFINED;
7774 #else
7775 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
7776 #endif
7777 }
7778 else if(C_block_header(lst) == C_PAIR_TAG) {
7779 if(C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)
7780 n = C_u_i_car(lst);
7781 else {
7782 #ifdef RELAX_MULTIVAL_CHECK
7783 n = C_u_i_car(lst);
7784 #else
7785 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
7786 #endif
7787 }
7788 }
7789 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);
7790
7791 C_kontinue(k, n);
7792 }
7793
7794
7795 void C_ccall C_call_with_values(C_word c, C_word *av)
7796 {
7797 C_word
7798 /* closure = av[ 0 ] */
7799 k = av[ 1 ],
7800 thunk,
7801 kont,
7802 *a = C_alloc(C_SIZEOF_CLOSURE(3)),
7803 kk;
7804
7805 if(c != 4) C_bad_argc(c, 4);
7806
7807 thunk = av[ 2 ];
7808 kont = av[ 3 ];
7809
7810 if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)
7811 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);
7812
7813 if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)
7814 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);
7815
7816 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
7817 av[ 0 ] = thunk; /* reuse av */
7818 av[ 1 ] = kk;
7819 C_do_apply(2, av);
7820 }
7821
7822
7823 void C_ccall C_u_call_with_values(C_word c, C_word *av)
7824 {
7825 C_word
7826 /* closure = av[ 0 ] */
7827 k = av[ 1 ],
7828 thunk = av[ 2 ],
7829 kont = av[ 3 ],
7830 *a = C_alloc(C_SIZEOF_CLOSURE(3)),
7831 kk;
7832
7833 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
7834 av[ 0 ] = thunk; /* reuse av */
7835 av[ 1 ] = kk;
7836 C_do_apply(2, av);
7837 }
7838
7839
7840 void C_ccall values_continuation(C_word c, C_word *av)
7841 {
7842 C_word
7843 closure = av[ 0 ],
7844 kont = C_block_item(closure, 1),
7845 k = C_block_item(closure, 2),
7846 *av2 = C_alloc(c + 1);
7847
7848 av2[ 0 ] = kont;
7849 av2[ 1 ] = k;
7850 C_memcpy(av2 + 2, av + 1, (c - 1) * sizeof(C_word));
7851 C_do_apply(c + 1, av2);
7852 }
7853
7854 static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i)
7855 {
7856 C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab, num, denom, gcd, a_div_g;
7857
7858 switch (i) {
7859 case C_fix(0): return C_fix(0);
7860 case C_fix(1): return rat;
7861 case C_fix(-1):
7862 num = C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(rat));
7863 return C_ratnum(ptr, num , C_u_i_ratnum_denom(rat));
7864 /* default: CONTINUE BELOW */
7865 }
7866
7867 num = C_u_i_ratnum_num(rat);
7868 denom = C_u_i_ratnum_denom(rat);
7869
7870 /* a/b * c/d = a*c / b*d [with b = 1] */
7871 /* = ((a / g) * c) / (d / g) */
7872 /* With g = gcd(a, d) and a = x [Knuth, 4.5.1] */
7873 gcd = C_s_a_u_i_integer_gcd(&a, 2, i, denom);
7874
7875 /* Calculate a/g (= i/gcd), which will later be multiplied by y */
7876 a_div_g = C_s_a_u_i_integer_quotient(&a, 2, i, gcd);
7877 if (a_div_g == C_fix(0)) {
7878 clear_buffer_object(ab, gcd);
7879 return C_fix(0); /* Save some work */
7880 }
7881
7882 /* Final numerator = a/g * c (= a_div_g * num) */
7883 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g, num);
7884
7885 /* Final denominator = d/g (= denom/gcd) */
7886 denom = C_s_a_u_i_integer_quotient(ptr, 2, denom, gcd);
7887
7888 num = move_buffer_object(ptr, ab, num);
7889 denom = move_buffer_object(ptr, ab, denom);
7890
7891 clear_buffer_object(ab, gcd);
7892 clear_buffer_object(ab, a_div_g);
7893
7894 if (denom == C_fix(1)) return num;
7895 else return C_ratnum(ptr, num, denom);
7896 }
7897
7898 static C_word rat_times_rat(C_word **ptr, C_word x, C_word y)
7899 {
7900 C_word ab[C_SIZEOF_FIX_BIGNUM * 6], *a = ab,
7901 num, denom, xnum, xdenom, ynum, ydenom,
7902 g1, g2, a_div_g1, b_div_g2, c_div_g2, d_div_g1;
7903
7904 xnum = C_u_i_ratnum_num(x);
7905 xdenom = C_u_i_ratnum_denom(x);
7906 ynum = C_u_i_ratnum_num(y);
7907 ydenom = C_u_i_ratnum_denom(y);
7908
7909 /* a/b * c/d = a*c / b*d [generic] */
7910 /* = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1)) */
7911 /* With g1 = gcd(a, d) and g2 = gcd(b, c) [Knuth, 4.5.1] */
7912 g1 = C_s_a_u_i_integer_gcd(&a, 2, xnum, ydenom);
7913 g2 = C_s_a_u_i_integer_gcd(&a, 2, ynum, xdenom);
7914
7915 /* Calculate a/g1 (= xnum/g1), which will later be multiplied by c/g2 */
7916 a_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, xnum, g1);
7917
7918 /* Calculate c/g2 (= ynum/g2), which will later be multiplied by a/g1 */
7919 c_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, ynum, g2);
7920
7921 /* Final numerator = a/g1 * c/g2 */
7922 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g1, c_div_g2);
7923
7924 /* Now, do the same for the denominator.... */
7925
7926 /* Calculate b/g2 (= xdenom/g2), which will later be multiplied by d/g1 */
7927 b_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g2);
7928
7929 /* Calculate d/g1 (= ydenom/g1), which will later be multiplied by b/g2 */
7930 d_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);
7931
7932 /* Final denominator = b/g2 * d/g1 */
7933 denom = C_s_a_u_i_integer_times(ptr, 2, b_div_g2, d_div_g1);
7934
7935 num = move_buffer_object(ptr, ab, num);
7936 denom = move_buffer_object(ptr, ab, denom);
7937
7938 clear_buffer_object(ab, g1);
7939 clear_buffer_object(ab, g2);
7940 clear_buffer_object(ab, a_div_g1);
7941 clear_buffer_object(ab, b_div_g2);
7942 clear_buffer_object(ab, c_div_g2);
7943 clear_buffer_object(ab, d_div_g1);
7944
7945 if (denom == C_fix(1)) return num;
7946 else return C_ratnum(ptr, num, denom);
7947 }
7948
7949 static C_word
7950 cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)
7951 {
7952 /* Allocation here is kind of tricky: Each intermediate result can
7953 * be at most a ratnum consisting of two bignums (2 digits), so
7954 * C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2) = 9 words
7955 */
7956 C_word ab[(C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2))*6], *a = ab,
7957 r1, r2, i1, i2, r, i;
7958
7959 /* a+bi * c+di = (a*c - b*d) + (a*d + b*c)i */
7960 /* We call these: r1 = a*c, r2 = b*d, i1 = a*d, i2 = b*c */
7961 r1 = C_s_a_i_times(&a, 2, rx, ry);
7962 r2 = C_s_a_i_times(&a, 2, ix, iy);
7963 i1 = C_s_a_i_times(&a, 2, rx, iy);
7964 i2 = C_s_a_i_times(&a, 2, ix, ry);
7965
7966 r = C_s_a_i_minus(ptr, 2, r1, r2);
7967 i = C_s_a_i_plus(ptr, 2, i1, i2);
7968
7969 r = move_buffer_object(ptr, ab, r);
7970 i = move_buffer_object(ptr, ab, i);
7971
7972 clear_buffer_object(ab, r1);
7973 clear_buffer_object(ab, r2);
7974 clear_buffer_object(ab, i1);
7975 clear_buffer_object(ab, i2);
7976
7977 if (C_truep(C_u_i_zerop2(i))) return r;
7978 else return C_cplxnum(ptr, r, i);
7979 }
7980
7981 /* The maximum size this needs is that required to store a complex
7982 * number result, where both real and imag parts consist of ratnums.
7983 * The maximum size of those ratnums is if they consist of two bignums
7984 * from a fixnum multiplication (2 digits each), so we're looking at
7985 * C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words!
7986 */
7987 C_regparm C_word C_fcall
7988 C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
7989 {
7990 if (x & C_FIXNUM_BIT) {
7991 if (y & C_FIXNUM_BIT) {
7992 return C_a_i_fixnum_times(ptr, 2, x, y);
7993 } else if (C_immediatep(y)) {
7994 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
7995 } else if (C_block_header(y) == C_FLONUM_TAG) {
7996 return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y));
7997 } else if (C_truep(C_bignump(y))) {
7998 return C_s_a_u_i_integer_times(ptr, 2, x, y);
7999 } else if (C_block_header(y) == C_RATNUM_TAG) {
8000 return rat_times_integer(ptr, y, x);
8001 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8002 return cplx_times(ptr, x, C_fix(0),
8003 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));
8004 } else {
8005 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
8006 }
8007 } else if (C_immediatep(x)) {
8008 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
8009 } else if (C_block_header(x) == C_FLONUM_TAG) {
8010 if (y & C_FIXNUM_BIT) {
8011 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y));
8012 } else if (C_immediatep(y)) {
8013 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
8014 } else if (C_block_header(y) == C_FLONUM_TAG) {
8015 return C_a_i_flonum_times(ptr, 2, x, y);
8016 } else if (C_truep(C_bignump(y))) {
8017 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y));
8018 } else if (C_block_header(y) == C_RATNUM_TAG) {
8019 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));
8020 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8021 C_word ab[C_SIZEOF_FLONUM], *a = ab;
8022 return cplx_times(ptr, x, C_flonum(&a, 0.0),
8023 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));
8024 } else {
8025 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
8026 }
8027 } else if (C_truep(C_bignump(x))) {
8028 if (y & C_FIXNUM_BIT) {
8029 return C_s_a_u_i_integer_times(ptr, 2, x, y);
8030 } else if (C_immediatep(y)) {
8031 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
8032 } else if (C_block_header(y) == C_FLONUM_TAG) {
8033 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y));
8034 } else if (C_truep(C_bignump(y))) {
8035 return C_s_a_u_i_integer_times(ptr, 2, x, y);
8036 } else if (C_block_header(y) == C_RATNUM_TAG) {
8037 return rat_times_integer(ptr, y, x);
8038 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8039 return cplx_times(ptr, x, C_fix(0),
8040 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));
8041 } else {
8042 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
8043 }
8044 } else if (C_block_header(x) == C_RATNUM_TAG) {
8045 if (y & C_FIXNUM_BIT) {
8046 return rat_times_integer(ptr, x, y);
8047 } else if (C_immediatep(y)) {
8048 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
8049 } else if (C_block_header(y) == C_FLONUM_TAG) {
8050 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);
8051 } else if (C_truep(C_bignump(y))) {
8052 return rat_times_integer(ptr, x, y);
8053 } else if (C_block_header(y) == C_RATNUM_TAG) {
8054 return rat_times_rat(ptr, x, y);
8055 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8056 return cplx_times(ptr, x, C_fix(0),
8057 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));
8058 } else {
8059 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
8060 }
8061 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
8062 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {
8063 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x),
8064 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));
8065 } else {
8066 C_word ab[C_SIZEOF_FLONUM], *a = ab, yi;
8067 yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0);
8068 return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi);
8069 }
8070 } else {
8071 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);
8072 }
8073 }
8074
8075
8076 C_regparm C_word C_fcall
8077 C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)
8078 {
8079 if (x & C_FIXNUM_BIT) {
8080 if (y & C_FIXNUM_BIT) {
8081 return C_a_i_fixnum_times(ptr, 2, x, y);
8082 } else {
8083 C_word tmp = x; /* swap to ensure x is a bignum and y a fixnum */
8084 x = y;
8085 y = tmp;
8086 }
8087 }
8088 /* Here, we know for sure that X is a bignum */
8089 if (y == C_fix(0)) {
8090 return C_fix(0);
8091 } else if (y == C_fix(1)) {
8092 return x;
8093 } else if (y == C_fix(-1)) {
8094 return C_s_a_u_i_integer_negate(ptr, 1, x);
8095 } else if (y & C_FIXNUM_BIT) { /* Any other fixnum */
8096 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y),
8097 negp = C_mk_bool((y & C_INT_SIGN_BIT) ?
8098 !C_bignum_negativep(x) :
8099 C_bignum_negativep(x));
8100
8101 if (C_fitsinbignumhalfdigitp(absy) ||
8102 (((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {
8103 C_word size, res;
8104 C_uword *startr, *endr;
8105 int shift;
8106 size = C_bignum_size(x) + 1; /* Needs _at most_ one more digit */
8107 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
8108
8109 bignum_digits_destructive_copy(res, x);
8110
8111 startr = C_bignum_digits(res);
8112 endr = startr + size - 1;
8113 /* Scale up, and sanitise the result. */
8114 shift = C_ilen(absy) - 1;
8115 if (((C_uword)1 << shift) == absy) { /* Power of two? */
8116 *endr = bignum_digits_destructive_shift_left(startr, endr, shift);
8117 } else {
8118 *endr = bignum_digits_destructive_scale_up_with_carry(startr, endr,
8119 absy, 0);
8120 }
8121 return C_bignum_simplify(res);
8122 } else {
8123 C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);
8124 y = C_a_u_i_fix_to_big(&a, y);
8125 return bignum_times_bignum_unsigned(ptr, x, y, negp);
8126 }
8127 } else {
8128 C_word negp = C_bignum_negativep(x) ?
8129 !C_bignum_negativep(y) :
8130 C_bignum_negativep(y);
8131 return bignum_times_bignum_unsigned(ptr, x, y, C_mk_bool(negp));
8132 }
8133 }
8134
8135 static C_regparm C_word
8136 bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)
8137 {
8138 C_word size, res = C_SCHEME_FALSE;
8139 if (C_bignum_size(y) < C_bignum_size(x)) { /* Ensure size(x) <= size(y) */
8140 C_word z = x;
8141 x = y;
8142 y = z;
8143 }
8144
8145 if (C_bignum_size(x) >= C_KARATSUBA_THRESHOLD)
8146 res = bignum_times_bignum_karatsuba(ptr, x, y, negp);
8147
8148 if (!C_truep(res)) {
8149 size = C_bignum_size(x) + C_bignum_size(y);
8150 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_TRUE);
8151 bignum_digits_multiply(x, y, res);
8152 res = C_bignum_simplify(res);
8153 }
8154 return res;
8155 }
8156
8157 /* Karatsuba multiplication: invoked when the two numbers are large
8158 * enough to make it worthwhile, and we still have enough stack left.
8159 * Complexity is O(n^log2(3)), where n is max(len(x), len(y)). The
8160 * description in [Knuth, 4.3.3] leaves a lot to be desired. [MCA,
8161 * 1.3.2] and [MpNT, 3.2] are a bit easier to understand. We assume
8162 * that length(x) <= length(y).
8163 */
8164 static C_regparm C_word
8165 bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)
8166 {
8167 C_word kab[C_SIZEOF_FIX_BIGNUM*15+C_SIZEOF_BIGNUM(2)*3], *ka = kab, o[18],
8168 xhi, xlo, xmid, yhi, ylo, ymid, a, b, c, n, bits;
8169 int i = 0;
8170
8171 /* Ran out of stack? Fall back to non-recursive multiplication */
8172 C_stack_check1(return C_SCHEME_FALSE);
8173
8174 /* Split |x| in half: <xhi,xlo> and |y|: <yhi,ylo> with len(ylo)=len(xlo) */
8175 x = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, x);
8176 y = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, y);
8177 n = C_fix(C_bignum_size(y) >> 1);
8178 xhi = o[i++] = bignum_extract_digits(&ka, 3, x, n, C_SCHEME_FALSE);
8179 xlo = o[i++] = bignum_extract_digits(&ka, 3, x, C_fix(0), n);
8180 yhi = o[i++] = bignum_extract_digits(&ka, 3, y, n, C_SCHEME_FALSE);
8181 ylo = o[i++] = bignum_extract_digits(&ka, 3, y, C_fix(0), n);
8182
8183 /* a = xhi * yhi, b = xlo * ylo, c = (xhi - xlo) * (yhi - ylo) */
8184 a = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xhi, yhi);
8185 b = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xlo, ylo);
8186 xmid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, xhi, xlo);
8187 ymid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, yhi, ylo);
8188 c = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xmid, ymid);
8189
8190 /* top(x) = a << (bits - 1) and bottom(y) = ((b + (a - c)) << bits) + b */
8191 bits = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;
8192 x = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, a, C_fix((C_uword)bits << 1));
8193 c = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, a, c);
8194 c = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, b, c);
8195 c = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, c, C_fix(bits));
8196 y = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, c, b);
8197 /* Finally, return top + bottom, and correct for negative */
8198 n = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, x, y);
8199 if (C_truep(negp)) n = o[i++] = C_s_a_u_i_integer_negate(&ka, 1, n);
8200
8201 n = move_buffer_object(ptr, kab, n);
8202 while(i--) clear_buffer_object(kab, o[i]);
8203 return n;
8204 }
8205
8206 void C_ccall C_times(C_word c, C_word *av)
8207 {
8208 /* C_word closure = av[ 0 ]; */
8209 C_word k = av[ 1 ];
8210 C_word next_val,
8211 result = C_fix(1),
8212 prev_result = result;
8213 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a;
8214
8215 c -= 2;
8216 av += 2;
8217
8218 while (c--) {
8219 next_val = *(av++);
8220 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */
8221 result = C_s_a_i_times(&a, 2, result, next_val);
8222 result = move_buffer_object(&a, ab[(c+1)&1], result);
8223 clear_buffer_object(ab[(c+1)&1], prev_result);
8224 prev_result = result;
8225 }
8226
8227 C_kontinue(k, result);
8228 }
8229
8230
8231 static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)
8232 {
8233 C_word size, result;
8234 C_uword sum, digit, *scan_y, *end_y, *scan_r, *end_r;
8235 int carry = 0;
8236
8237 if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(y) <= size(x) */
8238 C_word z = x;
8239 x = y;
8240 y = z;
8241 }
8242
8243 size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */
8244 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);
8245
8246 scan_y = C_bignum_digits(y);
8247 end_y = scan_y + C_bignum_size(y);
8248 scan_r = C_bignum_digits(result);
8249 end_r = scan_r + C_bignum_size(result);
8250
8251 /* Copy x into r so we can operate on two pointers, which is faster
8252 * than three, and we can stop earlier after adding y. It's slower
8253 * if x and y have equal length. On average it's slightly faster.
8254 */
8255 bignum_digits_destructive_copy(result, x);
8256 *(end_r-1) = 0; /* Ensure most significant digit is initialised */
8257
8258 /* Move over x and y simultaneously, destructively adding digits w/ carry. */
8259 while (scan_y < end_y) {
8260 digit = *scan_r;
8261 if (carry) {
8262 sum = digit + *scan_y++ + 1;
8263 carry = sum <= digit;
8264 } else {
8265 sum = digit + *scan_y++;
8266 carry = sum < digit;
8267 }
8268 (*scan_r++) = sum;
8269 }
8270
8271 /* The end of y, the smaller number. Propagate carry into the rest of x. */
8272 while (carry) {
8273 sum = (*scan_r) + 1;
8274 carry = (sum == 0);
8275 (*scan_r++) = sum;
8276 }
8277 assert(scan_r <= end_r);
8278
8279 return C_bignum_simplify(result);
8280 }
8281
8282 static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op)
8283 {
8284 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,
8285 num, denom, tmp, res;
8286
8287 if (i == C_fix(0)) return rat;
8288
8289 num = C_u_i_ratnum_num(rat);
8290 denom = C_u_i_ratnum_denom(rat);
8291
8292 /* a/b [+-] c/d = (a*d [+-] b*c)/(b*d) | d = 1: (num + denom * i) / denom */
8293 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);
8294 res = plusmin_op(&a, 2, num, tmp);
8295 res = move_buffer_object(ptr, ab, res);
8296 clear_buffer_object(ab, tmp);
8297 return C_ratnum(ptr, res, denom);
8298 }
8299
8300 /* This is needed only for minus: plus is commutative but minus isn't. */
8301 static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat)
8302 {
8303 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,
8304 num, denom, tmp, res;
8305
8306 num = C_u_i_ratnum_num(rat);
8307 denom = C_u_i_ratnum_denom(rat);
8308
8309 if (i == C_fix(0))
8310 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, num), denom);
8311
8312 /* a/b - c/d = (a*d - b*c)/(b*d) | b = 1: (denom * i - num) / denom */
8313 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);
8314 res = C_s_a_u_i_integer_minus(&a, 2, tmp, num);
8315 res = move_buffer_object(ptr, ab, res);
8316 clear_buffer_object(ab, tmp);
8317 return C_ratnum(ptr, res, denom);
8318 }
8319
8320 /* This is pretty braindead and ugly */
8321 static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op)
8322 {
8323 C_word ab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)*2], *a = ab,
8324 xnum = C_u_i_ratnum_num(x), ynum = C_u_i_ratnum_num(y),
8325 xdenom = C_u_i_ratnum_denom(x), ydenom = C_u_i_ratnum_denom(y),
8326 xnorm, ynorm, tmp_r, g1, ydenom_g1, xdenom_g1, norm_sum, g2, len,
8327 res_num, res_denom;
8328
8329 /* Knuth, 4.5.1. Start with g1 = gcd(xdenom, ydenom) */
8330 g1 = C_s_a_u_i_integer_gcd(&a, 2, xdenom, ydenom);
8331
8332 /* xnorm = xnum * (ydenom/g1) */
8333 ydenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);
8334 xnorm = C_s_a_u_i_integer_times(&a, 2, xnum, ydenom_g1);
8335
8336 /* ynorm = ynum * (xdenom/g1) */
8337 xdenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g1);
8338 ynorm = C_s_a_u_i_integer_times(&a, 2, ynum, xdenom_g1);
8339
8340 /* norm_sum = xnorm [+-] ynorm */
8341 norm_sum = plusmin_op(&a, 2, xnorm, ynorm);
8342
8343 /* g2 = gcd(norm_sum, g1) */
8344 g2 = C_s_a_u_i_integer_gcd(&a, 2, norm_sum, g1);
8345
8346 /* res_num = norm_sum / g2 */
8347 res_num = C_s_a_u_i_integer_quotient(ptr, 2, norm_sum, g2);
8348 if (res_num == C_fix(0)) {
8349 res_denom = C_fix(0); /* No need to calculate denom: we'll return 0 */
8350 } else {
8351 /* res_denom = xdenom_g1 * (ydenom / g2) */
8352 C_word res_tmp_denom = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g2);
8353 res_denom = C_s_a_u_i_integer_times(ptr, 2, xdenom_g1, res_tmp_denom);
8354
8355 /* Ensure they're allocated in the correct place */
8356 res_num = move_buffer_object(ptr, ab, res_num);
8357 res_denom = move_buffer_object(ptr, ab, res_denom);
8358 clear_buffer_object(ab, res_tmp_denom);
8359 }
8360
8361 clear_buffer_object(ab, xdenom_g1);
8362 clear_buffer_object(ab, ydenom_g1);
8363 clear_buffer_object(ab, xnorm);
8364 clear_buffer_object(ab, ynorm);
8365 clear_buffer_object(ab, norm_sum);
8366 clear_buffer_object(ab, g1);
8367 clear_buffer_object(ab, g2);
8368
8369 switch (res_denom) {
8370 case C_fix(0): return C_fix(0);
8371 case C_fix(1): return res_num;
8372 default: return C_ratnum(ptr, res_num, res_denom);
8373 }
8374 }
8375
8376 /* The maximum size this needs is that required to store a complex
8377 * number result, where both real and imag parts consist of ratnums.
8378 * The maximum size of those ratnums is if they consist of two "fix
8379 * bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM *
8380 * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!
8381 */
8382 C_regparm C_word C_fcall
8383 C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)
8384 {
8385 if (x & C_FIXNUM_BIT) {
8386 if (y & C_FIXNUM_BIT) {
8387 return C_a_i_fixnum_plus(ptr, 2, x, y);
8388 } else if (C_immediatep(y)) {
8389 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8390 } else if (C_block_header(y) == C_FLONUM_TAG) {
8391 return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y));
8392 } else if (C_truep(C_bignump(y))) {
8393 return C_s_a_u_i_integer_plus(ptr, 2, x, y);
8394 } else if (C_block_header(y) == C_RATNUM_TAG) {
8395 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);
8396 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8397 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8398 imag = C_u_i_cplxnum_imag(y);
8399 if (C_truep(C_u_i_inexactp(real_sum)))
8400 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8401 return C_cplxnum(ptr, real_sum, imag);
8402 } else {
8403 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8404 }
8405 } else if (C_immediatep(x)) {
8406 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);
8407 } else if (C_block_header(x) == C_FLONUM_TAG) {
8408 if (y & C_FIXNUM_BIT) {
8409 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y));
8410 } else if (C_immediatep(y)) {
8411 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8412 } else if (C_block_header(y) == C_FLONUM_TAG) {
8413 return C_a_i_flonum_plus(ptr, 2, x, y);
8414 } else if (C_truep(C_bignump(y))) {
8415 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y));
8416 } else if (C_block_header(y) == C_RATNUM_TAG) {
8417 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));
8418 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8419 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8420 imag = C_u_i_cplxnum_imag(y);
8421 if (C_truep(C_u_i_inexactp(real_sum)))
8422 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8423 return C_cplxnum(ptr, real_sum, imag);
8424 } else {
8425 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8426 }
8427 } else if (C_truep(C_bignump(x))) {
8428 if (y & C_FIXNUM_BIT) {
8429 return C_s_a_u_i_integer_plus(ptr, 2, x, y);
8430 } else if (C_immediatep(y)) {
8431 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8432 } else if (C_block_header(y) == C_FLONUM_TAG) {
8433 return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y));
8434 } else if (C_truep(C_bignump(y))) {
8435 return C_s_a_u_i_integer_plus(ptr, 2, x, y);
8436 } else if (C_block_header(y) == C_RATNUM_TAG) {
8437 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);
8438 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8439 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8440 imag = C_u_i_cplxnum_imag(y);
8441 if (C_truep(C_u_i_inexactp(real_sum)))
8442 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8443 return C_cplxnum(ptr, real_sum, imag);
8444 } else {
8445 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8446 }
8447 } else if (C_block_header(x) == C_RATNUM_TAG) {
8448 if (y & C_FIXNUM_BIT) {
8449 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);
8450 } else if (C_immediatep(y)) {
8451 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8452 } else if (C_block_header(y) == C_FLONUM_TAG) {
8453 return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);
8454 } else if (C_truep(C_bignump(y))) {
8455 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);
8456 } else if (C_block_header(y) == C_RATNUM_TAG) {
8457 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus);
8458 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8459 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8460 imag = C_u_i_cplxnum_imag(y);
8461 if (C_truep(C_u_i_inexactp(real_sum)))
8462 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8463 return C_cplxnum(ptr, real_sum, imag);
8464 } else {
8465 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
8466 }
8467 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
8468 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {
8469 C_word real_sum, imag_sum;
8470 real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y));
8471 imag_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y));
8472 if (C_truep(C_u_i_zerop2(imag_sum))) return real_sum;
8473 else return C_cplxnum(ptr, real_sum, imag_sum);
8474 } else {
8475 C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y),
8476 imag = C_u_i_cplxnum_imag(x);
8477 if (C_truep(C_u_i_inexactp(real_sum)))
8478 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8479 return C_cplxnum(ptr, real_sum, imag);
8480 }
8481 } else {
8482 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);
8483 }
8484 }
8485
8486 C_regparm C_word C_fcall
8487 C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y)
8488 {
8489 if ((x & y) & C_FIXNUM_BIT) {
8490 return C_a_i_fixnum_plus(ptr, 2, x, y);
8491 } else {
8492 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;
8493 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
8494 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
8495
8496 if (C_bignum_negativep(x)) {
8497 if (C_bignum_negativep(y)) {
8498 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);
8499 } else {
8500 return bignum_minus_unsigned(ptr, y, x);
8501 }
8502 } else {
8503 if (C_bignum_negativep(y)) {
8504 return bignum_minus_unsigned(ptr, x, y);
8505 } else {
8506 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);
8507 }
8508 }
8509 }
8510 }
8511
8512 void C_ccall C_plus(C_word c, C_word *av)
8513 {
8514 /* C_word closure = av[ 0 ]; */
8515 C_word k = av[ 1 ];
8516 C_word next_val,
8517 result = C_fix(0),
8518 prev_result = result;
8519 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;
8520
8521 c -= 2;
8522 av += 2;
8523
8524 while (c--) {
8525 next_val = *(av++);
8526 a = ab[c&1]; /* One may hold last iteration result, the other is unused */
8527 result = C_s_a_i_plus(&a, 2, result, next_val);
8528 result = move_buffer_object(&a, ab[(c+1)&1], result);
8529 clear_buffer_object(ab[(c+1)&1], prev_result);
8530 prev_result = result;
8531 }
8532
8533 C_kontinue(k, result);
8534 }
8535
8536 static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)
8537 {
8538 C_word res, size;
8539 C_uword *scan_r, *end_r, *scan_y, *end_y, difference, digit;
8540 int borrow = 0;
8541
8542 switch(bignum_cmp_unsigned(x, y)) {
8543 case 0: /* x = y, return 0 */
8544 return C_fix(0);
8545 case -1: /* abs(x) < abs(y), return -(abs(y) - abs(x)) */
8546 size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */
8547 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_TRUE, C_SCHEME_FALSE);
8548 size = y;
8549 y = x;
8550 x = size;
8551 break;
8552 case 1: /* abs(x) > abs(y), return abs(x) - abs(y) */
8553 default:
8554 size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */
8555 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
8556 break;
8557 }
8558
8559 scan_r = C_bignum_digits(res);
8560 end_r = scan_r + C_bignum_size(res);
8561 scan_y = C_bignum_digits(y);
8562 end_y = scan_y + C_bignum_size(y);
8563
8564 bignum_digits_destructive_copy(res, x); /* See bignum_plus_unsigned */
8565
8566 /* Destructively subtract y's digits w/ borrow from and back into r. */
8567 while (scan_y < end_y) {
8568 digit = *scan_r;
8569 if (borrow) {
8570 difference = digit - *scan_y++ - 1;
8571 borrow = difference >= digit;
8572 } else {
8573 difference = digit - *scan_y++;
8574 borrow = difference > digit;
8575 }
8576 (*scan_r++) = difference;
8577 }
8578
8579 /* The end of y, the smaller number. Propagate borrow into the rest of x. */
8580 while (borrow) {
8581 digit = *scan_r;
8582 difference = digit - borrow;
8583 borrow = difference >= digit;
8584 (*scan_r++) = difference;
8585 }
8586
8587 assert(scan_r <= end_r);
8588
8589 return C_bignum_simplify(res);
8590 }
8591
8592 /* Like C_s_a_i_plus, this needs at most 29 words */
8593 C_regparm C_word C_fcall
8594 C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)
8595 {
8596 if (x & C_FIXNUM_BIT) {
8597 if (y & C_FIXNUM_BIT) {
8598 return C_a_i_fixnum_difference(ptr, 2, x, y);
8599 } else if (C_immediatep(y)) {
8600 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8601 } else if (C_block_header(y) == C_FLONUM_TAG) {
8602 return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y));
8603 } else if (C_truep(C_bignump(y))) {
8604 return C_s_a_u_i_integer_minus(ptr, 2, x, y);
8605 } else if (C_block_header(y) == C_RATNUM_TAG) {
8606 return integer_minus_rat(ptr, x, y);
8607 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8608 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8609 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));
8610 if (C_truep(C_u_i_inexactp(real_diff)))
8611 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8612 return C_cplxnum(ptr, real_diff, imag);
8613 } else {
8614 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8615 }
8616 } else if (C_immediatep(x)) {
8617 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
8618 } else if (C_block_header(x) == C_FLONUM_TAG) {
8619 if (y & C_FIXNUM_BIT) {
8620 return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y));
8621 } else if (C_immediatep(y)) {
8622 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8623 } else if (C_block_header(y) == C_FLONUM_TAG) {
8624 return C_a_i_flonum_difference(ptr, 2, x, y);
8625 } else if (C_truep(C_bignump(y))) {
8626 return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y));
8627 } else if (C_block_header(y) == C_RATNUM_TAG) {
8628 return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));
8629 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8630 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8631 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));
8632 if (C_truep(C_u_i_inexactp(real_diff)))
8633 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8634 return C_cplxnum(ptr, real_diff, imag);
8635 } else {
8636 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8637 }
8638 } else if (C_truep(C_bignump(x))) {
8639 if (y & C_FIXNUM_BIT) {
8640 return C_s_a_u_i_integer_minus(ptr, 2, x, y);
8641 } else if (C_immediatep(y)) {
8642 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8643 } else if (C_block_header(y) == C_FLONUM_TAG) {
8644 return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y));
8645 } else if (C_truep(C_bignump(y))) {
8646 return C_s_a_u_i_integer_minus(ptr, 2, x, y);
8647 } else if (C_block_header(y) == C_RATNUM_TAG) {
8648 return integer_minus_rat(ptr, x, y);
8649 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8650 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8651 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));
8652 if (C_truep(C_u_i_inexactp(real_diff)))
8653 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8654 return C_cplxnum(ptr, real_diff, imag);
8655 } else {
8656 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8657 }
8658 } else if (C_block_header(x) == C_RATNUM_TAG) {
8659 if (y & C_FIXNUM_BIT) {
8660 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);
8661 } else if (C_immediatep(y)) {
8662 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8663 } else if (C_block_header(y) == C_FLONUM_TAG) {
8664 return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);
8665 } else if (C_truep(C_bignump(y))) {
8666 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);
8667 } else if (C_block_header(y) == C_RATNUM_TAG) {
8668 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus);
8669 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
8670 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),
8671 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));
8672 if (C_truep(C_u_i_inexactp(real_diff)))
8673 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8674 return C_cplxnum(ptr, real_diff, imag);
8675 } else {
8676 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
8677 }
8678 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
8679 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {
8680 C_word real_diff, imag_diff;
8681 real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y));
8682 imag_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_imag(x),C_u_i_cplxnum_imag(y));
8683 if (C_truep(C_u_i_zerop2(imag_diff))) return real_diff;
8684 else return C_cplxnum(ptr, real_diff, imag_diff);
8685 } else {
8686 C_word real_diff = C_s_a_i_minus(ptr, 2, C_u_i_cplxnum_real(x), y),
8687 imag = C_u_i_cplxnum_imag(x);
8688 if (C_truep(C_u_i_inexactp(real_diff)))
8689 imag = C_a_i_exact_to_inexact(ptr, 1, imag);
8690 return C_cplxnum(ptr, real_diff, imag);
8691 }
8692 } else {
8693 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);
8694 }
8695 }
8696
8697 C_regparm C_word C_fcall
8698 C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y)
8699 {
8700 if ((x & y) & C_FIXNUM_BIT) {
8701 return C_a_i_fixnum_difference(ptr, 2, x, y);
8702 } else {
8703 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;
8704 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
8705 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
8706
8707 if (C_bignum_negativep(x)) {
8708 if (C_bignum_negativep(y)) {
8709 return bignum_minus_unsigned(ptr, y, x);
8710 } else {
8711 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);
8712 }
8713 } else {
8714 if (C_bignum_negativep(y)) {
8715 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);
8716 } else {
8717 return bignum_minus_unsigned(ptr, x, y);
8718 }
8719 }
8720 }
8721 }
8722
8723 void C_ccall C_minus(C_word c, C_word *av)
8724 {
8725 /* C_word closure = av[ 0 ]; */
8726 C_word k = av[ 1 ];
8727 C_word next_val, result, prev_result;
8728 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;
8729
8730 if (c < 3) {
8731 C_bad_min_argc(c, 3);
8732 } else if (c == 3) {
8733 a = ab[0];
8734 C_kontinue(k, C_s_a_i_negate(&a, 1, av[ 2 ]));
8735 } else {
8736 prev_result = result = av[ 2 ];
8737 c -= 3;
8738 av += 3;
8739
8740 while (c--) {
8741 next_val = *(av++);
8742 a = ab[c&1]; /* One may hold last iteration result, the other is unused */
8743 result = C_s_a_i_minus(&a, 2, result, next_val);
8744 result = move_buffer_object(&a, ab[(c+1)&1], result);
8745 clear_buffer_object(ab[(c+1)&1], prev_result);
8746 prev_result = result;
8747 }
8748
8749 C_kontinue(k, result);
8750 }
8751 }
8752
8753
8754 static C_regparm void
8755 integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)
8756 {
8757 if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */
8758 if (x & C_FIXNUM_BIT) {
8759 /* abs(x) < abs(y), so it will always be [0, x] except for this case: */
8760 if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&
8761 C_bignum_negated_fitsinfixnump(y)) {
8762 if (q != NULL) *q = C_fix(-1);
8763 if (r != NULL) *r = C_fix(0);
8764 } else {
8765 if (q != NULL) *q = C_fix(0);
8766 if (r != NULL) *r = x;
8767 }
8768 } else {
8769 bignum_divrem(ptr, x, y, q, r);
8770 }
8771 } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */
8772 if (q != NULL) *q = C_a_i_fixnum_quotient_checked(ptr, 2, x, y);
8773 if (r != NULL) *r = C_i_fixnum_remainder_checked(x, y);
8774 } else { /* x is bignum, y is fixnum. */
8775 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
8776
8777 if (y == C_fix(1)) {
8778 if (q != NULL) *q = x;
8779 if (r != NULL) *r = C_fix(0);
8780 } else if (y == C_fix(-1)) {
8781 if (q != NULL) *q = C_s_a_u_i_integer_negate(ptr, 1, x);
8782 if (r != NULL) *r = C_fix(0);
8783 } else if (C_fitsinbignumhalfdigitp(absy) ||
8784 ((((C_uword)1 << (C_ilen(absy)-1)) == absy) &&
8785 C_fitsinfixnump(absy))) {
8786 assert(y != C_fix(0)); /* _must_ be checked by caller */
8787 if (q != NULL) {
8788 bignum_destructive_divide_unsigned_small(ptr, x, y, q, r);
8789 } else { /* We assume r isn't NULL here (that makes no sense) */
8790 C_word rem;
8791 C_uword next_power = (C_uword)1 << (C_ilen(absy)-1);
8792
8793 if (next_power == absy) { /* Is absy a power of two? */
8794 rem = *(C_bignum_digits(x)) & (next_power - 1);
8795 } else { /* Too bad, we have to do some real work */
8796 rem = bignum_remainder_unsigned_halfdigit(x, absy);
8797 }
8798 *r = C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem);
8799 }
8800 } else { /* Just divide it as two bignums */
8801 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
8802 bignum_divrem(ptr, x, C_a_u_i_fix_to_big(&a, y), q, r);
8803 if (q != NULL) *q = move_buffer_object(ptr, ab, *q);
8804 if (r != NULL) *r = move_buffer_object(ptr, ab, *r);
8805 }
8806 }
8807 }
8808
8809 /* This _always_ needs two bignum wrappers in ptr! */
8810 static C_regparm void
8811 bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)
8812 {
8813 C_word q_negp = C_mk_bool(C_bignum_negativep(y) != C_bignum_negativep(x)),
8814 r_negp = C_mk_bool(C_bignum_negativep(x)), res, size;
8815
8816 switch(bignum_cmp_unsigned(x, y)) {
8817 case 0:
8818 if (q != NULL) *q = C_truep(q_negp) ? C_fix(-1) : C_fix(1);
8819 if (r != NULL) *r = C_fix(0);
8820 break;
8821 case -1:
8822 if (q != NULL) *q = C_fix(0);
8823 if (r != NULL) *r = x;
8824 break;
8825 case 1:
8826 default:
8827 res = C_SCHEME_FALSE;
8828 size = C_bignum_size(x) - C_bignum_size(y);
8829 if (C_bignum_size(y) > C_BURNIKEL_ZIEGLER_THRESHOLD &&
8830 size > C_BURNIKEL_ZIEGLER_THRESHOLD) {
8831 res = bignum_divide_burnikel_ziegler(ptr, x, y, q, r);
8832 }
8833
8834 if (!C_truep(res)) {
8835 bignum_divide_unsigned(ptr, x, y, q, q_negp, r, r_negp);
8836 if (q != NULL) *q = C_bignum_simplify(*q);
8837 if (r != NULL) *r = C_bignum_simplify(*r);
8838 }
8839 break;
8840 }
8841 }
8842
8843 /* Burnikel-Ziegler recursive division: Split high number (x) in three
8844 * or four parts and divide by the lowest number (y), split in two
8845 * parts. There are descriptions in [MpNT, 4.2], [MCA, 1.4.3] and the
8846 * paper "Fast Recursive Division" by Christoph Burnikel & Joachim
8847 * Ziegler is freely available. There is also a description in Karl
8848 * Hasselstrom's thesis "Fast Division of Integers".
8849 *
8850 * The complexity of this is supposedly O(r*s^{log(3)-1} + r*log(s)),
8851 * where s is the length of x, and r is the length of y (in digits).
8852 *
8853 * TODO: See if it's worthwhile to implement "division without remainder"
8854 * from the Burnikel-Ziegler paper.
8855 */
8856 static C_regparm C_word
8857 bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)
8858 {
8859 C_word ab[C_SIZEOF_FIX_BIGNUM*9], *a = ab,
8860 lab[2][C_SIZEOF_FIX_BIGNUM*10], *la,
8861 q_negp = (C_bignum_negativep(y) ? C_mk_nbool(C_bignum_negativep(x)) :
8862 C_mk_bool(C_bignum_negativep(x))),
8863 r_negp = C_mk_bool(C_bignum_negativep(x)), s, m, n, i, j, l, shift,
8864 yhi, ylo, zi, zi_orig, newx, newy, quot, qi, ri;
8865
8866 /* Ran out of stack? Fall back to non-recursive division */
8867 C_stack_check1(return C_SCHEME_FALSE);
8868
8869 x = C_s_a_u_i_integer_abs(&a, 1, x);
8870 y = C_s_a_u_i_integer_abs(&a, 1, y);
8871
8872 /* Define m as min{2^k|(2^k)*BURNIKEL_ZIEGLER_DIFF_THRESHOLD > s}
8873 * This ensures we shift as little as possible (less pressure
8874 * on the GC) while maintaining a power of two until we drop
8875 * below the threshold, so we can always split N in half.
8876 */
8877 s = C_bignum_size(y);
8878 m = 1 << C_ilen(s / C_BURNIKEL_ZIEGLER_THRESHOLD);
8879 j = (s+m-1) / m; /* j = s/m, rounded up */
8880 n = j * m;
8881
8882 shift = (C_BIGNUM_DIGIT_LENGTH * n) - integer_length_abs(y);
8883 newx = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(shift));
8884 newy = C_s_a_i_arithmetic_shift(&a, 2, y, C_fix(shift));
8885 if (shift != 0) {
8886 clear_buffer_object(ab, x);
8887 clear_buffer_object(ab, y);
8888 }
8889 x = newx;
8890 y = newy;
8891
8892 /* l needs to be the smallest value so that a < base^{l*n}/2 */
8893 l = (C_bignum_size(x) + n) / n;
8894 if ((C_BIGNUM_DIGIT_LENGTH * l) == integer_length_abs(x)) l++;
8895 l = nmax(l, 2);
8896
8897 yhi = bignum_extract_digits(&a, 3, y, C_fix(n >> 1), C_SCHEME_FALSE);
8898 ylo = bignum_extract_digits(&a, 3, y, C_fix(0), C_fix(n >> 1));
8899
8900 s = (l - 2) * n * C_BIGNUM_DIGIT_LENGTH;
8901 zi_orig = zi = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(-s));
8902 quot = C_fix(0);
8903
8904 for(i = l - 2; i >= 0; --i) {
8905 la = lab[i&1];
8906
8907 burnikel_ziegler_2n_div_1n(&la, zi, y, yhi, ylo, C_fix(n), &qi, &ri);
8908
8909 newx = C_s_a_i_arithmetic_shift(&la, 2, quot, C_fix(n*C_BIGNUM_DIGIT_LENGTH));
8910 clear_buffer_object(lab, quot);
8911 quot = C_s_a_u_i_integer_plus(&la, 2, newx, qi);
8912 move_buffer_object(&la, lab[(i+1)&1], quot);
8913 clear_buffer_object(lab, newx);
8914 clear_buffer_object(lab, qi);
8915
8916 if (i > 0) { /* Set z_{i-1} = [r{i}, x{i-1}] */
8917 newx = bignum_extract_digits(&la, 3, x, C_fix(n * (i-1)), C_fix(n * i));
8918 newy = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(n*C_BIGNUM_DIGIT_LENGTH));
8919 clear_buffer_object(lab, zi);
8920 zi = C_s_a_u_i_integer_plus(&la, 2, newx, newy);
8921 move_buffer_object(&la, lab[(i+1)&1], zi);
8922 move_buffer_object(&la, lab[(i+1)&1], quot);
8923 clear_buffer_object(lab, newx);
8924 clear_buffer_object(lab, newy);
8925 clear_buffer_object(lab, ri);
8926 }
8927 }
8928 clear_buffer_object(ab, x);
8929 clear_buffer_object(ab, y);
8930 clear_buffer_object(ab, yhi);
8931 clear_buffer_object(ab, ylo);
8932 clear_buffer_object(ab, zi_orig);
8933 clear_buffer_object(lab, zi);
8934
8935 if (q != NULL) {
8936 if (C_truep(q_negp)) {
8937 newx = C_s_a_u_i_integer_negate(&la, 1, quot);
8938 clear_buffer_object(lab, quot);
8939 quot = newx;
8940 }
8941 *q = move_buffer_object(ptr, lab, quot);
8942 }
8943 clear_buffer_object(lab, quot);
8944
8945 if (r != NULL) {
8946 newx = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(-shift));
8947 if (C_truep(r_negp)) {
8948 newy = C_s_a_u_i_integer_negate(ptr, 1, newx);
8949 clear_buffer_object(lab, newx);
8950 newx = newy;
8951 }
8952 *r = move_buffer_object(ptr, lab, newx);
8953 }
8954 clear_buffer_object(lab, ri);
8955
8956 return C_SCHEME_TRUE;
8957 }
8958
8959 static C_regparm void
8960 burnikel_ziegler_3n_div_2n(C_word **ptr, C_word a12, C_word a3, C_word b, C_word b1, C_word b2, C_word n, C_word *q, C_word *r)
8961 {
8962 C_word kab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)], *ka = kab,
8963 lab[2][C_SIZEOF_FIX_BIGNUM*4], *la,
8964 size, tmp, less, qhat, rhat, r1, r1a3, i = 0;
8965
8966 size = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;
8967 tmp = C_s_a_i_arithmetic_shift(&ka, 2, a12, C_fix(-size));
8968 less = C_i_integer_lessp(tmp, b1); /* a1 < b1 ? */
8969 clear_buffer_object(kab, tmp);
8970
8971 if (C_truep(less)) {
8972 C_word atmpb[C_SIZEOF_FIX_BIGNUM*2], *atmp = atmpb, b11, b12, halfn;
8973
8974 halfn = C_fix(C_unfix(n) >> 1);
8975 b11 = bignum_extract_digits(&atmp, 3, b1, halfn, C_SCHEME_FALSE);
8976 b12 = bignum_extract_digits(&atmp, 3, b1, C_fix(0), halfn);
8977
8978 burnikel_ziegler_2n_div_1n(&ka, a12, b1, b11, b12, n, &qhat, &r1);
8979 qhat = move_buffer_object(&ka, atmpb, qhat);
8980 r1 = move_buffer_object(&ka, atmpb, r1);
8981
8982 clear_buffer_object(atmpb, b11);
8983 clear_buffer_object(atmpb, b12);
8984 } else {
8985 C_word atmpb[C_SIZEOF_FIX_BIGNUM*5], *atmp = atmpb, tmp2;
8986
8987 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, C_fix(1), C_fix(size));
8988 qhat = C_s_a_u_i_integer_minus(&ka, 2, tmp, C_fix(1)); /* B^n - 1 */
8989 qhat = move_buffer_object(&ka, atmpb, qhat);
8990 clear_buffer_object(atmpb, tmp);
8991
8992 /* r1 = (a12 - b1*B^n) + b1 */
8993 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, b1, C_fix(size));
8994 tmp2 = C_s_a_u_i_integer_minus(&atmp, 2, a12, tmp);
8995 r1 = C_s_a_u_i_integer_plus(&ka, 2, tmp2, b1);
8996 r1 = move_buffer_object(&ka, atmpb, r1);
8997 clear_buffer_object(atmpb, tmp);
8998 clear_buffer_object(atmpb, tmp2);
8999 }
9000
9001 tmp = C_s_a_i_arithmetic_shift(&ka, 2, r1, C_fix(size));
9002 clear_buffer_object(kab, r1);
9003 r1a3 = C_s_a_u_i_integer_plus(&ka, 2, tmp, a3);
9004 b2 = C_s_a_u_i_integer_times(&ka, 2, qhat, b2);
9005
9006 la = lab[0];
9007 rhat = C_s_a_u_i_integer_minus(&la, 2, r1a3, b2);
9008 rhat = move_buffer_object(&la, kab, rhat);
9009 qhat = move_buffer_object(&la, kab, qhat);
9010
9011 clear_buffer_object(kab, tmp);
9012 clear_buffer_object(kab, r1a3);
9013 clear_buffer_object(kab, b2);
9014
9015 while(C_truep(C_i_negativep(rhat))) {
9016 la = lab[(++i)&1];
9017 /* rhat += b */
9018 r1 = C_s_a_u_i_integer_plus(&la, 2, rhat, b);
9019 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);
9020 clear_buffer_object(lab[(i-1)&1], r1);
9021 clear_buffer_object(lab[(i-1)&1], rhat);
9022 clear_buffer_object(kab, rhat);
9023 rhat = tmp;
9024
9025 /* qhat -= 1 */
9026 r1 = C_s_a_u_i_integer_minus(&la, 2, qhat, C_fix(1));
9027 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);
9028 clear_buffer_object(lab[(i-1)&1], r1);
9029 clear_buffer_object(lab[(i-1)&1], qhat);
9030 clear_buffer_object(kab, qhat);
9031 qhat = tmp;
9032 }
9033
9034 if (q != NULL) *q = move_buffer_object(ptr, lab, qhat);
9035 if (r != NULL) *r = move_buffer_object(ptr, lab, rhat);
9036 clear_buffer_object(lab, qhat);
9037 clear_buffer_object(lab, rhat);
9038 }
9039
9040 static C_regparm void
9041 burnikel_ziegler_2n_div_1n(C_word **ptr, C_word a, C_word b, C_word b1, C_word b2, C_word n, C_word *q, C_word *r)
9042 {
9043 C_word kab[2][C_SIZEOF_FIX_BIGNUM*7], *ka, a12, a3, a4,
9044 q1 = C_fix(0), r1, q2 = C_fix(0), r2, *qp;
9045 int stack_full = 0;
9046
9047 C_stack_check1(stack_full = 1);
9048
9049 n = C_unfix(n);
9050 if (stack_full || (n & 1) || (n < C_BURNIKEL_ZIEGLER_THRESHOLD)) {
9051 integer_divrem(ptr, a, b, q, r);
9052 } else {
9053 ka = kab[0];
9054 a12 = bignum_extract_digits(&ka, 3, a, C_fix(n), C_SCHEME_FALSE);
9055 a3 = bignum_extract_digits(&ka, 3, a, C_fix(n >> 1), C_fix(n));
9056
9057 qp = (q == NULL) ? NULL : &q1;
9058 ka = kab[1];
9059 burnikel_ziegler_3n_div_2n(&ka, a12, a3, b, b1, b2, C_fix(n >> 1), qp, &r1);
9060 q1 = move_buffer_object(&ka, kab[0], q1);
9061 r1 = move_buffer_object(&ka, kab[0], r1);
9062 clear_buffer_object(kab[0], a12);
9063 clear_buffer_object(kab[0], a3);
9064
9065 a4 = bignum_extract_digits(&ka, 3, a, C_fix(0), C_fix(n >> 1));
9066
9067 qp = (q == NULL) ? NULL : &q2;
9068 ka = kab[0];
9069 burnikel_ziegler_3n_div_2n(&ka, r1, a4, b, b1, b2, C_fix(n >> 1), qp, r);
9070 if (r != NULL) *r = move_buffer_object(ptr, kab[0], *r);
9071 clear_buffer_object(kab[1], r1);
9072
9073 if (q != NULL) {
9074 C_word halfn_bits = (n >> 1) * C_BIGNUM_DIGIT_LENGTH;
9075 r1 = C_s_a_i_arithmetic_shift(&ka, 2, q1, C_fix(halfn_bits));
9076 *q = C_s_a_i_plus(ptr, 2, r1, q2); /* q = [q1, q2] */
9077 *q = move_buffer_object(ptr, kab[0], *q);
9078 clear_buffer_object(kab[0], r1);
9079 clear_buffer_object(kab[1], q1);
9080 clear_buffer_object(kab[0], q2);
9081 }
9082 clear_buffer_object(kab[1], a4);
9083 }
9084 }
9085
9086
9087 static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y)
9088 {
9089 C_uword *start = C_bignum_digits(x),
9090 *scan = start + C_bignum_size(x),
9091 rem = 0, two_digits;
9092
9093 assert((y > 1) && (C_fitsinbignumhalfdigitp(y)));
9094 while (start < scan) {
9095 two_digits = (*--scan);
9096 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % y;
9097 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % y;
9098 }
9099 return rem;
9100 }
9101
9102 /* There doesn't seem to be a way to return two values from inline functions */
9103 void C_ccall C_quotient_and_remainder(C_word c, C_word *av)
9104 {
9105 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab,
9106 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE,
9107 q, r, k, x, y;
9108
9109 if (c != 4) C_bad_argc_2(c, 4, av[ 0 ]);
9110
9111 k = av[ 1 ];
9112 x = av[ 2 ];
9113 y = av[ 3 ];
9114
9115 if (!C_truep(C_i_integerp(x)))
9116 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", x);
9117 if (!C_truep(C_i_integerp(y)))
9118 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", y);
9119 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient&remainder");
9120
9121 if (C_truep(C_i_flonump(x))) {
9122 if C_truep(C_i_flonump(y)) {
9123 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;
9124
9125 C_modf(dx / dy, &tmp);
9126 q = C_flonum(&a, tmp);
9127 r = C_flonum(&a, dx - tmp * dy);
9128 /* reuse av */
9129 av[ 0 ] = C_SCHEME_UNDEFINED;
9130 /* av[ 1 ] = k; */ /* stays the same */
9131 av[ 2 ] = q;
9132 av[ 3 ] = r;
9133 C_values(4, av);
9134 }
9135 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);
9136 }
9137 if (C_truep(C_i_flonump(y))) {
9138 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);
9139 }
9140
9141 integer_divrem(&a, x, y, &q, &r);
9142
9143 if (C_truep(nx) || C_truep(ny)) {
9144 C_word newq, newr;
9145 newq = C_a_i_exact_to_inexact(&a, 1, q);
9146 newr = C_a_i_exact_to_inexact(&a, 1, r);
9147 clear_buffer_object(ab, q);
9148 clear_buffer_object(ab, r);
9149 q = newq;
9150 r = newr;
9151
9152 clear_buffer_object(ab, nx);
9153 clear_buffer_object(ab, ny);
9154 }
9155 /* reuse av */
9156 av[ 0 ] = C_SCHEME_UNDEFINED;
9157 /* av[ 1 ] = k; */ /* stays the same */
9158 av[ 2 ] = q;
9159 av[ 3 ] = r;
9160 C_values(4, av);
9161 }
9162
9163 void C_ccall C_u_integer_quotient_and_remainder(C_word c, C_word *av)
9164 {
9165 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q, r;
9166
9167 if (av[ 3 ] == C_fix(0)) C_div_by_zero_error("quotient&remainder");
9168
9169 integer_divrem(&a, av[ 2 ], av[ 3 ], &q, &r);
9170
9171 /* reuse av */
9172 av[ 0 ] = C_SCHEME_UNDEFINED;
9173 /* av[ 1 ] = k; */ /* stays the same */
9174 av[ 2 ] = q;
9175 av[ 3 ] = r;
9176 C_values(4, av);
9177 }
9178
9179 C_regparm C_word C_fcall
9180 C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)
9181 {
9182 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, r,
9183 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;
9184
9185 if (!C_truep(C_i_integerp(x)))
9186 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", x);
9187 if (!C_truep(C_i_integerp(y)))
9188 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", y);
9189 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("remainder");
9190
9191 if (C_truep(C_i_flonump(x))) {
9192 if C_truep(C_i_flonump(y)) {
9193 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;
9194
9195 C_modf(dx / dy, &tmp);
9196 return C_flonum(ptr, dx - tmp * dy);
9197 }
9198 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);
9199 }
9200 if (C_truep(C_i_flonump(y))) {
9201 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);
9202 }
9203
9204 integer_divrem(&a, x, y, NULL, &r);
9205
9206 if (C_truep(nx) || C_truep(ny)) {
9207 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);
9208 clear_buffer_object(ab, r);
9209 r = newr;
9210
9211 clear_buffer_object(ab, nx);
9212 clear_buffer_object(ab, ny);
9213 }
9214 return move_buffer_object(ptr, ab, r);
9215 }
9216
9217 C_regparm C_word C_fcall
9218 C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)
9219 {
9220 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, r;
9221 if (y == C_fix(0)) C_div_by_zero_error("remainder");
9222 integer_divrem(&a, x, y, NULL, &r);
9223 return move_buffer_object(ptr, ab, r);
9224 }
9225
9226 /* Modulo's sign follows y (whereas remainder's sign follows x) */
9227 C_regparm C_word C_fcall
9228 C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)
9229 {
9230 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;
9231
9232 if (!C_truep(C_i_integerp(x)))
9233 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", x);
9234 if (!C_truep(C_i_integerp(y)))
9235 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", y);
9236 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("modulo");
9237
9238 r = C_s_a_i_remainder(&a, 2, x, y);
9239 if (C_i_positivep(y) != C_i_positivep(r) && !C_truep(C_i_zerop(r))) {
9240 C_word m = C_s_a_i_plus(ptr, 2, r, y);
9241 m = move_buffer_object(ptr, ab, m);
9242 clear_buffer_object(ab, r);
9243 r = m;
9244 }
9245 return move_buffer_object(ptr, ab, r);
9246 }
9247
9248 C_regparm C_word C_fcall
9249 C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)
9250 {
9251 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;
9252 if (y == C_fix(0)) C_div_by_zero_error("modulo");
9253
9254 r = C_s_a_i_remainder(&a, 2, x, y);
9255 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {
9256 C_word m = C_s_a_u_i_integer_plus(ptr, 2, r, y);
9257 m = move_buffer_object(ptr, ab, m);
9258 clear_buffer_object(ab, r);
9259 r = m;
9260 }
9261 return move_buffer_object(ptr, ab, r);
9262 }
9263
9264 C_regparm C_word C_fcall
9265 C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)
9266 {
9267 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, q,
9268 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;
9269
9270 if (!C_truep(C_i_integerp(x)))
9271 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", x);
9272 if (!C_truep(C_i_integerp(y)))
9273 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", y);
9274 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient");
9275
9276 if (C_truep(C_i_flonump(x))) {
9277 if C_truep(C_i_flonump(y)) {
9278 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;
9279
9280 C_modf(dx / dy, &tmp);
9281 return C_flonum(ptr, tmp);
9282 }
9283 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);
9284 }
9285 if (C_truep(C_i_flonump(y))) {
9286 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);
9287 }
9288
9289 integer_divrem(&a, x, y, &q, NULL);
9290
9291 if (C_truep(nx) || C_truep(ny)) {
9292 C_word newq = C_a_i_exact_to_inexact(ptr, 1, q);
9293 clear_buffer_object(ab, q);
9294 q = newq;
9295
9296 clear_buffer_object(ab, nx);
9297 clear_buffer_object(ab, ny);
9298 }
9299 return move_buffer_object(ptr, ab, q);
9300 }
9301
9302 C_regparm C_word C_fcall
9303 C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y)
9304 {
9305 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q;
9306 if (y == C_fix(0)) C_div_by_zero_error("quotient");
9307 integer_divrem(&a, x, y, &q, NULL);
9308 return move_buffer_object(ptr, ab, q);
9309 }
9310
9311
9312 /* For help understanding this algorithm, see:
9313 Knuth, Donald E., "The Art of Computer Programming",
9314 volume 2, "Seminumerical Algorithms"
9315 section 4.3.1, "Multiple-Precision Arithmetic".
9316
9317 [Yeah, that's a nice book but that particular section is not
9318 helpful at all, which is also pointed out by P. Brinch Hansen's
9319 "Multiple-Length Division Revisited: A Tour Of The Minefield".
9320 That's a more down-to-earth step-by-step explanation of the
9321 algorithm. Add to this the C implementation in Hacker's Delight
9322 (section 9-2, p141--142) and you may be able to grok this...
9323 ...barely, if you're as math-challenged as I am -- sjamaan]
9324
9325 This assumes that numerator >= denominator!
9326 */
9327 static void
9328 bignum_divide_unsigned(C_word **ptr, C_word num, C_word denom, C_word *q, C_word q_negp, C_word *r, C_word r_negp)
9329 {
9330 C_word quotient = C_SCHEME_UNDEFINED, remainder = C_SCHEME_UNDEFINED,
9331 return_rem = C_mk_nbool(r == NULL), size;
9332
9333 if (q != NULL) {
9334 size = C_fix(C_bignum_size(num) + 1 - C_bignum_size(denom));
9335 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);
9336 }
9337
9338 /* An object is always required to receive the remainder */
9339 size = C_fix(C_bignum_size(num) + 1);
9340 remainder = C_allocate_scratch_bignum(ptr, size, r_negp, C_SCHEME_FALSE);
9341 bignum_destructive_divide_full(num, denom, quotient, remainder, return_rem);
9342
9343 /* Simplification must be done by the caller, for consistency */
9344 if (q != NULL) *q = quotient;
9345 if (r == NULL) {
9346 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(remainder));
9347 } else {
9348 *r = remainder;
9349 }
9350 }
9351
9352 /* Compare two numbers as ratnums. Either may be rat-, fix- or bignums */
9353 static C_word rat_cmp(C_word x, C_word y)
9354 {
9355 C_word ab[C_SIZEOF_FIX_BIGNUM*4], *a = ab, x1, x2, y1, y2,
9356 s, t, ssize, tsize, result, negp;
9357 C_uword *scan;
9358
9359 /* Check for 1 or 0; if x or y is this, the other must be the ratnum */
9360 if (x == C_fix(0)) { /* Only the sign of y1 matters */
9361 return basic_cmp(x, C_u_i_ratnum_num(y), "ratcmp", 0);
9362 } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */
9363 return basic_cmp(C_u_i_ratnum_denom(y), C_u_i_ratnum_num(y), "ratcmp", 0);
9364 } else if (y == C_fix(0)) { /* Only the sign of x1 matters */
9365 return basic_cmp(C_u_i_ratnum_num(x), y, "ratcmp", 0);
9366 } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */
9367 return basic_cmp(C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), "ratcmp", 0);
9368 }
9369
9370 /* Extract components x=x1/x2 and y=y1/y2 */
9371 if (x & C_FIXNUM_BIT || C_truep(C_bignump(x))) {
9372 x1 = x;
9373 x2 = C_fix(1);
9374 } else {
9375 x1 = C_u_i_ratnum_num(x);
9376 x2 = C_u_i_ratnum_denom(x);
9377 }
9378
9379 if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) {
9380 y1 = y;
9381 y2 = C_fix(1);
9382 } else {
9383 y1 = C_u_i_ratnum_num(y);
9384 y2 = C_u_i_ratnum_denom(y);
9385 }
9386
9387 /* We only want to deal with bignums (this is tricky enough) */
9388 if (x1 & C_FIXNUM_BIT) x1 = C_a_u_i_fix_to_big(&a, x1);
9389 if (x2 & C_FIXNUM_BIT) x2 = C_a_u_i_fix_to_big(&a, x2);
9390 if (y1 & C_FIXNUM_BIT) y1 = C_a_u_i_fix_to_big(&a, y1);
9391 if (y2 & C_FIXNUM_BIT) y2 = C_a_u_i_fix_to_big(&a, y2);
9392
9393 /* We multiply using schoolbook method, so this will be very slow in
9394 * extreme cases. This is a tradeoff we make so that comparisons
9395 * are inlineable, which makes a big difference for the common case.
9396 */
9397 ssize = C_bignum_size(x1) + C_bignum_size(y2);
9398 negp = C_mk_bool(C_bignum_negativep(x1));
9399 s = allocate_tmp_bignum(C_fix(ssize), negp, C_SCHEME_TRUE);
9400 bignum_digits_multiply(x1, y2, s); /* Swap args if x1 < y2? */
9401
9402 tsize = C_bignum_size(y1) + C_bignum_size(x2);
9403 negp = C_mk_bool(C_bignum_negativep(y1));
9404 t = allocate_tmp_bignum(C_fix(tsize), negp, C_SCHEME_TRUE);
9405 bignum_digits_multiply(y1, x2, t); /* Swap args if y1 < x2? */
9406
9407 /* Shorten the numbers if needed */
9408 for (scan = C_bignum_digits(s)+ssize-1; *scan == 0; scan--) ssize--;
9409 C_bignum_mutate_size(s, ssize);
9410 for (scan = C_bignum_digits(t)+tsize-1; *scan == 0; scan--) tsize--;
9411 C_bignum_mutate_size(t, tsize);
9412
9413 result = C_i_bignum_cmp(s, t);
9414
9415 free_tmp_bignum(t);
9416 free_tmp_bignum(s);
9417 return result;
9418 }
9419
9420 C_regparm double C_fcall C_bignum_to_double(C_word bignum)
9421 {
9422 double accumulator = 0;
9423 C_uword *start = C_bignum_digits(bignum),
9424 *scan = start + C_bignum_size(bignum);
9425 while (start < scan) {
9426 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;
9427 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;
9428 accumulator += (*--scan);
9429 }
9430 return(C_bignum_negativep(bignum) ? -accumulator : accumulator);
9431 }
9432
9433 C_regparm C_word C_fcall
9434 C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x)
9435 {
9436 int exponent;
9437 double significand = frexp(C_flonum_magnitude(x), &exponent);
9438
9439 assert(C_truep(C_u_i_fpintegerp(x)));
9440
9441 if (exponent <= 0) {
9442 return C_fix(0);
9443 } else if (exponent == 1) { /* TODO: check significand * 2^exp fits fixnum? */
9444 return significand < 0.0 ? C_fix(-1) : C_fix(1);
9445 } else {
9446 C_word size, negp = C_mk_bool(C_flonum_magnitude(x) < 0.0), result;
9447 C_uword *start, *end;
9448
9449 size = C_fix(C_BIGNUM_BITS_TO_DIGITS(exponent));
9450 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);
9451
9452 start = C_bignum_digits(result);
9453 end = start + C_bignum_size(result);
9454
9455 fabs_frexp_to_digits(exponent, fabs(significand), start, end);
9456 return C_bignum_simplify(result);
9457 }
9458 }
9459
9460 static void
9461 fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)
9462 {
9463 C_uword digit, odd_bits = exp % C_BIGNUM_DIGIT_LENGTH;
9464
9465 assert(C_isfinite(sign));
9466 assert(0.5 <= sign && sign < 1); /* Guaranteed by frexp() and fabs() */
9467 assert((scan - start) == C_BIGNUM_BITS_TO_DIGITS(exp));
9468
9469 if (odd_bits > 0) { /* Handle most significant digit first */
9470 sign *= (C_uword)1 << odd_bits;
9471 digit = (C_uword)sign;
9472 (*--scan) = digit;
9473 sign -= (double)digit;
9474 }
9475
9476 while (start < scan && sign > 0) {
9477 sign *= pow(2.0, C_BIGNUM_DIGIT_LENGTH);
9478 digit = (C_uword)sign;
9479 (*--scan) = digit;
9480 sign -= (double)digit;
9481 }
9482
9483 /* Finish up by clearing any remaining, lower, digits */
9484 while (start < scan)
9485 (*--scan) = 0;
9486 }
9487
9488 /* This is a bit weird: We have to compare flonums as bignums due to
9489 * precision loss on 64-bit platforms. For simplicity, we convert
9490 * fixnums to bignums here.
9491 */
9492 static C_word int_flo_cmp(C_word intnum, C_word flonum)
9493 {
9494 C_word ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_FLONUM], *a = ab, flo_int, res;
9495 double i, f;
9496
9497 f = C_flonum_magnitude(flonum);
9498
9499 if (C_isnan(f)) {
9500 return C_SCHEME_FALSE; /* "mu" */
9501 } else if (C_isinf(f)) {
9502 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */
9503 } else {
9504 f = modf(f, &i);
9505
9506 flo_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));
9507
9508 res = basic_cmp(intnum, flo_int, "int_flo_cmp", 0);
9509 clear_buffer_object(ab, flo_int);
9510
9511 if (res == C_fix(0)) /* Use fraction to break tie. If f > 0, x is smaller */
9512 return C_fix((f > 0.0) ? -1 : ((f < 0.0) ? 1 : 0));
9513 else
9514 return res;
9515 }
9516 }
9517
9518 /* For convenience (ie, to reduce the degree of mindfuck) */
9519 static C_word flo_int_cmp(C_word flonum, C_word intnum)
9520 {
9521 C_word res = int_flo_cmp(intnum, flonum);
9522 switch(res) {
9523 case C_fix(1): return C_fix(-1);
9524 case C_fix(-1): return C_fix(1);
9525 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */
9526 }
9527 }
9528
9529 /* This code is a bit tedious, but it makes inline comparisons possible! */
9530 static C_word rat_flo_cmp(C_word ratnum, C_word flonum)
9531 {
9532 C_word ab[C_SIZEOF_FIX_BIGNUM * 4 + C_SIZEOF_FLONUM], *a = ab,
9533 num, denom, i_int, res, nscaled, iscaled, negp, shift_amount;
9534 C_uword *scan;
9535 double i, f;
9536
9537 f = C_flonum_magnitude(flonum);
9538
9539 if (C_isnan(f)) {
9540 return C_SCHEME_FALSE; /* "mu" */
9541 } else if (C_isinf(f)) {
9542 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */
9543 } else {
9544 /* Scale up the floating-point number to become a whole integer,
9545 * and remember power of two (# of bits) to shift the numerator.
9546 */
9547 shift_amount = 0;
9548
9549 /* TODO: This doesn't work for denormalized flonums! */
9550 while (modf(f, &i) != 0.0) {
9551 f = ldexp(f, 1);
9552 shift_amount++;
9553 }
9554
9555 i = f; /* TODO: split i and f so it'll work for denormalized flonums */
9556
9557 num = C_u_i_ratnum_num(ratnum);
9558 negp = C_i_negativep(num);
9559
9560 if (C_truep(negp) && i >= 0.0) { /* Save some time if signs differ */
9561 return C_fix(-1);
9562 } else if (!C_truep(negp) && i <= 0.0) { /* num is never 0 */
9563 return C_fix(1);
9564 } else {
9565 denom = C_u_i_ratnum_denom(ratnum);
9566 i_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));
9567
9568 /* Multiply the scaled flonum integer by the denominator, and
9569 * shift the numerator so that they may be directly compared. */
9570 iscaled = C_s_a_u_i_integer_times(&a, 2, i_int, denom);
9571 nscaled = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));
9572
9573 /* Finally, we're ready to compare them! */
9574 res = basic_cmp(nscaled, iscaled, "rat_flo_cmp", 0);
9575 clear_buffer_object(ab, nscaled);
9576 clear_buffer_object(ab, iscaled);
9577 clear_buffer_object(ab, i_int);
9578
9579 return res;
9580 }
9581 }
9582 }
9583
9584 static C_word flo_rat_cmp(C_word flonum, C_word ratnum)
9585 {
9586 C_word res = rat_flo_cmp(ratnum, flonum);
9587 switch(res) {
9588 case C_fix(1): return C_fix(-1);
9589 case C_fix(-1): return C_fix(1);
9590 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */
9591 }
9592 }
9593
9594 /* The primitive comparison operator. eqp should be 1 if we're only
9595 * interested in equality testing (can speed things up and in case of
9596 * compnums, equality checking is the only available operation). This
9597 * may return #f, in case there is no answer (for NaNs) or as a quick
9598 * and dirty non-zero answer when eqp is true. Ugly but effective :)
9599 */
9600 static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
9601 {
9602 if (x & C_FIXNUM_BIT) {
9603 if (y & C_FIXNUM_BIT) {
9604 return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0));
9605 } else if (C_immediatep(y)) {
9606 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9607 } else if (C_block_header(y) == C_FLONUM_TAG) {
9608 return int_flo_cmp(x, y);
9609 } else if (C_truep(C_bignump(y))) {
9610 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
9611 return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);
9612 } else if (C_block_header(y) == C_RATNUM_TAG) {
9613 if (eqp) return C_SCHEME_FALSE;
9614 else return rat_cmp(x, y);
9615 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
9616 if (eqp) return C_SCHEME_FALSE;
9617 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
9618 } else {
9619 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9620 }
9621 } else if (C_immediatep(x)) {
9622 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);
9623 } else if (C_block_header(x) == C_FLONUM_TAG) {
9624 if (y & C_FIXNUM_BIT) {
9625 return flo_int_cmp(x, y);
9626 } else if (C_immediatep(y)) {
9627 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9628 } else if (C_block_header(y) == C_FLONUM_TAG) {
9629 double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);
9630 if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */
9631 else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));
9632 } else if (C_truep(C_bignump(y))) {
9633 return flo_int_cmp(x, y);
9634 } else if (C_block_header(y) == C_RATNUM_TAG) {
9635 return flo_rat_cmp(x, y);
9636 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
9637 if (eqp) return C_SCHEME_FALSE;
9638 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
9639 } else {
9640 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9641 }
9642 } else if (C_truep(C_bignump(x))) {
9643 if (y & C_FIXNUM_BIT) {
9644 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
9645 return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));
9646 } else if (C_immediatep(y)) {
9647 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9648 } else if (C_block_header(y) == C_FLONUM_TAG) {
9649 return int_flo_cmp(x, y);
9650 } else if (C_truep(C_bignump(y))) {
9651 return C_i_bignum_cmp(x, y);
9652 } else if (C_block_header(y) == C_RATNUM_TAG) {
9653 if (eqp) return C_SCHEME_FALSE;
9654 else return rat_cmp(x, y);
9655 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
9656 if (eqp) return C_SCHEME_FALSE;
9657 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
9658 } else {
9659 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9660 }
9661 } else if (C_block_header(x) == C_RATNUM_TAG) {
9662 if (y & C_FIXNUM_BIT) {
9663 if (eqp) return C_SCHEME_FALSE;
9664 else return rat_cmp(x, y);
9665 } else if (C_immediatep(y)) {
9666 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9667 } else if (C_block_header(y) == C_FLONUM_TAG) {
9668 return rat_flo_cmp(x, y);
9669 } else if (C_truep(C_bignump(y))) {
9670 if (eqp) return C_SCHEME_FALSE;
9671 else return rat_cmp(x, y);
9672 } else if (C_block_header(y) == C_RATNUM_TAG) {
9673 if (eqp) {
9674 return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x),
9675 C_u_i_ratnum_num(y)),
9676 C_i_integer_equalp(C_u_i_ratnum_denom(x),
9677 C_u_i_ratnum_denom(y))),
9678 C_fix(0));
9679 } else {
9680 return rat_cmp(x, y);
9681 }
9682 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
9683 if (eqp) return C_SCHEME_FALSE;
9684 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
9685 } else {
9686 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9687 }
9688 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
9689 if (!eqp) {
9690 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x);
9691 } else if (y & C_FIXNUM_BIT) {
9692 return C_SCHEME_FALSE;
9693 } else if (C_immediatep(y)) {
9694 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9695 } else if (C_block_header(y) == C_FLONUM_TAG ||
9696 C_truep(C_bignump(x)) ||
9697 C_block_header(y) == C_RATNUM_TAG) {
9698 return C_SCHEME_FALSE;
9699 } else if (C_block_header(y) == C_CPLXNUM_TAG) {
9700 return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)),
9701 C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))),
9702 C_fix(0));
9703 } else {
9704 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
9705 }
9706 } else {
9707 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);
9708 }
9709 }
9710
9711 static int bignum_cmp_unsigned(C_word x, C_word y)
9712 {
9713 C_word xlen = C_bignum_size(x), ylen = C_bignum_size(y);
9714
9715 if (xlen < ylen) {
9716 return -1;
9717 } else if (xlen > ylen) {
9718 return 1;
9719 } else if (x == y) {
9720 return 0;
9721 } else {
9722 C_uword *startx = C_bignum_digits(x),
9723 *scanx = startx + xlen,
9724 *scany = C_bignum_digits(y) + ylen;
9725
9726 while (startx < scanx) {
9727 C_uword xdigit = (*--scanx), ydigit = (*--scany);
9728 if (xdigit < ydigit)
9729 return -1;
9730 if (xdigit > ydigit)
9731 return 1;
9732 }
9733 return 0;
9734 }
9735 }
9736
9737 C_regparm C_word C_fcall C_i_bignum_cmp(C_word x, C_word y)
9738 {
9739 if (C_bignum_negativep(x)) {
9740 if (C_bignum_negativep(y)) { /* Largest negative number is smallest */
9741 return C_fix(bignum_cmp_unsigned(y, x));
9742 } else {
9743 return C_fix(-1);
9744 }
9745 } else {
9746 if (C_bignum_negativep(y)) {
9747 return C_fix(1);
9748 } else {
9749 return C_fix(bignum_cmp_unsigned(x, y));
9750 }
9751 }
9752 }
9753
9754 void C_ccall C_nequalp(C_word c, C_word *av)
9755 {
9756 /* C_word closure = av[ 0 ]; */
9757 C_word k = av[ 1 ];
9758 C_word x, y, result = C_SCHEME_TRUE;
9759
9760 c -= 2;
9761 av += 2;
9762 if (c == 0) C_kontinue(k, result);
9763 x = *(av++);
9764
9765 if (c == 1 && !C_truep(C_i_numberp(x)))
9766 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);
9767
9768 while(--c) {
9769 y = *(av++);
9770 result = C_i_nequalp(x, y);
9771 if (result == C_SCHEME_FALSE) break;
9772 }
9773
9774 C_kontinue(k, result);
9775 }
9776
9777 C_regparm C_word C_fcall C_i_nequalp(C_word x, C_word y)
9778 {
9779 return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));
9780 }
9781
9782 C_regparm C_word C_fcall C_i_integer_equalp(C_word x, C_word y)
9783 {
9784 if (x & C_FIXNUM_BIT)
9785 return C_mk_bool(x == y);
9786 else if (y & C_FIXNUM_BIT)
9787 return C_SCHEME_FALSE;
9788 else
9789 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(0));
9790 }
9791
9792
9793 void C_ccall C_greaterp(C_word c, C_word *av)
9794 {
9795 C_word x, y,
9796 /* closure = av[ 0 ] */
9797 k = av[ 1 ],
9798 result = C_SCHEME_TRUE;
9799
9800 c -= 2;
9801 av += 2;
9802 if (c == 0) C_kontinue(k, result);
9803
9804 x = *(av++);
9805
9806 if (c == 1 && !C_truep(C_i_numberp(x)))
9807 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">", x);
9808
9809 while(--c) {
9810 y = *(av++);
9811 result = C_i_greaterp(x, y);
9812 if (result == C_SCHEME_FALSE) break;
9813 x = y;
9814 }
9815
9816 C_kontinue(k, result);
9817 }
9818
9819
9820 C_regparm C_word C_fcall C_i_greaterp(C_word x, C_word y)
9821 {
9822 return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));
9823 }
9824
9825 C_regparm C_word C_fcall C_i_integer_greaterp(C_word x, C_word y)
9826 {
9827 if (x & C_FIXNUM_BIT) {
9828 if (y & C_FIXNUM_BIT) {
9829 return C_mk_bool(C_unfix(x) > C_unfix(y));
9830 } else {
9831 return C_mk_bool(C_bignum_negativep(y));
9832 }
9833 } else if (y & C_FIXNUM_BIT) {
9834 return C_mk_nbool(C_bignum_negativep(x));
9835 } else {
9836 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(1));
9837 }
9838 }
9839
9840 void C_ccall C_lessp(C_word c, C_word *av)
9841 {
9842 C_word x, y,
9843 /* closure = av[ 0 ] */
9844 k = av[ 1 ],
9845 result = C_SCHEME_TRUE;
9846
9847 c -= 2;
9848 av += 2;
9849 if (c == 0) C_kontinue(k, result);
9850
9851 x = *(av++);
9852
9853 if (c == 1 && !C_truep(C_i_numberp(x)))
9854 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<", x);
9855
9856 while(--c) {
9857 y = *(av++);
9858 result = C_i_lessp(x, y);
9859 if (result == C_SCHEME_FALSE) break;
9860 x = y;
9861 }
9862
9863 C_kontinue(k, result);
9864 }
9865
9866
9867 C_regparm C_word C_fcall C_i_lessp(C_word x, C_word y)
9868 {
9869 return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));
9870 }
9871
9872 C_regparm C_word C_fcall C_i_integer_lessp(C_word x, C_word y)
9873 {
9874 if (x & C_FIXNUM_BIT) {
9875 if (y & C_FIXNUM_BIT) {
9876 return C_mk_bool(C_unfix(x) < C_unfix(y));
9877 } else {
9878 return C_mk_nbool(C_bignum_negativep(y));
9879 }
9880 } else if (y & C_FIXNUM_BIT) {
9881 return C_mk_bool(C_bignum_negativep(x));
9882 } else {
9883 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(-1));
9884 }
9885 }
9886
9887 void C_ccall C_greater_or_equal_p(C_word c, C_word *av)
9888 {
9889 C_word x, y,
9890 /* closure = av[ 0 ] */
9891 k = av[ 1 ],
9892 result = C_SCHEME_TRUE;
9893
9894 c -= 2;
9895 av += 2;
9896 if (c == 0) C_kontinue(k, result);
9897
9898 x = *(av++);
9899
9900 if (c == 1 && !C_truep(C_i_numberp(x)))
9901 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">=", x);
9902
9903 while(--c) {
9904 y = *(av++);
9905 result = C_i_greater_or_equalp(x, y);
9906 if (result == C_SCHEME_FALSE) break;
9907 x = y;
9908 }
9909
9910 C_kontinue(k, result);
9911 }
9912
9913
9914 C_regparm C_word C_fcall C_i_greater_or_equalp(C_word x, C_word y)
9915 {
9916 C_word res = basic_cmp(x, y, ">=", 0);
9917 return C_mk_bool(res == C_fix(0) || res == C_fix(1));
9918 }
9919
9920 C_regparm C_word C_fcall C_i_integer_greater_or_equalp(C_word x, C_word y)
9921 {
9922 if (x & C_FIXNUM_BIT) {
9923 if (y & C_FIXNUM_BIT) {
9924 return C_mk_bool(C_unfix(x) >= C_unfix(y));
9925 } else {
9926 return C_mk_bool(C_bignum_negativep(y));
9927 }
9928 } else if (y & C_FIXNUM_BIT) {
9929 return C_mk_nbool(C_bignum_negativep(x));
9930 } else {
9931 C_word res = C_i_bignum_cmp(x, y);
9932 return C_mk_bool(res == C_fix(0) || res == C_fix(1));
9933 }
9934 }
9935
9936 void C_ccall C_less_or_equal_p(C_word c, C_word *av)
9937 {
9938 C_word x, y,
9939 /* closure = av[ 0 ] */
9940 k = av[ 1 ],
9941 result = C_SCHEME_TRUE;
9942
9943 c -= 2;
9944 av += 2;
9945 if (c == 0) C_kontinue(k, result);
9946
9947 x = *(av++);
9948
9949 if (c == 1 && !C_truep(C_i_numberp(x)))
9950 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<=", x);
9951
9952 while(--c) {
9953 y = *(av++);
9954 result = C_i_less_or_equalp(x, y);
9955 if (result == C_SCHEME_FALSE) break;
9956 x = y;
9957 }
9958
9959 C_kontinue(k, result);
9960 }
9961
9962
9963 C_regparm C_word C_fcall C_i_less_or_equalp(C_word x, C_word y)
9964 {
9965 C_word res = basic_cmp(x, y, "<=", 0);
9966 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));
9967 }
9968
9969
9970 C_regparm C_word C_fcall C_i_integer_less_or_equalp(C_word x, C_word y)
9971 {
9972 if (x & C_FIXNUM_BIT) {
9973 if (y & C_FIXNUM_BIT) {
9974 return C_mk_bool(C_unfix(x) <= C_unfix(y));
9975 } else {
9976 return C_mk_nbool(C_bignum_negativep(y));
9977 }
9978 } else if (y & C_FIXNUM_BIT) {
9979 return C_mk_bool(C_bignum_negativep(x));
9980 } else {
9981 C_word res = C_i_bignum_cmp(x, y);
9982 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));
9983 }
9984 }
9985
9986
9987 void C_ccall C_gc(C_word c, C_word *av)
9988 {
9989 C_word
9990 /* closure = av[ 0 ] */
9991 k = av[ 1 ];
9992 int f;
9993 C_word
9994 arg, *p,
9995 size = 0;
9996
9997 if(c == 3) {
9998 arg = av[ 2 ];
9999 f = C_truep(arg);
10000 }
10001 else if(c != 2) C_bad_min_argc(c, 2);
10002 else f = 1;
10003
10004 C_save(k);
10005 p = C_temporary_stack;
10006
10007 if(c == 3) {
10008 if((arg & C_FIXNUM_BIT) != 0) size = C_unfix(arg);
10009 else if(arg == C_SCHEME_END_OF_LIST) size = percentage(heap_size, C_heap_growth);
10010 }
10011
10012 if(size && !C_heap_size_is_fixed) {
10013 C_rereclaim2(size, 0);
10014 C_temporary_stack = C_temporary_stack_bottom;
10015 gc_2(0, p);
10016 }
10017 else if(f) C_fromspace_top = C_fromspace_limit;
10018
10019 C_reclaim((void *)gc_2, 1);
10020 }
10021
10022
10023 void C_ccall gc_2(C_word c, C_word *av)
10024 {
10025 C_word k = av[ 0 ];
10026 C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));
10027 }
10028
10029
10030 void C_ccall C_open_file_port(C_word c, C_word *av)
10031 {
10032 C_word
10033 /* closure = av[ 0 ] */
10034 k = av[ 1 ],
10035 port = av[ 2 ],
10036 channel = av[ 3 ],
10037 mode = av[ 4 ];
10038 C_FILEPTR fp = (C_FILEPTR)NULL;
10039 C_char fmode[ 4 ];
10040 C_word n;
10041 char *buf;
10042
10043 switch(channel) {
10044 case C_fix(0): fp = C_stdin; break;
10045 case C_fix(1): fp = C_stdout; break;
10046 case C_fix(2): fp = C_stderr; break;
10047 default:
10048 n = C_header_size(channel);
10049 buf = buffer;
10050
10051 if(n >= STRING_BUFFER_SIZE) {
10052 if((buf = (char *)C_malloc(n + 1)) == NULL)
10053 barf(C_OUT_OF_MEMORY_ERROR, "open");
10054 }
10055
10056 C_strncpy(buf, C_c_string(channel), n);
10057 buf[ n ] = '\0';
10058 if (n != strlen(buf))
10059 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", channel);
10060 n = C_header_size(mode);
10061 if (n >= sizeof(fmode)) n = sizeof(fmode) - 1;
10062 C_strncpy(fmode, C_c_string(mode), n);
10063 fmode[ n ] = '\0';
10064 if (n != strlen(fmode)) /* Shouldn't happen, but never hurts */
10065 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", mode);
10066 fp = C_fopen(buf, fmode);
10067
10068 if(buf != buffer) C_free(buf);
10069 }
10070
10071 C_set_block_item(port, 0, (C_word)fp);
10072 C_kontinue(k, C_mk_bool(fp != NULL));
10073 }
10074
10075
10076 void C_ccall C_allocate_vector(C_word c, C_word *av)
10077 {
10078 C_word
10079 /* closure = av[ 0 ] */
10080 k = av[ 1 ],
10081 size, bvecf, init, align8,
10082 bytes,
10083 n, *p;
10084
10085 if(c != 6) C_bad_argc(c, 6);
10086
10087 size = av[ 2 ];
10088 bvecf = av[ 3 ];
10089 init = av[ 4 ];
10090 align8 = av[ 5 ];
10091 n = C_unfix(size);
10092
10093 if(n > C_HEADER_SIZE_MASK || n < 0)
10094 barf(C_OUT_OF_RANGE_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));
10095
10096 if(!C_truep(bvecf)) bytes = C_wordstobytes(n) + sizeof(C_word);
10097 else bytes = n + sizeof(C_word);
10098
10099 if(C_truep(align8)) bytes += sizeof(C_word);
10100
10101 C_save(k);
10102 C_save(size);
10103 C_save(init);
10104 C_save(bvecf);
10105 C_save(align8);
10106 C_save(C_fix(bytes));
10107
10108 if(!C_demand(C_bytestowords(bytes))) {
10109 /* Allocate on heap: */
10110 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))
10111 C_fromspace_top = C_fromspace_limit; /* trigger major GC */
10112
10113 C_save(C_SCHEME_TRUE);
10114 /* We explicitly pass 7 here, that's the number of things saved.
10115 * That's the arguments, plus one additional thing: the mode.
10116 */
10117 C_reclaim((void *)allocate_vector_2, 7);
10118 }
10119
10120 C_save(C_SCHEME_FALSE);
10121 p = C_temporary_stack;
10122 C_temporary_stack = C_temporary_stack_bottom;
10123 allocate_vector_2(0, p);
10124 }
10125
10126
10127 void C_ccall allocate_vector_2(C_word c, C_word *av)
10128 {
10129 C_word
10130 mode = av[ 0 ],
10131 bytes = C_unfix(av[ 1 ]),
10132 align8 = av[ 2 ],
10133 bvecf = av[ 3 ],
10134 init = av[ 4 ],
10135 size = C_unfix(av[ 5 ]),
10136 k = av[ 6 ],
10137 *v0, v;
10138
10139 if(C_truep(mode)) {
10140 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {
10141 if(C_heap_size_is_fixed)
10142 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));
10143
10144 C_save(init);
10145 C_save(k);
10146 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);
10147 k = C_restore;
10148 init = C_restore;
10149 }
10150
10151 v0 = (C_word *)C_align((C_word)C_fromspace_top);
10152 C_fromspace_top += C_align(bytes);
10153 }
10154 else v0 = C_alloc(C_bytestowords(bytes));
10155
10156 #ifndef C_SIXTY_FOUR
10157 if(C_truep(align8) && C_aligned8(v0)) ++v0;
10158 #endif
10159
10160 v = (C_word)v0;
10161
10162 if(!C_truep(bvecf)) {
10163 *(v0++) = C_VECTOR_TYPE | size | (C_truep(align8) ? C_8ALIGN_BIT : 0);
10164
10165 while(size--) *(v0++) = init;
10166 }
10167 else {
10168 *(v0++) = C_STRING_TYPE | size;
10169
10170 if(C_truep(init))
10171 C_memset(v0, C_character_code(init), size);
10172 }
10173
10174 C_kontinue(k, v);
10175 }
10176
10177 static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)
10178 {
10179 C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),
10180 bigvec = (C_word)(mem + C_SIZEOF_BIGNUM_WRAPPER);
10181 if (mem == NULL) abort(); /* TODO: panic */
10182
10183 C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));
10184 C_set_block_item(bigvec, 0, C_truep(negp));
10185
10186 if (C_truep(initp)) {
10187 C_memset(((C_uword *)C_data_pointer(bigvec))+1,
10188 0, C_wordstobytes(C_unfix(size)));
10189 }
10190
10191 return C_a_i_bignum_wrapper(&mem, bigvec);
10192 }
10193
10194 C_regparm C_word C_fcall
10195 C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)
10196 {
10197 C_word big, bigvec = C_scratch_alloc(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));
10198
10199 C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));
10200 C_set_block_item(bigvec, 0, C_truep(negp));
10201
10202 if (C_truep(initp)) {
10203 C_memset(((C_uword *)C_data_pointer(bigvec))+1,
10204 0, C_wordstobytes(C_unfix(size)));
10205 }
10206
10207 big = C_a_i_bignum_wrapper(ptr, bigvec);
10208 C_mutate_scratch_slot(&C_internal_bignum_vector(big), bigvec);
10209 return big;
10210 }
10211
10212 /* Simplification: scan trailing zeroes, then return a fixnum if the
10213 * value fits, or trim the bignum's length. If the bignum was stored
10214 * in scratch space, we mark it as reclaimable. This means any
10215 * references to the original bignum are invalid after simplification!
10216 */
10217 C_regparm C_word C_fcall C_bignum_simplify(C_word big)
10218 {
10219 C_uword *start = C_bignum_digits(big),
10220 *last_digit = start + C_bignum_size(big) - 1,
10221 *scan = last_digit, tmp;
10222 int length;
10223
10224 while (scan >= start && *scan == 0)
10225 scan--;
10226 length = scan - start + 1;
10227
10228 switch(length) {
10229 case 0:
10230 if (C_in_scratchspacep(C_internal_bignum_vector(big)))
10231 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));
10232 return C_fix(0);
10233 case 1:
10234 tmp = *start;
10235 if (C_bignum_negativep(big) ?
10236 !(tmp & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)tmp) :
10237 C_ufitsinfixnump(tmp)) {
10238 if (C_in_scratchspacep(C_internal_bignum_vector(big)))
10239 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));
10240 return C_bignum_negativep(big) ? C_fix(-(C_word)tmp) : C_fix(tmp);
10241 }
10242 /* FALLTHROUGH */
10243 default:
10244 if (scan < last_digit) C_bignum_mutate_size(big, length);
10245 return big;
10246 }
10247 }
10248
10249 static void bignum_digits_destructive_negate(C_word result)
10250 {
10251 C_uword *scan, *end, digit, sum;
10252
10253 scan = C_bignum_digits(result);
10254 end = scan + C_bignum_size(result);
10255
10256 do {
10257 digit = ~*scan;
10258 sum = digit + 1;
10259 *scan++ = sum;
10260 } while (sum == 0 && scan < end);
10261
10262 for (; scan < end; scan++) {
10263 *scan = ~*scan;
10264 }
10265 }
10266
10267 static C_uword
10268 bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)
10269 {
10270 C_uword digit, p;
10271
10272 assert(C_fitsinbignumhalfdigitp(carry));
10273 assert(C_fitsinbignumhalfdigitp(factor));
10274
10275 /* See fixnum_times. Substitute xlo = factor, xhi = 0, y = digit
10276 * and simplify the result to reduce variable usage.
10277 */
10278 while (start < end) {
10279 digit = (*start);
10280
10281 p = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;
10282 carry = C_BIGNUM_DIGIT_LO_HALF(p);
10283
10284 p = factor * C_BIGNUM_DIGIT_HI_HALF(digit) + C_BIGNUM_DIGIT_HI_HALF(p);
10285 (*start++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), carry);
10286 carry = C_BIGNUM_DIGIT_HI_HALF(p);
10287 }
10288 return carry;
10289 }
10290
10291 static C_uword
10292 bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator)
10293 {
10294 C_uword digit, k = 0;
10295 C_uhword q_j_hi, q_j_lo;
10296
10297 /* Single digit divisor case from Hacker's Delight, Figure 9-1,
10298 * adapted to modify u[] in-place instead of writing to q[].
10299 */
10300 while (start < end) {
10301 digit = (*--end);
10302
10303 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_HI_HALF(digit)); /* j */
10304 q_j_hi = k / denominator;
10305 k -= q_j_hi * denominator;
10306
10307 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */
10308 q_j_lo = k / denominator;
10309 k -= q_j_lo * denominator;
10310
10311 *end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);
10312 }
10313 return k;
10314 }
10315
10316 static C_uword
10317 bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp)
10318 {
10319 int shift_left = C_BIGNUM_DIGIT_LENGTH - shift_right;
10320 C_uword digit, carry = negp ? ((~(C_uword)0) << shift_left) : 0;
10321
10322 assert(shift_right < C_BIGNUM_DIGIT_LENGTH);
10323
10324 while (start < end) {
10325 digit = *(--end);
10326 *end = (digit >> shift_right) | carry;
10327 carry = digit << shift_left;
10328 }
10329 return carry >> shift_left; /* The bits that were shifted out to the right */
10330 }
10331
10332 static C_uword
10333 bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left)
10334 {
10335 C_uword carry = 0, digit;
10336 int shift_right = C_BIGNUM_DIGIT_LENGTH - shift_left;
10337
10338 assert(shift_left < C_BIGNUM_DIGIT_LENGTH);
10339
10340 while (start < end) {
10341 digit = *start;
10342 (*start++) = (digit << shift_left) | carry;
10343 carry = digit >> shift_right;
10344 }
10345 return carry; /* This would end up as most significant digit if it fit */
10346 }
10347
10348 static C_regparm void
10349 bignum_digits_multiply(C_word x, C_word y, C_word result)
10350 {
10351 C_uword product,
10352 *xd = C_bignum_digits(x),
10353 *yd = C_bignum_digits(y),
10354 *rd = C_bignum_digits(result);
10355 C_uhword carry, yj;
10356 /* Lengths in halfwords */
10357 int i, j, length_x = C_bignum_size(x) * 2, length_y = C_bignum_size(y) * 2;
10358
10359 /* From Hacker's Delight, Figure 8-1 (top part) */
10360 for (j = 0; j < length_y; ++j) {
10361 yj = C_uhword_ref(yd, j);
10362 if (yj == 0) continue;
10363 carry = 0;
10364 for (i = 0; i < length_x; ++i) {
10365 product = (C_uword)C_uhword_ref(xd, i) * yj +
10366 (C_uword)C_uhword_ref(rd, i + j) + carry;
10367 C_uhword_set(rd, i + j, product);
10368 carry = C_BIGNUM_DIGIT_HI_HALF(product);
10369 }
10370 C_uhword_set(rd, j + length_x, carry);
10371 }
10372 }
10373
10374
10375 /* "small" is either a number that fits a halfdigit, or a power of two */
10376 static C_regparm void
10377 bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)
10378 {
10379 C_word size, quotient, q_negp = C_mk_bool((y & C_INT_SIGN_BIT) ?
10380 !(C_bignum_negativep(x)) :
10381 C_bignum_negativep(x)),
10382 r_negp = C_mk_bool(C_bignum_negativep(x));
10383 C_uword *start, *end, remainder;
10384 int shift_amount;
10385
10386 size = C_fix(C_bignum_size(x));
10387 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);
10388 bignum_digits_destructive_copy(quotient, x);
10389
10390 start = C_bignum_digits(quotient);
10391 end = start + C_bignum_size(quotient);
10392
10393 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
10394
10395 shift_amount = C_ilen(y) - 1;
10396 if (((C_uword)1 << shift_amount) == y) { /* Power of two? Shift! */
10397 remainder = bignum_digits_destructive_shift_right(start,end,shift_amount,0);
10398 assert(C_ufitsinfixnump(remainder));
10399 } else {
10400 remainder = bignum_digits_destructive_scale_down(start, end, y);
10401 assert(C_fitsinbignumhalfdigitp(remainder));
10402 }
10403
10404 if (r != NULL) *r = C_truep(r_negp) ? C_fix(-remainder) : C_fix(remainder);
10405 /* Calling this function only makes sense if quotient is needed */
10406 *q = C_bignum_simplify(quotient);
10407 }
10408
10409 static C_regparm void
10410 bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder)
10411 {
10412 C_word length = C_bignum_size(denominator);
10413 C_uword d1 = *(C_bignum_digits(denominator) + length - 1),
10414 *startr = C_bignum_digits(remainder),
10415 *endr = startr + C_bignum_size(remainder);
10416 int shift;
10417
10418 shift = C_BIGNUM_DIGIT_LENGTH - C_ilen(d1); /* nlz */
10419
10420 /* We have to work on halfdigits, so we shift out only the necessary
10421 * amount in order fill out that halfdigit (base is halved).
10422 * This trick is shamelessly stolen from Gauche :)
10423 * See below for part 2 of the trick.
10424 */
10425 if (shift >= C_BIGNUM_HALF_DIGIT_LENGTH)
10426 shift -= C_BIGNUM_HALF_DIGIT_LENGTH;
10427
10428 /* Code below won't always set high halfdigit of quotient, so do it here. */
10429 if (quotient != C_SCHEME_UNDEFINED)
10430 C_bignum_digits(quotient)[C_bignum_size(quotient)-1] = 0;
10431
10432 bignum_digits_destructive_copy(remainder, numerator);
10433 *(endr-1) = 0; /* Ensure most significant digit is initialised */
10434 if (shift == 0) { /* Already normalized */
10435 bignum_destructive_divide_normalized(remainder, denominator, quotient);
10436 } else { /* Requires normalisation; allocate scratch denominator for this */
10437 C_uword *startnd;
10438 C_word ndenom;
10439
10440 bignum_digits_destructive_shift_left(startr, endr, shift);
10441
10442 ndenom = allocate_tmp_bignum(C_fix(length), C_SCHEME_FALSE, C_SCHEME_FALSE);
10443 startnd = C_bignum_digits(ndenom);
10444 bignum_digits_destructive_copy(ndenom, denominator);
10445 bignum_digits_destructive_shift_left(startnd, startnd+length, shift);
10446
10447 bignum_destructive_divide_normalized(remainder, ndenom, quotient);
10448 if (C_truep(return_remainder)) /* Otherwise, don't bother shifting back */
10449 bignum_digits_destructive_shift_right(startr, endr, shift, 0);
10450
10451 free_tmp_bignum(ndenom);
10452 }
10453 }
10454
10455 static C_regparm void
10456 bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)
10457 {
10458 C_uword *v = C_bignum_digits(big_v),
10459 *u = C_bignum_digits(big_u),
10460 *q = big_q == C_SCHEME_UNDEFINED ? NULL : C_bignum_digits(big_q),
10461 p, /* product of estimated quotient & "denominator" */
10462 hat, qhat, rhat, /* estimated quotient and remainder digit */
10463 vn_1, vn_2; /* "cached" values v[n-1], v[n-2] */
10464 C_word t, k; /* Two helpers: temp/final remainder and "borrow" */
10465 /* We use plain ints here, which theoretically may not be enough on
10466 * 64-bit for an insanely huge number, but it is a _lot_ faster.
10467 */
10468 int n = C_bignum_size(big_v) * 2, /* in halfwords */
10469 m = (C_bignum_size(big_u) * 2) - 2; /* Correct for extra digit */
10470 int i, j; /* loop vars */
10471
10472 /* Part 2 of Gauche's aforementioned trick: */
10473 if (C_uhword_ref(v, n-1) == 0) n--;
10474
10475 /* These won't change during the loop, but are used in every step. */
10476 vn_1 = C_uhword_ref(v, n-1);
10477 vn_2 = C_uhword_ref(v, n-2);
10478
10479 /* See also Hacker's Delight, Figure 9-1. This is almost exactly that. */
10480 for (j = m - n; j >= 0; j--) {
10481 hat = C_BIGNUM_DIGIT_COMBINE(C_uhword_ref(u, j+n), C_uhword_ref(u, j+n-1));
10482 if (hat == 0) {
10483 if (q != NULL) C_uhword_set(q, j, 0);
10484 continue;
10485 }
10486 qhat = hat / vn_1;
10487 rhat = hat % vn_1;
10488
10489 /* Two whiles is faster than one big check with an OR. Thanks, Gauche! */
10490 while(qhat >= ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) { qhat--; rhat += vn_1; }
10491 while(qhat * vn_2 > C_BIGNUM_DIGIT_COMBINE(rhat, C_uhword_ref(u, j+n-2))
10492 && rhat < ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) {
10493 qhat--;
10494 rhat += vn_1;
10495 }
10496
10497 /* Multiply and subtract */
10498 k = 0;
10499 for (i = 0; i < n; i++) {
10500 p = qhat * C_uhword_ref(v, i);
10501 t = C_uhword_ref(u, i+j) - k - C_BIGNUM_DIGIT_LO_HALF(p);
10502 C_uhword_set(u, i+j, t);
10503 k = C_BIGNUM_DIGIT_HI_HALF(p) - (t >> C_BIGNUM_HALF_DIGIT_LENGTH);
10504 }
10505 t = C_uhword_ref(u,j+n) - k;
10506 C_uhword_set(u, j+n, t);
10507
10508 if (t < 0) { /* Subtracted too much? */
10509 qhat--;
10510 k = 0;
10511 for (i = 0; i < n; i++) {
10512 t = (C_uword)C_uhword_ref(u, i+j) + C_uhword_ref(v, i) + k;
10513 C_uhword_set(u, i+j, t);
10514 k = t >> C_BIGNUM_HALF_DIGIT_LENGTH;
10515 }
10516 C_uhword_set(u, j+n, (C_uhword_ref(u, j+n) + k));
10517 }
10518 if (q != NULL) C_uhword_set(q, j, qhat);
10519 } /* end j */
10520 }
10521
10522
10523 void C_ccall C_string_to_symbol(C_word c, C_word *av)
10524 {
10525 C_word
10526 /* closure = av[ 0 ] */
10527 k = av[ 1 ],
10528 string;
10529 int len, key;
10530 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);
10531 C_char *name;
10532
10533 if(c != 3) C_bad_argc(c, 3);
10534
10535 string = av[ 2 ];
10536
10537 if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)
10538 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->symbol", string);
10539
10540 len = C_header_size(string);
10541 name = (C_char *)C_data_pointer(string);
10542
10543 key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
10544 if(!C_truep(s = lookup(key, len, name, symbol_table)))
10545 s = add_symbol(&a, key, string, symbol_table);
10546
10547 C_kontinue(k, s);
10548 }
10549
10550 void C_ccall C_string_to_keyword(C_word c, C_word *av)
10551 {
10552 C_word
10553 /* closure = av[ 0 ] */
10554 k = av[ 1 ],
10555 string;
10556 int len, key;
10557 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);
10558 C_char *name;
10559
10560 if(c != 3) C_bad_argc(c, 3);
10561
10562 string = av[ 2 ];
10563
10564 if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)
10565 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->keyword", string);
10566
10567 len = C_header_size(string);
10568 name = (C_char *)C_data_pointer(string);
10569 key = hash_string(len, name, keyword_table->size, keyword_table->rand, 0);
10570
10571 if(!C_truep(s = lookup(key, len, name, keyword_table))) {
10572 s = add_symbol(&a, key, string, keyword_table);
10573 C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */
10574 C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */
10575 }
10576 C_kontinue(k, s);
10577 }
10578
10579 /* This will usually return a flonum, but it may also return a cplxnum
10580 * consisting of two flonums, making for a total of 11 words.
10581 */
10582 C_regparm C_word C_fcall
10583 C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)
10584 {
10585 if (n & C_FIXNUM_BIT) {
10586 return C_flonum(ptr, (double)C_unfix(n));
10587 } else if (C_immediatep(n)) {
10588 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);
10589 } else if (C_block_header(n) == C_FLONUM_TAG) {
10590 return n;
10591 } else if (C_truep(C_bignump(n))) {
10592 return C_a_u_i_big_to_flo(ptr, c, n);
10593 } else if (C_block_header(n) == C_CPLXNUM_TAG) {
10594 return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)),
10595 C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n)));
10596 /* The horribly painful case: ratnums */
10597 } else if (C_block_header(n) == C_RATNUM_TAG) {
10598 /* This tries to keep the numbers within representable ranges and
10599 * tries to drop as few significant digits as possible by bringing
10600 * the two numbers to within the same powers of two. See
10601 * algorithms M & N in Knuth, 4.2.1.
10602 */
10603 C_word num = C_u_i_ratnum_num(n), denom = C_u_i_ratnum_denom(n),
10604 /* e = approx. distance between the numbers in powers of 2.
10605 * ie, 2^e-1 < n/d < 2^e+1 (e is the *un*biased value of
10606 * e_w in M2. TODO: What if b!=2 (ie, flonum-radix isn't 2)?
10607 */
10608 e = integer_length_abs(num) - integer_length_abs(denom),
10609 ab[C_SIZEOF_FIX_BIGNUM*5+C_SIZEOF_FLONUM], *a = ab, tmp, q, r, len,
10610 shift_amount, negp = C_i_integer_negativep(num);
10611 C_uword *d;
10612 double res, fraction;
10613
10614 /* Align by shifting the smaller to the size of the larger */
10615 if (e < 0) num = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(-e));
10616 else if (e > 0) denom = C_s_a_i_arithmetic_shift(&a, 2, denom, C_fix(e));
10617
10618 /* Here, 1/2 <= n/d < 2 [N3] */
10619 if (C_truep(C_i_integer_lessp(num, denom))) { /* n/d < 1? */
10620 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(1));
10621 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */
10622 num = tmp;
10623 e--;
10624 }
10625
10626 /* Here, 1 <= n/d < 2 (normalized) [N5] */
10627 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));
10628
10629 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));
10630 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */
10631 num = tmp;
10632
10633 /* Now, calculate round(num/denom). We start with a quotient&remainder */
10634 integer_divrem(&a, num, denom, &q, &r);
10635
10636 /* We multiply the remainder by two to simulate adding 1/2 for
10637 * round. However, we don't do it if num = denom (q=1,r=0) */
10638 if (!((q == C_fix(1) || q == C_fix(-1)) && r == C_fix(0))) {
10639 tmp = C_s_a_i_arithmetic_shift(&a, 2, r, C_fix(1));
10640 clear_buffer_object(ab, r); /* "knows" shift creates fresh numbers */
10641 r = tmp;
10642 }
10643
10644 /* Now q is the quotient, but to "round" result we need to
10645 * adjust. This follows the semantics of the "round" procedure:
10646 * Round away from zero on positive numbers (ignoring sign). In
10647 * case of exactly halfway, we round up if odd.
10648 */
10649 tmp = C_a_i_exact_to_inexact(&a, 1, q);
10650 fraction = fabs(C_flonum_magnitude(tmp));
10651 switch (basic_cmp(r, denom, "", 0)) {
10652 case C_fix(0):
10653 if (C_truep(C_i_oddp(q))) fraction += 1.0;
10654 break;
10655 case C_fix(1):
10656 fraction += 1.0;
10657 break;
10658 default: /* if r <= denom, we're done */ break;
10659 }
10660
10661 clear_buffer_object(ab, num);
10662 clear_buffer_object(ab, denom);
10663 clear_buffer_object(ab, q);
10664 clear_buffer_object(ab, r);
10665
10666 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));
10667 res = ldexp(fraction, e - shift_amount);
10668 return C_flonum(ptr, C_truep(negp) ? -res : res);
10669 } else {
10670 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);
10671 }
10672 }
10673
10674
10675 /* this is different from C_a_i_flonum_round, for R5RS compatibility */
10676 C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)
10677 {
10678 double fn, i, f, i2, r;
10679
10680 fn = C_flonum_magnitude(n);
10681 if(fn < 0.0) {
10682 f = modf(-fn, &i);
10683 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))
10684 r = -i;
10685 else
10686 r = -(i + 1.0);
10687 }
10688 else if(fn == 0.0/* || fn == -0.0*/)
10689 r = fn;
10690 else {
10691 f = modf(fn, &i);
10692 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))
10693 r = i;
10694 else
10695 r = i + 1.0;
10696 }
10697
10698 return C_flonum(ptr, r);
10699 }
10700
10701 C_regparm C_word C_fcall
10702 C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)
10703 {
10704 double xub, yub, r;
10705
10706 if (!C_truep(C_u_i_fpintegerp(x)))
10707 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);
10708 if (!C_truep(C_u_i_fpintegerp(y)))
10709 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);
10710
10711 xub = C_flonum_magnitude(x);
10712 yub = C_flonum_magnitude(y);
10713
10714 if (xub < 0.0) xub = -xub;
10715 if (yub < 0.0) yub = -yub;
10716
10717 while(yub != 0.0) {
10718 r = fmod(xub, yub);
10719 xub = yub;
10720 yub = r;
10721 }
10722 return C_flonum(p, xub);
10723 }
10724
10725 /* This is Lehmer's GCD algorithm with Jebelean's quotient test, as
10726 * it is presented in the paper "An Analysis of Lehmer’s Euclidean
10727 * GCD Algorithm", by J. Sorenson. Fuck the ACM and their goddamn
10728 * paywall; you can currently find the paper here:
10729 * http://www.csie.nuk.edu.tw/~cychen/gcd/An%20analysis%20of%20Lehmer%27s%20Euclidean%20GCD%20algorithm.pdf
10730 * If that URI fails, it's also explained in [MpNT, 5.2]
10731 *
10732 * The basic idea is to avoid divisions which yield only small
10733 * quotients, in which the remainder won't reduce the numbers by
10734 * much. This can be detected by dividing only the leading k bits.
10735 * In our case, k = C_WORD_SIZE - 2.
10736 */
10737 inline static void lehmer_gcd(C_word **ptr, C_word u, C_word v, C_word *x, C_word *y)
10738 {
10739 int i_even = 1, done = 0;
10740 C_word shift_amount = integer_length_abs(u) - (C_WORD_SIZE - 2),
10741 ab[C_SIZEOF_BIGNUM(2)*2+C_SIZEOF_FIX_BIGNUM*2], *a = ab,
10742 uhat, vhat, qhat, xnext, ynext,
10743 xprev = 1, yprev = 0, xcurr = 0, ycurr = 1;
10744
10745 uhat = C_s_a_i_arithmetic_shift(&a, 2, u, C_fix(-shift_amount));
10746 vhat = C_s_a_i_arithmetic_shift(&a, 2, v, C_fix(-shift_amount));
10747 assert(uhat & C_FIXNUM_BIT); uhat = C_unfix(uhat);
10748 assert(vhat & C_FIXNUM_BIT); vhat = C_unfix(vhat);
10749
10750 do {
10751 qhat = uhat / vhat; /* Estimated quotient for this step */
10752 xnext = xprev - qhat * xcurr;
10753 ynext = yprev - qhat * ycurr;
10754
10755 /* Euclidean GCD swap on uhat and vhat (shift_amount is not needed): */
10756 shift_amount = vhat;
10757 vhat = uhat - qhat * vhat;
10758 uhat = shift_amount;
10759
10760 i_even = !i_even;
10761 if (i_even)
10762 done = (vhat < -xnext) || ((uhat - vhat) < (ynext - ycurr));
10763 else
10764 done = (vhat < -ynext) || ((uhat - vhat) < (xnext - xcurr));
10765
10766 if (!done) {
10767 xprev = xcurr; yprev = ycurr;
10768 xcurr = xnext; ycurr = ynext;
10769 }
10770 } while (!done);
10771
10772 /* x = xprev * u + yprev * v */
10773 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xprev), u);
10774 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(yprev), v);
10775 *x = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);
10776 *x = move_buffer_object(ptr, ab, *x);
10777 clear_buffer_object(ab, uhat);
10778 clear_buffer_object(ab, vhat);
10779
10780 /* y = xcurr * u + ycurr * v */
10781 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xcurr), u);
10782 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(ycurr), v);
10783 *y = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);
10784 *y = move_buffer_object(ptr, ab, *y);
10785 clear_buffer_object(ab, uhat);
10786 clear_buffer_object(ab, vhat);
10787 }
10788
10789 /* Because this must be inlineable (due to + and - using this for
10790 * ratnums), we can't use burnikel-ziegler division here, until we
10791 * have a C implementation that doesn't consume stack. However,
10792 * we *can* use Lehmer's GCD.
10793 */
10794 C_regparm C_word C_fcall
10795 C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)
10796 {
10797 C_word ab[2][C_SIZEOF_BIGNUM(2) * 2], *a, newx, newy, size, i = 0;
10798
10799 if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);
10800
10801 a = ab[i++];
10802 x = C_s_a_u_i_integer_abs(&a, 1, x);
10803 y = C_s_a_u_i_integer_abs(&a, 1, y);
10804
10805 if (!C_truep(C_i_integer_greaterp(x, y))) {
10806 newx = y; y = x; x = newx; /* Ensure loop invariant: abs(x) >= abs(y) */
10807 }
10808
10809 while(y != C_fix(0)) {
10810 assert(integer_length_abs(x) >= integer_length_abs(y));
10811 /* x and y are stored in the same buffer, as well as a result */
10812 a = ab[i++];
10813 if (i == 2) i = 0;
10814
10815 if (x & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);
10816
10817 /* First, see if we should run a Lehmer step */
10818 if ((integer_length_abs(x) - integer_length_abs(y)) < C_HALF_WORD_SIZE) {
10819 lehmer_gcd(&a, x, y, &newx, &newy);
10820 newx = move_buffer_object(&a, ab[i], newx);
10821 newy = move_buffer_object(&a, ab[i], newy);
10822 clear_buffer_object(ab[i], x);
10823 clear_buffer_object(ab[i], y);
10824 x = newx;
10825 y = newy;
10826 a = ab[i++]; /* Ensure x and y get cleared correctly below */
10827 if (i == 2) i = 0;
10828 }
10829
10830 newy = C_s_a_u_i_integer_remainder(&a, 2, x, y);
10831 newy = move_buffer_object(&a, ab[i], newy);
10832 newx = move_buffer_object(&a, ab[i], y);
10833 clear_buffer_object(ab[i], x);
10834 clear_buffer_object(ab[i], y);
10835 x = newx;
10836 y = newy;
10837 }
10838
10839 newx = C_s_a_u_i_integer_abs(ptr, 1, x);
10840 newx = move_buffer_object(ptr, ab, newx);
10841 clear_buffer_object(ab, x);
10842 clear_buffer_object(ab, y);
10843 return newx;
10844 }
10845
10846
10847 C_regparm C_word C_fcall
10848 C_s_a_i_digits_to_integer(C_word **ptr, C_word n, C_word str, C_word start, C_word end, C_word radix, C_word negp)
10849 {
10850 if (start == end) {
10851 return C_SCHEME_FALSE;
10852 } else {
10853 size_t nbits;
10854 char *s = C_c_string(str);
10855 C_word result, size;
10856 end = C_unfix(end);
10857 start = C_unfix(start);
10858 radix = C_unfix(radix);
10859
10860 assert((radix > 1) && C_fitsinbignumhalfdigitp(radix));
10861
10862 nbits = (end - start) * C_ilen(radix - 1);
10863 size = C_BIGNUM_BITS_TO_DIGITS(nbits);
10864 if (size == 1) {
10865 result = C_bignum1(ptr, C_truep(negp), 0);
10866 } else if (size == 2) {
10867 result = C_bignum2(ptr, C_truep(negp), 0, 0);
10868 } else {
10869 size = C_fix(size);
10870 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);
10871 }
10872
10873 return str_to_bignum(result, s + start, s + end, radix);
10874 }
10875 }
10876
10877 inline static int hex_char_to_digit(int ch)
10878 {
10879 if (ch == (int)'#') return 0; /* Hash characters in numbers are mapped to 0 */
10880 else if (ch >= (int)'a') return ch - (int)'a' + 10; /* lower hex */
10881 else if (ch >= (int)'A') return ch - (int)'A' + 10; /* upper hex */
10882 else return ch - (int)'0'; /* decimal (OR INVALID; handled elsewhere) */
10883 }
10884
10885 /* Write from digit character stream to bignum. Bignum does not need
10886 * to be initialised. Returns the bignum, or a fixnum. Assumes the
10887 * string contains only digits that fit within radix (checked by
10888 * string->number).
10889 */
10890 static C_regparm C_word
10891 str_to_bignum(C_word bignum, char *str, char *str_end, int radix)
10892 {
10893 int radix_shift, str_digit;
10894 C_uword *digits = C_bignum_digits(bignum),
10895 *end_digits = digits + C_bignum_size(bignum), big_digit = 0;
10896
10897 /* Below, we try to save up as much as possible in big_digit, and
10898 * only when it exceeds what we would be able to multiply easily, we
10899 * scale up the bignum and add what we saved up.
10900 */
10901 radix_shift = C_ilen(radix) - 1;
10902 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */
10903 int n = 0; /* Number of bits read so far into current big digit */
10904
10905 /* Read from least to most significant digit to avoid shifting or scaling */
10906 while (str_end > str) {
10907 str_digit = hex_char_to_digit((int)*--str_end);
10908
10909 big_digit |= (C_uword)str_digit << n;
10910 n += radix_shift;
10911
10912 if (n >= C_BIGNUM_DIGIT_LENGTH) {
10913 n -= C_BIGNUM_DIGIT_LENGTH;
10914 *digits++ = big_digit;
10915 big_digit = str_digit >> (radix_shift - n);
10916 }
10917 }
10918 assert(n < C_BIGNUM_DIGIT_LENGTH);
10919 /* If radix isn't an exact divisor of digit length, write final digit */
10920 if (n > 0) *digits++ = big_digit;
10921 assert(digits == end_digits);
10922 } else { /* Not a power of two */
10923 C_uword *last_digit = digits, factor; /* bignum starts as zero */
10924
10925 do {
10926 factor = radix;
10927 while (str < str_end && C_fitsinbignumhalfdigitp(factor)) {
10928 str_digit = hex_char_to_digit((int)*str++);
10929 factor *= radix;
10930 big_digit = radix * big_digit + str_digit;
10931 }
10932
10933 big_digit = bignum_digits_destructive_scale_up_with_carry(
10934 digits, last_digit, factor / radix, big_digit);
10935
10936 if (big_digit) {
10937 (*last_digit++) = big_digit; /* Move end */
10938 big_digit = 0;
10939 }
10940 } while (str < str_end);
10941
10942 /* Set remaining digits to zero so bignum_simplify can do its work */
10943 assert(last_digit <= end_digits);
10944 while (last_digit < end_digits) *last_digit++ = 0;
10945 }
10946
10947 return C_bignum_simplify(bignum);
10948 }
10949
10950
10951 static C_regparm double C_fcall decode_flonum_literal(C_char *str)
10952 {
10953 C_char *eptr;
10954 double flo;
10955 int len = C_strlen(str);
10956
10957 /* We only need to be able to parse what C_flonum_to_string() emits,
10958 * so we avoid too much error checking.
10959 */
10960 if (len == 6) { /* Only perform comparisons when necessary */
10961 if (!C_strcmp(str, "-inf.0")) return -1.0 / 0.0;
10962 if (!C_strcmp(str, "+inf.0")) return 1.0 / 0.0;
10963 if (!C_strcmp(str, "+nan.0")) return 0.0 / 0.0;
10964 }
10965
10966 errno = 0;
10967 flo = C_strtod(str, &eptr);
10968
10969 if((flo == HUGE_VAL && errno != 0) ||
10970 (flo == -HUGE_VAL && errno != 0) ||
10971 (*eptr != '\0' && C_strcmp(eptr, ".0") != 0)) {
10972 panic(C_text("could not decode flonum literal"));
10973 }
10974
10975 return flo;
10976 }
10977
10978
10979 static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum)
10980 {
10981 static char *digits = "0123456789abcdef";
10982 char *p;
10983 C_uword shift = C_ilen(base) - 1;
10984 int mask = (1 << shift) - 1;
10985 if (as_flonum) {
10986 buffer[68] = '\0';
10987 buffer[67] = '0';
10988 buffer[66] = '.';
10989 } else {
10990 buffer[66] = '\0';
10991 }
10992 p = buffer + 66;
10993 if (mask == base - 1) {
10994 do {
10995 *(--p) = digits [ num & mask ];
10996 num >>= shift;
10997 } while (num);
10998 } else {
10999 do {
11000 *(--p) = digits [ num % base ];
11001 num /= base;
11002 } while (num);
11003 }
11004 if (negp) *(--p) = '-';
11005 return p;
11006 }
11007
11008
11009 void C_ccall C_number_to_string(C_word c, C_word *av)
11010 {
11011 C_word radix, num;
11012
11013 if(c == 3) {
11014 radix = C_fix(10);
11015 } else if(c == 4) {
11016 radix = av[ 3 ];
11017 if(!(radix & C_FIXNUM_BIT))
11018 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);
11019 } else {
11020 C_bad_argc(c, 3);
11021 }
11022
11023 num = av[ 2 ];
11024
11025 if(num & C_FIXNUM_BIT) {
11026 C_fixnum_to_string(c, av); /* reuse av */
11027 } else if (C_immediatep(num)) {
11028 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);
11029 } else if(C_block_header(num) == C_FLONUM_TAG) {
11030 C_flonum_to_string(c, av); /* reuse av */
11031 } else if (C_truep(C_bignump(num))) {
11032 C_integer_to_string(c, av); /* reuse av */
11033 } else {
11034 C_word k = av[ 1 ];
11035 try_extended_number("##sys#extended-number->string", 3, k, num, radix);
11036 }
11037 }
11038
11039 void C_ccall C_fixnum_to_string(C_word c, C_word *av)
11040 {
11041 C_char *p;
11042 C_word *a,
11043 /* self = av[ 0 ] */
11044 k = av[ 1 ],
11045 num = av[ 2 ],
11046 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ])),
11047 neg = ((num & C_INT_SIGN_BIT) ? 1 : 0);
11048
11049 if (radix < 2 || radix > 16) {
11050 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
11051 }
11052
11053 num = neg ? -C_unfix(num) : C_unfix(num);
11054 p = to_n_nary(num, radix, neg, 0);
11055
11056 num = C_strlen(p);
11057 a = C_alloc((C_bytestowords(num) + 1));
11058 C_kontinue(k, C_string(&a, num, p));
11059 }
11060
11061 void C_ccall C_flonum_to_string(C_word c, C_word *av)
11062 {
11063 C_char *p;
11064 double f, fa, m;
11065 C_word *a,
11066 /* self = av[ 0 ] */
11067 k = av[ 1 ],
11068 num = av[ 2 ],
11069 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));
11070
11071 f = C_flonum_magnitude(num);
11072 fa = fabs(f);
11073
11074 /* XXX TODO: Should inexacts be printable in other bases than 10?
11075 * Perhaps output a string starting with #i?
11076 * Right now something like (number->string 1e40 16) results in
11077 * a string that can't be read back using string->number.
11078 */
11079 if((radix < 2) || (radix > 16)){
11080 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
11081 }
11082
11083 if(f == 0.0 || (C_modf(f, &m) == 0.0 && log2(fa) < C_WORD_SIZE)) { /* Use fast int code */
11084 if(signbit(f)) {
11085 p = to_n_nary((C_uword)-f, radix, 1, 1);
11086 } else {
11087 p = to_n_nary((C_uword)f, radix, 0, 1);
11088 }
11089 } else if(C_isnan(f)) {
11090 p = "+nan.0";
11091 } else if(C_isinf(f)) {
11092 p = f > 0 ? "+inf.0" : "-inf.0";
11093 } else { /* Doesn't fit an unsigned int and not "special"; use system libc */
11094 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),
11095 /* XXX: flonum_print_precision */
11096 (int)C_unfix(C_get_print_precision()), f);
11097 buffer[STRING_BUFFER_SIZE-1] = '\0';
11098
11099 if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {
11100 /* Already checked for these, so shouldn't happen */
11101 assert(*buffer != 'i'); /* "inf" */
11102 assert(*buffer != 'n'); /* "nan" */
11103 /* Ensure integral flonums w/o expt are always terminated by .0 */
11104 #if defined(HAVE_STRLCAT) || !defined(C_strcat)
11105 C_strlcat(buffer, C_text(".0"), sizeof(buffer));
11106 #else
11107 C_strcat(buffer, C_text(".0"));
11108 #endif
11109 }
11110 p = buffer;
11111 }
11112
11113 radix = C_strlen(p);
11114 a = C_alloc((C_bytestowords(radix) + 1));
11115 radix = C_string(&a, radix, p);
11116 C_kontinue(k, radix);
11117 }
11118
11119 void C_ccall C_integer_to_string(C_word c, C_word *av)
11120 {
11121 C_word
11122 /* self = av[ 0 ] */
11123 k = av[ 1 ],
11124 num = av[ 2 ],
11125 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));
11126
11127 if (num & C_FIXNUM_BIT) {
11128 C_fixnum_to_string(4, av); /* reuse av */
11129 } else {
11130 int len, radix_shift;
11131 size_t nbits;
11132
11133 if ((radix < 2) || (radix > 16)) {
11134 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));
11135 }
11136
11137 /* Approximation of the number of radix digits we'll need. We try
11138 * to be as precise as possible to avoid memmove overhead at the end
11139 * of the non-powers of two part of the conversion procedure, which
11140 * we may need to do because we write strings back-to-front, and
11141 * pointers must be aligned (even for byte blocks).
11142 */
11143 len = C_bignum_size(num)-1;
11144
11145 nbits = (size_t)len * C_BIGNUM_DIGIT_LENGTH;
11146 nbits += C_ilen(C_bignum_digits(num)[len]);
11147
11148 len = C_ilen(radix)-1;
11149 len = (nbits + len - 1) / len;
11150 len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */
11151
11152 radix_shift = C_ilen(radix) - 1;
11153 if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&
11154 /* The power of two fast path is much faster than recursion */
11155 ((C_uword)1 << radix_shift) != radix) {
11156 try_extended_number("##sys#integer->string/recursive",
11157 4, k, num, C_fix(radix), C_fix(len));
11158 } else {
11159 C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[6];
11160
11161 kav[ 0 ] = (C_word)NULL; /* No "self" closure */
11162 kav[ 1 ] = C_closure(&ka, 4, (C_word)bignum_to_str_2,
11163 k, num, C_fix(radix));
11164 kav[ 2 ] = C_fix(len);
11165 kav[ 3 ] = C_SCHEME_TRUE; /* Byte vector */
11166 kav[ 4 ] = C_SCHEME_FALSE; /* No initialization */
11167 kav[ 5 ] = C_SCHEME_FALSE; /* Don't align at 8 bytes */
11168 C_allocate_vector(6, kav);
11169 }
11170 }
11171 }
11172
11173 static void bignum_to_str_2(C_word c, C_word *av)
11174 {
11175 static char *characters = "0123456789abcdef";
11176 C_word
11177 self = av[ 0 ],
11178 string = av[ 1 ],
11179 k = C_block_item(self, 1),
11180 bignum = C_block_item(self, 2),
11181 radix = C_unfix(C_block_item(self, 3));
11182 char
11183 *buf = C_c_string(string),
11184 *index = buf + C_header_size(string) - 1;
11185 int radix_shift,
11186 negp = (C_bignum_negativep(bignum) ? 1 : 0);
11187
11188 radix_shift = C_ilen(radix) - 1;
11189 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */
11190 int radix_mask = radix - 1, big_digit_len = 0, radix_digit;
11191 C_uword *scan, *end, big_digit = 0;
11192
11193 scan = C_bignum_digits(bignum);
11194 end = scan + C_bignum_size(bignum);
11195
11196 while (scan < end) {
11197 /* If radix isn't an exact divisor of digit length, handle overlap */
11198 if (big_digit_len == 0) {
11199 big_digit = *scan++;
11200 big_digit_len = C_BIGNUM_DIGIT_LENGTH;
11201 } else {
11202 assert(index >= buf);
11203 radix_digit = big_digit;
11204 big_digit = *scan++;
11205 radix_digit |= ((unsigned int)big_digit << big_digit_len) & radix_mask;
11206 *index-- = characters[radix_digit];
11207 big_digit >>= (radix_shift - big_digit_len);
11208 big_digit_len = C_BIGNUM_DIGIT_LENGTH - (radix_shift - big_digit_len);
11209 }
11210
11211 while(big_digit_len >= radix_shift && index >= buf) {
11212 radix_digit = big_digit & radix_mask;
11213 *index-- = characters[radix_digit];
11214 big_digit >>= radix_shift;
11215 big_digit_len -= radix_shift;
11216 }
11217 }
11218
11219 assert(big_digit < radix);
11220
11221 /* Final digit (like overlap at start of while loop) */
11222 if (big_digit) *index-- = characters[big_digit];
11223
11224 if (negp) {
11225 /* Loop above might've overwritten sign position with a zero */
11226 if (*(index+1) == '0') *(index+1) = '-';
11227 else *index-- = '-';
11228 }
11229
11230 /* Length calculation is always precise for radix powers of two. */
11231 assert(index == buf-1);
11232 } else {
11233 C_uword base, *start, *scan, big_digit;
11234 C_word working_copy;
11235 int steps, i;
11236
11237 working_copy = allocate_tmp_bignum(C_fix(C_bignum_size(bignum)),
11238 C_mk_bool(negp), C_SCHEME_FALSE);
11239 bignum_digits_destructive_copy(working_copy, bignum);
11240
11241 start = C_bignum_digits(working_copy);
11242
11243 scan = start + C_bignum_size(bignum);
11244 /* Calculate the largest power of radix that fits a halfdigit:
11245 * steps = log10(2^halfdigit_bits), base = 10^steps
11246 */
11247 for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)
11248 steps++;
11249
11250 base /= radix; /* Back down: we overshot in the loop */
11251
11252 while (scan > start) {
11253 big_digit = bignum_digits_destructive_scale_down(start, scan, base);
11254
11255 if (*(scan-1) == 0) scan--; /* Adjust if we exhausted the highest digit */
11256
11257 for(i = 0; i < steps && index >= buf; ++i) {
11258 C_word tmp = big_digit / radix;
11259 *index-- = characters[big_digit - (tmp*radix)]; /* big_digit % radix */
11260 big_digit = tmp;
11261 }
11262 }
11263 assert(index >= buf-1);
11264 free_tmp_bignum(working_copy);
11265
11266 /* Move index onto first nonzero digit. We're writing a bignum
11267 here: it can't consist of only zeroes. */
11268 while(*++index == '0');
11269
11270 if (negp) *--index = '-';
11271
11272 /* Shorten with distance between start and index. */
11273 if (buf != index) {
11274 i = C_header_size(string) - (index - buf);
11275 C_memmove(buf, index, i); /* Move start of number to beginning. */
11276 C_block_header(string) = C_STRING_TYPE | i; /* Mutate strlength. */
11277 }
11278 }
11279
11280 C_kontinue(k, string);
11281 }
11282
11283
11284 void C_ccall C_make_structure(C_word c, C_word *av)
11285 {
11286 C_word
11287 /* closure = av[ 0 ] */
11288 k = av[ 1 ],
11289 type = av[ 2 ],
11290 size = c - 3,
11291 *s, s0;
11292
11293 if(!C_demand(size + 2))
11294 C_save_and_reclaim((void *)C_make_structure, c, av);
11295
11296 s = C_alloc(C_SIZEOF_STRUCTURE(size + 1)),
11297 s0 = (C_word)s;
11298 *(s++) = C_STRUCTURE_TYPE | (size + 1);
11299 *(s++) = type;
11300 av += 3;
11301
11302 while(size--)
11303 *(s++) = *(av++);
11304
11305 C_kontinue(k, s0);
11306 }
11307
11308
11309 void C_ccall C_make_symbol(C_word c, C_word *av)
11310 {
11311 C_word
11312 /* closure = av[ 0 ] */
11313 k = av[ 1 ],
11314 name = av[ 2 ],
11315 ab[ C_SIZEOF_SYMBOL ],
11316 *a = ab,
11317 s0 = (C_word)a;
11318
11319 *(a++) = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);
11320 *(a++) = C_SCHEME_UNBOUND;
11321 *(a++) = name;
11322 *a = C_SCHEME_END_OF_LIST;
11323 C_kontinue(k, s0);
11324 }
11325
11326
11327 void C_ccall C_make_pointer(C_word c, C_word *av)
11328 {
11329 C_word
11330 /* closure = av[ 0 ] */
11331 k = av[ 1 ],
11332 ab[ 2 ],
11333 *a = ab,
11334 p;
11335
11336 p = C_mpointer(&a, NULL);
11337 C_kontinue(k, p);
11338 }
11339
11340
11341 void C_ccall C_make_tagged_pointer(C_word c, C_word *av)
11342 {
11343 C_word
11344 /* closure = av[ 0 ] */
11345 k = av[ 1 ],
11346 tag = av[ 2 ],
11347 ab[ 3 ],
11348 *a = ab,
11349 p;
11350
11351 p = C_taggedmpointer(&a, tag, NULL);
11352 C_kontinue(k, p);
11353 }
11354
11355
11356 void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)
11357 {
11358 C_word
11359 /* closure = av[ 0 ] */
11360 k = av[ 1 ],
11361 n = av[ 2 ],
11362 *p;
11363
11364 C_save(k);
11365
11366 if(!C_demand(C_bytestowords(C_unfix(n))))
11367 C_reclaim((void *)generic_trampoline, 1);
11368
11369 p = C_temporary_stack;
11370 C_temporary_stack = C_temporary_stack_bottom;
11371 generic_trampoline(0, p);
11372 }
11373
11374
11375 void C_ccall generic_trampoline(C_word c, C_word *av)
11376 {
11377 C_word k = av[ 0 ];
11378
11379 C_kontinue(k, C_SCHEME_UNDEFINED);
11380 }
11381
11382
11383 void C_ccall C_return_to_host(C_word c, C_word *av)
11384 {
11385 C_word
11386 /* closure = av[ 0 ] */
11387 k = av[ 1 ];
11388
11389 return_to_host = 1;
11390 C_save(k);
11391 C_reclaim((void *)generic_trampoline, 1);
11392 }
11393
11394
11395 void C_ccall C_get_symbol_table_info(C_word c, C_word *av)
11396 {
11397 C_word
11398 /* closure = av[ 0 ] */
11399 k = av[ 1 ];
11400 double d1, d2;
11401 int n = 0, total;
11402 C_SYMBOL_TABLE *stp;
11403 C_word
11404 x, y,
11405 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_VECTOR(4) ],
11406 *a = ab;
11407
11408 for(stp = symbol_table_list; stp != NULL; stp = stp->next)
11409 ++n;
11410
11411 d1 = compute_symbol_table_load(&d2, &total);
11412 x = C_flonum(&a, d1); /* load */
11413 y = C_flonum(&a, d2); /* avg bucket length */
11414 C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));
11415 }
11416
11417
11418 void C_ccall C_get_memory_info(C_word c, C_word *av)
11419 {
11420 C_word
11421 /* closure = av[ 0 ] */
11422 k = av[ 1 ],
11423 ab[ C_SIZEOF_VECTOR(2) ],
11424 *a = ab;
11425
11426 C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));
11427 }
11428
11429
11430 void C_ccall C_context_switch(C_word c, C_word *av)
11431 {
11432 C_word
11433 /* closure = av[ 0 ] */
11434 state = av[ 2 ],
11435 n = C_header_size(state) - 1,
11436 adrs = C_block_item(state, 0),
11437 *av2;
11438 C_proc tp = (C_proc)C_block_item(adrs,0);
11439
11440 /* Copy argvector because it may be mutated in-place. The state
11441 * vector should not be re-invoked(?), but it can be kept alive
11442 * during GC, so the mutated argvector/state slots may turn stale.
11443 */
11444 av2 = C_alloc(n);
11445 C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word));
11446 tp(n, av2);
11447 }
11448
11449
11450 void C_ccall C_peek_signed_integer(C_word c, C_word *av)
11451 {
11452 C_word
11453 /* closure = av[ 0 ] */
11454 k = av[ 1 ],
11455 v = av[ 2 ],
11456 index = av[ 3 ],
11457 x = C_block_item(v, C_unfix(index)),
11458 ab[C_SIZEOF_BIGNUM(1)], *a = ab;
11459
11460 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];
11461
11462 C_kontinue(k, C_int_to_num(&a, num));
11463 }
11464
11465
11466 void C_ccall C_peek_unsigned_integer(C_word c, C_word *av)
11467 {
11468 C_word
11469 /* closure = av[ 0 ] */
11470 k = av[ 1 ],
11471 v = av[ 2 ],
11472 index = av[ 3 ],
11473 x = C_block_item(v, C_unfix(index)),
11474 ab[C_SIZEOF_BIGNUM(1)], *a = ab;
11475
11476 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];
11477
11478 C_kontinue(k, C_unsigned_int_to_num(&a, num));
11479 }
11480
11481 void C_ccall C_peek_int64(C_word c, C_word *av)
11482 {
11483 C_word
11484 /* closure = av[ 0 ] */
11485 k = av[ 1 ],
11486 v = av[ 2 ],
11487 index = av[ 3 ],
11488 x = C_block_item(v, C_unfix(index)),
11489 ab[C_SIZEOF_BIGNUM(2)], *a = ab;
11490
11491 C_s64 num = ((C_s64 *)C_data_pointer(v))[ C_unfix(index) ];
11492
11493 C_kontinue(k, C_int64_to_num(&a, num));
11494 }
11495
11496
11497 void C_ccall C_peek_uint64(C_word c, C_word *av)
11498 {
11499 C_word
11500 /* closure = av[ 0 ] */
11501 k = av[ 1 ],
11502 v = av[ 2 ],
11503 index = av[ 3 ],
11504 x = C_block_item(v, C_unfix(index)),
11505 ab[C_SIZEOF_BIGNUM(2)], *a = ab;
11506
11507 C_u64 num = ((C_u64 *)C_data_pointer(v))[ C_unfix(index) ];
11508
11509 C_kontinue(k, C_uint64_to_num(&a, num));
11510 }
11511
11512
11513 void C_ccall C_decode_seconds(C_word c, C_word *av)
11514 {
11515 C_word
11516 /* closure = av[ 0 ] */
11517 k = av[ 1 ],
11518 secs = av[ 2 ],
11519 mode = av[ 3 ];
11520 time_t tsecs;
11521 struct tm *tmt;
11522 C_word
11523 ab[ C_SIZEOF_VECTOR(10) ],
11524 *a = ab,
11525 info;
11526
11527 tsecs = (time_t)C_num_to_int64(secs);
11528
11529 if(mode == C_SCHEME_FALSE) tmt = C_localtime(&tsecs);
11530 else tmt = C_gmtime(&tsecs);
11531
11532 if(tmt == NULL)
11533 C_kontinue(k, C_SCHEME_FALSE);
11534
11535 info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),
11536 C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),
11537 C_fix(tmt->tm_wday), C_fix(tmt->tm_yday),
11538 tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,
11539 #ifdef C_GNU_ENV
11540 /* negative for west of UTC, but we want positive */
11541 C_fix(-tmt->tm_gmtoff)
11542 #elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
11543 C_fix(mode == C_SCHEME_FALSE ? _timezone : 0) /* does not account for DST */
11544 #else
11545 C_fix(mode == C_SCHEME_FALSE ? timezone : 0) /* does not account for DST */
11546 #endif
11547 );
11548 C_kontinue(k, info);
11549 }
11550
11551
11552 void C_ccall C_machine_byte_order(C_word c, C_word *av)
11553 {
11554 C_word
11555 /* closure = av[ 0 ] */
11556 k = av[ 1 ];
11557 char *str;
11558 C_word *a, s;
11559
11560 if(c != 2) C_bad_argc(c, 2);
11561
11562 #if defined(C_MACHINE_BYTE_ORDER)
11563 str = C_MACHINE_BYTE_ORDER;
11564 #else
11565 C_cblock
11566 static C_word one_two_three = 123;
11567 str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";
11568 C_cblockend;
11569 #endif
11570
11571 a = C_alloc(2 + C_bytestowords(strlen(str)));
11572 s = C_string2(&a, str);
11573
11574 C_kontinue(k, s);
11575 }
11576
11577
11578 void C_ccall C_machine_type(C_word c, C_word *av)
11579 {
11580 C_word
11581 /* closure = av[ 0 ] */
11582 k = av[ 1 ],
11583 *a, s;
11584
11585 if(c != 2) C_bad_argc(c, 2);
11586
11587 a = C_alloc(2 + C_bytestowords(strlen(C_MACHINE_TYPE)));
11588 s = C_string2(&a, C_MACHINE_TYPE);
11589
11590 C_kontinue(k, s);
11591 }
11592
11593
11594 void C_ccall C_software_type(C_word c, C_word *av)
11595 {
11596 C_word
11597 /* closure = av[ 0 ] */
11598 k = av[ 1 ],
11599 *a, s;
11600
11601 if(c != 2) C_bad_argc(c, 2);
11602
11603 a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_TYPE)));
11604 s = C_string2(&a, C_SOFTWARE_TYPE);
11605
11606 C_kontinue(k, s);
11607 }
11608
11609
11610 void C_ccall C_build_platform(C_word c, C_word *av)
11611 {
11612 C_word
11613 /* closure = av[ 0 ] */
11614 k = av[ 1 ],
11615 *a, s;
11616
11617 if(c != 2) C_bad_argc(c, 2);
11618
11619 a = C_alloc(2 + C_bytestowords(strlen(C_BUILD_PLATFORM)));
11620 s = C_string2(&a, C_BUILD_PLATFORM);
11621
11622 C_kontinue(k, s);
11623 }
11624
11625
11626 void C_ccall C_software_version(C_word c, C_word *av)
11627 {
11628 C_word
11629 /* closure = av[ 0 ] */
11630 k = av[ 1 ],
11631 *a, s;
11632
11633 if(c != 2) C_bad_argc(c, 2);
11634
11635 a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_VERSION)));
11636 s = C_string2(&a, C_SOFTWARE_VERSION);
11637
11638 C_kontinue(k, s);
11639 }
11640
11641
11642 /* Register finalizer: */
11643
11644 void C_ccall C_register_finalizer(C_word c, C_word *av)
11645 {
11646 C_word
11647 /* closure = av[ 0 ]) */
11648 k = av[ 1 ],
11649 x = av[ 2 ],
11650 proc = av[ 3 ];
11651
11652 if(C_immediatep(x) ||
11653 (!C_in_stackp(x) && !C_in_heapp(x) && !C_in_scratchspacep(x)))
11654 C_kontinue(k, x); /* not GCable */
11655
11656 C_do_register_finalizer(x, proc);
11657 C_kontinue(k, x);
11658 }
11659
11660
11661 /*XXX could this be made static? is it used in eggs somewhere?
11662 if not, declare as fcall/regparm (and static, remove from chicken.h)
11663 */
11664 void C_ccall C_do_register_finalizer(C_word x, C_word proc)
11665 {
11666 C_word *ptr;
11667 int n, i;
11668 FINALIZER_NODE *flist;
11669
11670 if(finalizer_free_list == NULL) {
11671 if((flist = (FINALIZER_NODE *)C_malloc(sizeof(FINALIZER_NODE))) == NULL)
11672 panic(C_text("out of memory - cannot allocate finalizer node"));
11673
11674 ++allocated_finalizer_count;
11675 }
11676 else {
11677 flist = finalizer_free_list;
11678 finalizer_free_list = flist->next;
11679 }
11680
11681 if(finalizer_list != NULL) finalizer_list->previous = flist;
11682
11683 flist->previous = NULL;
11684 flist->next = finalizer_list;
11685 finalizer_list = flist;
11686
11687 if(C_in_stackp(x)) C_mutate_slot(&flist->item, x);
11688 else flist->item = x;
11689
11690 if(C_in_stackp(proc)) C_mutate_slot(&flist->finalizer, proc);
11691 else flist->finalizer = proc;
11692
11693 ++live_finalizer_count;
11694 }
11695
11696
11697 /*XXX same here */
11698 int C_do_unregister_finalizer(C_word x)
11699 {
11700 int n;
11701 FINALIZER_NODE *flist;
11702
11703 for(flist = finalizer_list; flist != NULL; flist = flist->next) {
11704 if(flist->item == x) {
11705 if(flist->previous == NULL) finalizer_list = flist->next;
11706 else flist->previous->next = flist->next;
11707
11708 return 1;
11709 }
11710 }
11711
11712 return 0;
11713 }
11714
11715
11716 /* Dynamic loading of shared objects: */
11717
11718 void C_ccall C_set_dlopen_flags(C_word c, C_word *av)
11719 {
11720 C_word
11721 /* closure = av[ 0 ] */
11722 k = av[ 1 ],
11723 now = av[ 2 ],
11724 global = av[ 3 ];
11725
11726 #if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
11727 dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);
11728 #endif
11729 C_kontinue(k, C_SCHEME_UNDEFINED);
11730 }
11731
11732
11733 void C_ccall C_dload(C_word c, C_word *av)
11734 {
11735 C_word
11736 /* closure = av[ 0 ] */
11737 k = av[ 1 ],
11738 name = av[ 2 ],
11739 entry = av[ 3 ];
11740
11741 #if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
11742 /* Force minor GC: otherwise the lf may contain pointers to stack-data
11743 (stack allocated interned symbols, for example) */
11744 C_save_and_reclaim_args((void *)dload_2, 3, k, name, entry);
11745 #endif
11746
11747 C_kontinue(k, C_SCHEME_FALSE);
11748 }
11749
11750
11751 #ifdef DLOAD_2_DEFINED
11752 # undef DLOAD_2_DEFINED
11753 #endif
11754
11755 #if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)
11756 # ifdef __hpux__
11757 # define DLOAD_2_DEFINED
11758 void C_ccall dload_2(C_word c, C_word *av0)
11759 {
11760 void *handle, *p;
11761 C_word
11762 entry = av0[ 0 ],
11763 name = av0[ 1 ],
11764 k = av0[ 2 ],,
11765 av[ 2 ];
11766 C_char *mname = (C_char *)C_data_pointer(name);
11767
11768 /*
11769 * C_fprintf(C_stderr,
11770 * "shl_loading %s : %s\n",
11771 * (char *) C_data_pointer(name),
11772 * (char *) C_data_pointer(entry));
11773 */
11774
11775 if ((handle = (void *) shl_load(mname,
11776 BIND_IMMEDIATE | DYNAMIC_PATH,
11777 0L)) != NULL) {
11778 shl_t shl_handle = (shl_t) handle;
11779
11780 /*** This version does not check for C_dynamic_and_unsafe. Fix it. */
11781 if (shl_findsym(&shl_handle, (char *) C_data_pointer(entry), TYPE_PROCEDURE, &p) == 0) {
11782 current_module_name = C_strdup(mname);
11783 current_module_handle = handle;
11784
11785 if(debug_mode) {
11786 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),
11787 current_module_name, (C_uword)current_module_handle);
11788 }
11789
11790 av[ 0 ] = C_SCHEME_UNDEFINED;
11791 av[ 1 ] = k;
11792 ((C_proc)p)(2, av); /* doesn't return */
11793 } else {
11794 C_dlerror = (char *) C_strerror(errno);
11795 shl_unload(shl_handle);
11796 }
11797 } else {
11798 C_dlerror = (char *) C_strerror(errno);
11799 }
11800
11801 C_kontinue(k, C_SCHEME_FALSE);
11802 }
11803 # endif
11804 #endif
11805
11806
11807 #if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)
11808 # ifndef __hpux__
11809 # define DLOAD_2_DEFINED
11810 void C_ccall dload_2(C_word c, C_word *av0)
11811 {
11812 void *handle, *p, *p2;
11813 C_word
11814 entry = av0[ 0 ],
11815 name = av0[ 1 ],
11816 k = av0[ 2 ],
11817 av[ 2 ];
11818 C_char *topname = (C_char *)C_data_pointer(entry);
11819 C_char *mname = (C_char *)C_data_pointer(name);
11820 C_char *tmp;
11821 int tmp_len = 0;
11822
11823 if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {
11824 if((p = C_dlsym(handle, topname)) == NULL) {
11825 tmp_len = C_strlen(topname) + 2;
11826 tmp = (C_char *)C_malloc(tmp_len);
11827
11828 if(tmp == NULL)
11829 panic(C_text("out of memory - cannot allocate toplevel name string"));
11830
11831 C_strlcpy(tmp, C_text("_"), tmp_len);
11832 C_strlcat(tmp, topname, tmp_len);
11833 p = C_dlsym(handle, tmp);
11834 C_free(tmp);
11835 }
11836
11837 if(p != NULL) {
11838 current_module_name = C_strdup(mname);
11839 current_module_handle = handle;
11840
11841 if(debug_mode) {
11842 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),
11843 current_module_name, (C_uword)current_module_handle);
11844 }
11845
11846 av[ 0 ] = C_SCHEME_UNDEFINED;
11847 av[ 1 ] = k;
11848 ((C_proc)p)(2, av); /* doesn't return */
11849 }
11850
11851 C_dlclose(handle);
11852 }
11853
11854 C_dlerror = (char *)dlerror();
11855 C_kontinue(k, C_SCHEME_FALSE);
11856 }
11857 # endif
11858 #endif
11859
11860
11861 #if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)
11862 # define DLOAD_2_DEFINED
11863 void C_ccall dload_2(C_word c, C_word *av0)
11864 {
11865 HINSTANCE handle;
11866 FARPROC p = NULL, p2;
11867 C_word
11868 entry = av0[ 0 ],
11869 name = av0[ 1 ],
11870 k = av0[ 2 ],
11871 av[ 2 ];
11872 C_char *topname = (C_char *)C_data_pointer(entry);
11873 C_char *mname = (C_char *)C_data_pointer(name);
11874
11875 /* cannot use LoadLibrary on non-DLLs, so we use extension checking */
11876 if (C_header_size(name) >= 5) {
11877 char *n = (char*) C_data_pointer(name);
11878 int l = C_header_size(name);
11879 if (C_strncasecmp(".dll", n+l-5, 4) &&
11880 C_strncasecmp(".so", n+l-4, 3))
11881 C_kontinue(k, C_SCHEME_FALSE);
11882 }
11883
11884 if((handle = LoadLibrary(mname)) != NULL) {
11885 if ((p = GetProcAddress(handle, topname)) != NULL) {
11886 current_module_name = C_strdup(mname);
11887 current_module_handle = handle;
11888
11889 if(debug_mode) {
11890 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),
11891 current_module_name, (C_uword)current_module_handle);
11892 }
11893
11894 av[ 0 ] = C_SCHEME_UNDEFINED;
11895 av[ 1 ] = k;
11896 ((C_proc)p)(2, av); /* doesn't return */
11897 }
11898 else FreeLibrary(handle);
11899 }
11900
11901 C_dlerror = (char *) C_strerror(errno);
11902 C_kontinue(k, C_SCHEME_FALSE);
11903 }
11904 #endif
11905
11906
11907 void C_ccall C_become(C_word c, C_word *av)
11908 {
11909 C_word
11910 /* closure = av[ 0 ] */
11911 k = av[ 1 ],
11912 table = av[ 2 ],
11913 tp, x, old, neu, i, *p;
11914
11915 i = forwarding_table_size;
11916 p = forwarding_table;
11917
11918 for(tp = table; tp != C_SCHEME_END_OF_LIST; tp = C_u_i_cdr(tp)) {
11919 x = C_u_i_car(tp);
11920 old = C_u_i_car(x);
11921 neu = C_u_i_cdr(x);
11922
11923 if(i == 0) {
11924 if((forwarding_table = (C_word *)realloc(forwarding_table, (forwarding_table_size + 1) * 4 * sizeof(C_word))) == NULL)
11925 panic(C_text("out of memory - cannot re-allocate forwarding table"));
11926
11927 i = forwarding_table_size;
11928 p = forwarding_table + forwarding_table_size * 2;
11929 forwarding_table_size *= 2;
11930 }
11931
11932 *(p++) = old;
11933 *(p++) = neu;
11934 --i;
11935 }
11936
11937 *p = 0;
11938 C_fromspace_top = C_fromspace_limit;
11939 C_save_and_reclaim_args((void *)become_2, 1, k);
11940 }
11941
11942
11943 void C_ccall become_2(C_word c, C_word *av)
11944 {
11945 C_word k = av[ 0 ];
11946
11947 *forwarding_table = 0;
11948 C_kontinue(k, C_SCHEME_UNDEFINED);
11949 }
11950
11951
11952 C_regparm C_word C_fcall
11953 C_a_i_cpu_time(C_word **a, int c, C_word buf)
11954 {
11955 C_word u, s = C_fix(0);
11956
11957 #if defined(C_NONUNIX) || defined(__CYGWIN__)
11958 if(CLOCKS_PER_SEC == 1000) u = clock();
11959 else u = C_uint64_to_num(a, ((C_u64)clock() / CLOCKS_PER_SEC) * 1000);
11960 #else
11961 struct rusage ru;
11962
11963 if(C_getrusage(RUSAGE_SELF, &ru) == -1) u = 0;
11964 else {
11965 u = C_uint64_to_num(a, (C_u64)ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000);
11966 s = C_uint64_to_num(a, (C_u64)ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000);
11967 }
11968 #endif
11969
11970 /* buf must not be in nursery */
11971 C_set_block_item(buf, 0, u);
11972 C_set_block_item(buf, 1, s);
11973 return buf;
11974 }
11975
11976
11977 C_regparm C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak)
11978 {
11979 C_word *loc = *a;
11980 int offset, i, in = C_unfix(index);
11981 *a = loc + C_SIZEOF_LOCATIVE;
11982
11983 loc[ 0 ] = C_LOCATIVE_TAG;
11984
11985 switch(C_unfix(type)) {
11986 case C_SLOT_LOCATIVE: in *= sizeof(C_word); break;
11987 case C_U16_LOCATIVE:
11988 case C_S16_LOCATIVE: in *= 2; break;
11989 case C_U32_LOCATIVE:
11990 case C_F32_LOCATIVE:
11991 case C_S32_LOCATIVE: in *= 4; break;
11992 case C_U64_LOCATIVE:
11993 case C_S64_LOCATIVE:
11994 case C_F64_LOCATIVE: in *= 8; break;
11995 }
11996
11997 offset = in + sizeof(C_header);
11998 loc[ 1 ] = object + offset;
11999 loc[ 2 ] = C_fix(offset);
12000 loc[ 3 ] = type;
12001 loc[ 4 ] = C_truep(weak) ? C_SCHEME_FALSE : object;
12002
12003 for(i = 0; i < locative_table_count; ++i)
12004 if(locative_table[ i ] == C_SCHEME_UNDEFINED) {
12005 locative_table[ i ] = (C_word)loc;
12006 return (C_word)loc;
12007 }
12008
12009 if(locative_table_count >= locative_table_size) {
12010 if(debug_mode == 2)
12011 C_dbg(C_text("debug"), C_text("resizing locative table from %d to %d (count is %d)\n"),
12012 locative_table_size, locative_table_size * 2, locative_table_count);
12013
12014 locative_table = (C_word *)C_realloc(locative_table, locative_table_size * 2 * sizeof(C_word));
12015
12016 if(locative_table == NULL)
12017 panic(C_text("out of memory - cannot resize locative table"));
12018
12019 locative_table_size *= 2;
12020 }
12021
12022 locative_table[ locative_table_count++ ] = (C_word)loc;
12023 return (C_word)loc;
12024 }
12025
12026 C_regparm C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc)
12027 {
12028 C_word *ptr;
12029
12030 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
12031 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);
12032
12033 ptr = (C_word *)C_block_item(loc, 0);
12034
12035 if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);
12036
12037 switch(C_unfix(C_block_item(loc, 2))) {
12038 case C_SLOT_LOCATIVE: return *ptr;
12039 case C_CHAR_LOCATIVE: return C_make_character(*((char *)ptr));
12040 case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));
12041 case C_S8_LOCATIVE: return C_fix(*((char *)ptr));
12042 case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));
12043 case C_S16_LOCATIVE: return C_fix(*((short *)ptr));
12044 case C_U32_LOCATIVE: return C_unsigned_int_to_num(a, *((C_u32 *)ptr));
12045 case C_S32_LOCATIVE: return C_int_to_num(a, *((C_s32 *)ptr));
12046 case C_U64_LOCATIVE: return C_uint64_to_num(a, *((C_u64 *)ptr));
12047 case C_S64_LOCATIVE: return C_int64_to_num(a, *((C_s64 *)ptr));
12048 case C_F32_LOCATIVE: return C_flonum(a, *((float *)ptr));
12049 case C_F64_LOCATIVE: return C_flonum(a, *((double *)ptr));
12050 default: panic(C_text("bad locative type"));
12051 }
12052 }
12053
12054 C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)
12055 {
12056 C_word *ptr, val;
12057
12058 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
12059 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);
12060
12061 ptr = (C_word *)C_block_item(loc, 0);
12062
12063 if(ptr == NULL)
12064 barf(C_LOST_LOCATIVE_ERROR, "locative-set!", loc);
12065
12066 switch(C_unfix(C_block_item(loc, 2))) {
12067 case C_SLOT_LOCATIVE: C_mutate(ptr, x); break;
12068
12069 case C_CHAR_LOCATIVE:
12070 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
12071 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12072
12073 *((char *)ptr) = C_character_code(x);
12074 break;
12075
12076 case C_U8_LOCATIVE:
12077 if((x & C_FIXNUM_BIT) == 0)
12078 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12079
12080 *((unsigned char *)ptr) = C_unfix(x);
12081 break;
12082
12083 case C_S8_LOCATIVE:
12084 if((x & C_FIXNUM_BIT) == 0)
12085 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12086
12087 *((char *)ptr) = C_unfix(x);
12088 break;
12089
12090 case C_U16_LOCATIVE:
12091 if((x & C_FIXNUM_BIT) == 0)
12092 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12093
12094 *((unsigned short *)ptr) = C_unfix(x);
12095 break;
12096
12097 case C_S16_LOCATIVE:
12098 if((x & C_FIXNUM_BIT) == 0)
12099 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12100
12101 *((short *)ptr) = C_unfix(x);
12102 break;
12103
12104 case C_U32_LOCATIVE:
12105 if(!C_truep(C_i_exact_integerp(x)))
12106 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12107
12108 *((C_u32 *)ptr) = C_num_to_unsigned_int(x);
12109 break;
12110
12111 case C_S32_LOCATIVE:
12112 if(!C_truep(C_i_exact_integerp(x)))
12113 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12114
12115 *((C_s32 *)ptr) = C_num_to_int(x);
12116 break;
12117
12118 case C_U64_LOCATIVE:
12119 if(!C_truep(C_i_exact_integerp(x)))
12120 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12121
12122 *((C_u64 *)ptr) = C_num_to_uint64(x);
12123 break;
12124
12125 case C_S64_LOCATIVE:
12126 if(!C_truep(C_i_exact_integerp(x)))
12127 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12128
12129 *((C_s64 *)ptr) = C_num_to_int64(x);
12130 break;
12131
12132 case C_F32_LOCATIVE:
12133 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
12134 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12135
12136 *((float *)ptr) = C_flonum_magnitude(x);
12137 break;
12138
12139 case C_F64_LOCATIVE:
12140 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
12141 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
12142
12143 *((double *)ptr) = C_flonum_magnitude(x);
12144 break;
12145
12146 default: panic(C_text("bad locative type"));
12147 }
12148
12149 return C_SCHEME_UNDEFINED;
12150 }
12151
12152
12153 C_regparm C_word C_fcall C_i_locative_to_object(C_word loc)
12154 {
12155 C_word *ptr;
12156
12157 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
12158 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative->object", loc);
12159
12160 ptr = (C_word *)C_block_item(loc, 0);
12161
12162 if(ptr == NULL) return C_SCHEME_FALSE;
12163 else return (C_word)ptr - C_unfix(C_block_item(loc, 1));
12164 }
12165
12166
12167 /* GC protection of user-variables: */
12168
12169 C_regparm void C_fcall C_gc_protect(C_word **addr, int n)
12170 {
12171 int k;
12172
12173 if(collectibles_top + n >= collectibles_limit) {
12174 k = collectibles_limit - collectibles;
12175 collectibles = (C_word **)C_realloc(collectibles, sizeof(C_word *) * k * 2);
12176
12177 if(collectibles == NULL)
12178 panic(C_text("out of memory - cannot allocate GC protection vector"));
12179
12180 collectibles_top = collectibles + k;
12181 collectibles_limit = collectibles + k * 2;
12182 }
12183
12184 C_memcpy(collectibles_top, addr, n * sizeof(C_word *));
12185 collectibles_top += n;
12186 }
12187
12188
12189 C_regparm void C_fcall C_gc_unprotect(int n)
12190 {
12191 collectibles_top -= n;
12192 }
12193
12194
12195 /* Map procedure-ptr to id or id to ptr: */
12196
12197 C_char *C_lookup_procedure_id(void *ptr)
12198 {
12199 LF_LIST *lfl;
12200 C_PTABLE_ENTRY *pt;
12201
12202 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {
12203 pt = lfl->ptable;
12204
12205 if(pt != NULL) {
12206 while(pt->id != NULL) {
12207 if(pt->ptr == ptr) return pt->id;
12208 else ++pt;
12209 }
12210 }
12211 }
12212
12213 return NULL;
12214 }
12215
12216
12217 void *C_lookup_procedure_ptr(C_char *id)
12218 {
12219 LF_LIST *lfl;
12220 C_PTABLE_ENTRY *pt;
12221
12222 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {
12223 pt = lfl->ptable;
12224
12225 if(pt != NULL) {
12226 while(pt->id != NULL) {
12227 if(!C_strcmp(id, pt->id)) return pt->ptr;
12228 else ++pt;
12229 }
12230 }
12231 }
12232
12233 return NULL;
12234 }
12235
12236
12237 void C_ccall C_copy_closure(C_word c, C_word *av)
12238 {
12239 C_word
12240 /* closure = av[ 0 ] */
12241 k = av[ 1 ],
12242 proc = av[ 2 ],
12243 *p;
12244 int n = C_header_size(proc);
12245
12246 if(!C_demand(n + 1))
12247 C_save_and_reclaim_args((void *)copy_closure_2, 2, proc, k);
12248 else {
12249 C_save(proc);
12250 C_save(k);
12251 p = C_temporary_stack;
12252 C_temporary_stack = C_temporary_stack_bottom;
12253 copy_closure_2(0, p);
12254 }
12255 }
12256
12257
12258 static void C_ccall copy_closure_2(C_word c, C_word *av)
12259 {
12260 C_word
12261 k = av[ 0 ],
12262 proc = av[ 1 ];
12263 int cells = C_header_size(proc);
12264 C_word
12265 *ptr = C_alloc(C_SIZEOF_CLOSURE(cells)),
12266 *p = ptr;
12267
12268 *(p++) = C_CLOSURE_TYPE | cells;
12269 /* this is only allowed because the storage is freshly allocated: */
12270 C_memcpy_slots(p, C_data_pointer(proc), cells);
12271 C_kontinue(k, (C_word)ptr);
12272 }
12273
12274
12275 /* Ph'nglui mglw'nafh Cthulhu R'lyeh wgah'nagl fhtagn */
12276
12277 void C_ccall C_call_with_cthulhu(C_word c, C_word *av)
12278 {
12279 C_word
12280 proc = av[ 2 ],
12281 *a = C_alloc(C_SIZEOF_CLOSURE(1)),
12282 av2[ 2 ];
12283
12284 av2[ 0 ] = proc;
12285 av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */
12286 C_do_apply(2, av2);
12287 }
12288
12289
12290 /* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)
12291 These routines return #f if the operation failed due to overflow.
12292 */
12293
12294 C_regparm C_word C_fcall C_i_o_fixnum_plus(C_word n1, C_word n2)
12295 {
12296 C_word x1, x2, s;
12297
12298 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12299
12300 x1 = C_unfix(n1);
12301 x2 = C_unfix(n2);
12302 s = x1 + x2;
12303
12304 #ifdef C_SIXTY_FOUR
12305 if((((s ^ x1) & (s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;
12306 #else
12307 if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;
12308 #endif
12309 else return C_fix(s);
12310 }
12311
12312
12313 C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)
12314 {
12315 C_word x1, x2, s;
12316
12317 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12318
12319 x1 = C_unfix(n1);
12320 x2 = C_unfix(n2);
12321 s = x1 - x2;
12322
12323 #ifdef C_SIXTY_FOUR
12324 if((((s ^ x1) & ~(s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;
12325 #else
12326 if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;
12327 #endif
12328 else return C_fix(s);
12329 }
12330
12331
12332 C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)
12333 {
12334 C_word x1, x2;
12335 C_uword x1u, x2u;
12336 #ifdef C_SIXTY_FOUR
12337 # ifdef C_LLP
12338 C_uword c = 1ULL<<63ULL;
12339 # else
12340 C_uword c = 1UL<<63UL;
12341 # endif
12342 #else
12343 C_uword c = 1UL<<31UL;
12344 #endif
12345
12346 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12347
12348 if((n1 & C_INT_SIGN_BIT) == (n2 & C_INT_SIGN_BIT)) --c;
12349
12350 x1 = C_unfix(n1);
12351 x2 = C_unfix(n2);
12352 x1u = x1 < 0 ? -x1 : x1;
12353 x2u = x2 < 0 ? -x2 : x2;
12354
12355 if(x2u != 0 && x1u > (c / x2u)) return C_SCHEME_FALSE;
12356
12357 x1 = x1 * x2;
12358
12359 if(C_fitsinfixnump(x1)) return C_fix(x1);
12360 else return C_SCHEME_FALSE;
12361 }
12362
12363
12364 C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, C_word n2)
12365 {
12366 C_word x1, x2;
12367
12368 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12369
12370 x1 = C_unfix(n1);
12371 x2 = C_unfix(n2);
12372
12373 if(x2 == 0)
12374 barf(C_DIVISION_BY_ZERO_ERROR, "fx/?");
12375
12376 #ifdef C_SIXTY_FOUR
12377 if(x1 == 0x8000000000000000L && x2 == -1) return C_SCHEME_FALSE;
12378 #else
12379 if(x1 == 0x80000000L && x2 == -1) return C_SCHEME_FALSE;
12380 #endif
12381
12382 x1 = x1 / x2;
12383
12384 if(C_fitsinfixnump(x1)) return C_fix(x1);
12385 else return C_SCHEME_FALSE;
12386 }
12387
12388
12389 C_regparm C_word C_fcall C_i_o_fixnum_and(C_word n1, C_word n2)
12390 {
12391 C_uword x1, x2, r;
12392
12393 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12394
12395 x1 = C_unfix(n1);
12396 x2 = C_unfix(n2);
12397 r = x1 & x2;
12398
12399 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;
12400 else return C_fix(r);
12401 }
12402
12403
12404 C_regparm C_word C_fcall C_i_o_fixnum_ior(C_word n1, C_word n2)
12405 {
12406 C_uword x1, x2, r;
12407
12408 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12409
12410 x1 = C_unfix(n1);
12411 x2 = C_unfix(n2);
12412 r = x1 | x2;
12413
12414 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;
12415 else return C_fix(r);
12416 }
12417
12418
12419 C_regparm C_word C_fcall C_i_o_fixnum_xor(C_word n1, C_word n2)
12420 {
12421 C_uword x1, x2, r;
12422
12423 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
12424
12425 x1 = C_unfix(n1);
12426 x2 = C_unfix(n2);
12427 r = x1 ^ x2;
12428
12429 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;
12430 else return C_fix(r);
12431 }
12432
12433
12434 /* decoding of literals in compressed format */
12435
12436 static C_regparm C_uword C_fcall decode_size(C_char **str)
12437 {
12438 C_uchar **ustr = (C_uchar **)str;
12439 C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */
12440
12441 size |= (*((*ustr)++) & 0xff) << 8;
12442 size |= (*((*ustr)++) & 0xff);
12443 return size;
12444 }
12445
12446
12447 static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
12448 C_word *dest)
12449 {
12450 C_ulong bits = *((*str)++) & 0xff;
12451 C_word *data, *dptr, val;
12452 C_uword size;
12453
12454 /* vvv this can be taken out at a later stage (once it works reliably) vvv */
12455 if(bits != 0xfe)
12456 panic(C_text("invalid encoded literal format"));
12457
12458 bits = *((*str)++) & 0xff;
12459 /* ^^^ */
12460
12461 #ifdef C_SIXTY_FOUR
12462 bits <<= 24 + 32;
12463 #else
12464 bits <<= 24;
12465 #endif
12466
12467 if(bits == C_HEADER_BITS_MASK) { /* special/immediate */
12468 switch(0xff & *((*str)++)) {
12469 case C_BOOLEAN_BITS:
12470 return C_mk_bool(*((*str)++));
12471
12472 case C_CHARACTER_BITS:
12473 return C_make_character(decode_size(str));
12474
12475 case C_SCHEME_END_OF_LIST:
12476 case C_SCHEME_UNDEFINED:
12477 case C_SCHEME_END_OF_FILE:
12478 return (C_word)(*(*str - 1));
12479
12480 case C_FIXNUM_BIT:
12481 val = (C_uword)(signed char)*((*str)++) << 24; /* always big endian */
12482 val |= ((C_uword)*((*str)++) & 0xff) << 16;
12483 val |= ((C_uword)*((*str)++) & 0xff) << 8;
12484 val |= ((C_uword)*((*str)++) & 0xff);
12485 return C_fix(val);
12486
12487 #ifdef C_SIXTY_FOUR
12488 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:
12489 #else
12490 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:
12491 #endif
12492 bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);
12493 break;
12494
12495 default:
12496 panic(C_text("invalid encoded special literal"));
12497 }
12498 }
12499
12500 #ifndef C_SIXTY_FOUR
12501 if((bits & C_8ALIGN_BIT) != 0) {
12502 /* Align _data_ on 8-byte boundary: */
12503 if(C_aligned8(*ptr)) ++(*ptr);
12504 }
12505 #endif
12506
12507 val = (C_word)(*ptr);
12508
12509 if((bits & C_SPECIALBLOCK_BIT) != 0)
12510 panic(C_text("literals with special bit cannot be decoded"));
12511
12512 if(bits == C_FLONUM_TYPE) {
12513 val = C_flonum(ptr, decode_flonum_literal(*str));
12514 while(*((*str)++) != '\0'); /* skip terminating '\0' */
12515 return val;
12516 }
12517
12518 size = decode_size(str);
12519
12520 switch(bits) {
12521 /* This cannot be encoded as a blob due to endianness differences */
12522 case (C_STRING_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */
12523 /* bignums are also allocated statically */
12524 val = C_static_bignum(ptr, size, *str);
12525 *str += size;
12526 break;
12527
12528 case C_STRING_TYPE:
12529 /* strings are always allocated statically */
12530 val = C_static_string(ptr, size, *str);
12531 *str += size;
12532 break;
12533
12534 case C_BYTEVECTOR_TYPE:
12535 /* ... as are bytevectors (blobs) */
12536 val = C_static_bytevector(ptr, size, *str);
12537 *str += size;
12538 break;
12539
12540 case C_SYMBOL_TYPE:
12541 if(dest == NULL)
12542 panic(C_text("invalid literal symbol destination"));
12543
12544 if (**str == '\1') {
12545 val = C_h_intern(dest, size, ++*str);
12546 } else if (**str == '\2') {
12547 val = C_h_intern_kw(dest, size, ++*str);
12548 } else {
12549 C_snprintf(buffer, sizeof(buffer), C_text("Unknown symbol subtype: %d"), (int)**str);
12550 panic(buffer);
12551 }
12552 *str += size;
12553 break;
12554
12555 case C_LAMBDA_INFO_TYPE:
12556 /* lambda infos are always allocated statically */
12557 val = C_static_lambda_info(ptr, size, *str);
12558 *str += size;
12559 break;
12560
12561 default:
12562 *((*ptr)++) = C_make_header(bits, size);
12563 data = *ptr;
12564
12565 if((bits & C_BYTEBLOCK_BIT) != 0) {
12566 C_memcpy(data, *str, size);
12567 size = C_align(size);
12568 *str += size;
12569 *ptr = (C_word *)C_align((C_word)(*ptr) + size);
12570 }
12571 else {
12572 C_word *dptr = *ptr;
12573 *ptr += size;
12574
12575 while(size--) {
12576 *dptr = decode_literal2(ptr, str, dptr);
12577 ++dptr;
12578 }
12579 }
12580 }
12581
12582 return val;
12583 }
12584
12585
12586 C_regparm C_word C_fcall
12587 C_decode_literal(C_word **ptr, C_char *str)
12588 {
12589 return decode_literal2(ptr, &str, NULL);
12590 }
12591
12592
12593 void
12594 C_use_private_repository(C_char *path)
12595 {
12596 private_repository = path;
12597 }
12598
12599
12600 C_char *
12601 C_private_repository_path()
12602 {
12603 return private_repository;
12604 }
12605
12606 C_char *
12607 C_executable_pathname() {
12608 #ifdef SEARCH_EXE_PATH
12609 return C_main_exe == NULL ? NULL : C_strdup(C_main_exe);
12610 #else
12611 return C_resolve_executable_pathname(NULL);
12612 #endif
12613 }
12614
12615 C_char *
12616 C_executable_dirname() {
12617 int len;
12618 C_char *path;
12619
12620 if((path = C_executable_pathname()) == NULL)
12621 return NULL;
12622
12623 #if defined(_WIN32) && !defined(__CYGWIN__)
12624 for(len = C_strlen(path); len >= 0 && path[len] != '\\'; len--);
12625 #else
12626 for(len = C_strlen(path); len >= 0 && path[len] != '/'; len--);
12627 #endif
12628
12629 path[len] = '\0';
12630 return path;
12631 }
12632
12633 C_char *
12634 C_resolve_executable_pathname(C_char *fname)
12635 {
12636 int n;
12637 C_char *buffer = (C_char *) C_malloc(C_MAX_PATH);
12638
12639 if(buffer == NULL) return NULL;
12640
12641 #if defined(__linux__) || defined(__sun)
12642 C_char linkname[64]; /* /proc/<pid>/exe */
12643 pid_t pid = C_getpid();
12644
12645 # ifdef __linux__
12646 C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);
12647 # else
12648 C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */
12649 # endif
12650
12651 n = C_readlink(linkname, buffer, C_MAX_PATH);
12652 if(n < 0 || n >= C_MAX_PATH)
12653 goto error;
12654
12655 buffer[n] = '\0';
12656 return buffer;
12657 #elif defined(_WIN32) && !defined(__CYGWIN__)
12658 n = GetModuleFileName(NULL, buffer, C_MAX_PATH);
12659 if(n == 0 || n >= C_MAX_PATH)
12660 goto error;
12661
12662 return buffer;
12663 #elif defined(C_MACOSX)
12664 C_char buf[C_MAX_PATH];
12665 C_u32 size = C_MAX_PATH;
12666
12667 if(_NSGetExecutablePath(buf, &size) != 0)
12668 goto error;
12669
12670 if(C_realpath(buf, buffer) == NULL)
12671 goto error;
12672
12673 return buffer;
12674 #elif defined(__HAIKU__)
12675 {
12676 image_info info;
12677 int32 cookie = 0;
12678
12679 while (get_next_image_info(0, &cookie, &info) == B_OK) {
12680 if (info.type == B_APP_IMAGE) {
12681 C_strlcpy(buffer, info.name, C_MAX_PATH);
12682 return buffer;
12683 }
12684 }
12685 }
12686 #elif defined(SEARCH_EXE_PATH)
12687 int len;
12688 C_char *path, buf[C_MAX_PATH];
12689
12690 /* no name given (execve) */
12691 if(fname == NULL)
12692 goto error;
12693
12694 /* absolute pathname */
12695 if(fname[0] == '/') {
12696 if(C_realpath(fname, buffer) == NULL)
12697 goto error;
12698 else
12699 return buffer;
12700 }
12701
12702 /* current directory */
12703 if(C_strchr(fname, '/') != NULL) {
12704 if(C_getcwd(buffer, C_MAX_PATH) == NULL)
12705 goto error;
12706
12707 n = C_snprintf(buf, C_MAX_PATH, "%s/%s", buffer, fname);
12708 if(n < 0 || n >= C_MAX_PATH)
12709 goto error;
12710
12711 if(C_access(buf, X_OK) == 0) {
12712 if(C_realpath(buf, buffer) == NULL)
12713 goto error;
12714 else
12715 return buffer;
12716 }
12717 }
12718
12719 /* walk PATH */
12720 if((path = C_getenv("PATH")) == NULL)
12721 goto error;
12722
12723 do {
12724 /* check PATH entry length */
12725 len = C_strcspn(path, ":");
12726 if(len == 0 || len >= C_MAX_PATH)
12727 continue;
12728
12729 /* "<path>/<fname>" to buf */
12730 C_strncpy(buf, path, len);
12731 n = C_snprintf(buf + len, C_MAX_PATH - len, "/%s", fname);
12732 if(n < 0 || n + len >= C_MAX_PATH)
12733 continue;
12734
12735 if(C_access(buf, X_OK) != 0)
12736 continue;
12737
12738 /* fname found, resolve links */
12739 if(C_realpath(buf, buffer) != NULL)
12740 return buffer;
12741
12742 /* seek next entry, skip colon */
12743 } while (path += len, *path++);
12744 #else
12745 # error "Please either define SEARCH_EXE_PATH in Makefile.<platform> or implement C_resolve_executable_pathname for your platform!"
12746 #endif
12747
12748 error:
12749 C_free(buffer);
12750 return NULL;
12751 }
12752
12753 C_regparm C_word C_fcall
12754 C_i_getprop(C_word sym, C_word prop, C_word def)
12755 {
12756 C_word pl = C_symbol_plist(sym);
12757
12758 while(pl != C_SCHEME_END_OF_LIST) {
12759 if(C_block_item(pl, 0) == prop)
12760 return C_u_i_car(C_u_i_cdr(pl));
12761 else pl = C_u_i_cdr(C_u_i_cdr(pl));
12762 }
12763
12764 return def;
12765 }
12766
12767
12768 C_regparm C_word C_fcall
12769 C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
12770 {
12771 C_word pl = C_symbol_plist(sym);
12772
12773 /* Newly added plist? Ensure the symbol stays! */
12774 if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym);
12775
12776 while(pl != C_SCHEME_END_OF_LIST) {
12777 if(C_block_item(pl, 0) == prop) {
12778 C_mutate(&C_u_i_car(C_u_i_cdr(pl)), val);
12779 return val;
12780 }
12781 else pl = C_u_i_cdr(C_u_i_cdr(pl));
12782 }
12783
12784 pl = C_a_pair(ptr, val, C_symbol_plist(sym));
12785 pl = C_a_pair(ptr, prop, pl);
12786 C_mutate_slot(&C_symbol_plist(sym), pl);
12787 return val;
12788 }
12789
12790
12791 C_regparm C_word C_fcall
12792 C_i_get_keyword(C_word kw, C_word args, C_word def)
12793 {
12794 while(!C_immediatep(args)) {
12795 if(C_block_header(args) == C_PAIR_TAG) {
12796 if(kw == C_u_i_car(args)) {
12797 args = C_u_i_cdr(args);
12798
12799 if(C_immediatep(args) || C_block_header(args) != C_PAIR_TAG)
12800 return def;
12801 else return C_u_i_car(args);
12802 }
12803 else {
12804 args = C_u_i_cdr(args);
12805
12806 if(C_immediatep(args) || C_block_header(args) != C_PAIR_TAG)
12807 return def;
12808 else args = C_u_i_cdr(args);
12809 }
12810 }
12811 }
12812
12813 return def;
12814 }
12815
12816 C_word C_i_dump_statistical_profile()
12817 {
12818 PROFILE_BUCKET *b, *b2, **bp;
12819 FILE *fp;
12820 C_char *k1, *k2 = NULL;
12821 int n;
12822 double ms;
12823
12824 assert(profiling);
12825 assert(profile_table != NULL);
12826
12827 set_profile_timer(0);
12828
12829 profiling = 0; /* In case a SIGPROF is delivered late */
12830 bp = profile_table;
12831
12832 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("PROFILE.%d"), C_getpid());
12833
12834 if(debug_mode)
12835 C_dbg(C_text("debug"), C_text("dumping statistical profile to `%s'...\n"), buffer);
12836
12837 fp = C_fopen(buffer, "w");
12838 if (fp == NULL)
12839 panic(C_text("could not write profile!"));
12840
12841 C_fputs(C_text("statistical\n"), fp);
12842 for(n = 0; n < PROFILE_TABLE_SIZE; ++n) {
12843 for(b = bp[ n ]; b != NULL; b = b2) {
12844 b2 = b->next;
12845
12846 k1 = b->key;
12847 C_fputs(C_text("(|"), fp);
12848 /* Dump raw C string as if it were a symbol */
12849 while((k2 = C_strpbrk(k1, C_text("\\|"))) != NULL) {
12850 C_fwrite(k1, 1, k2-k1, fp);
12851 C_fputc('\\', fp);
12852 C_fputc(*k2, fp);
12853 k1 = k2+1;
12854 }
12855 C_fputs(k1, fp);
12856 ms = (double)b->sample_count * (double)profile_frequency / 1000.0;
12857 C_fprintf(fp, C_text("| " UWORD_COUNT_FORMAT_STRING " %lf)\n"),
12858 b->call_count, ms);
12859 C_free(b);
12860 }
12861 }
12862
12863 C_fclose(fp);
12864 C_free(profile_table);
12865 profile_table = NULL;
12866
12867 return C_SCHEME_UNDEFINED;
12868 }
12869
12870 void C_ccall C_dump_heap_state(C_word c, C_word *av)
12871 {
12872 C_word
12873 /* closure = av[ 0 ] */
12874 k = av[ 1 ];
12875
12876 /* make sure heap is compacted */
12877 C_save(k);
12878 C_fromspace_top = C_fromspace_limit; /* force major GC */
12879 C_reclaim((void *)dump_heap_state_2, 1);
12880 }
12881
12882
12883 static C_ulong
12884 hdump_hash(C_word key)
12885 {
12886 return (C_ulong)key % HDUMP_TABLE_SIZE;
12887 }
12888
12889
12890 static void
12891 hdump_count(C_word key, int n, int t)
12892 {
12893 HDUMP_BUCKET **bp = hdump_table + hdump_hash(key);
12894 HDUMP_BUCKET *b = *bp;
12895
12896 while(b != NULL) {
12897 if(b->key == key) {
12898 b->count += n;
12899 b->total += t;
12900 return;
12901 }
12902 else b = b->next;
12903 }
12904
12905 b = (HDUMP_BUCKET *)C_malloc(sizeof(HDUMP_BUCKET));
12906
12907 if(b == 0)
12908 panic(C_text("out of memory - can not allocate heap-dump table-bucket"));
12909
12910 b->next = *bp;
12911 b->key = key;
12912 *bp = b;
12913 b->count = n;
12914 b->total = t;
12915 }
12916
12917
12918 static void C_ccall dump_heap_state_2(C_word c, C_word *av)
12919 {
12920 C_word k = av[ 0 ];
12921 HDUMP_BUCKET *b, *b2, **bp;
12922 int n, bytes;
12923 C_byte *scan;
12924 C_SCHEME_BLOCK *sbp;
12925 C_header h;
12926 C_word x, key, *p;
12927 int imm = 0, blk = 0;
12928
12929 hdump_table = (HDUMP_BUCKET **)C_malloc(HDUMP_TABLE_SIZE * sizeof(HDUMP_BUCKET *));
12930
12931 if(hdump_table == NULL)
12932 panic(C_text("out of memory - can not allocate heap-dump table"));
12933
12934 C_memset(hdump_table, 0, sizeof(HDUMP_BUCKET *) * HDUMP_TABLE_SIZE);
12935
12936 scan = fromspace_start;
12937
12938 while(scan < C_fromspace_top) {
12939 ++blk;
12940 sbp = (C_SCHEME_BLOCK *)scan;
12941
12942 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)
12943 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);
12944
12945 n = C_header_size(sbp);
12946 h = sbp->header;
12947 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
12948 key = (C_word)(h & C_HEADER_BITS_MASK);
12949 p = sbp->data;
12950
12951 if(key == C_STRUCTURE_TYPE) key = *p;
12952
12953 hdump_count(key, 1, bytes);
12954
12955 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
12956 if((h & C_SPECIALBLOCK_BIT) != 0) {
12957 --n;
12958 ++p;
12959 }
12960
12961 while(n--) {
12962 x = *(p++);
12963
12964 if(C_immediatep(x)) {
12965 ++imm;
12966
12967 if((x & C_FIXNUM_BIT) != 0) key = C_fix(1);
12968 else {
12969 switch(x & C_IMMEDIATE_TYPE_BITS) {
12970 case C_BOOLEAN_BITS: key = C_SCHEME_TRUE; break;
12971 case C_CHARACTER_BITS: key = C_make_character('A'); break;
12972 default: key = x;
12973 }
12974 }
12975
12976 hdump_count(key, 1, 0);
12977 }
12978 }
12979 }
12980
12981 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);
12982 }
12983
12984 bp = hdump_table;
12985 /* HACK */
12986 #define C_WEAK_PAIR_TYPE (C_PAIR_TYPE | C_SPECIALBLOCK_BIT)
12987
12988 for(n = 0; n < HDUMP_TABLE_SIZE; ++n) {
12989 for(b = bp[ n ]; b != NULL; b = b2) {
12990 b2 = b->next;
12991
12992 switch(b->key) {
12993 case C_fix(1): C_fprintf(C_stderr, C_text("fixnum ")); break;
12994 case C_SCHEME_TRUE: C_fprintf(C_stderr, C_text("boolean ")); break;
12995 case C_SCHEME_END_OF_LIST: C_fprintf(C_stderr, C_text("null ")); break;
12996 case C_SCHEME_UNDEFINED : C_fprintf(C_stderr, C_text("void ")); break;
12997 case C_make_character('A'): C_fprintf(C_stderr, C_text("character ")); break;
12998 case C_SCHEME_END_OF_FILE: C_fprintf(C_stderr, C_text("eof ")); break;
12999 case C_SCHEME_UNBOUND: C_fprintf(C_stderr, C_text("unbound ")); break;
13000 case C_SYMBOL_TYPE: C_fprintf(C_stderr, C_text("symbol ")); break;
13001 case C_STRING_TYPE: C_fprintf(C_stderr, C_text("string ")); break;
13002 case C_PAIR_TYPE: C_fprintf(C_stderr, C_text("pair ")); break;
13003 case C_CLOSURE_TYPE: C_fprintf(C_stderr, C_text("closure ")); break;
13004 case C_FLONUM_TYPE: C_fprintf(C_stderr, C_text("flonum ")); break;
13005 case C_PORT_TYPE: C_fprintf(C_stderr, C_text("port ")); break;
13006 case C_POINTER_TYPE: C_fprintf(C_stderr, C_text("pointer ")); break;
13007 case C_LOCATIVE_TYPE: C_fprintf(C_stderr, C_text("locative ")); break;
13008 case C_TAGGED_POINTER_TYPE: C_fprintf(C_stderr, C_text("tagged pointer ")); break;
13009 case C_LAMBDA_INFO_TYPE: C_fprintf(C_stderr, C_text("lambda info ")); break;
13010 case C_WEAK_PAIR_TYPE: C_fprintf(C_stderr, C_text("weak pair ")); break;
13011 case C_VECTOR_TYPE: C_fprintf(C_stderr, C_text("vector ")); break;
13012 case C_BYTEVECTOR_TYPE: C_fprintf(C_stderr, C_text("bytevector ")); break;
13013 case C_BIGNUM_TYPE: C_fprintf(C_stderr, C_text("bignum ")); break;
13014 case C_CPLXNUM_TYPE: C_fprintf(C_stderr, C_text("cplxnum ")); break;
13015 case C_RATNUM_TYPE: C_fprintf(C_stderr, C_text("ratnum ")); break;
13016 /* XXX this is sort of funny: */
13017 case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("blob ")); break;
13018 default:
13019 x = b->key;
13020
13021 if(!C_immediatep(x) && C_header_bits(x) == C_SYMBOL_TYPE) {
13022 x = C_block_item(x, 1);
13023 C_fprintf(C_stderr, C_text("`%.*s'"), (int)C_header_size(x), C_c_string(x));
13024 }
13025 else C_fprintf(C_stderr, C_text("unknown key " UWORD_FORMAT_STRING), (C_uword)b->key);
13026 }
13027
13028 C_fprintf(C_stderr, C_text("\t%d"), b->count);
13029
13030 if(b->total > 0)
13031 C_fprintf(C_stderr, C_text("\t%d bytes"), b->total);
13032
13033 C_fputc('\n', C_stderr);
13034 C_free(b);
13035 }
13036 }
13037
13038 C_fprintf(C_stderr, C_text("\ntotal number of blocks: %d, immediates: %d\n"),
13039 blk, imm);
13040 C_free(hdump_table);
13041 C_kontinue(k, C_SCHEME_UNDEFINED);
13042 }
13043
13044
13045 static void C_ccall filter_heap_objects_2(C_word c, C_word *av)
13046 {
13047 void *func = C_pointer_address(av[ 0 ]);
13048 C_word
13049 userarg = av[ 1 ],
13050 vector = av[ 2 ],
13051 k = av[ 3 ];
13052 int n, bytes;
13053 C_byte *scan;
13054 C_SCHEME_BLOCK *sbp;
13055 C_header h;
13056 C_word *p;
13057 int vecsize = C_header_size(vector);
13058 typedef int (*filterfunc)(C_word x, C_word userarg);
13059 filterfunc ff = (filterfunc)func;
13060 int vcount = 0;
13061
13062 scan = fromspace_start;
13063
13064 while(scan < C_fromspace_top) {
13065 sbp = (C_SCHEME_BLOCK *)scan;
13066
13067 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)
13068 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);
13069
13070 n = C_header_size(sbp);
13071 h = sbp->header;
13072 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
13073 p = sbp->data;
13074
13075 if(ff((C_word)sbp, userarg)) {
13076 if(vcount < vecsize) {
13077 C_set_block_item(vector, vcount, (C_word)sbp);
13078 ++vcount;
13079 }
13080 else {
13081 C_kontinue(k, C_fix(-1));
13082 }
13083 }
13084
13085 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);
13086 }
13087
13088 C_kontinue(k, C_fix(vcount));
13089 }
13090
13091
13092 void C_ccall C_filter_heap_objects(C_word c, C_word *av)
13093 {
13094 C_word
13095 /* closure = av[ 0 ] */
13096 k = av[ 1 ],
13097 func = av[ 2 ],
13098 vector = av[ 3 ],
13099 userarg = av[ 4 ];
13100
13101 /* make sure heap is compacted */
13102 C_save(k);
13103 C_save(vector);
13104 C_save(userarg);
13105 C_save(func);
13106 C_fromspace_top = C_fromspace_limit; /* force major GC */
13107 C_reclaim((void *)filter_heap_objects_2, 4);
13108 }
13109
13110 C_regparm C_word C_fcall C_i_process_sleep(C_word n)
13111 {
13112 #if defined(_WIN32) && !defined(__CYGWIN__)
13113 Sleep(C_unfix(n) * 1000);
13114 return C_fix(0);
13115 #else
13116 return C_fix(sleep(C_unfix(n)));
13117 #endif
13118 }
13119
13120 C_regparm C_word C_fcall
13121 C_i_file_exists_p(C_word name, C_word file, C_word dir)
13122 {
13123 struct stat buf;
13124 int res;
13125
13126 res = C_stat(C_c_string(name), &buf);
13127
13128 if(res != 0) {
13129 switch(errno) {
13130 case ENOENT: return C_SCHEME_FALSE;
13131 case EOVERFLOW: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;
13132 case ENOTDIR: return C_SCHEME_FALSE;
13133 default: return C_fix(res);
13134 }
13135 }
13136
13137 switch(buf.st_mode & S_IFMT) {
13138 case S_IFDIR: return C_truep(file) ? C_SCHEME_FALSE : C_SCHEME_TRUE;
13139 default: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;
13140 }
13141 }
13142
13143
13144 C_regparm C_word C_fcall
13145 C_i_pending_interrupt(C_word dummy)
13146 {
13147 if(pending_interrupts_count > 0) {
13148 handling_interrupts = 1; /* Lock out further forced GCs until we're done */
13149 return C_fix(pending_interrupts[ --pending_interrupts_count ]);
13150 } else {
13151 handling_interrupts = 0; /* OK, can go on */
13152 return C_SCHEME_FALSE;
13153 }
13154 }
13155
13156
13157 /* random numbers, mostly lifted from
13158 https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c
13159 */
13160
13161 #ifdef __linux__
13162 # include <sys/syscall.h>
13163 #endif
13164
13165
13166 #if !defined(_WIN32)
13167 static C_word random_urandom(C_word buf, int count)
13168 {
13169 static int fd = -1;
13170 int off = 0, r;
13171
13172 if(fd == -1) {
13173 fd = open("/dev/urandom", O_RDONLY);
13174
13175 if(fd == -1) return C_SCHEME_FALSE;
13176 }
13177
13178 while(count > 0) {
13179 r = read(fd, C_data_pointer(buf) + off, count);
13180
13181 if(r == -1) {
13182 if(errno != EINTR && errno != EAGAIN) return C_SCHEME_FALSE;
13183 else r = 0;
13184 }
13185
13186 count -= r;
13187 off += r;
13188 }
13189
13190 return C_SCHEME_TRUE;
13191 }
13192 #endif
13193
13194
13195 C_word C_random_bytes(C_word buf, C_word size)
13196 {
13197 int count = C_unfix(size);
13198 int r = 0;
13199 int off = 0;
13200
13201 #if defined(__OpenBSD__) || defined(__FreeBSD__)
13202 arc4random_buf(C_data_pointer(buf), count);
13203 #elif defined(SYS_getrandom) && defined(__NR_getrandom)
13204 static int use_urandom = 0;
13205
13206 if(use_urandom) return random_urandom(buf, count);
13207
13208 while(count > 0) {
13209 /* GRND_NONBLOCK = 0x0001 */
13210 r = syscall(SYS_getrandom, C_data_pointer(buf) + off, count, 1);
13211
13212 if(r == -1) {
13213 if(errno == ENOSYS) {
13214 use_urandom = 1;
13215 return random_urandom(buf, count);
13216 }
13217 else if(errno != EINTR) return C_SCHEME_FALSE;
13218 else r = 0;
13219 }
13220
13221 count -= r;
13222 off += r;
13223 }
13224 #elif defined(_WIN32) && !defined(__CYGWIN__)
13225 typedef BOOLEAN (*func)(PVOID, ULONG);
13226 static func RtlGenRandom = NULL;
13227
13228 if(RtlGenRandom == NULL) {
13229 HMODULE mod = LoadLibrary("advapi32.dll");
13230
13231 if(mod == NULL) return C_SCHEME_FALSE;
13232
13233 if((RtlGenRandom = (func)GetProcAddress(mod, "SystemFunction036")) == NULL)
13234 return C_SCHEME_FALSE;
13235 }
13236
13237 if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))
13238 return C_SCHEME_FALSE;
13239 #else
13240 return random_urandom(buf, count);
13241 #endif
13242
13243 return C_SCHEME_TRUE;
13244 }
13245
13246
13247 /* WELL512 pseudo random number generator, see also:
13248 https://en.wikipedia.org/wiki/Well_equidistributed_long-period_linear
13249 http://lomont.org/Math/Papers/2008/Lomont_PRNG_2008.pdf
13250 */
13251
13252 static C_uword random_word(void)
13253 {
13254 C_uword a, b, c, d, r;
13255 a = random_state[random_state_index];
13256 c = random_state[(random_state_index+13)&15];
13257 b = a^c^(a<<16)^(c<<15);
13258 c = random_state[(random_state_index+9)&15];
13259 c ^= (c>>11);
13260 a = random_state[random_state_index] = b^c;
13261 d = a^((a<<5)&0xDA442D24UL);
13262 random_state_index = (random_state_index + 15)&15;
13263 a = random_state[random_state_index];
13264 random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);
13265 r = random_state[random_state_index];
13266 return r;
13267 }
13268
13269
13270 static C_uword random_uniform(C_uword bound)
13271 {
13272 C_uword r, min;
13273
13274 if (bound < 2) return 0;
13275
13276 min = (1U + ~bound) % bound; /* = 2**<wordsize> mod bound */
13277
13278 do r = random_word(); while (r < min);
13279
13280 /* r is now clamped to a set whose size mod upper_bound == 0
13281 * the worst case (2**<wordsize-1>+1) requires ~ 2 attempts */
13282
13283 return r % bound;
13284 }
13285
13286
13287 C_regparm C_word C_random_fixnum(C_word n)
13288 {
13289 C_word nf;
13290
13291 if (!(n & C_FIXNUM_BIT))
13292 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "pseudo-random-integer", n);
13293
13294 nf = C_unfix(n);
13295
13296 if(nf < 0)
13297 barf(C_OUT_OF_RANGE_ERROR, "pseudo-random-integer", n, C_fix(0));
13298
13299 return C_fix(random_uniform(nf));
13300 }
13301
13302
13303 C_regparm C_word C_fcall
13304 C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)
13305 {
13306 C_uword *start, *end;
13307
13308 if(C_bignum_negativep(rn))
13309 barf(C_OUT_OF_RANGE_ERROR, "pseudo-random-integer", rn, C_fix(0));
13310
13311 int len = integer_length_abs(rn);
13312 C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));
13313 C_word result = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);
13314 C_uword *p;
13315 C_uword highest_word = C_bignum_digits(rn)[C_bignum_size(rn)-1];
13316 start = C_bignum_digits(result);
13317 end = start + C_bignum_size(result);
13318
13319 for(p = start; p < (end - 1); ++p) {
13320 *p = random_word();
13321 len -= sizeof(C_uword);
13322 }
13323
13324 *p = random_uniform(highest_word);
13325 return C_bignum_simplify(result);
13326 }
13327
13328 /*
13329 * C_a_i_random_real: Generate a stream of bits uniformly at random and
13330 * interpret it as the fractional part of the binary expansion of a
13331 * number in [0, 1], 0.00001010011111010100...; then round it.
13332 * More information on https://mumble.net/~campbell/2014/04/28/uniform-random-float
13333 */
13334
13335 static inline C_u64 random64() {
13336 #ifdef C_SIXTY_FOUR
13337 return random_word();
13338 #else
13339 C_u64 v = 0;
13340 v |= ((C_u64) random_word()) << 32;
13341 v |= (C_u64) random_word();
13342 return v;
13343 #endif
13344 }
13345
13346 #if defined(__GNUC__) && !defined(__TINYC__)
13347 # define clz64 __builtin_clzll
13348 #else
13349 /* https://en.wikipedia.org/wiki/Find_first_set#CLZ */
13350 static const C_uchar clz_table_4bit[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 };
13351
13352 int clz32(C_u32 x)
13353 {
13354 int n;
13355 if ((x & 0xFFFF0000) == 0) {n = 16; x <<= 16;} else {n = 0;}
13356 if ((x & 0xFF000000) == 0) {n += 8; x <<= 8;}
13357 if ((x & 0xF0000000) == 0) {n += 4; x <<= 4;}
13358 n += (int)clz_table_4bit[x >> (32-4)];
13359 return n;
13360 }
13361
13362 int clz64(C_u64 x)
13363 {
13364 int y = clz32(x >> 32);
13365
13366 if(y == 32) return y + clz32(x);
13367
13368 return y;
13369 }
13370 #endif
13371
13372 C_regparm C_word C_fcall
13373 C_a_i_random_real(C_word **ptr, C_word n) {
13374 int exponent = -64;
13375 uint64_t significand;
13376 unsigned shift;
13377
13378 while (C_unlikely((significand = random64()) == 0)) {
13379 exponent -= 64;
13380 if (C_unlikely(exponent < -1074))
13381 return 0;
13382 }
13383
13384 shift = clz64(significand);
13385 if (shift != 0) {
13386 exponent -= shift;
13387 significand <<= shift;
13388 significand |= (random64() >> (64 - shift));
13389 }
13390
13391 significand |= 1;
13392 return C_flonum(ptr, ldexp((double)significand, exponent));
13393 }
13394
13395 C_word C_set_random_seed(C_word buf, C_word n)
13396 {
13397 int i, nsu = C_unfix(n) / sizeof(C_uword);
13398 int off = 0;
13399
13400 for(i = 0; i < (C_RANDOM_STATE_SIZE / sizeof(C_uword)); ++i) {
13401 if(off >= nsu) off = 0;
13402
13403 random_state[ i ] = *((C_uword *)C_data_pointer(buf) + off);
13404 ++off;
13405 }
13406
13407 random_state_index = 0;
13408 return C_SCHEME_FALSE;
13409 }
13410