~ chicken-core (master) /runtime.c
Trap1/* runtime.c - Runtime code for compiler generated executables2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; 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 promote15; 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 EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.26*/272829#include "chicken.h"30#include <assert.h>31#include <float.h>32#include <signal.h>33#include <sys/stat.h>34#include <strings.h>3536#ifdef HAVE_SYSEXITS_H37# include <sysexits.h>38#endif3940#ifdef __ANDROID__41# include <android/log.h>42#endif4344#if !defined(PIC)45# define NO_DLOAD246#endif4748#ifndef NO_DLOAD249# ifdef HAVE_DLFCN_H50# include <dlfcn.h>51# endif5253# ifdef HAVE_DL_H54# include <dl.h>55# endif56#endif5758#ifndef EX_SOFTWARE59# define EX_SOFTWARE 7060#endif6162#ifndef EOVERFLOW63# define EOVERFLOW 064#endif6566/* TODO: Include sys/select.h? Windows doesn't seem to have it... */67#ifndef NO_POSIX_POLL68# include <poll.h>69#endif7071#if !defined(C_NONUNIX)7273# include <sys/time.h>74# include <sys/resource.h>75# include <sys/wait.h>76# include <fcntl.h>7778/* ITIMER_PROF is more precise, but Cygwin doesn't support it... */79# ifdef __CYGWIN__80# define C_PROFILE_SIGNAL SIGALRM81# define C_PROFILE_TIMER ITIMER_REAL82# else83# define C_PROFILE_SIGNAL SIGPROF84# define C_PROFILE_TIMER ITIMER_PROF85# endif8687#else8889# define C_PROFILE_SIGNAL -1 /* Stupid way to avoid error */9091#ifdef ECOS92#include <cyg/kernel/kapi.h>93static int timezone;94#define NSIG 3295#endif9697#endif9899#ifndef RTLD_GLOBAL100# define RTLD_GLOBAL 0101#endif102103#ifndef RTLD_NOW104# define RTLD_NOW 0105#endif106107#ifndef RTLD_LOCAL108# define RTLD_LOCAL 0109#endif110111#ifndef RTLD_LAZY112# define RTLD_LAZY 0113#endif114115#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#endif122123/* For image_info retrieval */124#if defined(__HAIKU__)125# include <kernel/image.h>126#endif127128/* For _NSGetExecutablePath */129#if defined(C_MACOSX)130# include <mach-o/dyld.h>131#endif132133/* Parameters: */134135#define RELAX_MULTIVAL_CHECK136137#ifdef C_SIXTY_FOUR138# define DEFAULT_STACK_SIZE (1024 * 1024)139# define DEFAULT_MAXIMAL_HEAP_SIZE 0x7ffffffffffffff0140#else141# define DEFAULT_STACK_SIZE (256 * 1024)142# define DEFAULT_MAXIMAL_HEAP_SIZE 0x7ffffff0143#endif144145#define DEFAULT_SYMBOL_TABLE_SIZE 2999146#define DEFAULT_KEYWORD_TABLE_SIZE 499147#define DEFAULT_HEAP_SIZE DEFAULT_STACK_SIZE148#define MINIMAL_HEAP_SIZE DEFAULT_STACK_SIZE149#define DEFAULT_SCRATCH_SPACE_SIZE 256150#define DEFAULT_HEAP_GROWTH 200151#define DEFAULT_HEAP_SHRINKAGE 50152#define DEFAULT_HEAP_SHRINKAGE_USED 25153#define DEFAULT_HEAP_MIN_FREE (4 * 1024 * 1024)154#define HEAP_SHRINK_COUNTS 10155#define DEFAULT_FORWARDING_TABLE_SIZE 32156#define DEFAULT_COLLECTIBLES_SIZE 1024157#define DEFAULT_TRACE_BUFFER_SIZE 16158#define MIN_TRACE_BUFFER_SIZE 3159160#define MAX_HASH_PREFIX 64161162#define DEFAULT_TEMPORARY_STACK_SIZE 256163#define STRING_BUFFER_SIZE 4096164#define DEFAULT_MUTATION_STACK_SIZE 1024165#define PROFILE_TABLE_SIZE 1024166167#define MAX_PENDING_INTERRUPTS 100168169#ifdef C_DOUBLE_IS_32_BITS170# define FLONUM_PRINT_PRECISION 7171#else172# define FLONUM_PRINT_PRECISION 15173#endif174175#define WORDS_PER_FLONUM C_SIZEOF_FLONUM176#define INITIAL_TIMER_INTERRUPT_PERIOD 10000177#define HDUMP_TABLE_SIZE 1001178179/* only for relevant for Windows: */180181#define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 256182183184/* Constants: */185186#ifdef C_SIXTY_FOUR187# ifdef C_LLP188# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffffffffffeLL)189# define UWORD_FORMAT_STRING "0x%016llx"190# define UWORD_COUNT_FORMAT_STRING "%llu"191# else192# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffffffffffeL)193# define UWORD_FORMAT_STRING "0x%016lx"194# define UWORD_COUNT_FORMAT_STRING "%lu"195# endif196#else197# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffe)198# define UWORD_FORMAT_STRING "0x%08x"199# define UWORD_COUNT_FORMAT_STRING "%u"200#endif201202#ifdef C_LLP203# define LONG_FORMAT_STRING "%lld"204#else205# define LONG_FORMAT_STRING "%ld"206#endif207208#define GC_MINOR 0209#define GC_MAJOR 1210#define GC_REALLOC 2211212213/* Macros: */214215#define nmax(x, y) ((x) > (y) ? (x) : (y))216#define nmin(x, y) ((x) < (y) ? (x) : (y))217#define percentage(n, p) ((C_long)(((double)(n) * (double)p) / 100))218219#define clear_buffer_object(buf, obj) C_migrate_buffer_object(NULL, (C_word *)(buf), C_buf_end(buf), (obj))220#define move_buffer_object(ptr, buf, obj) C_migrate_buffer_object(ptr, (C_word *)(buf), C_buf_end(buf), (obj))221222/* The bignum digit representation is fullword- little endian, so on223 * LE machines the halfdigits are numbered in the same order. On BE224 * machines, we must swap the odd and even positions.225 */226#ifdef C_BIG_ENDIAN227#define C_uhword_ref(x, p) ((C_uhword *)(x))[(p)^1]228#else229#define C_uhword_ref(x, p) ((C_uhword *)(x))[(p)]230#endif231#define C_uhword_set(x, p, d) (C_uhword_ref(x,p) = (d))232233#define free_tmp_bignum(b) C_free((void *)(b))234235/* Forwarding pointers abuse the fact that objects must be236 * word-aligned, so we can just drop the lowest bit.237 */238#define is_fptr(x) (((x) & C_GC_FORWARDING_BIT) != 0)239#define ptr_to_fptr(x) (((C_uword)(x) >> 1) | C_GC_FORWARDING_BIT)240#define fptr_to_ptr(x) ((C_uword)(x) << 1)241242#define C_check_real(x, w, v) if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \243 else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \244 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \245 else v = C_flonum_magnitude(x);246247248#define C_pte(name) pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;249250#ifndef SIGBUS251# define SIGBUS 0252#endif253254#define C_thread_id(x) C_block_item((x), 14)255256257/* Type definitions: */258259typedef C_regparm C_word (*integer_plusmin_op) (C_word **ptr, C_word n, C_word x, C_word y);260261typedef struct lf_list_struct262{263 C_word *lf;264 int count;265 struct lf_list_struct *next, *prev;266 C_PTABLE_ENTRY *ptable;267 void *module_handle;268 char *module_name;269} LF_LIST;270271typedef struct finalizer_node_struct272{273 struct finalizer_node_struct274 *next,275 *previous;276 C_word277 item,278 finalizer;279} FINALIZER_NODE;280281typedef struct trace_info_struct282{283 /* Either raw_location is set to a C string or NULL */284 C_char *raw_location;285 /* cooked_location is C_SCHEME_FALSE or a Scheme string (when raw_location is NULL) */286 C_word cooked_location, cooked1, cooked2, thread;287} TRACE_INFO;288289typedef struct hdump_bucket_struct290{291 C_word key;292 int count, total;293 struct hdump_bucket_struct *next;294} HDUMP_BUCKET;295296typedef struct profile_bucket_struct297{298 C_char *key;299 C_uword sample_count; /* Multiplied by profile freq = time spent */300 C_uword call_count; /* Distinct calls seen while sampling */301 struct profile_bucket_struct *next;302} PROFILE_BUCKET;303304305/* Variables: */306307C_word308 *C_temporary_stack,309 *C_temporary_stack_bottom,310 *C_temporary_stack_limit,311 *C_stack_limit, /* "Soft" limit, may be reset to force GC */312 *C_stack_hard_limit, /* Actual stack limit */313 *C_scratchspace_start,314 *C_scratchspace_top,315 *C_scratchspace_limit,316 C_scratch_usage;317C_long318 C_timer_interrupt_counter,319 C_initial_timer_interrupt_period;320C_byte321 *C_fromspace_top,322 *C_fromspace_limit;323#ifdef HAVE_SIGSETJMP324sigjmp_buf C_restart;325#else326jmp_buf C_restart;327#endif328void *C_restart_trampoline;329C_word C_restart_c;330int C_entry_point_status;331int (*C_gc_mutation_hook)(C_word *slot, C_word val);332void (*C_gc_trace_hook)(C_word *var, int mode);333void (*C_panic_hook)(C_char *msg) = NULL;334void (*C_pre_gc_hook)(int mode) = NULL;335void (*C_post_gc_hook)(int mode, C_long ms) = NULL;336C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc) = NULL;337338int339 C_gui_mode = 0,340 C_abort_on_thread_exceptions,341 C_interrupts_enabled,342 C_disable_overflow_check,343 C_heap_size_is_fixed,344 C_trace_buffer_size = DEFAULT_TRACE_BUFFER_SIZE,345 C_max_pending_finalizers = C_DEFAULT_MAX_PENDING_FINALIZERS,346 C_debugging = 0,347 C_main_argc;348C_uword349 C_heap_growth = DEFAULT_HEAP_GROWTH,350 C_heap_shrinkage = DEFAULT_HEAP_SHRINKAGE,351 C_heap_shrinkage_used = DEFAULT_HEAP_SHRINKAGE_USED,352 C_heap_half_min_free = DEFAULT_HEAP_MIN_FREE,353 C_maximal_heap_size = DEFAULT_MAXIMAL_HEAP_SIZE,354 heap_shrink_counter = 0;355time_t356 C_startup_time_sec,357 C_startup_time_msec,358 profile_frequency = 10000;359C_char360 **C_main_argv,361#ifdef SEARCH_EXE_PATH362 *C_main_exe = NULL,363#endif364 *C_dlerror;365366static TRACE_INFO367 *trace_buffer,368 *trace_buffer_limit,369 *trace_buffer_top;370371static C_byte372 *heapspace1,373 *heapspace2,374 *fromspace_start,375 *tospace_start,376 *tospace_top,377 *tospace_limit,378 *new_tospace_start,379 *new_tospace_top,380 *new_tospace_limit;381static C_uword382 heapspace1_size,383 heapspace2_size,384 heap_size,385 scratchspace_size,386 temporary_stack_size,387 fixed_temporary_stack_size = 0,388 maximum_heap_usage;389static C_char390 buffer[ STRING_BUFFER_SIZE ],391 *private_repository = NULL,392 *current_module_name,393 *save_string;394static C_SYMBOL_TABLE395 *symbol_table,396 *symbol_table_list,397 *keyword_table;398static C_word399 **collectibles,400 **collectibles_top,401 **collectibles_limit,402 **mutation_stack_bottom,403 **mutation_stack_limit,404 **mutation_stack_top,405 *stack_bottom,406 weak_pair_chain,407 locative_chain,408 error_location,409 interrupt_hook_symbol,410 current_thread_symbol,411 error_hook_symbol,412 pending_finalizers_symbol,413 callback_continuation_stack_symbol,414 core_provided_symbol,415 s8vector_symbol,416 u16vector_symbol,417 s16vector_symbol,418 u32vector_symbol,419 s32vector_symbol,420 u64vector_symbol,421 s64vector_symbol,422 f32vector_symbol,423 f64vector_symbol,424 *forwarding_table;425static int426 trace_buffer_full,427 forwarding_table_size,428 return_to_host,429 page_size,430 show_trace,431 fake_tty_flag,432 debug_mode,433 dump_heap_on_exit,434 gc_bell,435 gc_report_flag = 0,436 gc_mode,437 gc_count_1,438 gc_count_1_total,439 gc_count_2,440 stack_size_changed,441 dlopen_flags,442 heap_size_changed,443 random_state_initialized = 0,444 chicken_is_running,445 chicken_ran_once,446 pass_serious_signals = 1,447 callback_continuation_level;448static volatile int449 serious_signal_occurred = 0,450 profiling = 0;451static unsigned int452 mutation_count,453 tracked_mutation_count,454 stack_check_demand,455 stack_size;456static int chicken_is_initialized;457#ifdef HAVE_SIGSETJMP458static sigjmp_buf gc_restart;459#else460static jmp_buf gc_restart;461#endif462static double463 timer_start_ms,464 gc_ms,465 timer_accumulated_gc_ms,466 interrupt_time,467 last_interrupt_latency;468static LF_LIST *lf_list;469static int signal_mapping_table[ NSIG ];470static int471 live_finalizer_count,472 allocated_finalizer_count,473 pending_finalizer_count,474 callback_returned_flag;475static C_GC_ROOT *gc_root_list = NULL;476static FINALIZER_NODE477 *finalizer_list,478 *finalizer_free_list,479 **pending_finalizer_indices;480static void *current_module_handle;481static int flonum_print_precision = FLONUM_PRINT_PRECISION;482static HDUMP_BUCKET **hdump_table;483static PROFILE_BUCKET484 *next_profile_bucket = NULL,485 **profile_table = NULL;486static int487 pending_interrupts[ MAX_PENDING_INTERRUPTS ],488 pending_interrupts_count,489 handling_interrupts;490static C_uword random_state[ C_RANDOM_STATE_SIZE / sizeof(C_uword) ];491static int random_state_index = 0;492493494/* Prototypes: */495496static void parse_argv(C_char *cmds);497static void initialize_symbol_table(void);498static void global_signal_handler(int signum);499static C_word arg_val(C_char *arg);500static void barf(int code, char *loc, ...) C_noret;501static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_noret;502static void panic(C_char *msg) C_noret;503static void usual_panic(C_char *msg) C_noret;504static void horror(C_char *msg) C_noret;505static void really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;506static C_cpsproc(values_continuation) C_noret;507static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);508static C_regparm int C_in_new_heapp(C_word x);509static C_regparm C_word bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);510static C_regparm C_word bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end);511512static C_regparm C_word bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp);513static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);514static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op);515static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat);516static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op);517static C_word rat_times_integer(C_word **ptr, C_word x, C_word y);518static C_word rat_times_rat(C_word **ptr, C_word x, C_word y);519static C_word cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy);520static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y);521static C_regparm void integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);522static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y);523static C_regparm void bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);524static C_regparm C_word bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);525static 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);526static 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);527static C_word rat_cmp(C_word x, C_word y);528static void fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan);529static C_word int_flo_cmp(C_word intnum, C_word flonum);530static C_word flo_int_cmp(C_word flonum, C_word intnum);531static C_word rat_flo_cmp(C_word ratnum, C_word flonum);532static C_word flo_rat_cmp(C_word flonum, C_word ratnum);533static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp);534static int bignum_cmp_unsigned(C_word x, C_word y);535static C_word hash_string(int len, C_char *str, C_word m, C_word r) C_regparm;536static C_word lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;537static C_word lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm;538static double compute_symbol_table_load(double *avg_bucket_len, int *total);539static double decode_flonum_literal(C_char *str) C_regparm;540static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);541static void 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;542static void mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;543static void mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;544static C_word intern0(C_char *name) C_regparm;545static void update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;546static void update_locatives(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;547static LF_LIST *find_module_handle(C_char *name);548static void set_profile_timer(C_uword freq);549static void take_profile_sample();550551static C_cpsproc(call_cc_wrapper) C_noret;552static C_cpsproc(call_cc_values_wrapper) C_noret;553static C_cpsproc(gc_2) C_noret;554static C_cpsproc(allocate_vector_2) C_noret;555static C_cpsproc(allocate_bytevector_2) C_noret;556static C_cpsproc(generic_trampoline) C_noret;557static void handle_interrupt(void *trampoline) C_noret;558static C_cpsproc(callback_return_continuation) C_noret;559static C_cpsproc(termination_continuation) C_noret;560static C_cpsproc(become_2) C_noret;561static C_cpsproc(copy_closure_2) C_noret;562static C_cpsproc(dump_heap_state_2) C_noret;563static C_cpsproc(sigsegv_trampoline) C_noret;564static C_cpsproc(sigill_trampoline) C_noret;565static C_cpsproc(sigfpe_trampoline) C_noret;566static C_cpsproc(sigbus_trampoline) C_noret;567static C_cpsproc(bignum_to_str_2) C_noret;568569static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp);570static C_word allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp);571static void bignum_digits_destructive_negate(C_word bignum);572static C_uword bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry);573static C_uword bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator);574static C_uword bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp);575static C_uword bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left);576static C_regparm void bignum_digits_multiply(C_word x, C_word y, C_word result);577static 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);578static C_regparm void bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);579static C_regparm void bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder);580static C_regparm void bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q);581582static C_PTABLE_ENTRY *create_initial_ptable();583584#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))585static void C_ccall dload_2(C_word, C_word *) C_noret;586#endif587588static void589C_dbg(C_char *prefix, C_char *fstr, ...)590{591 va_list va;592593 va_start(va, fstr);594#ifdef __ANDROID__595 __android_log_vprint(ANDROID_LOG_DEBUG, prefix, fstr, va);596#else597 C_fflush(C_stdout);598 C_fprintf(C_stderr, "[%s] ", prefix);599 C_vfprintf(C_stderr, fstr, va);600 C_fflush(C_stderr);601#endif602 va_end(va);603}604605/* Startup code: */606607int CHICKEN_main(int argc, char *argv[], void *toplevel)608{609 C_word h, s, n;610611#ifdef _WIN32612 parse_argv(C_utf8(GetCommandLineW()));613 argc = C_main_argc;614 argv = C_main_argv;615#endif616617 pass_serious_signals = 0;618 CHICKEN_parse_command_line(argc, argv, &h, &s, &n);619620 if(!CHICKEN_initialize(h, s, n, toplevel))621 panic(C_text("cannot initialize - out of memory"));622623 CHICKEN_run(NULL);624 return 0;625}626627628/* Custom argv parser for Windowz: */629630void parse_argv(C_char *cmds)631{632 C_char *ptr = cmds, *bptr0, *bptr, *aptr;633 int n = 0, delim = 0;634 C_main_argv = (C_char **)malloc((MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS + 1) * sizeof(C_char *));635636 if(C_main_argv == NULL)637 panic(C_text("cannot allocate argument-list buffer"));638639 C_main_argc = 0;640641 while(C_main_argc < MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS) {642 while(C_utf_isspace((int)(*ptr))) ++ptr;643644 if(*ptr == '\0') break;645646 bptr0 = bptr = buffer;647 n = 0;648 if(*ptr == '\"' || *ptr == '\'') delim = *(ptr++);649 else delim = 0;650651 while(*ptr != '\0') {652 if(*ptr == delim || (C_utf_isspace((int)(*ptr)) && !delim)) break;653 if(delim && *ptr == '\\') ++ptr;654 *(bptr++) = *(ptr++);655 ++n;656 }657658 if(delim) ++ptr;659660 *bptr = '\0';661 aptr = (C_char*)malloc(n + 1);662 if(!aptr) panic(C_text("cannot allocate argument buffer"));663664 C_strlcpy(aptr, bptr0, n + 1);665 C_main_argv[ C_main_argc++ ] = aptr;666 }667668 C_main_argv[ C_main_argc ] = NULL;669}670671/* simple linear congruential PRNG, to avoid OpenBSD warnings.672 https://stackoverflow.com/questions/26237419/faster-than-rand673*/674675static int g_seed;676677void C_fast_srand(int seed) { g_seed = seed; }678679/* Output value in range [0, 32767] */680int C_fast_rand(void)681{682 g_seed = (214013*g_seed+2531011);683 return (g_seed>>16)&0x7FFF;684}685686687/* Initialize runtime system: */688689int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)690{691 C_SCHEME_BLOCK *k0;692 int i;693#ifdef HAVE_SIGACTION694 struct sigaction sa;695#endif696697 /* FIXME Should have C_tzset in chicken.h? */698#if defined(__MINGW32__)699# if defined(__MINGW64_VERSION_MAJOR)700 ULONGLONG tick_count = GetTickCount64();701# else702 /* mingw doesn't yet have GetTickCount64 support */703 ULONGLONG tick_count = GetTickCount();704# endif705 C_startup_time_sec = tick_count / 1000;706 C_startup_time_msec = tick_count % 1000;707 /* Make sure _tzname, _timezone, and _daylight are set */708 _tzset();709#else710 struct timeval tv;711 C_gettimeofday(&tv, NULL);712 C_startup_time_sec = tv.tv_sec;713 C_startup_time_msec = tv.tv_usec / 1000;714 /* Make sure tzname, timezone, and daylight are set */715 tzset();716#endif717718 if(chicken_is_initialized) return 1;719 else chicken_is_initialized = 1;720721#if defined(__ANDROID__) && defined(DEBUGBUILD)722 debug_mode = 2;723#endif724725 if(debug_mode)726 C_dbg(C_text("debug"), C_text("application startup...\n"));727728 C_panic_hook = usual_panic;729 symbol_table_list = NULL;730731 symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE);732733 if(symbol_table == NULL)734 return 0;735736 keyword_table = C_new_symbol_table("kw", symbols ? symbols / 4 : DEFAULT_KEYWORD_TABLE_SIZE);737738 if(keyword_table == NULL)739 return 0;740741 page_size = 0;742 stack_size = stack ? stack : DEFAULT_STACK_SIZE;743 C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);744745 /* Allocate temporary stack: */746 temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;747 if((C_temporary_stack_limit = (C_word *)C_malloc(temporary_stack_size * sizeof(C_word))) == NULL)748 return 0;749750 C_temporary_stack_bottom = C_temporary_stack_limit + temporary_stack_size;751 C_temporary_stack = C_temporary_stack_bottom;752753 /* Allocate mutation stack: */754 mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));755756 if(mutation_stack_bottom == NULL) return 0;757758 mutation_stack_top = mutation_stack_bottom;759 mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;760 C_gc_mutation_hook = NULL;761 C_gc_trace_hook = NULL;762763 /* Initialize finalizer lists: */764 finalizer_list = NULL;765 finalizer_free_list = NULL;766 pending_finalizer_indices =767 (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));768769 if(pending_finalizer_indices == NULL) return 0;770771 /* Initialize forwarding table: */772 forwarding_table =773 (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));774775 if(forwarding_table == NULL) return 0;776777 *forwarding_table = 0;778 forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;779780 /* Setup collectibles: */781 collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);782783 if(collectibles == NULL) return 0;784785 collectibles_top = collectibles;786 collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;787 gc_root_list = NULL;788789#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)790 dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;791#else792 dlopen_flags = 0;793#endif794795#ifdef HAVE_SIGACTION796 sa.sa_flags = 0;797 sigfillset(&sa.sa_mask); /* See note in C_establish_signal_handler() */798 sa.sa_handler = global_signal_handler;799#endif800801 /* setup signal handlers */802 if(!pass_serious_signals) {803#ifdef HAVE_SIGACTION804 C_sigaction(SIGBUS, &sa, NULL);805 C_sigaction(SIGFPE, &sa, NULL);806 C_sigaction(SIGILL, &sa, NULL);807 C_sigaction(SIGSEGV, &sa, NULL);808#else809 C_signal(SIGBUS, global_signal_handler);810 C_signal(SIGILL, global_signal_handler);811 C_signal(SIGFPE, global_signal_handler);812 C_signal(SIGSEGV, global_signal_handler);813#endif814 }815816 tracked_mutation_count = mutation_count = gc_count_1 = gc_count_1_total = gc_count_2 = maximum_heap_usage = 0;817 lf_list = NULL;818 C_register_lf2(NULL, 0, create_initial_ptable());819 C_restart_trampoline = (void *)toplevel;820 trace_buffer = NULL;821 C_clear_trace_buffer();822 chicken_is_running = chicken_ran_once = 0;823 pending_interrupts_count = 0;824 handling_interrupts = 0;825 last_interrupt_latency = 0;826 C_interrupts_enabled = 1;827 C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;828 C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;829 memset(signal_mapping_table, 0, sizeof(int) * NSIG);830 C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";831 error_location = C_SCHEME_FALSE;832 C_pre_gc_hook = NULL;833 C_post_gc_hook = NULL;834 C_scratchspace_start = NULL;835 C_scratchspace_top = NULL;836 C_scratchspace_limit = NULL;837 C_scratch_usage = 0;838 scratchspace_size = 0;839 live_finalizer_count = 0;840 allocated_finalizer_count = 0;841 current_module_name = NULL;842 current_module_handle = NULL;843 callback_continuation_level = 0;844 weak_pair_chain = (C_word)NULL;845 locative_chain = (C_word)NULL;846 gc_ms = 0;847 if (!random_state_initialized) {848 C_fast_srand(time(NULL));849 random_state_initialized = 1;850 }851852 for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_uword); ++i)853 random_state[ i ] = C_fast_rand();854855 initialize_symbol_table();856857 if (profiling) {858#ifndef C_NONUNIX859# ifdef HAVE_SIGACTION860 C_sigaction(C_PROFILE_SIGNAL, &sa, NULL);861# else862 C_signal(C_PROFILE_SIGNAL, global_signal_handler);863# endif864#endif865866 profile_table = (PROFILE_BUCKET **)C_malloc(PROFILE_TABLE_SIZE * sizeof(PROFILE_BUCKET *));867868 if(profile_table == NULL)869 panic(C_text("out of memory - can not allocate profile table"));870871 C_memset(profile_table, 0, sizeof(PROFILE_BUCKET *) * PROFILE_TABLE_SIZE);872 }873874 /* create k to invoke code for system-startup: */875 k0 = (C_SCHEME_BLOCK *)C_align((C_word)C_fromspace_top);876 C_fromspace_top += C_align(2 * sizeof(C_word));877 k0->header = C_CLOSURE_TYPE | 1;878 C_set_block_item(k0, 0, (C_word)termination_continuation);879 C_save(k0);880 C_save(C_SCHEME_UNDEFINED);881 C_restart_c = 2;882 return 1;883}884885886void *C_get_statistics(void) {887 static void *stats[ 8 ];888889 stats[ 0 ] = fromspace_start;890 stats[ 1 ] = C_fromspace_limit;891 stats[ 2 ] = C_scratchspace_start;892 stats[ 3 ] = C_scratchspace_limit;893 stats[ 4 ] = C_stack_limit;894 stats[ 5 ] = stack_bottom;895 stats[ 6 ] = C_fromspace_top;896 stats[ 7 ] = C_scratchspace_top;897 return stats;898}899900901static C_PTABLE_ENTRY *create_initial_ptable()902{903 /* IMPORTANT: hardcoded table size -904 this must match the number of C_pte calls + 1 (NULL terminator)! */905 C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 64);906 int i = 0;907908 if(pt == NULL)909 panic(C_text("out of memory - cannot create initial ptable"));910911 C_pte(termination_continuation);912 C_pte(callback_return_continuation);913 C_pte(values_continuation);914 C_pte(call_cc_values_wrapper);915 C_pte(call_cc_wrapper);916 C_pte(C_gc);917 C_pte(C_allocate_vector);918 C_pte(C_allocate_bytevector);919 C_pte(C_make_structure);920 C_pte(C_ensure_heap_reserve);921 C_pte(C_return_to_host);922 C_pte(C_get_symbol_table_info);923 C_pte(C_get_memory_info);924 C_pte(C_decode_seconds);925 C_pte(C_stop_timer);926 C_pte(C_dload);927 C_pte(C_set_dlopen_flags);928 C_pte(C_become);929 C_pte(C_apply_values);930 C_pte(C_times);931 C_pte(C_minus);932 C_pte(C_plus);933 C_pte(C_nequalp);934 C_pte(C_greaterp);935 /* IMPORTANT: have you read the comments at the start and the end of this function? */936 C_pte(C_lessp);937 C_pte(C_greater_or_equal_p);938 C_pte(C_less_or_equal_p);939 C_pte(C_number_to_string);940 C_pte(C_make_symbol);941 C_pte(C_string_to_symbol);942 C_pte(C_string_to_keyword);943 C_pte(C_apply);944 C_pte(C_call_cc);945 C_pte(C_values);946 C_pte(C_call_with_values);947 C_pte(C_continuation_graft);948 C_pte(C_open_file_port);949 C_pte(C_software_type);950 C_pte(C_machine_type);951 C_pte(C_machine_byte_order);952 C_pte(C_software_version);953 C_pte(C_build_platform);954 C_pte(C_make_pointer);955 /* IMPORTANT: have you read the comments at the start and the end of this function? */956 C_pte(C_make_tagged_pointer);957 C_pte(C_peek_signed_integer);958 C_pte(C_peek_unsigned_integer);959 C_pte(C_peek_int64);960 C_pte(C_peek_uint64);961 C_pte(C_context_switch);962 C_pte(C_register_finalizer);963 C_pte(C_copy_closure);964 C_pte(C_dump_heap_state);965 C_pte(C_filter_heap_objects);966 C_pte(C_fixnum_to_string);967 C_pte(C_integer_to_string);968 C_pte(C_flonum_to_string);969 C_pte(C_signum);970 C_pte(C_quotient_and_remainder);971 C_pte(C_u_integer_quotient_and_remainder);972 C_pte(C_bitwise_and);973 C_pte(C_bitwise_ior);974 C_pte(C_bitwise_xor);975976 /* IMPORTANT: did you remember the hardcoded pte table size? */977 pt[ i ].id = NULL;978 return pt;979}980981982void *CHICKEN_new_gc_root_2(int finalizable)983{984 C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));985986 if(r == NULL)987 panic(C_text("out of memory - cannot allocate GC root"));988989 r->value = C_SCHEME_UNDEFINED;990 r->next = gc_root_list;991 r->prev = NULL;992 r->finalizable = finalizable;993994 if(gc_root_list != NULL) gc_root_list->prev = r;995996 gc_root_list = r;997 return (void *)r;998}99910001001void *CHICKEN_new_gc_root()1002{1003 return CHICKEN_new_gc_root_2(0);1004}100510061007void *CHICKEN_new_finalizable_gc_root()1008{1009 return CHICKEN_new_gc_root_2(1);1010}101110121013void CHICKEN_delete_gc_root(void *root)1014{1015 C_GC_ROOT *r = (C_GC_ROOT *)root;10161017 if(r->prev == NULL) gc_root_list = r->next;1018 else r->prev->next = r->next;10191020 if(r->next != NULL) r->next->prev = r->prev;10211022 C_free(root);1023}102410251026void *CHICKEN_global_lookup(char *name)1027{1028 int1029 len = C_strlen(name),1030 key = hash_string(len, name, symbol_table->size, symbol_table->rand);1031 C_word s;1032 void *root = CHICKEN_new_gc_root();10331034 if(C_truep(s = lookup(key, len, name, symbol_table))) {1035 if(C_block_item(s, 0) != C_SCHEME_UNBOUND) {1036 CHICKEN_gc_root_set(root, s);1037 return root;1038 }1039 }10401041 return NULL;1042}104310441045int CHICKEN_is_running()1046{1047 return chicken_is_running;1048}104910501051void CHICKEN_interrupt()1052{1053 C_timer_interrupt_counter = 0;1054}105510561057C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)1058{1059 C_SYMBOL_TABLE *stp;1060 int i;10611062 if((stp = C_find_symbol_table(name)) != NULL) return stp;10631064 if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)1065 return NULL;10661067 stp->name = name;1068 stp->size = size;1069 stp->next = symbol_table_list;1070 stp->rand = C_fast_rand();10711072 if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)1073 return NULL;10741075 for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);10761077 symbol_table_list = stp;1078 return stp;1079}108010811082C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)1083{1084 C_SYMBOL_TABLE *stp;10851086 for(stp = symbol_table_list; stp != NULL; stp = stp->next)1087 if(!C_strcmp(name, stp->name)) return stp;10881089 return NULL;1090}109110921093C_regparm C_word C_find_symbol(C_word bv, C_SYMBOL_TABLE *stable)1094{1095 C_char *sptr = C_c_string(bv);1096 int len = C_header_size(bv) - 1;1097 int key;1098 C_word s;10991100 if(stable == NULL) stable = symbol_table;11011102 key = hash_string(len, sptr, stable->size, stable->rand);11031104 if(C_truep(s = lookup(key, len, sptr, stable))) return s;1105 else return C_SCHEME_FALSE;1106}110711081109/* Setup symbol-table with internally used symbols; */11101111void initialize_symbol_table(void)1112{1113 int i;11141115 for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);11161117 /* Obtain reference to hooks for later: */1118 core_provided_symbol = C_intern2(C_heaptop, C_text("##core#provided"));1119 interrupt_hook_symbol = C_intern2(C_heaptop, C_text("##sys#interrupt-hook"));1120 error_hook_symbol = C_intern2(C_heaptop, C_text("##sys#error-hook"));1121 callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);1122 pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));1123 current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);11241125 /* SRFI-4 tags */1126 s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));1127 u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));1128 s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));1129 u32vector_symbol = C_intern2(C_heaptop, C_text("u32vector"));1130 s32vector_symbol = C_intern2(C_heaptop, C_text("s32vector"));1131 u64vector_symbol = C_intern2(C_heaptop, C_text("u64vector"));1132 s64vector_symbol = C_intern2(C_heaptop, C_text("s64vector"));1133 f32vector_symbol = C_intern2(C_heaptop, C_text("f32vector"));1134 f64vector_symbol = C_intern2(C_heaptop, C_text("f64vector"));1135}113611371138C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)1139{1140 C_char *sptr = C_c_string(str);1141 int len = C_header_size(str) - 1;1142 int key;1143 C_word s;11441145 if(kwtable == NULL) kwtable = keyword_table;11461147 key = hash_string(len, sptr, kwtable->size, kwtable->rand);11481149 if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;1150 else return C_SCHEME_FALSE;1151}115211531154void C_ccall sigsegv_trampoline(C_word c, C_word *av)1155{1156 barf(C_MEMORY_VIOLATION_ERROR, NULL);1157}115811591160void C_ccall sigbus_trampoline(C_word c, C_word *av)1161{1162 barf(C_BUS_ERROR, NULL);1163}116411651166void C_ccall sigfpe_trampoline(C_word c, C_word *av)1167{1168 barf(C_FLOATING_POINT_EXCEPTION_ERROR, NULL);1169}117011711172void C_ccall sigill_trampoline(C_word c, C_word *av)1173{1174 barf(C_ILLEGAL_INSTRUCTION_ERROR, NULL);1175}117611771178/* This is called from POSIX signals: */11791180void global_signal_handler(int signum)1181{1182#if defined(HAVE_SIGPROCMASK)1183 if(signum == SIGSEGV || signum == SIGFPE || signum == SIGILL || signum == SIGBUS) {1184 sigset_t sset;11851186 if(serious_signal_occurred || !chicken_is_running) {1187 switch(signum) {1188 case SIGSEGV: panic(C_text("unrecoverable segmentation violation"));1189 case SIGFPE: panic(C_text("unrecoverable floating-point exception"));1190 case SIGILL: panic(C_text("unrecoverable illegal instruction error"));1191 case SIGBUS: panic(C_text("unrecoverable bus error"));1192 default: panic(C_text("unrecoverable serious condition"));1193 }1194 }1195 else serious_signal_occurred = 1;11961197 /* unblock signal to avoid nested invocation of the handler */1198 sigemptyset(&sset);1199 sigaddset(&sset, signum);1200 C_sigprocmask(SIG_UNBLOCK, &sset, NULL);12011202 switch(signum) {1203 case SIGSEGV: C_reclaim(sigsegv_trampoline, 0);1204 case SIGFPE: C_reclaim(sigfpe_trampoline, 0);1205 case SIGILL: C_reclaim(sigill_trampoline, 0);1206 case SIGBUS: C_reclaim(sigbus_trampoline, 0);1207 default: panic(C_text("invalid serious signal"));1208 }1209 }1210#endif12111212 /* TODO: Make full use of sigaction: check that /our/ timer expired */1213 if (signum == C_PROFILE_SIGNAL && profiling) take_profile_sample();1214 else C_raise_interrupt(signal_mapping_table[ signum ]);12151216#ifndef HAVE_SIGACTION1217 /* not necessarily needed, but older UNIXen may not leave the handler installed: */1218 C_signal(signum, global_signal_handler);1219#endif1220}122112221223/* Align memory to page boundary */12241225static void *align_to_page(void *mem)1226{1227 return (void *)C_align((C_uword)mem);1228}122912301231static C_byte *1232heap_alloc (size_t size, C_byte **page_aligned)1233{1234 C_byte *p;1235 p = (C_byte *)C_malloc (size + page_size);12361237 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12381239 return p;1240}124112421243static void1244heap_free (C_byte *ptr, size_t size)1245{1246 C_free (ptr);1247}124812491250static C_byte *1251heap_realloc (C_byte *ptr, size_t old_size,1252 size_t new_size, C_byte **page_aligned)1253{1254 C_byte *p;1255 p = (C_byte *)C_realloc (ptr, new_size + page_size);12561257 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12581259 return p;1260}126112621263/* Modify heap size at runtime: */12641265void C_set_or_change_heap_size(C_word heap, int reintern)1266{1267 C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;1268 C_word size = heap / 2;12691270 if(heap_size_changed && fromspace_start) return;12711272 if(fromspace_start && heap_size >= heap) return;12731274 if(debug_mode)1275 C_dbg(C_text("debug"), C_text("heap resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), heap);12761277 heap_size = heap;12781279 if((ptr1 = heap_realloc (fromspace_start,1280 C_fromspace_limit - fromspace_start,1281 size, &ptr1a)) == NULL ||1282 (ptr2 = heap_realloc (tospace_start,1283 tospace_limit - tospace_start,1284 size, &ptr2a)) == NULL)1285 panic(C_text("out of memory - cannot allocate heap"));12861287 heapspace1 = ptr1;1288 heapspace1_size = size;1289 heapspace2 = ptr2;1290 heapspace2_size = size;1291 fromspace_start = ptr1a;1292 C_fromspace_top = fromspace_start;1293 C_fromspace_limit = fromspace_start + size;1294 tospace_start = ptr2a;1295 tospace_top = tospace_start;1296 tospace_limit = tospace_start + size;1297 mutation_stack_top = mutation_stack_bottom;12981299 if(reintern) initialize_symbol_table();1300}130113021303/* Modify stack-size at runtime: */13041305void C_do_resize_stack(C_word stack)1306{1307 C_uword old = stack_size,1308 diff = stack - old;13091310 if(diff != 0 && !stack_size_changed) {1311 if(debug_mode)1312 C_dbg(C_text("debug"), C_text("stack resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), stack);13131314 stack_size = stack;13151316#if C_STACK_GROWS_DOWNWARD1317 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit - diff);1318#else1319 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit + diff);1320#endif1321 C_stack_limit = C_stack_hard_limit;1322 }1323}132413251326/* Check whether nursery is sufficiently big: */13271328void C_check_nursery_minimum(C_word words)1329{1330 if(words >= C_bytestowords(stack_size))1331 panic(C_text("nursery is too small - try higher setting using the `-:s' option"));1332}13331334C_word C_resize_pending_finalizers(C_word size) {1335 int sz = C_num_to_int(size);13361337 FINALIZER_NODE **newmem =1338 (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));13391340 if (newmem == NULL)1341 return C_SCHEME_FALSE;13421343 pending_finalizer_indices = newmem;1344 C_max_pending_finalizers = sz;1345 return C_SCHEME_TRUE;1346}134713481349/* Parse runtime options from command-line: */13501351void CHICKEN_parse_command_line(int argc, C_char *argv[], C_word *heap, C_word *stack, C_word *symbols)1352{1353 int i;1354 C_char *ptr;1355 C_word x;13561357 C_main_argc = argc;1358 C_main_argv = argv;13591360 *heap = DEFAULT_HEAP_SIZE;1361 *stack = DEFAULT_STACK_SIZE;1362 *symbols = DEFAULT_SYMBOL_TABLE_SIZE;13631364 for(i = 1; i < C_main_argc; ++i) {1365 if (strncmp(C_main_argv[ i ], C_text("-:"), 2))1366 break; /* Stop parsing on first non-runtime option */13671368 ptr = &C_main_argv[ i ][ 2 ];1369 if (*ptr == '\0')1370 break; /* Also stop parsing on first "empty" option (i.e. "-:") */13711372 do {1373 switch(*(ptr++)) {1374 case '?':1375 C_dbg("Runtime options", "\n\n"1376 " -:? display this text\n"1377 " -:c always treat stdin as console\n"1378 " -:d enable debug output\n"1379 " -:D enable more debug output\n"1380 " -:g show GC information\n"1381 " -:o disable stack overflow checks\n"1382 " -:hiSIZE set initial heap size\n"1383 " -:hmSIZE set maximal heap size\n"1384 " -:hfSIZE set minimum unused heap size\n"1385 " -:hgPERCENTAGE set heap growth percentage\n"1386 " -:hsPERCENTAGE set heap shrink percentage\n"1387 " -:huPERCENTAGE set percentage of memory used at which heap will be shrunk\n"1388 " -:hSIZE set fixed heap size\n"1389 " -:r write trace output to stderr\n"1390 " -:RSEED initialize rand() seed with SEED (helpful for benchmark stability)\n"1391 " -:p collect statistical profile and write to file at exit\n"1392 " -:PFREQUENCY like -:p, specifying sampling frequency in us (default: 10000)\n"1393 " -:sSIZE set nursery (stack) size\n"1394 " -:tSIZE set symbol-table size\n"1395 " -:fSIZE set maximal number of pending finalizers\n"1396 " -:x deliver uncaught exceptions of other threads to primordial one\n"1397 " -:B sound bell on major GC\n"1398 " -:G force GUI mode\n"1399 " -:aSIZE set trace-buffer/call-chain size\n"1400 " -:ASIZE set fixed temporary stack size\n"1401 " -:H dump heap state on exit\n"1402 " -:S do not handle segfaults or other serious conditions\n"1403 "\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"1404 " times 1024, 1048576, and 1073741824, respectively.\n\n");1405 C_exit_runtime(C_fix(0));14061407 case 'h':1408 switch(*ptr) {1409 case 'i':1410 *heap = arg_val(ptr + 1);1411 heap_size_changed = 1;1412 goto next;1413 case 'f':1414 C_heap_half_min_free = arg_val(ptr + 1);1415 goto next;1416 case 'g':1417 C_heap_growth = arg_val(ptr + 1);1418 goto next;1419 case 'm':1420 C_maximal_heap_size = arg_val(ptr + 1);1421 goto next;1422 case 's':1423 C_heap_shrinkage = arg_val(ptr + 1);1424 goto next;1425 case 'u':1426 C_heap_shrinkage_used = arg_val(ptr + 1);1427 goto next;1428 default:1429 *heap = arg_val(ptr);1430 heap_size_changed = 1;1431 C_heap_size_is_fixed = 1;1432 goto next;1433 }14341435 case 'o':1436 C_disable_overflow_check = 1;1437 break;14381439 case 'B':1440 gc_bell = 1;1441 break;14421443 case 'G':1444 C_gui_mode = 1;1445 break;14461447 case 'H':1448 dump_heap_on_exit = 1;1449 break;14501451 case 'S':1452 pass_serious_signals = 1;1453 break;14541455 case 's':1456 *stack = arg_val(ptr);1457 stack_size_changed = 1;1458 goto next;14591460 case 'f':1461 C_max_pending_finalizers = arg_val(ptr);1462 goto next;14631464 case 'a':1465 C_trace_buffer_size = arg_val(ptr);1466 goto next;14671468 case 'A':1469 fixed_temporary_stack_size = arg_val(ptr);1470 goto next;14711472 case 't':1473 *symbols = arg_val(ptr);1474 goto next;14751476 case 'c':1477 fake_tty_flag = 1;1478 break;14791480 case 'd':1481 debug_mode = 1;1482 break;14831484 case 'D':1485 debug_mode = 2;1486 break;14871488 case 'g':1489 gc_report_flag = 2;1490 break;14911492 case 'P':1493 profiling = 1;1494 profile_frequency = arg_val(ptr);1495 goto next;14961497 case 'p':1498 profiling = 1;1499 break;15001501 case 'r':1502 show_trace = 1;1503 break;15041505 case 'R':1506 C_fast_srand((unsigned int)arg_val(ptr));1507 random_state_initialized = 1;1508 goto next;15091510 case 'x':1511 C_abort_on_thread_exceptions = 1;1512 break;15131514 default: panic(C_text("illegal runtime option"));1515 }1516 } while(*ptr != '\0');15171518 next:;1519 }1520}152115221523C_word arg_val(C_char *arg)1524{1525 int len;1526 C_char *end;1527 C_long val, mul = 1;15281529 if (arg == NULL) panic(C_text("illegal runtime-option argument"));15301531 len = C_strlen(arg);15321533 if(len < 1) panic(C_text("illegal runtime-option argument"));15341535 switch(arg[ len - 1 ]) {1536 case 'k':1537 case 'K': mul = 1024; break;15381539 case 'm':1540 case 'M': mul = 1024 * 1024; break;15411542 case 'g':1543 case 'G': mul = 1024 * 1024 * 1024; break;15441545 default: mul = 1;1546 }15471548 val = C_strtow(arg, &end, 10);15491550 if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))1551 panic(C_text("invalid runtime-option argument suffix"));15521553 return val * mul;1554}155515561557/* Run embedded code with arguments: */15581559C_word CHICKEN_run(void *toplevel)1560{1561 if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))1562 panic(C_text("could not initialize"));15631564 if(chicken_is_running)1565 panic(C_text("re-invocation of Scheme world while process is already running"));15661567 chicken_is_running = chicken_ran_once = 1;1568 return_to_host = 0;15691570 if(profiling) set_profile_timer(profile_frequency);15711572#if C_STACK_GROWS_DOWNWARD1573 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);1574#else1575 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);1576#endif1577 C_stack_limit = C_stack_hard_limit;15781579 stack_bottom = C_stack_pointer;15801581 if(debug_mode)1582 C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx\n"), (C_word)stack_bottom);15831584 /* The point of (usually) no return... */1585#ifdef HAVE_SIGSETJMP1586 C_sigsetjmp(C_restart, 0);1587#else1588 C_setjmp(C_restart);1589#endif15901591 serious_signal_occurred = 0;15921593 if(!return_to_host) {1594 /* We must copy the argvector onto the stack, because1595 * any subsequent save() will otherwise clobber it.1596 */1597 C_word *p = C_alloc(C_restart_c);1598 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));1599 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));1600 C_temporary_stack = C_temporary_stack_bottom;1601 ((C_proc)C_restart_trampoline)(C_restart_c, p);1602 }16031604 if(profiling) set_profile_timer(0);16051606 chicken_is_running = 0;1607 return C_restore;1608}160916101611C_word CHICKEN_continue(C_word k)1612{1613 if(C_temporary_stack_bottom != C_temporary_stack)1614 panic(C_text("invalid temporary stack level"));16151616 if(!chicken_is_initialized)1617 panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));16181619 C_save(k);1620 return CHICKEN_run(NULL);1621}162216231624/* The final continuation: */16251626void C_ccall termination_continuation(C_word c, C_word *av)1627{1628 if(debug_mode) {1629 C_dbg(C_text("debug"), C_text("application terminated normally\n"));1630 }16311632 C_exit_runtime(C_fix(0));1633}163416351636/* Signal unrecoverable runtime error: */16371638void panic(C_char *msg)1639{1640 if(C_panic_hook != NULL) C_panic_hook(msg);16411642 usual_panic(msg);1643}164416451646void usual_panic(C_char *msg)1647{1648 C_char *dmp = C_dump_trace(0);16491650 C_dbg_hook(C_SCHEME_UNDEFINED);16511652 if(C_gui_mode) {1653 C_snprintf(buffer, sizeof(buffer), C_text("%s\n\n%s"), msg, dmp);1654#if defined(_WIN32) && !defined(__CYGWIN__)1655 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1656 ExitProcess(1);1657#endif1658 } /* fall through if not WIN32 GUI app */16591660 C_dbg("panic", C_text("%s - execution terminated\n\n%s"), msg, dmp);1661 C_exit_runtime(C_fix(1));1662}166316641665void horror(C_char *msg)1666{1667 C_dbg_hook(C_SCHEME_UNDEFINED);16681669 if(C_gui_mode) {1670 C_snprintf(buffer, sizeof(buffer), C_text("%s"), msg);1671#if defined(_WIN32) && !defined(__CYGWIN__)1672 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1673 ExitProcess(1);1674#endif1675 } /* fall through */16761677 C_dbg("horror", C_text("\n%s - execution terminated"), msg);1678 C_exit_runtime(C_fix(1));1679}168016811682/* Error-hook, called from C-level runtime routines: */16831684void barf(int code, char *loc, ...)1685{1686 C_char *msg;1687 C_word err = error_hook_symbol;1688 int c, i;1689 va_list v;1690 C_word *av;16911692 C_dbg_hook(C_SCHEME_UNDEFINED);16931694 C_temporary_stack = C_temporary_stack_bottom;1695 err = C_block_item(err, 0);16961697 switch(code) {1698 case C_BAD_ARGUMENT_COUNT_ERROR:1699 msg = C_text("bad argument count");1700 c = 3;1701 break;17021703 case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:1704 msg = C_text("too few arguments");1705 c = 3;1706 break;17071708 case C_BAD_ARGUMENT_TYPE_ERROR:1709 msg = C_text("bad argument type");1710 c = 1;1711 break;17121713 case C_UNBOUND_VARIABLE_ERROR:1714 msg = C_text("unbound variable");1715 c = 1;1716 break;17171718 case C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR:1719 msg = C_text("bad argument type - not a keyword");1720 c = 1;1721 break;17221723 case C_OUT_OF_MEMORY_ERROR:1724 msg = C_text("not enough memory");1725 c = 0;1726 break;17271728 case C_DIVISION_BY_ZERO_ERROR:1729 msg = C_text("division by zero");1730 c = 0;1731 break;17321733 case C_OUT_OF_BOUNDS_ERROR:1734 msg = C_text("out of range");1735 c = 2;1736 break;17371738 case C_NOT_A_CLOSURE_ERROR:1739 msg = C_text("call of non-procedure");1740 c = 1;1741 break;17421743 case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:1744 msg = C_text("continuation cannot receive multiple values");1745 c = 1;1746 break;17471748 case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:1749 msg = C_text("bad argument type - not a non-cyclic list");1750 c = 1;1751 break;17521753 case C_TOO_DEEP_RECURSION_ERROR:1754 msg = C_text("recursion too deep");1755 c = 0;1756 break;17571758 case C_CANT_REPRESENT_INEXACT_ERROR:1759 msg = C_text("inexact number cannot be represented as an exact number");1760 c = 1;1761 break;17621763 case C_NOT_A_PROPER_LIST_ERROR:1764 msg = C_text("bad argument type - not a proper list");1765 c = 1;1766 break;17671768 case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:1769 msg = C_text("bad argument type - not a fixnum");1770 c = 1;1771 break;17721773 case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:1774 msg = C_text("bad argument type - not a string");1775 c = 1;1776 break;17771778 case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:1779 msg = C_text("bad argument type - not a pair");1780 c = 1;1781 break;17821783 case C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR:1784 msg = C_text("bad argument type - not a boolean");1785 c = 1;1786 break;17871788 case C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR:1789 msg = C_text("bad argument type - not a locative");1790 c = 1;1791 break;17921793 case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:1794 msg = C_text("bad argument type - not a list");1795 c = 1;1796 break;17971798 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:1799 msg = C_text("bad argument type - not a number");1800 c = 1;1801 break;18021803 case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:1804 msg = C_text("bad argument type - not a symbol");1805 c = 1;1806 break;18071808 case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:1809 msg = C_text("bad argument type - not a vector");1810 c = 1;1811 break;18121813 case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:1814 msg = C_text("bad argument type - not a character");1815 c = 1;1816 break;18171818 case C_STACK_OVERFLOW_ERROR:1819 msg = C_text("stack overflow");1820 c = 0;1821 break;18221823 case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:1824 msg = C_text("bad argument type - not a structure of the required type");1825 c = 2;1826 break;18271828 case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:1829 msg = C_text("bad argument type - not a bytevector");1830 c = 1;1831 break;18321833 case C_LOST_LOCATIVE_ERROR:1834 msg = C_text("locative refers to reclaimed object");1835 c = 1;1836 break;18371838 case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:1839 msg = C_text("bad argument type - not a object");1840 c = 1;1841 break;18421843 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:1844 msg = C_text("bad argument type - not a number vector");1845 c = 2;1846 break;18471848 case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:1849 msg = C_text("bad argument type - not an integer");1850 c = 1;1851 break;18521853 case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:1854 msg = C_text("bad argument type - not an unsigned integer");1855 c = 1;1856 break;18571858 case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:1859 msg = C_text("bad argument type - not a pointer");1860 c = 1;1861 break;18621863 case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:1864 msg = C_text("bad argument type - not a tagged pointer");1865 c = 2;1866 break;18671868 case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:1869 msg = C_text("bad argument type - not a flonum");1870 c = 1;1871 break;18721873 case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:1874 msg = C_text("bad argument type - not a procedure");1875 c = 1;1876 break;18771878 case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:1879 msg = C_text("bad argument type - invalid base");1880 c = 1;1881 break;18821883 case C_CIRCULAR_DATA_ERROR:1884 msg = C_text("recursion too deep or circular data encountered");1885 c = 0;1886 break;18871888 case C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR:1889 msg = C_text("bad argument type - not a port");1890 c = 1;1891 break;18921893 case C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR:1894 msg = C_text("bad argument type - not a port of the correct type");1895 c = 1;1896 break;18971898 case C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR:1899 msg = C_text("bad argument type - not an input-port");1900 c = 1;1901 break;19021903 case C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR:1904 msg = C_text("bad argument type - not an output-port");1905 c = 1;1906 break;19071908 case C_PORT_CLOSED_ERROR:1909 msg = C_text("port already closed");1910 c = 1;1911 break;19121913 case C_ASCIIZ_REPRESENTATION_ERROR:1914 msg = C_text("cannot represent string with NUL bytes as C string");1915 c = 1;1916 break;19171918 case C_MEMORY_VIOLATION_ERROR:1919 msg = C_text("segmentation violation");1920 c = 0;1921 break;19221923 case C_FLOATING_POINT_EXCEPTION_ERROR:1924 msg = C_text("floating point exception");1925 c = 0;1926 break;19271928 case C_ILLEGAL_INSTRUCTION_ERROR:1929 msg = C_text("illegal instruction");1930 c = 0;1931 break;19321933 case C_BUS_ERROR:1934 msg = C_text("bus error");1935 c = 0;1936 break;19371938 case C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR:1939 msg = C_text("bad argument type - not an exact number");1940 c = 1;1941 break;19421943 case C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR:1944 msg = C_text("bad argument type - not an inexact number");1945 c = 1;1946 break;19471948 case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:1949 msg = C_text("bad argument type - not an real");1950 c = 1;1951 break;19521953 case C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR:1954 msg = C_text("bad argument type - complex number has no ordering");1955 c = 1;1956 break;19571958 case C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR:1959 msg = C_text("bad argument type - not an exact integer");1960 c = 1;1961 break;19621963 case C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION:1964 msg = C_text("number does not fit in foreign type");1965 c = 1;1966 break;19671968 case C_BAD_ARGUMENT_TYPE_COMPLEX_ABS:1969 msg = C_text("cannot compute absolute value of complex number");1970 c = 1;1971 break;19721973 case C_REST_ARG_OUT_OF_BOUNDS_ERROR:1974 msg = C_text("attempted rest argument access beyond end of list");1975 c = 3;1976 break;19771978 case C_DECODING_ERROR:1979 msg = C_text("string contains invalid UTF-8 sequence");1980 c = 2;1981 break;19821983 case C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR:1984 msg = C_text("bad argument type - value exceeds numeric range");1985 c = 1;1986 break;19871988 default: panic(C_text("illegal internal error code"));1989 }19901991 if(C_immediatep(err)) {1992 C_dbg(C_text("error"), C_text("%s\n"), msg);1993 panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));1994 } else {1995 av = C_alloc(c + 4);1996 va_start(v, loc);1997 av[ 0 ] = err;1998 /* No continuation is passed: '##sys#error-hook' may not return: */1999 av[ 1 ] = C_SCHEME_UNDEFINED;2000 av[ 2 ] = C_fix(code);20012002 if(loc != NULL)2003 av[ 3 ] = intern0(loc);2004 else {2005 av[ 3 ] = error_location;2006 error_location = C_SCHEME_FALSE;2007 }20082009 for(i = 0; i < c; ++i)2010 av[ i + 4 ] = va_arg(v, C_word);20112012 va_end(v);2013 C_do_apply(c + 4, av);2014 }2015}201620172018/* Never use extended number hook procedure names longer than this! */2019/* Current longest name: ##sys#integer->string/recursive */2020#define MAX_EXTNUM_HOOK_NAME 3220212022/* This exists so that we don't have to create any extra closures */2023static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)2024{2025 static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];2026 int i;2027 va_list v;2028 C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;20292030 ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));20312032 if(!C_immediatep(ext_proc_sym))2033 ext_proc = C_block_item(ext_proc_sym, 0);20342035 if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {2036 C_word *av = C_alloc(c + 1);2037 av[ 0 ] = ext_proc;2038 av[ 1 ] = k;2039 va_start(v, k);20402041 for(i = 0; i < c - 1; ++i)2042 av[ i + 2 ] = va_arg(v, C_word);20432044 va_end(v);2045 C_do_apply(c + 1, av);2046 } else {2047 barf(C_UNBOUND_VARIABLE_ERROR, NULL, ext_proc_sym);2048 }2049}205020512052/* Hook for setting breakpoints */20532054C_word C_dbg_hook(C_word dummy)2055{2056 return dummy;2057}205820592060/* Timing routines: */20612062/* DEPRECATED */2063C_regparm C_u64 C_milliseconds(void)2064{2065 return C_current_process_milliseconds();2066}20672068C_regparm C_u64 C_current_process_milliseconds(void)2069{2070#if defined(__MINGW32__)2071# if defined(__MINGW64_VERSION_MAJOR)2072 ULONGLONG tick_count = GetTickCount64();2073# else2074 ULONGLONG tick_count = GetTickCount();2075# endif2076 return tick_count - (C_startup_time_sec * 1000) - C_startup_time_msec;2077#else2078 struct timeval tv;20792080 if(C_gettimeofday(&tv, NULL) == -1) return 0;2081 else return (tv.tv_sec - C_startup_time_sec) * 1000 + tv.tv_usec / 1000 - C_startup_time_msec;2082#endif2083}208420852086C_regparm time_t C_seconds(C_long *ms)2087{2088#ifdef C_NONUNIX2089 if(ms != NULL) *ms = 0;20902091 return (time_t)(clock() / CLOCKS_PER_SEC);2092#else2093 struct timeval tv;20942095 if(C_gettimeofday(&tv, NULL) == -1) {2096 if(ms != NULL) *ms = 0;20972098 return (time_t)0;2099 }2100 else {2101 if(ms != NULL) *ms = tv.tv_usec / 1000;21022103 return tv.tv_sec;2104 }2105#endif2106}210721082109C_regparm C_u64 C_cpu_milliseconds(void)2110{2111#if defined(C_NONUNIX) || defined(__CYGWIN__)2112 if(CLOCKS_PER_SEC == 1000) return clock();2113 else return ((C_u64)clock() / CLOCKS_PER_SEC) * 1000;2114#else2115 struct rusage ru;21162117 if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;2118 else return (((C_u64)ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 10002119 + ((C_u64)ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000);2120#endif2121}212221232124/* Support code for callbacks: */21252126int C_save_callback_continuation(C_word **ptr, C_word k)2127{2128 C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));21292130 C_mutate_slot(&C_block_item(callback_continuation_stack_symbol, 0), p);2131 return ++callback_continuation_level;2132}213321342135C_word C_restore_callback_continuation(void)2136{2137 /* obsolete, but retained for keeping old code working */2138 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2139 k;21402141 assert(!C_immediatep(p) && C_header_type(p) == C_PAIR_TYPE);2142 k = C_u_i_car(p);21432144 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2145 --callback_continuation_level;2146 return k;2147}214821492150C_word C_restore_callback_continuation2(int level)2151{2152 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2153 k;21542155 if(level != callback_continuation_level || C_immediatep(p) || C_header_type(p) != C_PAIR_TYPE)2156 panic(C_text("unbalanced callback continuation stack"));21572158 k = C_u_i_car(p);21592160 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2161 --callback_continuation_level;2162 return k;2163}216421652166C_word C_callback(C_word closure, int argc)2167{2168#ifdef HAVE_SIGSETJMP2169 sigjmp_buf prev;2170#else2171 jmp_buf prev;2172#endif2173 C_word2174 *a = C_alloc(C_SIZEOF_CLOSURE(2)),2175 k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE),2176 *av;2177 int old = chicken_is_running;21782179 if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)2180 panic(C_text("callback invoked in non-safe context"));21812182 C_memcpy(&prev, &C_restart, sizeof(C_restart));2183 callback_returned_flag = 0;2184 chicken_is_running = 1;2185 av = C_alloc(argc + 2);2186 av[ 0 ] = closure;2187 av[ 1 ] = k;2188 /*XXX is the order of arguments an issue? */2189 C_memcpy(av + 2, C_temporary_stack, argc * sizeof(C_word));2190 C_temporary_stack = C_temporary_stack_bottom;21912192#ifdef HAVE_SIGSETJMP2193 if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc + 2, av);2194#else2195 if(!C_setjmp(C_restart)) C_do_apply(argc + 2, av);2196#endif21972198 serious_signal_occurred = 0;21992200 if(!callback_returned_flag) {2201 /* We must copy the argvector onto the stack, because2202 * any subsequent save() will otherwise clobber it.2203 */2204 C_word *p = C_alloc(C_restart_c);2205 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));2206 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));2207 C_temporary_stack = C_temporary_stack_bottom;2208 ((C_proc)C_restart_trampoline)(C_restart_c, p);2209 }2210 else {2211 C_memcpy(&C_restart, &prev, sizeof(C_restart));2212 callback_returned_flag = 0;2213 }22142215 chicken_is_running = old;2216 return C_restore;2217}221822192220void C_callback_adjust_stack(C_word *a, int size)2221{2222 if(!chicken_is_running && !C_in_stackp((C_word)a)) {2223 if(debug_mode)2224 C_dbg(C_text("debug"),2225 C_text("callback invoked in lower stack region - adjusting limits:\n"2226 "[debug] current: \t%p\n"2227 "[debug] previous: \t%p (bottom) - %p (limit)\n"),2228 a, stack_bottom, C_stack_limit);22292230#if C_STACK_GROWS_DOWNWARD2231 C_stack_hard_limit = (C_word *)((C_byte *)a - stack_size);2232 stack_bottom = a + size;2233#else2234 C_stack_hard_limit = (C_word *)((C_byte *)a + stack_size);2235 stack_bottom = a;2236#endif2237 C_stack_limit = C_stack_hard_limit;22382239 if(debug_mode)2240 C_dbg(C_text("debug"), C_text("new: \t%p (bottom) - %p (limit)\n"),2241 stack_bottom, C_stack_limit);2242 }2243}224422452246C_word C_callback_wrapper(void *proc, int argc)2247{2248 C_word2249 *a = C_alloc(C_SIZEOF_CLOSURE(1)),2250 closure = C_closure(&a, 1, (C_word)proc),2251 result;22522253 result = C_callback(closure, argc);2254 assert(C_temporary_stack == C_temporary_stack_bottom);2255 return result;2256}225722582259void C_ccall callback_return_continuation(C_word c, C_word *av)2260{2261 C_word self = av[0];2262 C_word r = av[1];22632264 if(C_block_item(self, 1) == C_SCHEME_TRUE)2265 panic(C_text("callback returned twice"));22662267 assert(callback_returned_flag == 0);2268 callback_returned_flag = 1;2269 C_set_block_item(self, 1, C_SCHEME_TRUE);2270 C_save(r);2271 C_reclaim(NULL, 0);2272}227322742275/* Register/unregister literal frame: */22762277void C_initialize_lf(C_word *lf, int count)2278{2279 while(count-- > 0)2280 *(lf++) = C_SCHEME_UNBOUND;2281}228222832284void *C_register_lf(C_word *lf, int count)2285{2286 return C_register_lf2(lf, count, NULL);2287}228822892290void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)2291{2292 LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));2293 LF_LIST *np;2294 int status = 0;22952296 node->lf = lf;2297 node->count = count;2298 node->ptable = ptable;2299 node->module_name = current_module_name;2300 node->module_handle = current_module_handle;2301 current_module_handle = NULL;23022303 if(lf_list) lf_list->prev = node;23042305 node->next = lf_list;2306 node->prev = NULL;2307 lf_list = node;2308 return (void *)node;2309}231023112312LF_LIST *find_module_handle(char *name)2313{2314 LF_LIST *np;23152316 for(np = lf_list; np != NULL; np = np->next) {2317 if(np->module_name != NULL && !C_strcmp(np->module_name, name))2318 return np;2319 }23202321 return NULL;2322}232323242325void C_unregister_lf(void *handle)2326{2327 LF_LIST *node = (LF_LIST *) handle;23282329 if (node->next) node->next->prev = node->prev;23302331 if (node->prev) node->prev->next = node->next;23322333 if (lf_list == node) lf_list = node->next;23342335 C_free(node->module_name);2336 C_free(node);2337}233823392340/* Intern symbol into symbol-table: */23412342C_regparm C_word C_intern(C_word **ptr, int len, C_char *str)2343{2344 return C_intern_in(ptr, len, str, symbol_table);2345}234623472348C_regparm C_word C_h_intern(C_word *slot, int len, C_char *str)2349{2350 return C_h_intern_in(slot, len, str, symbol_table);2351}235223532354C_regparm C_word C_intern_kw(C_word **ptr, int len, C_char *str)2355{2356 C_word kw = C_intern_in(ptr, 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}236123622363C_regparm C_word C_h_intern_kw(C_word *slot, int len, C_char *str)2364{2365 C_word kw = C_h_intern_in(slot, len, str, keyword_table);2366 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2367 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2368 return kw;2369}23702371C_regparm C_word C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)2372{2373 int key;2374 C_word s;23752376 if(stable == NULL) stable = symbol_table;23772378 key = hash_string(len, str, stable->size, stable->rand);23792380 if(C_truep(s = lookup(key, len, str, stable))) return s;23812382 s = C_bytevector(ptr, len + 1, str);2383 return add_symbol(ptr, key, s, stable);2384}238523862387C_regparm C_word C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)2388{2389 /* Intern as usual, but remember slot, and allocate in static2390 * memory. If symbol already exists, replace its string by a fresh2391 * statically allocated string to ensure it never gets collected, as2392 * lf[] entries are not tracked by the GC.2393 */2394 int key;2395 C_word s, bv;23962397 if(stable == NULL) stable = symbol_table;23982399 key = hash_string(len, str, stable->size, stable->rand);24002401 if(C_truep(s = lookup(key, len, str, stable))) {2402 if(C_in_stackp(s)) C_mutate_slot(slot, s);24032404 if(!C_truep(C_permanentp(C_symbol_name(s)))) {2405 /* Replace by statically allocated string, and persist it */2406 bv = C_static_bytevector(C_heaptop, len + 1, str);2407 C_c_bytevector(bv)[ len ] = 0;2408 C_set_block_item(s, 1, bv);2409 C_i_persist_symbol(s);2410 }2411 return s;2412 }24132414 bv = C_static_bytevector(C_heaptop, len + 1, str);2415 C_c_bytevector(bv)[ len ] = 0;2416 return add_symbol(C_heaptop, key, bv, stable);2417}241824192420C_regparm C_word intern0(C_char *str)2421{2422 int len = C_strlen(str);2423 int key = hash_string(len, str, symbol_table->size, symbol_table->rand);2424 C_word s;24252426 if(C_truep(s = lookup(key, len, str, symbol_table))) return s;2427 else return C_SCHEME_FALSE;2428}242924302431C_regparm C_word C_lookup_symbol(C_word sym)2432{2433 int key;2434 C_word bv = C_block_item(sym, 1);2435 int len = C_header_size(bv) - 1;24362437 key = hash_string(len, C_c_string(bv), symbol_table->size, symbol_table->rand);24382439 return lookup(key, len, C_c_string(bv), symbol_table);2440}244124422443C_regparm C_word C_intern2(C_word **ptr, C_char *str)2444{2445 return C_intern_in(ptr, C_strlen(str), str, symbol_table);2446}244724482449C_regparm C_word C_intern3(C_word **ptr, C_char *str, C_word value)2450{2451 C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);24522453 C_mutate(&C_block_item(s,0), value);2454 C_i_persist_symbol(s); /* Symbol has a value now; persist it */2455 return s;2456}245724582459C_regparm C_word hash_string(int len, C_char *str, C_word m, C_word r)2460{2461 C_uword key = r;24622463 while(len--)2464 key ^= (key << 6) + (key >> 2) + *(str++);24652466 return (C_word)(key % (C_uword)m);2467}246824692470C_regparm C_word lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)2471{2472 C_word bucket, last = 0, sym, s;24732474 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2475 bucket = C_block_item(bucket,1)) {2476 sym = C_block_item(bucket,0);24772478 /* If the symbol is unreferenced, drop it: */2479 if (sym == C_SCHEME_BROKEN_WEAK_PTR) {2480 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2481 else stable->table[ key ] = C_block_item(bucket,1);2482 } else {2483 last = bucket;2484 s = C_block_item(sym, 1);24852486 if(C_header_size(s) - 1 == (C_word)len2487 && !C_memcmp(str, (C_char *)C_data_pointer(s), len))2488 return sym;2489 }2490 }24912492 return C_SCHEME_FALSE;2493}24942495/* Mark a symbol as "persistent", to prevent it from being GC'ed */2496C_regparm C_word C_i_persist_symbol(C_word sym)2497{2498 C_word bucket;2499 C_SYMBOL_TABLE *stp;25002501 /* Normally, this will get called with a symbol, but in2502 * C_h_intern_kw we may call it with keywords too.2503 */2504 if(!C_truep(C_i_symbolp(sym)) && !C_truep(C_i_keywordp(sym))) {2505 error_location = C_SCHEME_FALSE;2506 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, sym);2507 }25082509 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2510 bucket = lookup_bucket(sym, stp);25112512 if (C_truep(bucket)) {2513 /* Change weak to strong ref to ensure long-term survival */2514 C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;2515 /* Ensure survival on next minor GC */2516 if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);2517 }2518 }2519 return C_SCHEME_UNDEFINED;2520}25212522/* Possibly remove "persistence" of symbol, to allowed it to be GC'ed.2523 * This is only done if the symbol is unbound, has an empty plist and2524 * is allocated in managed memory.2525 */2526C_regparm C_word C_i_unpersist_symbol(C_word sym)2527{2528 C_word bucket;2529 C_SYMBOL_TABLE *stp;25302531 C_i_check_symbol(sym);25322533 if (C_persistable_symbol(sym) ||2534 C_truep(C_permanentp(C_symbol_name(sym)))) {2535 return C_SCHEME_FALSE;2536 }25372538 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2539 bucket = lookup_bucket(sym, NULL);25402541 if (C_truep(bucket)) {2542 /* Turn it into a weak ref */2543 C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;2544 return C_SCHEME_TRUE;2545 }2546 }2547 return C_SCHEME_FALSE;2548}25492550C_regparm C_word lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)2551{2552 C_word bucket, str = C_block_item(sym, 1);2553 int key, len = C_header_size(str) - 1;25542555 if (stable == NULL) stable = symbol_table;25562557 key = hash_string(len, C_c_string(str), stable->size, stable->rand);25582559 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2560 bucket = C_block_item(bucket,1)) {2561 if (C_block_item(bucket,0) == sym) return bucket;2562 }2563 return C_SCHEME_FALSE;2564}256525662567double compute_symbol_table_load(double *avg_bucket_len, int *total_n)2568{2569 C_word bucket, last;2570 int i, j, alen = 0, bcount = 0, total = 0;25712572 for(i = 0; i < symbol_table->size; ++i) {2573 last = 0;2574 j = 0;2575 for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST;2576 bucket = C_block_item(bucket,1)) {2577 /* If the symbol is unreferenced, drop it: */2578 if (C_block_item(bucket,0) == C_SCHEME_BROKEN_WEAK_PTR) {2579 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2580 else symbol_table->table[ i ] = C_block_item(bucket,1);2581 } else {2582 last = bucket;2583 ++j;2584 }2585 }25862587 if(j > 0) {2588 alen += j;2589 ++bcount;2590 }25912592 total += j;2593 }25942595 if(avg_bucket_len != NULL)2596 *avg_bucket_len = (double)alen / (double)bcount;25972598 *total_n = total;25992600 /* return load: */2601 return (double)total / (double)symbol_table->size;2602}260326042605C_word add_symbol(C_word **ptr, C_word key, C_word bv, C_SYMBOL_TABLE *stable)2606{2607 C_word bucket, sym, b2, *p;26082609 p = *ptr;2610 sym = (C_word)p;2611 p += C_SIZEOF_SYMBOL;2612 C_block_header_init(sym, C_SYMBOL_TAG);2613 C_set_block_item(sym, 0, C_SCHEME_UNBOUND);2614 C_set_block_item(sym, 1, bv);2615 C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);2616 *ptr = p;2617 b2 = stable->table[ key ]; /* previous bucket */26182619 /* Create new weak or strong bucket depending on persistability */2620 if (C_truep(C_permanentp(bv))) {2621 bucket = C_a_pair(ptr, sym, b2);2622 } else {2623 bucket = C_a_weak_pair(ptr, sym, b2);2624 }26252626 if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);2627 else {2628 /* If a stack-allocated bucket was here, and we allocate from2629 heap-top (say, in a toplevel literal frame allocation) then we have2630 to inform the memory manager that a 2nd gen. block points to a2631 1st gen. block, hence the mutation: */2632 C_mutate(&C_block_item(bucket,1), b2);2633 stable->table[ key ] = bucket;2634 }26352636 return sym;2637}263826392640C_regparm int C_in_stackp(C_word x)2641{2642 C_word *ptr = (C_word *)(C_uword)x;26432644#if C_STACK_GROWS_DOWNWARD2645 return ptr >= C_stack_pointer_test && ptr <= stack_bottom;2646#else2647 return ptr < C_stack_pointer_test && ptr >= stack_bottom;2648#endif2649}265026512652C_regparm int C_in_heapp(C_word x)2653{2654 C_byte *ptr = (C_byte *)(C_uword)x;2655 return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||2656 (ptr >= tospace_start && ptr < tospace_limit);2657}26582659/* Only used during major GC (heap realloc) */2660static C_regparm int C_in_new_heapp(C_word x)2661{2662 C_byte *ptr = (C_byte *)(C_uword)x;2663 return (ptr >= new_tospace_start && ptr < new_tospace_limit);2664}26652666C_regparm int C_in_fromspacep(C_word x)2667{2668 C_byte *ptr = (C_byte *)(C_uword)x;2669 return (ptr >= fromspace_start && ptr < C_fromspace_limit);2670}26712672C_regparm int C_in_scratchspacep(C_word x)2673{2674 C_word *ptr = (C_word *)(C_uword)x;2675 return (ptr >= C_scratchspace_start && ptr < C_scratchspace_limit);2676}26772678/* Cons the rest-aguments together: */26792680C_regparm C_word C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)2681{2682 C_word2683 x = C_SCHEME_END_OF_LIST,2684 *p = *ptr;2685 C_SCHEME_BLOCK *node;26862687 av += c;26882689 while(--c >= n) {2690 node = (C_SCHEME_BLOCK *)p;2691 p += 3;2692 node->header = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2693 node->data[ 0 ] = *(--av);2694 node->data[ 1 ] = x;2695 x = (C_word)node;2696 }26972698 *ptr = p;2699 return x;2700}270127022703/* Print error messages and exit: */27042705void C_bad_memory(void)2706{2707 panic(C_text("there is not enough stack-space to run this executable"));2708}270927102711void C_bad_memory_2(void)2712{2713 panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));2714}271527162717/* The following two can be thrown out in the next release... */27182719void C_bad_argc(int c, int n)2720{2721 C_bad_argc_2(c, n, C_SCHEME_FALSE);2722}272327242725void C_bad_min_argc(int c, int n)2726{2727 C_bad_min_argc_2(c, n, C_SCHEME_FALSE);2728}272927302731void C_bad_argc_2(int c, int n, C_word closure)2732{2733 barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2734}273527362737void C_bad_min_argc_2(int c, int n, C_word closure)2738{2739 barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2740}274127422743void C_stack_overflow(C_char *loc)2744{2745 barf(C_STACK_OVERFLOW_ERROR, loc);2746}274727482749void C_no_closure_error(C_word x)2750{2751 barf(C_NOT_A_CLOSURE_ERROR, NULL, x);2752}275327542755void C_div_by_zero_error(C_char *loc)2756{2757 barf(C_DIVISION_BY_ZERO_ERROR, loc);2758}27592760void C_unimplemented(C_char *msg)2761{2762 C_fprintf(C_stderr, C_text("Error: unimplemented feature: %s\n"), msg);2763 C_exit_runtime(C_fix(EX_SOFTWARE));2764}27652766void C_not_an_integer_error(C_char *loc, C_word x)2767{2768 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);2769}27702771void C_not_an_uinteger_error(C_char *loc, C_word x)2772{2773 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x);2774}27752776void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka)2777{2778 C_rest_arg_out_of_bounds_error_2(c, n, ka, C_SCHEME_FALSE);2779}27802781void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure)2782{2783 barf(C_REST_ARG_OUT_OF_BOUNDS_ERROR, NULL, C_u_fixnum_difference(c, ka), C_u_fixnum_difference(n, ka), closure);2784}27852786/* Allocate and initialize record: */27872788C_regparm C_word C_string(C_word **ptr, int len, C_char *str)2789{2790 C_word buf = C_bytevector(ptr, len + 1, str);2791 C_word s = (C_word)(*ptr);2792 int n;2793 *ptr += 5; /* C_SIZEOF_STRING */2794 C_c_bytevector(buf)[ len ] = 0;2795 C_block_header_init(s, C_STRING_TAG);2796 C_set_block_item(s, 0, buf);2797 n = C_utf_count(str, len);2798 C_set_block_item(s, 1, C_fix(n));2799 C_set_block_item(s, 2, C_fix(0));2800 C_set_block_item(s, 3, C_fix(0));2801 return s;2802}28032804C_regparm C_word C_static_string(C_word **ptr, int len, C_char *str)2805{2806 C_word buf = C_static_bytevector(ptr, len + 1, str);2807 C_word s = (C_word)(*ptr);2808 int n;2809 *ptr += 5; /* C_SIZEOF_STRING */2810 C_c_bytevector(buf)[ len ] = 0;2811 C_block_header_init(s, C_STRING_TAG);2812 C_set_block_item(s, 0, buf);2813 n = C_utf_count(str, len);2814 C_set_block_item(s, 1, C_fix(n));2815 C_set_block_item(s, 2, C_fix(0));2816 C_set_block_item(s, 3, C_fix(0));2817 return s;2818}28192820C_regparm C_word C_static_bignum(C_word **ptr, int len, C_char *str)2821{2822 C_word *dptr, bignum, bigvec, retval, size, negp = 0;28232824 if (*str == '+' || *str == '-') {2825 negp = ((*str++) == '-') ? 1 : 0;2826 --len;2827 }2828 size = C_BIGNUM_BITS_TO_DIGITS((unsigned int)len << 2);28292830 dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(size)));2831 if(dptr == NULL)2832 panic(C_text("out of memory - cannot allocate static bignum"));28332834 bigvec = (C_word)dptr;2835 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(size + 1));2836 C_set_block_item(bigvec, 0, negp);2837 /* This needs to be allocated at ptr, not dptr, because GC moves type tag */2838 bignum = C_a_i_bignum_wrapper(ptr, bigvec);28392840 retval = str_to_bignum(bignum, str, str + len, 16);2841 if (retval & C_FIXNUM_BIT)2842 C_free(dptr); /* Might have been simplified */2843 return retval;2844}28452846C_regparm C_word C_static_lambda_info(C_word **ptr, int len, C_char *str)2847{2848 int dlen = sizeof(C_header) + C_align(len);2849 void *dptr = C_malloc(dlen);2850 C_word strblock;28512852 if(dptr == NULL)2853 panic(C_text("out of memory - cannot allocate static lambda info"));28542855 strblock = (C_word)dptr;2856 C_block_header_init(strblock, C_LAMBDA_INFO_TYPE | len);2857 C_memcpy(C_data_pointer(strblock), str, len);2858 return strblock;2859}286028612862C_regparm C_word C_bytevector(C_word **ptr, int len, C_char *str)2863{2864 C_word block = (C_word)(*ptr);2865 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));2866 C_block_header_init(block, C_BYTEVECTOR_TYPE | len);2867 C_memcpy(C_data_pointer(block), str, len);2868 return block;2869}287028712872C_regparm C_word C_static_bytevector(C_word **ptr, int len, C_char *str)2873{2874 /* we need to add 4 here, as utf8_decode does 3-byte lookahead */2875 C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len + 4));2876 C_word block;28772878 if(dptr == NULL)2879 panic(C_text("out of memory - cannot allocate static bytevector"));28802881 block = (C_word)dptr;2882 C_block_header_init(block, C_BYTEVECTOR_TYPE | len);2883 C_memcpy(C_data_pointer(block), str, len);2884 return block;2885}288628872888C_regparm C_word C_pbytevector(int len, C_char *str)2889{2890 C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));28912892 if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent bytevector"));28932894 pbv->header = C_BYTEVECTOR_TYPE | len;2895 C_memcpy(pbv->data, str, len);2896 return (C_word)pbv;2897}289828992900C_regparm C_word C_string2(C_word **ptr, C_char *str)2901{2902 C_word strblock = (C_word)(*ptr);2903 int len;29042905 if(str == NULL) return C_SCHEME_FALSE;29062907 len = C_strlen(str);2908 return C_string(ptr, len, str);2909}291029112912C_regparm C_word C_string2_safe(C_word **ptr, int max, C_char *str)2913{2914 C_word strblock = (C_word)(*ptr);2915 int len;29162917 if(str == NULL) return C_SCHEME_FALSE;29182919 len = C_strlen(str);29202921 if(len >= max) {2922 C_snprintf(buffer, sizeof(buffer), C_text("foreign string result exceeded maximum of %d bytes"), max);2923 panic(buffer);2924 }29252926 return C_string(ptr, len, str);2927}292829292930C_word C_closure(C_word **ptr, int cells, C_word proc, ...)2931{2932 va_list va;2933 C_word *p = *ptr,2934 *p0 = p;29352936 *p = C_CLOSURE_TYPE | cells;2937 *(++p) = proc;29382939 for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));29402941 va_end(va);2942 *ptr = p + 1;2943 return (C_word)p0;2944}294529462947/* obsolete: replaced by C_a_pair in chicken.h */2948C_regparm C_word C_pair(C_word **ptr, C_word car, C_word cdr)2949{2950 C_word *p = *ptr,2951 *p0 = p;29522953 *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2954 *(p++) = car;2955 *(p++) = cdr;2956 *ptr = p;2957 return (C_word)p0;2958}295929602961C_regparm C_word C_number(C_word **ptr, double n)2962{2963 C_word2964 *p = *ptr,2965 *p0;2966 double m;29672968 if(n <= (double)C_MOST_POSITIVE_FIXNUM2969 && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0) {2970 return C_fix(n);2971 }29722973#ifndef C_SIXTY_FOUR2974#ifndef C_DOUBLE_IS_32_BITS2975 /* Align double on 8-byte boundary: */2976 if(C_aligned8(p)) ++p;2977#endif2978#endif29792980 p0 = p;2981 *(p++) = C_FLONUM_TAG;2982 *((double *)p) = n;2983 *ptr = p + sizeof(double) / sizeof(C_word);2984 return (C_word)p0;2985}298629872988C_regparm C_word C_mpointer(C_word **ptr, void *mp)2989{2990 C_word2991 *p = *ptr,2992 *p0 = p;29932994 *(p++) = C_POINTER_TYPE | 1;2995 *((void **)p) = mp;2996 *ptr = p + 1;2997 return (C_word)p0;2998}299930003001C_regparm C_word C_mpointer_or_false(C_word **ptr, void *mp)3002{3003 C_word3004 *p = *ptr,3005 *p0 = p;30063007 if(mp == NULL) return C_SCHEME_FALSE;30083009 *(p++) = C_POINTER_TYPE | 1;3010 *((void **)p) = mp;3011 *ptr = p + 1;3012 return (C_word)p0;3013}301430153016C_regparm C_word C_taggedmpointer(C_word **ptr, C_word tag, void *mp)3017{3018 C_word3019 *p = *ptr,3020 *p0 = p;30213022 *(p++) = C_TAGGED_POINTER_TAG;3023 *((void **)p) = mp;3024 *(++p) = tag;3025 *ptr = p + 1;3026 return (C_word)p0;3027}302830293030C_regparm C_word C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)3031{3032 C_word3033 *p = *ptr,3034 *p0 = p;30353036 if(mp == NULL) return C_SCHEME_FALSE;30373038 *(p++) = C_TAGGED_POINTER_TAG;3039 *((void **)p) = mp;3040 *(++p) = tag;3041 *ptr = p + 1;3042 return (C_word)p0;3043}304430453046C_word C_vector(C_word **ptr, int n, ...)3047{3048 va_list v;3049 C_word3050 *p = *ptr,3051 *p0 = p;30523053 *(p++) = C_VECTOR_TYPE | n;3054 va_start(v, n);30553056 while(n--)3057 *(p++) = va_arg(v, C_word);30583059 *ptr = p;3060 va_end(v);3061 return (C_word)p0;3062}306330643065C_word C_structure(C_word **ptr, int n, ...)3066{3067 va_list v;3068 C_word *p = *ptr,3069 *p0 = p;30703071 *(p++) = C_STRUCTURE_TYPE | n;3072 va_start(v, n);30733074 while(n--)3075 *(p++) = va_arg(v, C_word);30763077 *ptr = p;3078 va_end(v);3079 return (C_word)p0;3080}308130823083C_regparm C_word3084C_mutate_slot(C_word *slot, C_word val)3085{3086 unsigned int mssize, newmssize, bytes;30873088 ++mutation_count;3089 /* Mutation stack exists to track mutations pointing from elsewhere3090 * into nursery. Stuff pointing anywhere else can be skipped, as3091 * well as mutations on nursery objects.3092 */3093 if(C_in_stackp((C_word)slot) || (!C_in_stackp(val) && !C_in_scratchspacep(val)))3094 return *slot = val;30953096#ifdef C_GC_HOOKS3097 if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;3098#endif30993100 if(mutation_stack_top >= mutation_stack_limit) {3101 assert(mutation_stack_top == mutation_stack_limit);3102 mssize = mutation_stack_top - mutation_stack_bottom;3103 newmssize = mssize * 2;3104 bytes = newmssize * sizeof(C_word *);31053106 if(debug_mode)3107 C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),3108 (mssize * sizeof(C_word *)) / 1024, bytes / 1024);31093110 mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, bytes);31113112 if(mutation_stack_bottom == NULL)3113 panic(C_text("out of memory - cannot re-allocate mutation stack"));31143115 mutation_stack_limit = mutation_stack_bottom + newmssize;3116 mutation_stack_top = mutation_stack_bottom + mssize;3117 }31183119 *(mutation_stack_top++) = slot;3120 ++tracked_mutation_count;3121 return *slot = val;3122}31233124/* Allocate memory in scratch space, "size" is in words, like C_alloc.3125 * The memory in the scratch space is laid out as follows: First,3126 * there's a count that indicates how big the object originally was,3127 * followed by a pointer to the slot in the object which points to the3128 * object in scratch space, finally followed by the object itself.3129 * The reason we store the slot pointer is so that we can figure out3130 * whether the object is still "live" when reallocating; that's3131 * because we don't have a saved continuation from where we can trace3132 * the live data. The reason we store the total length of the object3133 * is because we may be mutating in-place the lengths of the stored3134 * objects, and we need to know how much to skip over while scanning.3135 *3136 * If the allocating function returns, it *must* first mark all the3137 * values in scratch space as reclaimable. This is needed because3138 * there is no way to distinguish between a stale pointer into scratch3139 * space that's still somewhere on the stack in "uninitialized" memory3140 * versus a word that's been recycled by the next called function,3141 * which now holds a value that happens to have the same bit pattern3142 * but represents another thing entirely.3143 */3144C_regparm C_word C_scratch_alloc(C_uword size)3145{3146 C_word result;31473148 if (C_scratchspace_top + size + 2 >= C_scratchspace_limit) {3149 C_word *new_scratch_start, *new_scratch_top, *new_scratch_limit;3150 C_uword needed = C_scratch_usage + size + 2,3151 new_size = nmax(scratchspace_size << 1, 2UL << C_ilen(needed));31523153 /* Shrink if the needed size is much smaller, but not below minimum */3154 if (needed < (new_size >> 4)) new_size >>= 1;3155 new_size = nmax(new_size, DEFAULT_SCRATCH_SPACE_SIZE);31563157 /* TODO: Maybe we should work with two semispaces to reduce mallocs? */3158 new_scratch_start = (C_word *)C_malloc(C_wordstobytes(new_size));3159 if (new_scratch_start == NULL)3160 panic(C_text("out of memory - cannot (re-)allocate scratch space"));3161 new_scratch_top = new_scratch_start;3162 new_scratch_limit = new_scratch_start + new_size;31633164 if(debug_mode) {3165 C_dbg(C_text("debug"), C_text("resizing scratchspace dynamically from "3166 UWORD_COUNT_FORMAT_STRING "k to "3167 UWORD_COUNT_FORMAT_STRING "k ...\n"),3168 C_wordstobytes(scratchspace_size) / 1024,3169 C_wordstobytes(new_size) / 1024);3170 }31713172 if(gc_report_flag) {3173 C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING3174 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3175 (C_word)C_scratchspace_start, (C_word)C_scratchspace_limit);3176 C_dbg(C_text("GC"), C_text("(new) scratchspace: \tstart=" UWORD_FORMAT_STRING3177 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3178 (C_word)new_scratch_start, (C_word)new_scratch_limit);3179 }31803181 /* Move scratch data into new space and mutate slots pointing there.3182 * This is basically a much-simplified version of really_mark.3183 */3184 if (C_scratchspace_start != NULL) {3185 C_word val, *sscan, *slot;3186 C_uword n, words;3187 C_header h;3188 C_SCHEME_BLOCK *p, *p2;31893190 sscan = C_scratchspace_start;31913192 while (sscan < C_scratchspace_top) {3193 words = *sscan;3194 slot = (C_word *)*(sscan+1);31953196 if (*(sscan+2) == ALIGNMENT_HOLE_MARKER) val = (C_word)(sscan+3);3197 else val = (C_word)(sscan+2);31983199 sscan += words + 2;32003201 p = (C_SCHEME_BLOCK *)val;3202 h = p->header;3203 if (is_fptr(h)) /* TODO: Support scratch->scratch pointers? */3204 panic(C_text("Unexpected forwarding pointer in scratch space"));32053206 p2 = (C_SCHEME_BLOCK *)(new_scratch_top+2);32073208#ifndef C_SIXTY_FOUR3209 if ((h & C_8ALIGN_BIT) && C_aligned8(p2) &&3210 (C_word *)p2 < new_scratch_limit) {3211 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3212 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3213 }3214#endif32153216 /* If orig slot still points here, copy data and update it */3217 if (slot != NULL) {3218 assert(*slot == val);3219 n = C_header_size(p);3220 n = (h & C_BYTEBLOCK_BIT) ? C_bytestowords(n) : n;32213222 *slot = (C_word)p2;3223 /* size = header plus block size plus optional alignment hole */3224 *new_scratch_top = ((C_word *)p2-(C_word *)new_scratch_top-2) + n + 1;3225 *(new_scratch_top+1) = (C_word)slot;32263227 new_scratch_top = (C_word *)p2 + n + 1;3228 if(new_scratch_top > new_scratch_limit)3229 panic(C_text("out of memory - scratch space full while resizing"));32303231 p2->header = h;3232 p->header = ptr_to_fptr((C_uword)p2);3233 C_memcpy(p2->data, p->data, C_wordstobytes(n));3234 }3235 }3236 free(C_scratchspace_start);3237 }3238 C_scratchspace_start = new_scratch_start;3239 C_scratchspace_top = new_scratch_top;3240 C_scratchspace_limit = new_scratch_limit;3241 /* Scratch space is now tightly packed */3242 C_scratch_usage = (new_scratch_top - new_scratch_start);3243 scratchspace_size = new_size;3244 }3245 assert(C_scratchspace_top + size + 2 <= C_scratchspace_limit);32463247 *C_scratchspace_top = size;3248 *(C_scratchspace_top+1) = (C_word)NULL; /* Nothing points here 'til mutated */3249 result = (C_word)(C_scratchspace_top+2);3250 C_scratchspace_top += size + 2;3251 /* This will only be marked as "used" when it's claimed by a pointer */3252 /* C_scratch_usage += size + 2; */3253 return result;3254}32553256/* Given a root object, scan its slots recursively (the objects3257 * themselves should be shallow and non-recursive), and migrate every3258 * object stored between the memory boundaries to the supplied3259 * pointer. Scratch data pointed to by objects between the memory3260 * boundaries is updated to point to the new memory region. If the3261 * supplied pointer is NULL, the scratch memory is marked reclaimable.3262 */3263C_regparm C_word3264C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)3265{3266 C_word size, header, *data, *p = NULL, obj_in_buffer;32673268 if (C_immediatep(obj)) return obj;32693270 size = C_header_size(obj);3271 header = C_block_header(obj);3272 data = C_data_pointer(obj);3273 obj_in_buffer = (obj >= (C_word)start && obj < (C_word)end);32743275 /* Only copy object if we have a target pointer and it's in the buffer */3276 if (ptr != NULL && obj_in_buffer) {3277 p = *ptr;3278 obj = (C_word)p; /* Return the object's new location at the end */3279 }32803281 if (p != NULL) *p++ = header;32823283 if (header & C_BYTEBLOCK_BIT) {3284 if (p != NULL) {3285 *ptr = (C_word *)((C_byte *)(*ptr) + sizeof(C_header) + C_align(size));3286 C_memcpy(p, data, size);3287 }3288 } else {3289 if (p != NULL) *ptr += size + 1;32903291 if(header & C_SPECIALBLOCK_BIT) {3292 if (p != NULL) *(p++) = *data;3293 size--;3294 data++;3295 }32963297 /* TODO: See if we can somehow make this use Cheney's algorithm */3298 while(size--) {3299 C_word slot = *data;33003301 if(!C_immediatep(slot)) {3302 if (C_in_scratchspacep(slot)) {3303 if (obj_in_buffer) { /* Otherwise, don't touch scratch backpointer */3304 /* TODO: Support recursing into objects in scratch space? */3305 C_word *sp = (C_word *)slot;33063307 if (*(sp-1) == ALIGNMENT_HOLE_MARKER) --sp;3308 if (*(sp-1) != (C_word)NULL && p == NULL)3309 C_scratch_usage -= *(sp-2) + 2;3310 *(sp-1) = (C_word)p; /* This is why we traverse even if p = NULL */33113312 *data = C_SCHEME_UNBOUND; /* Ensure old reference is killed dead */3313 }3314 } else { /* Slot is not a scratchspace object: check sub-objects */3315 slot = C_migrate_buffer_object(ptr, start, end, slot);3316 }3317 }3318 if (p != NULL) *(p++) = slot;3319 else *data = slot; /* Sub-object may have moved! */3320 data++;3321 }3322 }3323 return obj; /* Should be NULL if ptr was NULL */3324}33253326/* Register an object's slot as holding data to scratch space. Only3327 * one slot can point to a scratch space object; the object in scratch3328 * space is preceded by a pointer that points to this slot (or NULL).3329 */3330C_regparm C_word C_mutate_scratch_slot(C_word *slot, C_word val)3331{3332 C_word *ptr = (C_word *)val;3333 assert(C_in_scratchspacep(val));3334/* XXX assert(slot == NULL || C_in_stackp((C_word)slot));3335*/3336 if (*(ptr-1) == ALIGNMENT_HOLE_MARKER) --ptr;3337 if (*(ptr-1) == (C_word)NULL && slot != NULL)3338 C_scratch_usage += *(ptr-2) + 2;3339 if (*(ptr-1) != (C_word)NULL && slot == NULL)3340 C_scratch_usage -= *(ptr-2) + 2;3341 *(ptr-1) = (C_word)slot; /* Remember the slot pointing here, for realloc */3342 if (slot != NULL) *slot = val;3343 return val;3344}33453346/* Initiate garbage collection: */334733483349void C_save_and_reclaim(void *trampoline, int n, C_word *av)3350{3351 C_word new_size = nmax((C_word)1 << C_ilen(n), DEFAULT_TEMPORARY_STACK_SIZE);33523353 assert(av > C_temporary_stack_bottom || av < C_temporary_stack_limit);3354 assert(C_temporary_stack == C_temporary_stack_bottom);33553356 /* Don't *immediately* slam back to default size */3357 if (new_size < temporary_stack_size / 4)3358 new_size = temporary_stack_size >> 1;33593360 if (new_size != temporary_stack_size) {33613362 if(fixed_temporary_stack_size)3363 panic(C_text("fixed temporary stack overflow (\"apply\" called with too many arguments?)"));33643365 if(gc_report_flag) {3366 C_dbg(C_text("GC"), C_text("resizing temporary stack dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),3367 C_wordstobytes(temporary_stack_size) / 1024,3368 C_wordstobytes(new_size) / 1024);3369 }33703371 C_free(C_temporary_stack_limit);33723373 if((C_temporary_stack_limit = (C_word *)C_malloc(new_size * sizeof(C_word))) == NULL)3374 panic(C_text("out of memory - could not resize temporary stack"));33753376 C_temporary_stack_bottom = C_temporary_stack_limit + new_size;3377 C_temporary_stack = C_temporary_stack_bottom;3378 temporary_stack_size = new_size;3379 }33803381 C_temporary_stack = C_temporary_stack_bottom - n;33823383 assert(C_temporary_stack >= C_temporary_stack_limit);33843385 C_memmove(C_temporary_stack, av, n * sizeof(C_word));3386 C_reclaim(trampoline, n);3387}338833893390void C_save_and_reclaim_args(void *trampoline, int n, ...)3391{3392 va_list v;3393 int i;33943395 va_start(v, n);33963397 for(i = 0; i < n; ++i)3398 C_save(va_arg(v, C_word));33993400 va_end(v);3401 C_reclaim(trampoline, n);3402}340334043405#ifdef __SUNPRO_C3406static void _mark(C_word *x, C_byte *s, C_byte **t, C_byte *l) { \3407 C_word *_x = (x), _val = *_x; \3408 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3409}3410#else3411# define _mark(x,s,t,l) \3412 C_cblock \3413 C_word *_x = (x), _val = *_x; \3414 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3415 C_cblockend3416#endif34173418/* NOTE: This macro is particularly unhygienic! */3419#define mark(x) _mark(x, tgt_space_start, tgt_space_top, tgt_space_limit)34203421C_regparm void C_reclaim(void *trampoline, C_word c)3422{3423 int i, j, fcount;3424 C_uword count;3425 C_word **msp, last;3426 C_byte *tmp, *start;3427 C_GC_ROOT *gcrp;3428 double tgc = 0;3429 volatile int finalizers_checked;3430 FINALIZER_NODE *flist;3431 C_DEBUG_INFO cell;3432 C_byte *tgt_space_start, **tgt_space_top, *tgt_space_limit;34333434 /* assert(C_timer_interrupt_counter >= 0); */34353436 if(pending_interrupts_count > 0 && C_interrupts_enabled) {3437 stack_check_demand = 0; /* forget demand: we're not going to gc yet */3438 handle_interrupt(trampoline);3439 }34403441 cell.enabled = 0;3442 cell.event = C_DEBUG_GC;3443 cell.loc = "<runtime>";3444 cell.val = "GC_MINOR";3445 C_debugger(&cell, 0, NULL);34463447 /* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */3448 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);34493450 finalizers_checked = 0;3451 C_restart_trampoline = trampoline;3452 C_restart_c = c;3453 gc_mode = GC_MINOR;3454 tgt_space_start = fromspace_start;3455 tgt_space_top = &C_fromspace_top;3456 tgt_space_limit = C_fromspace_limit;3457 weak_pair_chain = (C_word)NULL;3458 locative_chain = (C_word)NULL;34593460 start = C_fromspace_top;34613462 /* Entry point for second-level GC (on explicit request or because of full fromspace): */3463#ifdef HAVE_SIGSETJMP3464 if(C_sigsetjmp(gc_restart, 0) || start >= C_fromspace_limit) {3465#else3466 if(C_setjmp(gc_restart) || start >= C_fromspace_limit) {3467#endif3468 if(gc_bell) {3469 C_putchar(7);3470 C_fflush(stdout);3471 }34723473 tgc = C_cpu_milliseconds();34743475 if(gc_mode == GC_REALLOC) {3476 cell.val = "GC_REALLOC";3477 C_debugger(&cell, 0, NULL);3478 C_rereclaim2(percentage(heap_size, C_heap_growth), 0);3479 gc_mode = GC_MAJOR;34803481 tgt_space_start = tospace_start;3482 tgt_space_top = &tospace_top;3483 tgt_space_limit= tospace_limit;34843485 count = (C_uword)tospace_top - (C_uword)tospace_start;3486 goto never_mind_edsger;3487 }34883489 start = (C_byte *)C_align((C_uword)tospace_top);3490 gc_mode = GC_MAJOR;3491 tgt_space_start = tospace_start;3492 tgt_space_top = &tospace_top;3493 tgt_space_limit= tospace_limit;3494 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into tospace */3495 locative_chain = (C_word)NULL; /* same for locatives */34963497 cell.val = "GC_MAJOR";3498 C_debugger(&cell, 0, NULL);34993500 mark_live_heap_only_objects(tgt_space_start, tgt_space_top, tgt_space_limit);35013502 /* mark normal GC roots (see below for finalizer handling): */3503 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3504 if(!gcrp->finalizable) mark(&gcrp->value);3505 }3506 }3507 else {3508 /* Mark mutated slots: */3509 for(msp = mutation_stack_bottom; msp < mutation_stack_top; ++msp)3510 mark(*msp);3511 }35123513 mark_live_objects(tgt_space_start, tgt_space_top, tgt_space_limit);35143515 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);3516 start = *tgt_space_top;35173518 if(gc_mode == GC_MINOR) {3519 count = (C_uword)C_fromspace_top - (C_uword)start;3520 ++gc_count_1;3521 ++gc_count_1_total;3522 update_locatives(GC_MINOR, start, *tgt_space_top);3523 update_weak_pairs(GC_MINOR, start, *tgt_space_top);3524 }3525 else {3526 /* Mark finalizer list and remember pointers to non-forwarded items: */3527 last = C_block_item(pending_finalizers_symbol, 0);35283529 if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {3530 /* still finalizers pending: just mark table items... */3531 if(gc_report_flag)3532 C_dbg(C_text("GC"), C_text("%d finalized item(s) still pending\n"), j);35333534 j = fcount = 0;35353536 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3537 mark(&flist->item);3538 mark(&flist->finalizer);3539 ++fcount;3540 }35413542 /* mark finalizable GC roots: */3543 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3544 if(gcrp->finalizable) mark(&gcrp->value);3545 }35463547 if(gc_report_flag && fcount > 0)3548 C_dbg(C_text("GC"), C_text("%d finalizer value(s) marked\n"), fcount);3549 }3550 else {3551 j = fcount = 0;35523553 /* move into pending */3554 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3555 if(j < C_max_pending_finalizers) {3556 if(!is_fptr(C_block_header(flist->item)))3557 pending_finalizer_indices[ j++ ] = flist;3558 }3559 }35603561 /* mark */3562 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3563 mark(&flist->item);3564 mark(&flist->finalizer);3565 }35663567 /* mark finalizable GC roots: */3568 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3569 if(gcrp->finalizable) mark(&gcrp->value);3570 }3571 }35723573 pending_finalizer_count = j;3574 finalizers_checked = 1;35753576 if(pending_finalizer_count > 0 && gc_report_flag)3577 C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),3578 pending_finalizer_count, live_finalizer_count);35793580 /* Once more mark nested objects after (maybe) copying finalizer objects: */3581 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);35823583 /* Copy finalized items with remembered indices into `##sys#pending-finalizers'3584 (and release finalizer node): */3585 if(pending_finalizer_count > 0) {3586 if(gc_report_flag)3587 C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count);35883589 last = C_block_item(pending_finalizers_symbol, 0);3590 assert(C_block_item(last, 0) == C_fix(0));3591 C_set_block_item(last, 0, C_fix(pending_finalizer_count));35923593 for(i = 0; i < pending_finalizer_count; ++i) {3594 flist = pending_finalizer_indices[ i ];3595 C_set_block_item(last, 1 + i * 2, flist->item);3596 C_set_block_item(last, 2 + i * 2, flist->finalizer);35973598 if(flist->previous != NULL) flist->previous->next = flist->next;3599 else finalizer_list = flist->next;36003601 if(flist->next != NULL) flist->next->previous = flist->previous;36023603 flist->next = finalizer_free_list;3604 flist->previous = NULL;3605 finalizer_free_list = flist;3606 --live_finalizer_count;3607 }3608 }36093610 update_locatives(gc_mode, start, *tgt_space_top);3611 update_weak_pairs(gc_mode, start, *tgt_space_top);36123613 count = (C_uword)tospace_top - (C_uword)tospace_start; // Actual used, < heap_size/236143615 {3616 C_uword min_half = count + C_heap_half_min_free;3617 C_uword low_half = percentage(heap_size/2, C_heap_shrinkage_used);3618 C_uword grown = percentage(heap_size, C_heap_growth);3619 C_uword shrunk = percentage(heap_size, C_heap_shrinkage);36203621 if (count < low_half) {3622 heap_shrink_counter++;3623 } else {3624 heap_shrink_counter = 0;3625 }36263627 /*** isn't gc_mode always GC_MAJOR here? */3628 if(gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3629 C_heap_shrinkage > 0 &&3630 // This prevents grow, shrink, grow, shrink... spam3631 HEAP_SHRINK_COUNTS < heap_shrink_counter &&3632 (min_half * 2) <= shrunk && // Min. size trumps shrinkage3633 heap_size > MINIMAL_HEAP_SIZE) {3634 if(gc_report_flag) {3635 C_dbg(C_text("GC"), C_text("Heap low water mark hit (%d%%), shrinking...\n"),3636 C_heap_shrinkage_used);3637 }3638 heap_shrink_counter = 0;3639 C_rereclaim2(shrunk, 0);3640 } else if (gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3641 (heap_size / 2) < min_half) {3642 if(gc_report_flag) {3643 C_dbg(C_text("GC"), C_text("Heap high water mark hit, growing...\n"));3644 }3645 heap_shrink_counter = 0;3646 C_rereclaim2(grown, 0);3647 } else {3648 C_fromspace_top = tospace_top;3649 tmp = fromspace_start;3650 fromspace_start = tospace_start;3651 tospace_start = tospace_top = tmp;3652 tmp = C_fromspace_limit;3653 C_fromspace_limit = tospace_limit;3654 tospace_limit = tmp;3655 }3656 }36573658 never_mind_edsger:3659 ++gc_count_2;3660 }36613662 if(gc_mode == GC_MAJOR) {3663 tgc = C_cpu_milliseconds() - tgc;3664 gc_ms += tgc;3665 timer_accumulated_gc_ms += tgc;3666 }36673668 /* Display GC report:3669 Note: stubbornly writes to stderr - there is no provision for other output-ports */3670 if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {3671 C_dbg(C_text("GC"), C_text("level %d\tgcs(minor) %d\tgcs(major) %d\n"),3672 gc_mode, gc_count_1, gc_count_2);3673 i = (C_uword)C_stack_pointer;36743675#if C_STACK_GROWS_DOWNWARD3676 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3677 (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);3678#else3679 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3680 (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);3681#endif36823683 if(gc_mode == GC_MINOR)3684 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);36853686 C_fputc('\n', C_stderr);3687 C_dbg("GC", C_text(" from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3688 (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);36893690 if(gc_mode == GC_MAJOR)3691 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);36923693 C_fputc('\n', C_stderr);3694 C_dbg("GC", C_text(" to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),3695 (C_uword)tospace_start, (C_uword)tospace_top,3696 (C_uword)tospace_limit);3697 }36983699 /* GC will have copied any live objects out of scratch space: clear it */3700 if (C_scratchspace_start != C_scratchspace_top) {3701 /* And drop the scratchspace in case of a major or reallocating collection */3702 if (gc_mode != GC_MINOR) {3703 C_free(C_scratchspace_start);3704 C_scratchspace_start = NULL;3705 C_scratchspace_limit = NULL;3706 scratchspace_size = 0;3707 }3708 C_scratchspace_top = C_scratchspace_start;3709 C_scratch_usage = 0;3710 }37113712 if(gc_mode == GC_MAJOR) {3713 gc_count_1 = 0;3714 maximum_heap_usage = count > maximum_heap_usage ? count : maximum_heap_usage;3715 }37163717 if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);37183719 /* Unwind stack completely */3720#ifdef HAVE_SIGSETJMP3721 C_siglongjmp(C_restart, 1);3722#else3723 C_longjmp(C_restart, 1);3724#endif3725}372637273728/* Mark live objects which can exist in the nursery and/or the heap */3729static C_regparm void mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3730{3731 C_word *p;3732 TRACE_INFO *tinfo;37333734 assert(C_temporary_stack >= C_temporary_stack_limit);37353736 /* Mark live values from the currently running closure: */3737 for(p = C_temporary_stack; p < C_temporary_stack_bottom; ++p)3738 mark(p);37393740 /* Clear the mutated slot stack: */3741 mutation_stack_top = mutation_stack_bottom;37423743 /* Mark trace-buffer: */3744 for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {3745 mark(&tinfo->cooked_location);3746 mark(&tinfo->cooked1);3747 mark(&tinfo->cooked2);3748 mark(&tinfo->thread);3749 }3750}375137523753/*3754 * Mark all live *heap* objects that don't need GC mode-specific3755 * treatment. Thus, no finalizers or other GC roots.3756 *3757 * Finalizers are excluded because these need special handling:3758 * finalizers referring to dead objects must be marked and queued.3759 * However, *pending* finalizers (for objects previously determined3760 * to be collectable) are marked so that these objects stick around3761 * until after the finalizer has been run.3762 *3763 * This function does not need to be called on a minor GC, since these3764 * objects won't ever exist in the nursery.3765 */3766static C_regparm void mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3767{3768 LF_LIST *lfn;3769 C_word *p, **msp, last;3770 unsigned int i;3771 C_SYMBOL_TABLE *stp;37723773 /* Mark items in forwarding table: */3774 for(p = forwarding_table; *p != 0; p += 2) {3775 last = p[ 1 ];3776 mark(&p[ 1 ]);3777 C_block_header(p[ 0 ]) = C_block_header(last);3778 }37793780 /* Mark literal frames: */3781 for(lfn = lf_list; lfn != NULL; lfn = lfn->next)3782 for(i = 0; i < (unsigned int)lfn->count; ++i)3783 mark(&lfn->lf[i]);37843785 /* Mark symbol tables: */3786 for(stp = symbol_table_list; stp != NULL; stp = stp->next)3787 for(i = 0; i < stp->size; ++i)3788 mark(&stp->table[i]);37893790 /* Mark collectibles: */3791 for(msp = collectibles; msp < collectibles_top; ++msp)3792 if(*msp != NULL) mark(*msp);37933794 /* Mark system globals */3795 mark(&core_provided_symbol);3796 mark(&interrupt_hook_symbol);3797 mark(&error_hook_symbol);3798 mark(&callback_continuation_stack_symbol);3799 mark(&pending_finalizers_symbol);3800 mark(¤t_thread_symbol);38013802 mark(&s8vector_symbol);3803 mark(&u16vector_symbol);3804 mark(&s16vector_symbol);3805 mark(&u32vector_symbol);3806 mark(&s32vector_symbol);3807 mark(&u64vector_symbol);3808 mark(&s64vector_symbol);3809 mark(&f32vector_symbol);3810 mark(&f64vector_symbol);3811}381238133814/*3815 * Mark nested values in already moved (i.e., marked) blocks in3816 * breadth-first manner (Cheney's algorithm).3817 */3818static C_regparm void mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3819{3820 int n;3821 C_word bytes;3822 C_word *p;3823 C_header h;3824 C_SCHEME_BLOCK *bp;38253826 while(heap_scan_top < *tgt_space_top) {3827 bp = (C_SCHEME_BLOCK *)heap_scan_top;38283829 if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)3830 bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);38313832 n = C_header_size(bp);3833 h = bp->header;3834 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);3835 p = bp->data;38363837 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {3838 if(h & C_SPECIALBLOCK_BIT) {3839 --n;3840 ++p;3841 }38423843 while(n--) mark(p++);3844 }38453846 heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);3847 }3848}384938503851static C_regparm void really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3852{3853 C_word val;3854 C_uword n, bytes;3855 C_header h;3856 C_SCHEME_BLOCK *p, *p2;38573858 val = *x;38593860 if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_scratchspacep(val)) {3861#ifdef C_GC_HOOKS3862 if(C_gc_trace_hook != NULL)3863 C_gc_trace_hook(x, gc_mode);3864#endif3865 return;3866 }38673868 p = (C_SCHEME_BLOCK *)val;3869 h = p->header;38703871 while(is_fptr(h)) { /* TODO: Pass in fptr chain limit? */3872 val = fptr_to_ptr(h);3873 p = (C_SCHEME_BLOCK *)val;3874 h = p->header;3875 }38763877 /* Already in target space, probably as result of chasing fptrs */3878 if ((C_uword)val >= (C_uword)tgt_space_start && (C_uword)val < (C_uword)*tgt_space_top) {3879 *x = val;3880 return;3881 }38823883 p2 = (C_SCHEME_BLOCK *)C_align((C_uword)*tgt_space_top);38843885#ifndef C_SIXTY_FOUR3886 if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tgt_space_limit) {3887 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3888 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3889 }3890#endif38913892 n = C_header_size(p);3893 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);38943895 if(C_unlikely(((C_byte *)p2 + bytes + sizeof(C_word)) > tgt_space_limit)) {3896 if (gc_mode == GC_MAJOR) {3897 /* Detect impossibilities before GC_REALLOC to preserve state: */3898 if (C_in_stackp((C_word)p) && bytes > stack_size)3899 panic(C_text("Detected corrupted data in stack"));3900 if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))3901 panic(C_text("Detected corrupted data in heap"));3902 if(C_heap_size_is_fixed)3903 panic(C_text("out of memory - heap full"));39043905 gc_mode = GC_REALLOC;3906 } else if (gc_mode == GC_REALLOC) {3907 if (new_tospace_top > new_tospace_limit) {3908 panic(C_text("out of memory - heap full while resizing"));3909 }3910 }3911#ifdef HAVE_SIGSETJMP3912 C_siglongjmp(gc_restart, 1);3913#else3914 C_longjmp(gc_restart, 1);3915#endif3916 }39173918 *tgt_space_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);39193920 *x = (C_word)p2;3921 p2->header = h;3922 p->header = ptr_to_fptr((C_uword)p2);3923 C_memcpy(p2->data, p->data, bytes);3924 if (h == C_WEAK_PAIR_TAG && !C_immediatep(p2->data[0])) {3925 p->data[0] = weak_pair_chain; /* "Recycle" the weak pair's CAR to point to prev head */3926 weak_pair_chain = (C_word)p; /* Make this fwd ptr the new head of the weak pair chain */3927 } else if (h == C_LOCATIVE_TAG) {3928 p->data[0] = locative_chain; /* "Recycle" the locative pointer field to point to prev head */3929 locative_chain = (C_word)p; /* Make this fwd ptr the new head of the locative chain */3930 }3931}393239333934/* Do a major GC into a freshly allocated heap: */39353936#define remark(x) _mark(x, new_tospace_start, &new_tospace_top, new_tospace_limit)39373938C_regparm void C_rereclaim2(C_uword size, int relative_resize)3939{3940 int i;3941 C_GC_ROOT *gcrp;3942 FINALIZER_NODE *flist;3943 C_byte *new_heapspace, *start;3944 size_t new_heapspace_size;39453946 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);39473948 /*3949 * Normally, size is "absolute": it indicates the desired size of3950 * the entire new heap. With relative_resize, size is a demanded3951 * increase of the heap, so we'll have to add it. This calculation3952 * doubles the current heap size because heap_size is already both3953 * halves. We add size*2 because we'll eventually divide the size3954 * by 2 for both halves. We also add stack_size*2 because all the3955 * nursery data is also copied to the heap on GC, and the requested3956 * memory "size" must be available after the GC.3957 */3958 if(relative_resize) size = (heap_size + size + stack_size) * 2;39593960 if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;39613962 /*3963 * When heap grows, ensure it's enough to accommodate first3964 * generation (nursery). Because we're calculating the total heap3965 * size here (fromspace *AND* tospace), we have to double the stack3966 * size, otherwise we'd accommodate only half the stack in the tospace.3967 */3968 if(size > heap_size && size - heap_size < stack_size * 2)3969 size = heap_size + stack_size * 2;39703971 /*3972 * The heap has grown but we've already hit the maximal size with the current3973 * heap, we can't do anything else but panic.3974 */3975 if(size > heap_size && heap_size >= C_maximal_heap_size)3976 panic(C_text("out of memory - heap has reached its maximum size"));39773978 if(size > C_maximal_heap_size) size = C_maximal_heap_size;39793980 if(debug_mode) {3981 C_dbg(C_text("debug"), C_text("resizing heap dynamically from "3982 UWORD_COUNT_FORMAT_STRING "k to "3983 UWORD_COUNT_FORMAT_STRING "k ...\n"),3984 heap_size / 1024, size / 1024);3985 }39863987 if(gc_report_flag) {3988 C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING3989 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3990 (C_word)fromspace_start, (C_word)C_fromspace_limit);3991 C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING3992 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3993 (C_word)tospace_start, (C_word)tospace_limit);3994 }39953996 heap_size = size; /* Total heap size of the two halves... */3997 size /= 2; /* ...each half is this big */39983999 /*4000 * Start by allocating the new heap's fromspace. After remarking,4001 * allocate the other half of the new heap (its tospace).4002 *4003 * To clarify: what we call "new_space" here is what will eventually4004 * be cycled over to "fromspace" when re-reclamation has finished4005 * (that is, after the old one has been freed).4006 */4007 if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)4008 panic(C_text("out of memory - cannot allocate heap segment"));4009 new_heapspace_size = size;40104011 new_tospace_top = new_tospace_start;4012 new_tospace_limit = new_tospace_start + size;4013 start = new_tospace_top;4014 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into new heap */4015 locative_chain = (C_word)NULL; /* same for locatives */40164017 /* Mark standard live objects in nursery and heap */4018 mark_live_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);4019 mark_live_heap_only_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);40204021 /* Mark finalizer table: */4022 for(flist = finalizer_list; flist != NULL; flist = flist->next) {4023 remark(&flist->item);4024 remark(&flist->finalizer);4025 }40264027 /* Mark *all* GC roots */4028 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {4029 remark(&gcrp->value);4030 }40314032 /* Mark nested values in already moved (marked) blocks in breadth-first manner: */4033 mark_nested_objects(start, new_tospace_start, &new_tospace_top, new_tospace_limit);4034 update_locatives(GC_REALLOC, new_tospace_top, new_tospace_top);4035 update_weak_pairs(GC_REALLOC, new_tospace_top, new_tospace_top);40364037 heap_free (heapspace1, heapspace1_size);4038 heap_free (heapspace2, heapspace2_size);40394040 if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)4041 panic(C_text("out of memory - cannot allocate next heap segment"));4042 heapspace2_size = size;40434044 heapspace1 = new_heapspace;4045 heapspace1_size = new_heapspace_size;4046 tospace_limit = tospace_start + size;4047 tospace_top = tospace_start;4048 fromspace_start = new_tospace_start;4049 C_fromspace_top = new_tospace_top;4050 C_fromspace_limit = new_tospace_limit;40514052 if(gc_report_flag) {4053 C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);4054 C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING4055 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4056 (C_word)fromspace_start, (C_word)C_fromspace_limit);4057 C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING4058 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4059 (C_word)tospace_start, (C_word)tospace_limit);4060 }40614062 if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);4063}406440654066/* When a weak pair is encountered by GC, it turns it into a4067 * forwarding reference as usual, but then it re-uses the now-defunct4068 * pair's CAR field. It clobbers that field with a plain C pointer to4069 * the current "weak pair chain". Then, the weak pair chain is4070 * updated to point to this new forwarding pointer, creating a crude4071 * linked list of sorts.4072 *4073 * We can get away with this because the slots of an object are4074 * unused/dead when it is turned into a forwarding pointer - the4075 * forwarding pointer itself is just a header, but those data fields4076 * remain allocated. Since the weak pair chain is a linked list that4077 * can *only* contain weak-pairs-turned-forwarding-pointer, we may4078 * freely access the first slot of such forwarding pointers.4079 */4080static C_regparm void update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end)4081{4082 int weakn = 0;4083 C_word p, pair, car, h;4084 C_byte *car_ptr;40854086 /* NOTE: Don't use C_block_item() because it asserts the block is4087 * big enough in DEBUGBUILD, but forwarding pointers have size 0.4088 */4089 for (p = weak_pair_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4090 /* NOTE: We only chain up the weak pairs' forwarding pointers into4091 * the new space. This is safe because already forwarded weak4092 * pairs in nursery/fromspace will be forwarded *again* into4093 * tospace/new heap. That forwarding pointer is chained up.4094 * Still-unforwarded weak pairs will be forwarded straight to the4095 * new space, and also chained up.4096 */4097 h = C_block_header(p);4098 assert(is_fptr(h));4099 pair = fptr_to_ptr(h);4100 assert(!is_fptr(C_block_header(pair)));41014102 /* The pair itself should be live */4103 assert((mode == GC_MINOR && !C_in_stackp(pair)) ||4104 (mode == GC_MAJOR && !C_in_stackp(pair) && !C_in_fromspacep(pair)) ||4105 (mode == GC_REALLOC && !C_in_stackp(pair) && !C_in_heapp(pair))); /* NB: *old* heap! */41064107 car = C_block_item(pair, 0);4108 assert(!C_immediatep(car)); /* should be ensured when adding it to the chain */4109 h = C_block_header(car);4110 while (is_fptr(h)) {4111 car = fptr_to_ptr(h);4112 h = C_block_header(car);4113 }41144115 car_ptr = (C_byte *)(C_uword)car;4116 /* If the car is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4117 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4118 if((mode == GC_MINOR && C_in_stackp(car)) ||4119 (mode == GC_MAJOR && (C_in_stackp(car) || C_in_fromspacep(car) || (car_ptr >= undead_start && car_ptr < undead_end))) ||4120 (mode == GC_REALLOC && (C_in_stackp(car) || C_in_heapp(car) || (car_ptr >= undead_start && car_ptr < undead_end)))) { /* NB: *old* heap! */41214122 C_set_block_item(pair, 0, C_SCHEME_BROKEN_WEAK_PTR);4123 ++weakn;4124 } else {4125 /* Might have moved, re-set the car to the target value */4126 C_set_block_item(pair, 0, car);4127 }4128 }4129 weak_pair_chain = (C_word)NULL;4130 if(gc_report_flag && weakn)4131 C_dbg("GC", C_text("%d recoverable weak pairs found\n"), weakn);4132}41334134/* Same as weak pairs (see above), but for locatives. Note that this4135 * also includes non-weak locatives, as these point *into* an object,4136 * so the updating of that pointer is not handled by the GC proper4137 * (which only deals with full objects).4138 */4139static C_regparm void update_locatives(int mode, C_byte *undead_start, C_byte *undead_end)4140{4141 int weakn = 0;4142 C_word p, loc, ptr, obj, h, offset;4143 C_byte *obj_ptr;41444145 for (p = locative_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4146 h = C_block_header(p);4147 assert(is_fptr(h));4148 loc = fptr_to_ptr(h);4149 assert(!is_fptr(C_block_header(loc)));41504151 /* The locative object itself should be live */4152 assert((mode == GC_MINOR && !C_in_stackp(loc)) ||4153 (mode == GC_MAJOR && !C_in_stackp(loc) && !C_in_fromspacep(loc)) ||4154 (mode == GC_REALLOC && !C_in_stackp(loc) && !C_in_heapp(loc))); /* NB: *old* heap! */41554156 ptr = C_block_item(loc, 0); /* fix up ptr */4157 if (ptr == 0) continue; /* Skip already dropped weak locatives */4158 offset = C_unfix(C_block_item(loc, 1));4159 obj = ptr - offset;41604161 h = C_block_header(obj);4162 while (is_fptr(h)) {4163 obj = fptr_to_ptr(h);4164 h = C_block_header(obj);4165 }41664167 obj_ptr = (C_byte *)(C_uword)obj;4168 /* If the object is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4169 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4170 if((mode == GC_MINOR && C_in_stackp(obj)) ||4171 (mode == GC_MAJOR && (C_in_stackp(obj) || C_in_fromspacep(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end))) ||4172 (mode == GC_REALLOC && (C_in_stackp(obj) || C_in_heapp(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end)))) { /* NB: *old* heap! */41734174 /* NOTE: This does *not* use BROKEN_WEAK_POINTER. This slot4175 * holds an unaligned raw C pointer, not a Scheme object */4176 C_set_block_item(loc, 0, 0);4177 ++weakn;4178 } else {4179 /* Might have moved, re-set the object to the target value */4180 C_set_block_item(loc, 0, obj + offset);4181 }4182 }4183 locative_chain = (C_word)NULL;4184 if(gc_report_flag && weakn)4185 C_dbg("GC", C_text("%d recoverable weak locatives found\n"), weakn);4186}418741884189void handle_interrupt(void *trampoline)4190{4191 C_word *p, h, reason, state, proc, n;4192 double c;4193 C_word av[ 4 ];41944195 /* Build vector with context information: */4196 n = C_temporary_stack_bottom - C_temporary_stack;4197 p = C_alloc(C_SIZEOF_VECTOR(2) + C_SIZEOF_VECTOR(n));4198 proc = (C_word)p;4199 *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | sizeof(C_word);4200 *(p++) = (C_word)trampoline;4201 state = (C_word)p;4202 *(p++) = C_VECTOR_TYPE | (n + 1);4203 *(p++) = proc;4204 C_memcpy(p, C_temporary_stack, n * sizeof(C_word));42054206 /* Restore state to the one at the time of the interrupt: */4207 C_temporary_stack = C_temporary_stack_bottom;4208 C_stack_limit = C_stack_hard_limit;42094210 /* Invoke high-level interrupt handler: */4211 reason = C_fix(pending_interrupts[ --pending_interrupts_count ]);4212 proc = C_block_item(interrupt_hook_symbol, 0);42134214 if(C_immediatep(proc))4215 panic(C_text("`##sys#interrupt-hook' is not defined"));42164217 c = C_cpu_milliseconds() - interrupt_time;4218 last_interrupt_latency = c;4219 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4220 /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */4221 av[ 0 ] = proc;4222 av[ 1 ] = C_SCHEME_UNDEFINED;4223 av[ 2 ] = reason;4224 av[ 3 ] = state;4225 C_do_apply(4, av);4226}422742284229void4230C_unbound_variable(C_word sym)4231{4232 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);4233}423442354236void4237C_decoding_error(C_word str, C_word index)4238{4239 barf(C_DECODING_ERROR, NULL, str, index);4240}424142424243/* XXX: This needs to be given a better name.4244 C_retrieve used to exist but it just called C_fast_retrieve */4245C_regparm C_word C_retrieve2(C_word val, char *name)4246{4247 C_word *p;4248 int len;42494250 if(val == C_SCHEME_UNBOUND) {4251 len = C_strlen(name);4252 /* this is ok: we won't return from `C_retrieve2'4253 * (or the value isn't needed). */4254 p = C_alloc(C_SIZEOF_STRING(len));4255 C_unbound_variable(C_string2(&p, name));4256 }42574258 return val;4259}426042614262void C_ccall C_invalid_procedure(C_word c, C_word *av)4263{4264 C_word self = av[0];4265 barf(C_NOT_A_CLOSURE_ERROR, NULL, self);4266}426742684269C_regparm void *C_retrieve2_symbol_proc(C_word val, char *name)4270{4271 C_word *p;4272 int len;42734274 if(val == C_SCHEME_UNBOUND) {4275 len = C_strlen(name);4276 /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */4277 p = C_alloc(C_SIZEOF_STRING(len));4278 barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));4279 }42804281 return C_fast_retrieve_proc(val);4282}42834284#ifdef C_NONUNIX4285VOID CALLBACK win_timer(PVOID data_ignored, BOOLEAN wait_or_fired)4286{4287 if (profiling) take_profile_sample();4288}4289#endif42904291static void set_profile_timer(C_uword freq)4292{4293#ifdef C_NONUNIX4294 static HANDLE timer = NULL;42954296 if (freq == 0) {4297 assert(timer != NULL);4298 if (!DeleteTimerQueueTimer(NULL, timer, NULL)) goto error;4299 timer = NULL;4300 } else if (freq < 1000) {4301 panic(C_text("On Windows, sampling can only be done in milliseconds"));4302 } else {4303 if (!CreateTimerQueueTimer(&timer, NULL, win_timer, NULL, 0, freq/1000, 0))4304 goto error;4305 }4306#else4307 struct itimerval itv;43084309 itv.it_value.tv_sec = freq / 1000000;4310 itv.it_value.tv_usec = freq % 1000000;4311 itv.it_interval.tv_sec = itv.it_value.tv_sec;4312 itv.it_interval.tv_usec = itv.it_value.tv_usec;43134314 if (setitimer(C_PROFILE_TIMER, &itv, NULL) == -1) goto error;4315#endif43164317 return;43184319error:4320 if (freq == 0) panic(C_text("error clearing timer for profiling"));4321 else panic(C_text("error setting timer for profiling"));4322}43234324/* Bump profile count for current top of trace buffer */4325static void take_profile_sample()4326{4327 PROFILE_BUCKET **bp, *b;4328 C_char *key;4329 TRACE_INFO *tb;4330 /* To count distinct calls of a procedure, remember last call */4331 static C_char *prev_key = NULL;4332 static TRACE_INFO *prev_tb = NULL;43334334 /* trace_buffer_top points *beyond* the topmost entry: Go back one */4335 if (trace_buffer_top == trace_buffer) {4336 if (!trace_buffer_full) return; /* No data yet */4337 tb = trace_buffer_limit - 1;4338 } else {4339 tb = trace_buffer_top - 1;4340 }43414342 if (tb->raw_location != NULL) {4343 key = tb->raw_location;4344 } else {4345 key = "<eval>"; /* Location string is GCable, can't use it */4346 }43474348 /* We could also just hash the pointer but that's a bit trickier */4349 bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0);4350 b = *bp;43514352 /* First try to find pre-existing item in hash table */4353 while(b != NULL) {4354 if(b->key == key) {4355 b->sample_count++;4356 if (prev_key != key && prev_tb != tb)4357 b->call_count++;4358 goto done;4359 }4360 else b = b->next;4361 }43624363 /* Not found, allocate a new item and use it as bucket's new head */4364 b = next_profile_bucket;4365 next_profile_bucket = NULL;43664367 assert(b != NULL);43684369 b->next = *bp;4370 b->key = key;4371 *bp = b;4372 b->sample_count = 1;4373 b->call_count = 1;43744375done:4376 prev_tb = tb;4377 prev_key = key;4378}437943804381C_regparm void C_trace(C_char *name)4382{4383 C_word thread;43844385 if(show_trace) {4386 C_fputs(name, C_stderr);4387 C_fputc('\n', C_stderr);4388 }43894390 /*4391 * When profiling, pre-allocate profile bucket if necessary. This4392 * is used in the signal handler, because it may not malloc.4393 */4394 if(profiling && next_profile_bucket == NULL) {4395 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4396 if (next_profile_bucket == NULL) {4397 panic(C_text("out of memory - cannot allocate profile table-bucket"));4398 }4399 }44004401 if(trace_buffer_top >= trace_buffer_limit) {4402 trace_buffer_top = trace_buffer;4403 trace_buffer_full = 1;4404 }44054406 trace_buffer_top->raw_location = name;4407 trace_buffer_top->cooked_location = C_SCHEME_FALSE;4408 trace_buffer_top->cooked1 = C_SCHEME_FALSE;4409 trace_buffer_top->cooked2 = C_SCHEME_FALSE;4410 thread = C_block_item(current_thread_symbol, 0);4411 trace_buffer_top->thread = C_and(C_blockp(thread), C_thread_id(thread));4412 ++trace_buffer_top;4413}441444154416C_regparm C_word C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)4417{4418 /* See above */4419 if(profiling && next_profile_bucket == NULL) {4420 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4421 if (next_profile_bucket == NULL) {4422 panic(C_text("out of memory - cannot allocate profile table-bucket"));4423 }4424 }44254426 if(trace_buffer_top >= trace_buffer_limit) {4427 trace_buffer_top = trace_buffer;4428 trace_buffer_full = 1;4429 }44304431 trace_buffer_top->raw_location = raw;4432 trace_buffer_top->cooked_location = l;4433 trace_buffer_top->cooked1 = x;4434 trace_buffer_top->cooked2 = y;4435 trace_buffer_top->thread = t;4436 ++trace_buffer_top;4437 return x;4438}443944404441C_char *C_dump_trace(int start)4442{4443 TRACE_INFO *ptr;4444 C_char *result;4445 int i, result_len;44464447 result_len = STRING_BUFFER_SIZE;4448 if((result = (char *)C_malloc(result_len)) == NULL)4449 horror(C_text("out of memory - cannot allocate trace-dump buffer"));44504451 *result = '\0';44524453 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4454 if(trace_buffer_full) {4455 i = C_trace_buffer_size;4456 C_strlcat(result, C_text("...more...\n"), result_len);4457 }4458 else i = trace_buffer_top - trace_buffer;44594460 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4461 ptr += start;4462 i -= start;44634464 for(;i--; ++ptr) {4465 if(ptr >= trace_buffer_limit) ptr = trace_buffer;44664467 if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {4468 result_len = C_strlen(result) * 2;4469 result = C_realloc(result, result_len);4470 if(result == NULL)4471 horror(C_text("out of memory - cannot reallocate trace-dump buffer"));4472 }44734474 if (ptr->raw_location != NULL) {4475 C_strlcat(result, ptr->raw_location, result_len);4476 } else if (ptr->cooked_location != C_SCHEME_FALSE) {4477 C_word bv = C_block_item(ptr->cooked_location, 0);4478 C_strlcat(result, C_c_string(bv), nmin(C_header_size(bv) - 1, result_len));4479 } else {4480 C_strlcat(result, "<unknown>", result_len);4481 }44824483 if(i > 0) C_strlcat(result, "\n", result_len);4484 else C_strlcat(result, " \t<--\n", result_len);4485 }4486 }44874488 return result;4489}449044914492C_regparm void C_clear_trace_buffer(void)4493{4494 int i, old_profiling = profiling;44954496 profiling = 0;44974498 if(trace_buffer == NULL) {4499 if(C_trace_buffer_size < MIN_TRACE_BUFFER_SIZE)4500 C_trace_buffer_size = MIN_TRACE_BUFFER_SIZE;45014502 trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);45034504 if(trace_buffer == NULL)4505 panic(C_text("out of memory - cannot allocate trace-buffer"));4506 }45074508 trace_buffer_top = trace_buffer;4509 trace_buffer_limit = trace_buffer + C_trace_buffer_size;4510 trace_buffer_full = 0;45114512 for(i = 0; i < C_trace_buffer_size; ++i) {4513 trace_buffer[ i ].raw_location = NULL;4514 trace_buffer[ i ].cooked_location = C_SCHEME_FALSE;4515 trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;4516 trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;4517 trace_buffer[ i ].thread = C_SCHEME_FALSE;4518 }45194520 profiling = old_profiling;4521}45224523C_word C_resize_trace_buffer(C_word size) {4524 int old_size = C_trace_buffer_size, old_profiling = profiling;4525 assert(trace_buffer);4526 profiling = 0;4527 free(trace_buffer);4528 trace_buffer = NULL;4529 C_trace_buffer_size = C_unfix(size);4530 C_clear_trace_buffer();4531 profiling = old_profiling;4532 return(C_fix(old_size));4533}45344535C_word C_fetch_trace(C_word starti, C_word buffer)4536{4537 TRACE_INFO *ptr;4538 int i, p = 0, start = C_unfix(starti);45394540 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4541 if(trace_buffer_full) i = C_trace_buffer_size;4542 else i = trace_buffer_top - trace_buffer;45434544 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4545 ptr += start;4546 i -= start;45474548 if(C_header_size(buffer) < i * 5)4549 panic(C_text("destination buffer too small for call-chain"));45504551 for(;i--; ++ptr) {4552 if(ptr >= trace_buffer_limit) ptr = trace_buffer;45534554 /* outside-pointer, will be ignored by GC */4555 C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw_location);45564557 /* subject to GC */4558 C_mutate(&C_block_item(buffer, p++), ptr->cooked_location);4559 C_mutate(&C_block_item(buffer, p++), ptr->cooked1);4560 C_mutate(&C_block_item(buffer, p++), ptr->cooked2);4561 C_mutate(&C_block_item(buffer, p++), ptr->thread);4562 }4563 }45644565 return C_fix(p);4566}45674568C_regparm C_word C_u_i_bytevector_hash(C_word str, C_word start, C_word end, C_word rnd)4569{4570 int len = C_header_size(str);4571 C_char *ptr = C_c_string(str);4572 return C_fix(hash_string(C_unfix(end) - C_unfix(start), ptr + C_unfix(start), C_MOST_POSITIVE_FIXNUM, C_unfix(rnd)));4573}45744575C_regparm void C_toplevel_entry(C_char *name)4576{4577 if(debug_mode)4578 C_dbg(C_text("debug"), C_text("entering %s...\n"), name);4579}45804581C_regparm C_word C_a_i_provide(C_word **a, int c, C_word id)4582{4583 if (debug_mode == 2) {4584 C_word str = C_block_item(id, 1);4585 C_dbg(C_text("debug"), C_text("providing %s...\n"), C_c_string(str));4586 }4587 return C_a_i_putprop(a, 3, core_provided_symbol, id, C_SCHEME_TRUE);4588}45894590C_regparm C_word C_i_providedp(C_word id)4591{4592 return C_i_getprop(core_provided_symbol, id, C_SCHEME_FALSE);4593}45944595C_word C_halt(C_word msg)4596{4597 C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;45984599 if(C_gui_mode) {4600 if(msg != C_SCHEME_FALSE) {4601 int n = C_header_size(msg);46024603 if (n >= sizeof(buffer))4604 n = sizeof(buffer) - 1;4605 C_strlcpy(buffer, (C_char *)C_data_pointer(msg), n);4606 /* XXX msg isn't checked for NUL bytes, but we can't barf here either! */4607 }4608 else C_strlcpy(buffer, C_text("(aborted)"), sizeof(buffer));46094610 C_strlcat(buffer, C_text("\n\n"), sizeof(buffer));46114612 if(dmp != NULL) C_strlcat(buffer, dmp, sizeof(buffer));46134614#if defined(_WIN32) && !defined(__CYGWIN__)4615 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);4616 ExitProcess(1);4617#endif4618 } /* otherwise fall through */46194620 if(msg != C_SCHEME_FALSE) {4621 C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);4622 C_fputc('\n', C_stderr);4623 }46244625 if(dmp != NULL)4626 C_dbg("", C_text("\n%s"), dmp);46274628 C_exit_runtime(C_fix(EX_SOFTWARE));4629 return 0;4630}463146324633C_word C_message(C_word msg)4634{4635 C_word m = C_block_item(msg, 0);4636 unsigned int n = C_header_size(m);4637 /*4638 * Strictly speaking this isn't necessary for the non-gui-mode,4639 * but let's try and keep this consistent across modes.4640 */4641 if (C_memchr(C_c_string(m), '\0', n - 1) != NULL)4642 barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);46434644 if(C_gui_mode) {4645 if (n >= sizeof(buffer))4646 n = sizeof(buffer) - 1;4647 C_strncpy(buffer, C_c_string(m), n);4648 buffer[ n ] = '\0';4649#if defined(_WIN32) && !defined(__CYGWIN__)4650 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONEXCLAMATION);4651 return C_SCHEME_UNDEFINED;4652#endif4653 } /* fall through */46544655 C_fwrite(C_c_string(m), n, sizeof(C_char), stdout);4656 C_putchar('\n');4657 return C_SCHEME_UNDEFINED;4658}465946604661C_regparm C_word C_equalp(C_word x, C_word y)4662{4663 C_header header;4664 C_word bits, n, i;46654666 C_stack_check1(barf(C_CIRCULAR_DATA_ERROR, "equal?"));46674668 loop:4669 if(x == y) return 1;46704671 if(C_immediatep(x) || C_immediatep(y)) return 0;46724673 /* NOTE: Extra check at the end is special consideration for pairs being equal to weak pairs */4674 if((header = C_block_header(x)) != C_block_header(y) && !(C_header_type(x) == C_PAIR_TYPE && C_header_type(y) == C_PAIR_TYPE)) return 0;4675 else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {4676 if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)4677 return C_ub_i_flonum_eqvp(C_flonum_magnitude(x),4678 C_flonum_magnitude(y));4679 else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);4680 }4681 else if(C_header_bits(x) == C_STRING_TYPE)4682 return C_equalp(C_block_item(x, 0), C_block_item(y, 0));4683 else if(header == C_SYMBOL_TAG) return 0;4684 else {4685 i = 0;4686 n = header & C_HEADER_SIZE_MASK;46874688 if(bits & C_SPECIALBLOCK_BIT) {4689 /* do not recurse into closures */4690 if(C_header_bits(x) == C_CLOSURE_TYPE)4691 return !C_memcmp(C_data_pointer(x), C_data_pointer(y), n * sizeof(C_word));4692 else if(C_block_item(x, 0) != C_block_item(y, 0)) return 0;4693 else ++i;46944695 if(n == 1) return 1;4696 }46974698 if(--n < 0) return 1;46994700 while(i < n)4701 if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;4702 else ++i;47034704 x = C_block_item(x, i);4705 y = C_block_item(y, i);4706 goto loop;4707 }4708}470947104711C_regparm C_word C_set_gc_report(C_word flag)4712{4713 if(flag == C_SCHEME_FALSE) gc_report_flag = 0;4714 else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;4715 else gc_report_flag = 1;47164717 return C_SCHEME_UNDEFINED;4718}47194720C_regparm C_word C_i_accumulated_gc_time(void)4721{4722 double tgc;47234724 tgc = timer_accumulated_gc_ms;4725 timer_accumulated_gc_ms = 0;4726 return C_fix(tgc);4727}47284729C_regparm C_word C_start_timer(void)4730{4731 tracked_mutation_count = 0;4732 mutation_count = 0;4733 gc_count_1_total = 0;4734 gc_count_2 = 0;4735 timer_start_ms = C_cpu_milliseconds();4736 gc_ms = 0;4737 maximum_heap_usage = 0;4738 return C_SCHEME_UNDEFINED;4739}474047414742void C_ccall C_stop_timer(C_word c, C_word *av)4743{4744 C_word4745 closure = av[ 0 ],4746 k = av[ 1 ];4747 double t0 = C_cpu_milliseconds() - timer_start_ms;4748 C_word4749 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_BIGNUM(1) + C_SIZEOF_VECTOR(7) ],4750 *a = ab,4751 elapsed = C_flonum(&a, t0 / 1000.0),4752 gc_time = C_flonum(&a, gc_ms / 1000.0),4753 heap_usage = C_unsigned_int_to_num(&a, maximum_heap_usage),4754 info;47554756 info = C_vector(&a, 7, elapsed, gc_time, C_fix(mutation_count),4757 C_fix(tracked_mutation_count), C_fix(gc_count_1_total),4758 C_fix(gc_count_2), heap_usage);4759 C_kontinue(k, info);4760}476147624763C_word C_exit_runtime(C_word code)4764{4765 C_fflush(NULL);4766 C__exit(C_unfix(code));4767}476847694770C_regparm C_word C_set_print_precision(C_word n)4771{4772 flonum_print_precision = C_unfix(n);4773 return C_SCHEME_UNDEFINED;4774}477547764777C_regparm C_word C_get_print_precision(void)4778{4779 return C_fix(flonum_print_precision);4780}478147824783C_regparm C_word C_read_char(C_word port)4784{4785 C_FILEPTR fp = C_port_file(port);4786 C_char buf[ 5 ];4787 int n = 0, r, c;47884789 do {4790 c = C_getc(fp);47914792 if(c == EOF) {4793 if(ferror(fp)) {4794 clearerr(fp);4795 if(n == 0) return C_fix(-1);4796 }4797 /* Found here:4798 http://mail.python.org/pipermail/python-bugs-list/2002-July/012579.html */4799#if defined(_WIN32) && !defined(__CYGWIN__)4800 else if(GetLastError() == ERROR_OPERATION_ABORTED) {4801 if(n == 0) return C_fix(-1);4802 }4803#endif4804 else if(n == 0) return C_SCHEME_END_OF_FILE;4805 }48064807 if(n == 0) r = C_utf_expect(c);4808 buf[ n++ ] = c;4809 } while(n < r);48104811 return C_utf_decode_ptr(buf);4812}481348144815C_regparm C_word C_execute_shell_command(C_word string)4816{4817 C_word bv = C_block_item(string, 0);4818 int n = C_header_size(bv);4819 char *buf = buffer;48204821 /* Windows doc says to flush all output streams before calling system.4822 Probably a good idea for all platforms. */4823 (void)fflush(NULL);48244825 if(n >= STRING_BUFFER_SIZE) {4826 if((buf = (char *)C_malloc(n + 1)) == NULL)4827 barf(C_OUT_OF_MEMORY_ERROR, "system");4828 }48294830 C_memcpy(buf, C_data_pointer(bv), n); /* includes 0 */4831 if (n - 1 != strlen(buf))4832 barf(C_ASCIIZ_REPRESENTATION_ERROR, "system", string);48334834 n = C_system(C_OS_FILENAME(bv, 0));48354836 if(buf != buffer) C_free(buf);48374838 return C_fix(n);4839}48404841/*4842 * TODO: Implement something for Windows that supports selecting on4843 * arbitrary fds (there, select() only works on network sockets and4844 * poll() is not available at all).4845 */4846C_regparm int C_check_fd_ready(int fd)4847{4848#ifdef NO_POSIX_POLL4849 fd_set in;4850 struct timeval tm;4851 int rv;4852 FD_ZERO(&in);4853 FD_SET(fd, &in);4854 tm.tv_sec = tm.tv_usec = 0;4855 rv = select(fd + 1, &in, NULL, NULL, &tm);4856 if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }4857 return rv;4858#else4859 struct pollfd ps;4860 ps.fd = fd;4861 ps.events = POLLIN;4862 return poll(&ps, 1, 0);4863#endif4864}48654866C_regparm C_word C_char_ready_p(C_word port)4867{4868#if defined(C_NONUNIX)4869 /* The best we can currently do on Windows... */4870 return C_SCHEME_TRUE;4871#else4872 int fd = C_fileno(C_port_file(port));4873 return C_mk_bool(C_check_fd_ready(fd) == 1);4874#endif4875}48764877C_regparm C_word C_i_tty_forcedp(void)4878{4879 return C_mk_bool(fake_tty_flag);4880}48814882C_regparm C_word C_i_debug_modep(void)4883{4884 return C_mk_bool(debug_mode);4885}48864887C_regparm C_word C_i_dump_heap_on_exitp(void)4888{4889 return C_mk_bool(dump_heap_on_exit);4890}48914892C_regparm C_word C_i_profilingp(void)4893{4894 return C_mk_bool(profiling);4895}48964897C_regparm C_word C_i_live_finalizer_count(void)4898{4899 return C_fix(live_finalizer_count);4900}49014902C_regparm C_word C_i_allocated_finalizer_count(void)4903{4904 return C_fix(allocated_finalizer_count);4905}490649074908C_regparm void C_raise_interrupt(int reason)4909{4910 if(C_interrupts_enabled) {4911 if(pending_interrupts_count == 0 && !handling_interrupts) {4912 pending_interrupts[ pending_interrupts_count++ ] = reason;4913 /*4914 * Force the next "soft" stack check to fail by faking a "full"4915 * stack. This causes save_and_reclaim() to be called, which4916 * invokes handle_interrupt(), which restores the stack limit.4917 */4918 C_stack_limit = stack_bottom;4919 interrupt_time = C_cpu_milliseconds();4920 } else if(pending_interrupts_count < MAX_PENDING_INTERRUPTS) {4921 int i;4922 /*4923 * Drop signals if too many, but don't queue up multiple entries4924 * for the same signal.4925 */4926 for (i = 0; i < pending_interrupts_count; ++i) {4927 if (pending_interrupts[i] == reason)4928 return;4929 }4930 pending_interrupts[ pending_interrupts_count++ ] = reason;4931 }4932 }4933}493449354936C_regparm C_word C_enable_interrupts(void)4937{4938 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4939 /* assert(C_timer_interrupt_counter > 0); */4940 C_interrupts_enabled = 1;4941 return C_SCHEME_UNDEFINED;4942}494349444945C_regparm C_word C_disable_interrupts(void)4946{4947 C_interrupts_enabled = 0;4948 return C_SCHEME_UNDEFINED;4949}495049514952C_regparm C_word C_establish_signal_handler(C_word signum, C_word reason)4953{4954 int sig = C_unfix(signum);4955#if defined(HAVE_SIGACTION)4956 struct sigaction newsig;4957#endif49584959 if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);4960 else if(reason == C_SCHEME_TRUE) C_signal(sig, SIG_DFL);4961 else {4962 signal_mapping_table[ sig ] = C_unfix(reason);4963#if defined(HAVE_SIGACTION)4964 newsig.sa_flags = 0;4965 /* The global signal handler is used for all signals, and4966 manipulates a single queue. Don't allow other signals to4967 concurrently arrive while it's doing this, to avoid races. */4968 sigfillset(&newsig.sa_mask);4969 newsig.sa_handler = global_signal_handler;4970 C_sigaction(sig, &newsig, NULL);4971#else4972 C_signal(sig, global_signal_handler);4973#endif4974 }49754976 return C_SCHEME_UNDEFINED;4977}497849794980/* Copy blocks into collected or static memory: */49814982C_regparm C_word C_copy_block(C_word from, C_word to)4983{4984 int n = C_header_size(from);4985 C_long bytes;49864987 if(C_header_bits(from) & C_BYTEBLOCK_BIT) {4988 bytes = n;4989 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4990 }4991 else {4992 bytes = C_wordstobytes(n);4993 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4994 }49954996 return to;4997}499849995000C_regparm C_word C_evict_block(C_word from, C_word ptr)5001{5002 int n = C_header_size(from);5003 C_long bytes;5004 C_word *p = (C_word *)C_pointer_address(ptr);50055006 if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;5007 else bytes = C_wordstobytes(n);50085009 C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));5010 return (C_word)p;5011}501250135014/* Inline versions of some standard procedures: */50155016C_regparm C_word C_i_listp(C_word x)5017{5018 C_word fast = x, slow = x;50195020 while(fast != C_SCHEME_END_OF_LIST)5021 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5022 fast = C_u_i_cdr(fast);50235024 if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;5025 else if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5026 fast = C_u_i_cdr(fast);5027 slow = C_u_i_cdr(slow);50285029 if(fast == slow) return C_SCHEME_FALSE;5030 }5031 else return C_SCHEME_FALSE;5032 }5033 else return C_SCHEME_FALSE;50345035 return C_SCHEME_TRUE;5036}50375038C_regparm C_word C_i_s8vectorp(C_word x)5039{5040 return C_i_structurep(x, s8vector_symbol);5041}50425043C_regparm C_word C_i_u16vectorp(C_word x)5044{5045 return C_i_structurep(x, u16vector_symbol);5046}50475048C_regparm C_word C_i_s16vectorp(C_word x)5049{5050 return C_i_structurep(x, s16vector_symbol);5051}50525053C_regparm C_word C_i_u32vectorp(C_word x)5054{5055 return C_i_structurep(x, u32vector_symbol);5056}50575058C_regparm C_word C_i_s32vectorp(C_word x)5059{5060 return C_i_structurep(x, s32vector_symbol);5061}50625063C_regparm C_word C_i_u64vectorp(C_word x)5064{5065 return C_i_structurep(x, u64vector_symbol);5066}50675068C_regparm C_word C_i_s64vectorp(C_word x)5069{5070 return C_i_structurep(x, s64vector_symbol);5071}50725073C_regparm C_word C_i_f32vectorp(C_word x)5074{5075 return C_i_structurep(x, f32vector_symbol);5076}50775078C_regparm C_word C_i_f64vectorp(C_word x)5079{5080 return C_i_structurep(x, f64vector_symbol);5081}508250835084C_regparm C_word C_i_string_equal_p(C_word x, C_word y)5085{5086 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5087 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);50885089 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5090 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);50915092 return C_utf_equal(x, y);5093}509450955096C_regparm C_word C_i_string_ci_equal_p(C_word x, C_word y)5097{5098 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5099 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);51005101 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5102 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);51035104 return C_utf_equal_ci(x, y);5105}510651075108C_word C_a_i_list(C_word **a, int c, ...)5109{5110 va_list v;5111 C_word x, last, current,5112 first = C_SCHEME_END_OF_LIST;51135114 va_start(v, c);51155116 for(last = C_SCHEME_UNDEFINED; c--; last = current) {5117 x = va_arg(v, C_word);5118 current = C_a_pair(a, x, C_SCHEME_END_OF_LIST);51195120 if(last != C_SCHEME_UNDEFINED)5121 C_set_block_item(last, 1, current);5122 else first = current;5123 }51245125 va_end(v);5126 return first;5127}512851295130C_word C_a_i_string(C_word **a, int c, ...)5131{5132 va_list v;5133 C_word x, s, b;5134 char *p;5135 int len;51365137 s = (C_word)(*a);5138 *a = (C_word *)((C_word)(*a) + sizeof(C_word) * 5); /* C_SIZEOF_STRING */5139 b = (C_word)(*a);51405141 C_block_header_init(s, C_STRING_TAG);5142 C_set_block_item(s, 0, b);5143 C_set_block_item(s, 1, C_fix(c));5144 C_set_block_item(s, 2, C_fix(0));5145 C_set_block_item(s, 3, C_fix(0));5146 p = (char *)C_data_pointer(b);5147 va_start(v, c);51485149 for(; c; c--) {5150 x = va_arg(v, C_word);51515152 if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)5153 p = C_utf_encode(p, C_character_code(x));5154 else break;5155 }51565157 len = p - (char *)C_data_pointer(b) + 1;5158 *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(len));5159 *p = '\0';5160 C_block_header_init(b, C_BYTEVECTOR_TYPE | len);5161 va_end(v);5162 if (c) barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);5163 return s;5164}516551665167C_word C_a_i_record(C_word **ptr, int n, ...)5168{5169 va_list v;5170 C_word *p = *ptr,5171 *p0 = p;51725173 *(p++) = C_STRUCTURE_TYPE | n;5174 va_start(v, n);51755176 while(n--)5177 *(p++) = va_arg(v, C_word);51785179 *ptr = p;5180 va_end(v);5181 return (C_word)p0;5182}518351845185C_word C_a_i_port(C_word **ptr, int n)5186{5187 C_word5188 *p = *ptr,5189 *p0 = p;5190 int i;51915192 *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);5193 *(p++) = (C_word)NULL;51945195 for(i = 0; i < C_SIZEOF_PORT - 2; ++i)5196 *(p++) = C_SCHEME_FALSE;51975198 *ptr = p;5199 return (C_word)p0;5200}520152025203C_regparm C_word C_a_i_bytevector(C_word **ptr, int c, C_word num)5204{5205 C_word *p = *ptr,5206 *p0;5207 int n = C_unfix(num);52085209#ifndef C_SIXTY_FOUR5210 /* Align on 8-byte boundary: */5211 if(C_aligned8(p)) ++p;5212#endif52135214 p0 = p;5215 *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);5216 *ptr = p + n;5217 return (C_word)p0;5218}521952205221C_word C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)5222{5223 C_word5224 *p = *ptr,5225 *p0 = p;5226 void *mp;52275228 if(C_immediatep(x)) mp = NULL;5229 else if((C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);5230 else mp = C_data_pointer(x);52315232 *(p++) = C_POINTER_TYPE | 1;5233 *((void **)p) = mp;5234 *ptr = p + 1;5235 return (C_word)p0;5236}52375238C_regparm C_word C_i_nanp(C_word x)5239{5240 if (x & C_FIXNUM_BIT) {5241 return C_SCHEME_FALSE;5242 } else if (C_immediatep(x)) {5243 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5244 } else if (C_block_header(x) == C_FLONUM_TAG) {5245 return C_u_i_flonum_nanp(x);5246 } else if (C_truep(C_bignump(x))) {5247 return C_SCHEME_FALSE;5248 } else if (C_block_header(x) == C_RATNUM_TAG) {5249 return C_SCHEME_FALSE;5250 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5251 return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) ||5252 C_truep(C_i_nanp(C_u_i_cplxnum_imag(x))));5253 } else {5254 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5255 }5256}52575258C_regparm C_word C_i_finitep(C_word x)5259{5260 if (x & C_FIXNUM_BIT) {5261 return C_SCHEME_TRUE;5262 } else if (C_immediatep(x)) {5263 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5264 } else if (C_block_header(x) == C_FLONUM_TAG) {5265 return C_u_i_flonum_finitep(x);5266 } else if (C_truep(C_bignump(x))) {5267 return C_SCHEME_TRUE;5268 } else if (C_block_header(x) == C_RATNUM_TAG) {5269 return C_SCHEME_TRUE;5270 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5271 return C_and(C_i_finitep(C_u_i_cplxnum_real(x)),5272 C_i_finitep(C_u_i_cplxnum_imag(x)));5273 } else {5274 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5275 }5276}52775278C_regparm C_word C_i_infinitep(C_word x)5279{5280 if (x & C_FIXNUM_BIT) {5281 return C_SCHEME_FALSE;5282 } else if (C_immediatep(x)) {5283 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5284 } else if (C_block_header(x) == C_FLONUM_TAG) {5285 return C_u_i_flonum_infinitep(x);5286 } else if (C_truep(C_bignump(x))) {5287 return C_SCHEME_FALSE;5288 } else if (C_block_header(x) == C_RATNUM_TAG) {5289 return C_SCHEME_FALSE;5290 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5291 return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) ||5292 C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x))));5293 } else {5294 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5295 }5296}52975298C_regparm C_word C_i_exactp(C_word x)5299{5300 if (x & C_FIXNUM_BIT) {5301 return C_SCHEME_TRUE;5302 } else if (C_immediatep(x)) {5303 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5304 } else if (C_block_header(x) == C_FLONUM_TAG) {5305 return C_SCHEME_FALSE;5306 } else if (C_truep(C_bignump(x))) {5307 return C_SCHEME_TRUE;5308 } else if (C_block_header(x) == C_RATNUM_TAG) {5309 return C_SCHEME_TRUE;5310 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5311 return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5312 } else {5313 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5314 }5315}531653175318C_regparm C_word C_i_inexactp(C_word x)5319{5320 if (x & C_FIXNUM_BIT) {5321 return C_SCHEME_FALSE;5322 } else if (C_immediatep(x)) {5323 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5324 } else if (C_block_header(x) == C_FLONUM_TAG) {5325 return C_SCHEME_TRUE;5326 } else if (C_truep(C_bignump(x))) {5327 return C_SCHEME_FALSE;5328 } else if (C_block_header(x) == C_RATNUM_TAG) {5329 return C_SCHEME_FALSE;5330 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5331 return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5332 } else {5333 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5334 }5335}533653375338C_regparm C_word C_i_zerop(C_word x)5339{5340 if (x & C_FIXNUM_BIT) {5341 return C_mk_bool(x == C_fix(0));5342 } else if (C_immediatep(x)) {5343 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5344 } else if (C_block_header(x) == C_FLONUM_TAG) {5345 return C_mk_bool(C_flonum_magnitude(x) == 0.0);5346 } else if (C_block_header(x) == C_BIGNUM_TAG ||5347 C_block_header(x) == C_RATNUM_TAG ||5348 C_block_header(x) == C_CPLXNUM_TAG) {5349 return C_SCHEME_FALSE;5350 } else {5351 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5352 }5353}53545355/* DEPRECATED */5356C_regparm C_word C_u_i_zerop(C_word x)5357{5358 return C_mk_bool(x == C_fix(0) ||5359 (!C_immediatep(x) &&5360 C_block_header(x) == C_FLONUM_TAG &&5361 C_flonum_magnitude(x) == 0.0));5362}536353645365C_regparm C_word C_i_positivep(C_word x)5366{5367 if (x & C_FIXNUM_BIT)5368 return C_i_fixnum_positivep(x);5369 else if (C_immediatep(x))5370 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5371 else if (C_block_header(x) == C_FLONUM_TAG)5372 return C_mk_bool(C_flonum_magnitude(x) > 0.0);5373 else if (C_truep(C_bignump(x)))5374 return C_mk_nbool(C_bignum_negativep(x));5375 else if (C_block_header(x) == C_RATNUM_TAG)5376 return C_i_integer_positivep(C_u_i_ratnum_num(x));5377 else if (C_block_header(x) == C_CPLXNUM_TAG)5378 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x);5379 else5380 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5381}53825383C_regparm C_word C_i_integer_positivep(C_word x)5384{5385 if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);5386 else return C_mk_nbool(C_bignum_negativep(x));5387}53885389C_regparm C_word C_i_negativep(C_word x)5390{5391 if (x & C_FIXNUM_BIT)5392 return C_i_fixnum_negativep(x);5393 else if (C_immediatep(x))5394 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5395 else if (C_block_header(x) == C_FLONUM_TAG)5396 return C_mk_bool(C_flonum_magnitude(x) < 0.0);5397 else if (C_truep(C_bignump(x)))5398 return C_mk_bool(C_bignum_negativep(x));5399 else if (C_block_header(x) == C_RATNUM_TAG)5400 return C_i_integer_negativep(C_u_i_ratnum_num(x));5401 else if (C_block_header(x) == C_CPLXNUM_TAG)5402 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x);5403 else5404 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5405}540654075408C_regparm C_word C_i_integer_negativep(C_word x)5409{5410 if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);5411 else return C_mk_bool(C_bignum_negativep(x));5412}541354145415C_regparm C_word C_i_evenp(C_word x)5416{5417 if(x & C_FIXNUM_BIT) {5418 return C_i_fixnumevenp(x);5419 } else if(C_immediatep(x)) {5420 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5421 } else if (C_block_header(x) == C_FLONUM_TAG) {5422 double val, dummy;5423 val = C_flonum_magnitude(x);5424 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5425 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5426 else5427 return C_mk_bool(fmod(val, 2.0) == 0.0);5428 } else if (C_truep(C_bignump(x))) {5429 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5430 } else { /* No need to try extended number */5431 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5432 }5433}54345435C_regparm C_word C_i_integer_evenp(C_word x)5436{5437 if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);5438 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5439}544054415442C_regparm C_word C_i_oddp(C_word x)5443{5444 if(x & C_FIXNUM_BIT) {5445 return C_i_fixnumoddp(x);5446 } else if(C_immediatep(x)) {5447 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5448 } else if(C_block_header(x) == C_FLONUM_TAG) {5449 double val, dummy;5450 val = C_flonum_magnitude(x);5451 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5452 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5453 else5454 return C_mk_bool(fmod(val, 2.0) != 0.0);5455 } else if (C_truep(C_bignump(x))) {5456 return C_mk_bool(C_bignum_digits(x)[0] & 1);5457 } else {5458 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5459 }5460}546154625463C_regparm C_word C_i_integer_oddp(C_word x)5464{5465 if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);5466 return C_mk_bool(C_bignum_digits(x)[0] & 1);5467}546854695470C_regparm C_word C_i_car(C_word x)5471{5472 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5473 barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);54745475 return C_u_i_car(x);5476}547754785479C_regparm C_word C_i_cdr(C_word x)5480{5481 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5482 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);54835484 return C_u_i_cdr(x);5485}548654875488C_regparm C_word C_i_caar(C_word x)5489{5490 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5491 bad:5492 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x);5493 }54945495 x = C_u_i_car(x);54965497 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;54985499 return C_u_i_car(x);5500}550155025503C_regparm C_word C_i_cadr(C_word x)5504{5505 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5506 bad:5507 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);5508 }55095510 x = C_u_i_cdr(x);55115512 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55135514 return C_u_i_car(x);5515}551655175518C_regparm C_word C_i_cdar(C_word x)5519{5520 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5521 bad:5522 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x);5523 }55245525 x = C_u_i_car(x);55265527 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55285529 return C_u_i_cdr(x);5530}553155325533C_regparm C_word C_i_cddr(C_word x)5534{5535 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5536 bad:5537 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);5538 }55395540 x = C_u_i_cdr(x);5541 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55425543 return C_u_i_cdr(x);5544}554555465547C_regparm C_word C_i_caddr(C_word x)5548{5549 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5550 bad:5551 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);5552 }55535554 x = C_u_i_cdr(x);5555 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5556 x = C_u_i_cdr(x);5557 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55585559 return C_u_i_car(x);5560}556155625563C_regparm C_word C_i_cdddr(C_word x)5564{5565 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5566 bad:5567 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);5568 }55695570 x = C_u_i_cdr(x);5571 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5572 x = C_u_i_cdr(x);5573 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55745575 return C_u_i_cdr(x);5576}557755785579C_regparm C_word C_i_cadddr(C_word x)5580{5581 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5582 bad:5583 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);5584 }55855586 x = C_u_i_cdr(x);5587 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5588 x = C_u_i_cdr(x);5589 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5590 x = C_u_i_cdr(x);5591 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55925593 return C_u_i_car(x);5594}559555965597C_regparm C_word C_i_cddddr(C_word x)5598{5599 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5600 bad:5601 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);5602 }56035604 x = C_u_i_cdr(x);5605 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5606 x = C_u_i_cdr(x);5607 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5608 x = C_u_i_cdr(x);5609 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;56105611 return C_u_i_cdr(x);5612}561356145615C_regparm C_word C_i_list_tail(C_word lst, C_word i)5616{5617 C_word lst0 = lst;5618 int n;56195620 if(lst != C_SCHEME_END_OF_LIST &&5621 (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))5622 barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst);56235624 if(i & C_FIXNUM_BIT) n = C_unfix(i);5625 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);56265627 while(n--) {5628 if(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)5629 barf(C_OUT_OF_BOUNDS_ERROR, "list-tail", lst0, i);56305631 lst = C_u_i_cdr(lst);5632 }56335634 return lst;5635}563656375638C_regparm C_word C_i_vector_ref(C_word v, C_word i)5639{5640 int j;56415642 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5643 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);56445645 if(i & C_FIXNUM_BIT) {5646 j = C_unfix(i);56475648 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_BOUNDS_ERROR, "vector-ref", v, i);56495650 return C_block_item(v, j);5651 }56525653 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);5654 return C_SCHEME_UNDEFINED;5655}56565657C_regparm C_word C_i_bytevector_ref(C_word v, C_word i)5658{5659 int j;56605661 if(!C_truep(C_bytevectorp(v)))5662 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", v);56635664 if(i & C_FIXNUM_BIT) {5665 j = C_unfix(i);56665667 if(j < 0 || j >= C_header_size(v))5668 barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-ref", v, i);56695670 return C_fix(((unsigned char *)C_data_pointer(v))[j]);5671 }56725673 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", i);5674 return C_SCHEME_UNDEFINED;5675}56765677C_regparm C_word C_i_s8vector_ref(C_word v, C_word i)5678{5679 int j;56805681 if(!C_truep(C_i_s8vectorp(v)))5682 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", v);56835684 if(i & C_FIXNUM_BIT) {5685 j = C_unfix(i);56865687 if(j < 0 || j >= C_header_size(C_block_item(v, 1)))5688 barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-ref", v, i);56895690 return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);5691 }56925693 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);5694 return C_SCHEME_UNDEFINED;5695}56965697C_regparm C_word C_i_u16vector_ref(C_word v, C_word i)5698{5699 int j;57005701 if(!C_truep(C_i_u16vectorp(v)))5702 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", v);57035704 if(i & C_FIXNUM_BIT) {5705 j = C_unfix(i);57065707 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))5708 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);57095710 return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);5711 }57125713 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);5714 return C_SCHEME_UNDEFINED;5715}57165717C_regparm C_word C_i_s16vector_ref(C_word v, C_word i)5718{5719 C_word size;5720 int j;57215722 if(C_immediatep(v) || C_header_bits(v) != C_STRUCTURE_TYPE ||5723 C_header_size(v) != 2 || C_block_item(v, 0) != s16vector_symbol)5724 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", v);57255726 if(i & C_FIXNUM_BIT) {5727 j = C_unfix(i);57285729 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))5730 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);57315732 return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);5733 }57345735 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);5736 return C_SCHEME_UNDEFINED;5737}57385739C_regparm C_word C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5740{5741 int j;57425743 if(!C_truep(C_i_u32vectorp(v)))5744 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", v);57455746 if(i & C_FIXNUM_BIT) {5747 j = C_unfix(i);57485749 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5750 barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-ref", v, i);57515752 return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);5753 }57545755 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);5756 return C_SCHEME_UNDEFINED;5757}57585759C_regparm C_word C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5760{5761 int j;57625763 if(!C_truep(C_i_s32vectorp(v)))5764 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", v);57655766 if(i & C_FIXNUM_BIT) {5767 j = C_unfix(i);57685769 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5770 barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-ref", v, i);57715772 return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);5773 }57745775 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);5776 return C_SCHEME_UNDEFINED;5777}57785779C_regparm C_word C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5780{5781 int j;57825783 if(!C_truep(C_i_u64vectorp(v)))5784 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", v);57855786 if(i & C_FIXNUM_BIT) {5787 j = C_unfix(i);57885789 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5790 barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-ref", v, i);57915792 return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);5793 }57945795 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);5796 return C_SCHEME_UNDEFINED;5797}57985799C_regparm C_word C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5800{5801 int j;58025803 if(!C_truep(C_i_s64vectorp(v)))5804 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", v);58055806 if(i & C_FIXNUM_BIT) {5807 j = C_unfix(i);58085809 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5810 barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-ref", v, i);58115812 return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);5813 }58145815 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);5816 return C_SCHEME_UNDEFINED;5817}58185819C_regparm C_word C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5820{5821 int j;58225823 if(!C_truep(C_i_f32vectorp(v)))5824 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", v);58255826 if(i & C_FIXNUM_BIT) {5827 j = C_unfix(i);58285829 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5830 barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-ref", v, i);58315832 return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);5833 }58345835 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);5836 return C_SCHEME_UNDEFINED;5837}58385839C_regparm C_word C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5840{5841 C_word size;5842 int j;58435844 if(!C_truep(C_i_f64vectorp(v)))5845 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", v);58465847 if(i & C_FIXNUM_BIT) {5848 j = C_unfix(i);58495850 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5851 barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-ref", v, i);58525853 return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);5854 }58555856 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);5857 return C_SCHEME_UNDEFINED;5858}585958605861C_regparm C_word C_i_block_ref(C_word x, C_word i)5862{5863 int j;58645865 if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)5866 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);58675868 if(i & C_FIXNUM_BIT) {5869 j = C_unfix(i);58705871 if(j < 0 || j >= C_header_size(x))5872 barf(C_OUT_OF_BOUNDS_ERROR, "##sys#block-ref", x, i);58735874 return C_block_item(x, j);5875 }58765877 barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);5878 return C_SCHEME_UNDEFINED;5879}588058815882C_regparm C_word C_i_string_set(C_word s, C_word i, C_word c)5883{5884 int j;58855886 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5887 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);58885889 if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)5890 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);58915892 if(i & C_FIXNUM_BIT) {5893 j = C_unfix(i);58945895 if(j < 0 || j >= C_unfix(C_block_item(s, 1)))5896 barf(C_OUT_OF_BOUNDS_ERROR, "string-set!", s, i);58975898 return C_utf_setsubchar(s, i, c);5899 }59005901 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);5902 return C_SCHEME_UNDEFINED;5903}590459055906C_regparm C_word C_i_string_ref(C_word s, C_word i)5907{5908 int j;59095910 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5911 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);59125913 if(i & C_FIXNUM_BIT) {5914 j = C_unfix(i);59155916 if(j < 0 || j >= C_unfix(C_block_item(s, 1)))5917 barf(C_OUT_OF_BOUNDS_ERROR, "string-ref", s, i);59185919 return C_utf_subchar(s, i);5920 }59215922 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);5923 return C_SCHEME_UNDEFINED;5924}592559265927C_regparm C_word C_i_vector_length(C_word v)5928{5929 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5930 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);59315932 return C_fix(C_header_size(v));5933}59345935C_regparm C_word C_i_bytevector_length(C_word v)5936{5937 if(C_immediatep(v) || !C_truep(C_bytevectorp(v)))5938 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-length", v);59395940 return C_fix(C_header_size(v));5941}59425943C_regparm C_word C_i_s8vector_length(C_word v)5944{5945 if(!C_truep(C_i_s8vectorp(v)))5946 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);59475948 return C_fix(C_header_size(C_block_item(v, 1)));5949}59505951C_regparm C_word C_i_u16vector_length(C_word v)5952{5953 if(!C_truep(C_i_u16vectorp(v)))5954 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);59555956 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5957}59585959C_regparm C_word C_i_s16vector_length(C_word v)5960{5961 if(!C_truep(C_i_s16vectorp(v)))5962 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);59635964 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5965}59665967C_regparm C_word C_i_u32vector_length(C_word v)5968{5969 if(!C_truep(C_i_u32vectorp(v)))5970 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);59715972 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5973}59745975C_regparm C_word C_i_s32vector_length(C_word v)5976{5977 if(!C_truep(C_i_s32vectorp(v)))5978 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);59795980 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5981}59825983C_regparm C_word C_i_u64vector_length(C_word v)5984{5985 if(!C_truep(C_i_u64vectorp(v)))5986 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);59875988 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5989}59905991C_regparm C_word C_i_s64vector_length(C_word v)5992{5993 if(!C_truep(C_i_s64vectorp(v)))5994 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);59955996 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5997}599859996000C_regparm C_word C_i_f32vector_length(C_word v)6001{6002 if(!C_truep(C_i_f32vectorp(v)))6003 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);60046005 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);6006}60076008C_regparm C_word C_i_f64vector_length(C_word v)6009{6010 if(!C_truep(C_i_f64vectorp(v)))6011 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);60126013 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);6014}601560166017C_regparm C_word C_i_string_length(C_word s)6018{6019 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)6020 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);60216022 return C_block_item(s, 1);6023}602460256026C_regparm C_word C_i_length(C_word lst)6027{6028 C_word fast = lst, slow = lst;6029 int n = 0;60306031 while(slow != C_SCHEME_END_OF_LIST) {6032 if(fast != C_SCHEME_END_OF_LIST) {6033 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6034 fast = C_u_i_cdr(fast);60356036 if(fast != C_SCHEME_END_OF_LIST) {6037 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6038 fast = C_u_i_cdr(fast);6039 }6040 else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);6041 }60426043 if(fast == slow)6044 barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);6045 }6046 }60476048 if(C_immediatep(slow) || C_header_type(slow) != C_PAIR_TYPE)6049 barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);60506051 slow = C_u_i_cdr(slow);6052 ++n;6053 }60546055 return C_fix(n);6056}605760586059C_regparm C_word C_u_i_length(C_word lst)6060{6061 int n = 0;60626063 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {6064 lst = C_u_i_cdr(lst);6065 ++n;6066 }60676068 return C_fix(n);6069}60706071C_regparm C_word C_i_set_car(C_word x, C_word val)6072{6073 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6074 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);60756076 C_mutate(&C_u_i_car(x), val);6077 return C_SCHEME_UNDEFINED;6078}607960806081C_regparm C_word C_i_set_cdr(C_word x, C_word val)6082{6083 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6084 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);60856086 C_mutate(&C_u_i_cdr(x), val);6087 return C_SCHEME_UNDEFINED;6088}608960906091C_regparm C_word C_i_vector_set(C_word v, C_word i, C_word x)6092{6093 int j;60946095 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)6096 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);60976098 if(i & C_FIXNUM_BIT) {6099 j = C_unfix(i);61006101 if(j < 0 || j >= C_header_size(v))6102 barf(C_OUT_OF_BOUNDS_ERROR, "vector-set!", v, i);61036104 C_mutate(&C_block_item(v, j), x);6105 }6106 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);61076108 return C_SCHEME_UNDEFINED;6109}61106111C_regparm C_word C_i_bytevector_set(C_word v, C_word i, C_word x)6112{6113 int j;6114 C_word n;61156116 if(!C_truep(C_bytevectorp(v)))6117 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-set!", v);61186119 if(i & C_FIXNUM_BIT) {6120 j = C_unfix(i);61216122 if(j < 0 || j >= C_header_size(v))6123 barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-set!", v, i);61246125 if(x & C_FIXNUM_BIT) {6126 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6127 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "bytevector-u8-set!", x);6128 }6129 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", x);6130 }6131 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", i);61326133 ((signed char *)C_data_pointer(v))[j] = n;6134 return C_SCHEME_UNDEFINED;6135}61366137C_regparm C_word C_i_s8vector_set(C_word v, C_word i, C_word x)6138{6139 int j;6140 C_word n;61416142 if(!C_truep(C_i_s8vectorp(v)))6143 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", v);61446145 if(i & C_FIXNUM_BIT) {6146 j = C_unfix(i);61476148 if(j < 0 || j >= C_header_size(C_block_item(v, 1)))6149 barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-set!", v, i);61506151 if(x & C_FIXNUM_BIT) {6152 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6153 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s8vector-set!", x);6154 }6155 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);6156 }6157 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", i);61586159 ((signed char *)C_data_pointer(C_block_item(v, 1)))[j] = n;6160 return C_SCHEME_UNDEFINED;6161}61626163C_regparm C_word C_i_u16vector_set(C_word v, C_word i, C_word x)6164{6165 int j;6166 C_word n;61676168 if(!C_truep(C_i_u16vectorp(v)))6169 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", v);61706171 if(i & C_FIXNUM_BIT) {6172 j = C_unfix(i);61736174 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))6175 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);61766177 if(x & C_FIXNUM_BIT) {6178 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);6179 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u16vector-set!", x);6180 }6181 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);6182 }6183 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", i);61846185 ((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6186 return C_SCHEME_UNDEFINED;6187}61886189C_regparm C_word C_i_s16vector_set(C_word v, C_word i, C_word x)6190{6191 int j;6192 C_word n;61936194 if(!C_truep(C_i_s16vectorp(v)))6195 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", v);61966197 if(i & C_FIXNUM_BIT) {6198 j = C_unfix(i);61996200 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))6201 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);62026203 if(x & C_FIXNUM_BIT) {6204 if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);6205 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s16vector-set!", x);6206 }6207 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);6208 }6209 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", i);62106211 ((short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6212 return C_SCHEME_UNDEFINED;6213}62146215C_regparm C_word C_i_u32vector_set(C_word v, C_word i, C_word x)6216{6217 int j;6218 C_u32 n;62196220 if(!C_truep(C_i_u32vectorp(v)))6221 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", v);62226223 if(i & C_FIXNUM_BIT) {6224 j = C_unfix(i);62256226 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6227 barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-set!", v, i);62286229 if(C_truep(C_i_exact_integerp(x))) {6230 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);6231 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u32vector-set!", x);6232 }6233 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);6234 }6235 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", i);62366237 ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6238 return C_SCHEME_UNDEFINED;6239}62406241C_regparm C_word C_i_s32vector_set(C_word v, C_word i, C_word x)6242{6243 int j;6244 C_s32 n;62456246 if(!C_truep(C_i_s32vectorp(v)))6247 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", v);62486249 if(i & C_FIXNUM_BIT) {6250 j = C_unfix(i);62516252 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6253 barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-set!", v, i);62546255 if(C_truep(C_i_exact_integerp(x))) {6256 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);6257 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s32vector-set!", x);6258 }6259 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);6260 }6261 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", i);62626263 ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6264 return C_SCHEME_UNDEFINED;6265}62666267C_regparm C_word C_i_u64vector_set(C_word v, C_word i, C_word x)6268{6269 int j;6270 C_u64 n;62716272 if(!C_truep(C_i_u64vectorp(v)))6273 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", v);62746275 if(i & C_FIXNUM_BIT) {6276 j = C_unfix(i);62776278 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6279 barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-set!", v, i);62806281 if(C_truep(C_i_exact_integerp(x))) {6282 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);6283 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u64vector-set!", x);6284 }6285 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);6286 }6287 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", i);62886289 ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6290 return C_SCHEME_UNDEFINED;6291}62926293C_regparm C_word C_i_s64vector_set(C_word v, C_word i, C_word x)6294{6295 int j;6296 C_s64 n;62976298 if(!C_truep(C_i_s64vectorp(v)))6299 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", v);63006301 if(i & C_FIXNUM_BIT) {6302 j = C_unfix(i);63036304 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6305 barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-set!", v, i);63066307 if(C_truep(C_i_exact_integerp(x))) {6308 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);6309 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s64vector-set!", x);6310 }6311 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);6312 }6313 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", i);63146315 ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6316 return C_SCHEME_UNDEFINED;6317}63186319C_regparm C_word C_i_f32vector_set(C_word v, C_word i, C_word x)6320{6321 int j;6322 double f;63236324 if(!C_truep(C_i_f32vectorp(v)))6325 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", v);63266327 if(i & C_FIXNUM_BIT) {6328 j = C_unfix(i);63296330 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6331 barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-set!", v, i);63326333 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6334 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6335 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6336 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f32vector-set!", x);6337 }6338 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);63396340 ((float *)C_data_pointer(C_block_item(v, 1)))[j] = (float)f;6341 return C_SCHEME_UNDEFINED;6342}63436344C_regparm C_word C_i_f64vector_set(C_word v, C_word i, C_word x)6345{6346 int j;6347 double f;63486349 if(!C_truep(C_i_f64vectorp(v)))6350 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", v);63516352 if(i & C_FIXNUM_BIT) {6353 j = C_unfix(i);63546355 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6356 barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-set!", v, i);63576358 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6359 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6360 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6361 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f64vector-set!", x);63626363 }6364 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);63656366 ((double *)C_data_pointer(C_block_item(v, 1)))[j] = f;6367 return C_SCHEME_UNDEFINED;6368}636963706371/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */6372C_regparm C_word6373C_s_a_i_abs(C_word **ptr, C_word n, C_word x)6374{6375 if (x & C_FIXNUM_BIT) {6376 return C_a_i_fixnum_abs(ptr, 1, x);6377 } else if (C_immediatep(x)) {6378 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6379 } else if (C_block_header(x) == C_FLONUM_TAG) {6380 return C_a_i_flonum_abs(ptr, 1, x);6381 } else if (C_truep(C_bignump(x))) {6382 return C_s_a_u_i_integer_abs(ptr, 1, x);6383 } else if (C_block_header(x) == C_RATNUM_TAG) {6384 return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)),6385 C_u_i_ratnum_denom(x));6386 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6387 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x);6388 } else {6389 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6390 }6391}63926393void C_ccall C_signum(C_word c, C_word *av)6394{6395 C_word k = av[ 1 ], x, y;63966397 if (c != 3) C_bad_argc_2(c, 3, av[ 0 ]);63986399 x = av[ 2 ];6400 y = av[ 3 ];64016402 if (x & C_FIXNUM_BIT) {6403 C_kontinue(k, C_i_fixnum_signum(x));6404 } else if (C_immediatep(x)) {6405 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);6406 } else if (C_block_header(x) == C_FLONUM_TAG) {6407 C_word *a = C_alloc(C_SIZEOF_FLONUM);6408 C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));6409 } else if (C_truep(C_bignump(x))) {6410 C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));6411 } else {6412 try_extended_number("##sys#extended-signum", 2, k, x);6413 }6414}641564166417/* The maximum this can allocate is a cplxnum which consists of two6418 * ratnums that consist of 2 fix bignums each. So that's6419 * C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!6420 */6421C_regparm C_word6422C_s_a_i_negate(C_word **ptr, C_word n, C_word x)6423{6424 if (x & C_FIXNUM_BIT) {6425 return C_a_i_fixnum_negate(ptr, 1, x);6426 } else if (C_immediatep(x)) {6427 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6428 } else if (C_block_header(x) == C_FLONUM_TAG) {6429 return C_a_i_flonum_negate(ptr, 1, x);6430 } else if (C_truep(C_bignump(x))) {6431 return C_s_a_u_i_integer_negate(ptr, 1, x);6432 } else if (C_block_header(x) == C_RATNUM_TAG) {6433 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)),6434 C_u_i_ratnum_denom(x));6435 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6436 return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)),6437 C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x)));6438 } else {6439 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6440 }6441}64426443/* Copy all the digits from source to target, obliterating what was6444 * there. If target is larger than source, the most significant6445 * digits will remain untouched.6446 */6447inline static void bignum_digits_destructive_copy(C_word target, C_word source)6448{6449 C_memcpy(C_bignum_digits(target), C_bignum_digits(source),6450 C_wordstobytes(C_bignum_size(source)));6451}64526453C_regparm C_word6454C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)6455{6456 if (x & C_FIXNUM_BIT) {6457 return C_a_i_fixnum_negate(ptr, 1, x);6458 } else {6459 if (C_bignum_negated_fitsinfixnump(x)) {6460 return C_fix(C_MOST_NEGATIVE_FIXNUM);6461 } else {6462 C_word res, negp = C_mk_nbool(C_bignum_negativep(x)),6463 size = C_fix(C_bignum_size(x));6464 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);6465 bignum_digits_destructive_copy(res, x);6466 return C_bignum_simplify(res);6467 }6468 }6469}647064716472/* Faster version that ignores sign */6473inline static int integer_length_abs(C_word x)6474{6475 if (x & C_FIXNUM_BIT) {6476 return C_ilen(C_wabs(C_unfix(x)));6477 } else {6478 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6479 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6480 last_digit_length = C_ilen(*last_digit);6481 return result + last_digit_length;6482 }6483}64846485C_regparm C_word C_i_integer_length(C_word x)6486{6487 if (x & C_FIXNUM_BIT) {6488 return C_i_fixnum_length(x);6489 } else if (C_truep(C_i_bignump(x))) {6490 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6491 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6492 last_digit_length = C_ilen(*last_digit);64936494 /* If *only* the highest bit is set, negating will give one less bit */6495 if (C_bignum_negativep(x) &&6496 *last_digit == ((C_uword)1 << (last_digit_length-1))) {6497 C_uword *startx = C_bignum_digits(x);6498 while (startx < last_digit && *startx == 0) ++startx;6499 if (startx == last_digit) result--;6500 }6501 return C_fix(result + last_digit_length);6502 } else {6503 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "integer-length", x);6504 }6505}65066507/* This is currently only used by Karatsuba multiplication and6508 * Burnikel-Ziegler division. */6509static C_regparm C_word6510bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end)6511{6512 if (x & C_FIXNUM_BIT) { /* Needed? */6513 if (C_unfix(start) == 0 && (end == C_SCHEME_FALSE || C_unfix(end) > 0))6514 return x;6515 else6516 return C_fix(0);6517 } else {6518 C_word negp, size;65196520 negp = C_mk_bool(C_bignum_negativep(x)); /* Always false */65216522 start = C_unfix(start);6523 /* We might get passed larger values than actually fits; pad w/ zeroes */6524 if (end == C_SCHEME_FALSE) end = C_bignum_size(x);6525 else end = nmin(C_unfix(end), C_bignum_size(x));6526 assert(start >= 0);65276528 size = end - start;65296530 if (size == 0 || start >= C_bignum_size(x)) {6531 return C_fix(0);6532 } else {6533 C_uword res, *res_digits, *x_digits;6534 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6535 res_digits = C_bignum_digits(res);6536 x_digits = C_bignum_digits(x);6537 /* Can't use bignum_digits_destructive_copy because that assumes6538 * target is at least as big as source.6539 */6540 C_memcpy(res_digits, x_digits + start, C_wordstobytes(end - start));6541 return C_bignum_simplify(res);6542 }6543 }6544}65456546/* This returns a tmp bignum negated copy of X (must be freed!) when6547 * the number is negative, or #f if it doesn't need to be negated.6548 * The size can be larger or smaller than X (it may be 1-padded).6549 */6550inline static C_word maybe_negate_bignum_for_bitwise_op(C_word x, C_word size)6551{6552 C_word nx = C_SCHEME_FALSE, xsize;6553 if (C_bignum_negativep(x)) {6554 nx = allocate_tmp_bignum(C_fix(size), C_SCHEME_FALSE, C_SCHEME_FALSE);6555 xsize = C_bignum_size(x);6556 /* Copy up until requested size, and init any remaining upper digits */6557 C_memcpy(C_bignum_digits(nx), C_bignum_digits(x),6558 C_wordstobytes(nmin(size, xsize)));6559 if (size > xsize)6560 C_memset(C_bignum_digits(nx)+xsize, 0, C_wordstobytes(size-xsize));6561 bignum_digits_destructive_negate(nx);6562 }6563 return nx;6564}65656566/* DEPRECATED */6567C_regparm C_word C_i_bit_to_bool(C_word n, C_word i)6568{6569 if (!C_truep(C_i_exact_integerp(n))) {6570 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit->boolean", n);6571 } else if (!(i & C_FIXNUM_BIT)) {6572 if (!C_immediatep(i) && C_truep(C_bignump(i)) && !C_bignum_negativep(i)) {6573 return C_i_integer_negativep(n); /* A bit silly, but strictly correct */6574 } else {6575 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6576 }6577 } else if (i & C_INT_SIGN_BIT) {6578 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6579 } else {6580 i = C_unfix(i);6581 if (n & C_FIXNUM_BIT) {6582 if (i >= C_WORD_SIZE) return C_mk_bool(n & C_INT_SIGN_BIT);6583 else return C_mk_bool((C_unfix(n) & ((C_word)1 << i)) != 0);6584 } else {6585 C_word nn, d;6586 d = i / C_BIGNUM_DIGIT_LENGTH;6587 if (d >= C_bignum_size(n)) return C_mk_bool(C_bignum_negativep(n));65886589 /* TODO: this isn't necessary, is it? */6590 if (C_truep(nn = maybe_negate_bignum_for_bitwise_op(n, d))) n = nn;65916592 i %= C_BIGNUM_DIGIT_LENGTH;6593 d = C_mk_bool((C_bignum_digits(n)[d] & (C_uword)1 << i) != 0);6594 if (C_truep(nn)) free_tmp_bignum(nn);6595 return d;6596 }6597 }6598}65996600C_regparm C_word6601C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)6602{6603 if ((x & y) & C_FIXNUM_BIT) {6604 return C_u_fixnum_and(x, y);6605 } else if (!C_truep(C_i_exact_integerp(x))) {6606 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", x);6607 } else if (!C_truep(C_i_exact_integerp(y))) {6608 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", y);6609 } else {6610 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6611 C_uword *scanr, *endr, *scans1, *ends1, *scans2;66126613 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6614 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);66156616 negp = C_mk_bool(C_bignum_negativep(x) && C_bignum_negativep(y));6617 /* Allow negative 1-bits to propagate */6618 if (C_bignum_negativep(x) || C_bignum_negativep(y))6619 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6620 else6621 size = nmin(C_bignum_size(x), C_bignum_size(y));66226623 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6624 scanr = C_bignum_digits(res);6625 endr = scanr + C_bignum_size(res);66266627 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6628 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;66296630 if (C_bignum_size(x) < C_bignum_size(y)) {6631 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6632 scans2 = C_bignum_digits(y);6633 } else {6634 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6635 scans2 = C_bignum_digits(x);6636 }66376638 while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;6639 C_memset(scanr, 0, C_wordstobytes(endr - scanr));66406641 if (C_truep(nx)) free_tmp_bignum(nx);6642 if (C_truep(ny)) free_tmp_bignum(ny);6643 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);66446645 return C_bignum_simplify(res);6646 }6647}66486649void C_ccall C_bitwise_and(C_word c, C_word *av)6650{6651 /* C_word closure = av[ 0 ]; */6652 C_word k = av[ 1 ];6653 C_word next_val, result, prev_result;6654 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;66556656 c -= 2;6657 av += 2;66586659 if (c == 0) C_kontinue(k, C_fix(-1));66606661 prev_result = result = *(av++);66626663 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6664 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", result);66656666 while (c--) {6667 next_val = *(av++);6668 a = ab[c&1]; /* One may hold last iteration result, the other is unused */6669 result = C_s_a_i_bitwise_and(&a, 2, result, next_val);6670 result = move_buffer_object(&a, ab[(c+1)&1], result);6671 clear_buffer_object(ab[(c+1)&1], prev_result);6672 prev_result = result;6673 }66746675 C_kontinue(k, result);6676}66776678C_regparm C_word6679C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)6680{6681 if ((x & y) & C_FIXNUM_BIT) {6682 return C_u_fixnum_or(x, y);6683 } else if (!C_truep(C_i_exact_integerp(x))) {6684 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", x);6685 } else if (!C_truep(C_i_exact_integerp(y))) {6686 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", y);6687 } else {6688 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6689 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;66906691 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6692 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);66936694 negp = C_mk_bool(C_bignum_negativep(x) || C_bignum_negativep(y));6695 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6696 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6697 scanr = C_bignum_digits(res);6698 endr = scanr + C_bignum_size(res);66996700 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6701 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;67026703 if (C_bignum_size(x) < C_bignum_size(y)) {6704 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6705 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6706 } else {6707 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6708 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6709 }67106711 while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;6712 while (scans2 < ends2) *scanr++ = *scans2++;6713 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6714 assert(scanr == endr);67156716 if (C_truep(nx)) free_tmp_bignum(nx);6717 if (C_truep(ny)) free_tmp_bignum(ny);6718 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);67196720 return C_bignum_simplify(res);6721 }6722}67236724void C_ccall C_bitwise_ior(C_word c, C_word *av)6725{6726 /* C_word closure = av[ 0 ]; */6727 C_word k = av[ 1 ];6728 C_word next_val, result, prev_result;6729 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;67306731 c -= 2;6732 av += 2;67336734 if (c == 0) C_kontinue(k, C_fix(0));67356736 prev_result = result = *(av++);67376738 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6739 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", result);67406741 while (c--) {6742 next_val = *(av++);6743 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6744 result = C_s_a_i_bitwise_ior(&a, 2, result, next_val);6745 result = move_buffer_object(&a, ab[(c+1)&1], result);6746 clear_buffer_object(ab[(c+1)&1], prev_result);6747 prev_result = result;6748 }67496750 C_kontinue(k, result);6751}67526753C_regparm C_word6754C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)6755{6756 if ((x & y) & C_FIXNUM_BIT) {6757 return C_fixnum_xor(x, y);6758 } else if (!C_truep(C_i_exact_integerp(x))) {6759 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", x);6760 } else if (!C_truep(C_i_exact_integerp(y))) {6761 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", y);6762 } else {6763 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6764 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;67656766 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6767 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);67686769 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6770 negp = C_mk_bool(C_bignum_negativep(x) != C_bignum_negativep(y));6771 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6772 scanr = C_bignum_digits(res);6773 endr = scanr + C_bignum_size(res);67746775 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6776 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;67776778 if (C_bignum_size(x) < C_bignum_size(y)) {6779 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6780 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6781 } else {6782 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6783 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6784 }67856786 while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;6787 while (scans2 < ends2) *scanr++ = *scans2++;6788 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6789 assert(scanr == endr);67906791 if (C_truep(nx)) free_tmp_bignum(nx);6792 if (C_truep(ny)) free_tmp_bignum(ny);6793 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);67946795 return C_bignum_simplify(res);6796 }6797}67986799void C_ccall C_bitwise_xor(C_word c, C_word *av)6800{6801 /* C_word closure = av[ 0 ]; */6802 C_word k = av[ 1 ];6803 C_word next_val, result, prev_result;6804 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;68056806 c -= 2;6807 av += 2;68086809 if (c == 0) C_kontinue(k, C_fix(0));68106811 prev_result = result = *(av++);68126813 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6814 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", result);68156816 while (c--) {6817 next_val = *(av++);6818 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6819 result = C_s_a_i_bitwise_xor(&a, 2, result, next_val);6820 result = move_buffer_object(&a, ab[(c+1)&1], result);6821 clear_buffer_object(ab[(c+1)&1], prev_result);6822 prev_result = result;6823 }68246825 C_kontinue(k, result);6826}68276828C_regparm C_word6829C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)6830{6831 if (!C_truep(C_i_exact_integerp(x))) {6832 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-not", x);6833 } else {6834 return C_s_a_u_i_integer_minus(ptr, 2, C_fix(-1), x);6835 }6836}68376838C_regparm C_word6839C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)6840{6841 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, size, negp, res,6842 digit_offset, bit_offset;68436844 if (!(y & C_FIXNUM_BIT))6845 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", y);68466847 y = C_unfix(y);6848 if (y == 0 || x == C_fix(0)) { /* Done (no shift) */6849 return x;6850 } else if (x & C_FIXNUM_BIT) {6851 if (y < 0) {6852 /* Don't shift more than a word's length (that's undefined in C!) */6853 if (-y < C_WORD_SIZE) {6854 return C_fix(C_unfix(x) >> -y);6855 } else {6856 return (x < 0) ? C_fix(-1) : C_fix(0);6857 }6858 } else if (y > 0 && y < C_WORD_SIZE-2 &&6859 /* After shifting, the length still fits a fixnum */6860 (C_ilen(C_unfix(x)) + y) < C_WORD_SIZE-2) {6861 return C_fix((C_uword)C_unfix(x) << y);6862 } else {6863 x = C_a_u_i_fix_to_big(&a, x);6864 }6865 } else if (!C_truep(C_i_bignump(x))) {6866 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "arithmetic-shift", x);6867 }68686869 negp = C_mk_bool(C_bignum_negativep(x));68706871 if (y > 0) { /* Shift left */6872 C_uword *startr, *startx, *endx, *endr;68736874 digit_offset = y / C_BIGNUM_DIGIT_LENGTH;6875 bit_offset = y % C_BIGNUM_DIGIT_LENGTH;68766877 size = C_fix(C_bignum_size(x) + digit_offset + 1);6878 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);68796880 startr = C_bignum_digits(res);6881 endr = startr + C_bignum_size(res);68826883 startx = C_bignum_digits(x);6884 endx = startx + C_bignum_size(x);68856886 /* Initialize only the lower digits we're skipping and the MSD */6887 C_memset(startr, 0, C_wordstobytes(digit_offset));6888 *(endr-1) = 0;6889 startr += digit_offset;6890 /* Can't use bignum_digits_destructive_copy because it assumes6891 * we want to copy from the start.6892 */6893 C_memcpy(startr, startx, C_wordstobytes(endx-startx));6894 if(bit_offset > 0)6895 bignum_digits_destructive_shift_left(startr, endr, bit_offset);68966897 return C_bignum_simplify(res);6898 } else if (-y >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) {6899 /* All bits are shifted out, just return 0 or -1 */6900 return C_truep(negp) ? C_fix(-1) : C_fix(0);6901 } else { /* Shift right */6902 C_uword *startr, *startx, *endr;6903 C_word nx;69046905 digit_offset = -y / C_BIGNUM_DIGIT_LENGTH;6906 bit_offset = -y % C_BIGNUM_DIGIT_LENGTH;69076908 size = C_fix(C_bignum_size(x) - digit_offset);6909 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);69106911 startr = C_bignum_digits(res);6912 endr = startr + C_bignum_size(res);69136914 size = C_bignum_size(x) + 1;6915 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) {6916 startx = C_bignum_digits(nx) + digit_offset;6917 } else {6918 startx = C_bignum_digits(x) + digit_offset;6919 }6920 /* Can't use bignum_digits_destructive_copy because that assumes6921 * target is at least as big as source.6922 */6923 C_memcpy(startr, startx, C_wordstobytes(endr-startr));6924 if(bit_offset > 0)6925 bignum_digits_destructive_shift_right(startr,endr,bit_offset,C_truep(nx));69266927 if (C_truep(nx)) {6928 free_tmp_bignum(nx);6929 bignum_digits_destructive_negate(res);6930 }6931 return C_bignum_simplify(res);6932 }6933}693469356936C_regparm C_word C_a_i_exp(C_word **a, int c, C_word n)6937{6938 double f;69396940 C_check_real(n, "exp", f);6941 return C_flonum(a, C_exp(f));6942}694369446945C_regparm C_word C_a_i_log(C_word **a, int c, C_word n)6946{6947 double f;69486949 C_check_real(n, "log", f);6950 return C_flonum(a, C_log(f));6951}695269536954C_regparm C_word C_a_i_sin(C_word **a, int c, C_word n)6955{6956 double f;69576958 C_check_real(n, "sin", f);6959 return C_flonum(a, C_sin(f));6960}696169626963C_regparm C_word C_a_i_cos(C_word **a, int c, C_word n)6964{6965 double f;69666967 C_check_real(n, "cos", f);6968 return C_flonum(a, C_cos(f));6969}697069716972C_regparm C_word C_a_i_tan(C_word **a, int c, C_word n)6973{6974 double f;69756976 C_check_real(n, "tan", f);6977 return C_flonum(a, C_tan(f));6978}697969806981C_regparm C_word C_a_i_asin(C_word **a, int c, C_word n)6982{6983 double f;69846985 C_check_real(n, "asin", f);6986 return C_flonum(a, C_asin(f));6987}698869896990C_regparm C_word C_a_i_acos(C_word **a, int c, C_word n)6991{6992 double f;69936994 C_check_real(n, "acos", f);6995 return C_flonum(a, C_acos(f));6996}699769986999C_regparm C_word C_a_i_atan(C_word **a, int c, C_word n)7000{7001 double f;70027003 C_check_real(n, "atan", f);7004 return C_flonum(a, C_atan(f));7005}700670077008C_regparm C_word C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)7009{7010 double f1, f2;70117012 C_check_real(n1, "atan", f1);7013 C_check_real(n2, "atan", f2);7014 return C_flonum(a, C_atan2(f1, f2));7015}701670177018C_regparm C_word C_a_i_sinh(C_word **a, int c, C_word n)7019{7020 double f;70217022 C_check_real(n, "sinh", f);7023 return C_flonum(a, C_sinh(f));7024}702570267027C_regparm C_word C_a_i_cosh(C_word **a, int c, C_word n)7028{7029 double f;70307031 C_check_real(n, "cosh", f);7032 return C_flonum(a, C_cosh(f));7033}703470357036C_regparm C_word C_a_i_tanh(C_word **a, int c, C_word n)7037{7038 double f;70397040 C_check_real(n, "tanh", f);7041 return C_flonum(a, C_tanh(f));7042}704370447045C_regparm C_word C_a_i_asinh(C_word **a, int c, C_word n)7046{7047 double f;70487049 C_check_real(n, "asinh", f);7050 return C_flonum(a, C_asinh(f));7051}705270537054C_regparm C_word C_a_i_acosh(C_word **a, int c, C_word n)7055{7056 double f;70577058 C_check_real(n, "acosh", f);7059 return C_flonum(a, C_acosh(f));7060}706170627063C_regparm C_word C_a_i_atanh(C_word **a, int c, C_word n)7064{7065 double f;70667067 C_check_real(n, "atanh", f);7068 return C_flonum(a, C_atanh(f));7069}707070717072C_regparm C_word C_a_i_sqrt(C_word **a, int c, C_word n)7073{7074 double f;70757076 C_check_real(n, "sqrt", f);7077 return C_flonum(a, C_sqrt(f));7078}707970807081C_regparm C_word C_i_assq(C_word x, C_word lst)7082{7083 C_word a;70847085 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7086 a = C_u_i_car(lst);70877088 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7089 if(C_u_i_car(a) == x) return a;7090 }7091 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);70927093 lst = C_u_i_cdr(lst);7094 }70957096 if(lst!=C_SCHEME_END_OF_LIST)7097 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", lst);70987099 return C_SCHEME_FALSE;7100}710171027103C_regparm C_word C_i_assv(C_word x, C_word lst)7104{7105 C_word a;71067107 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7108 a = C_u_i_car(lst);71097110 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7111 if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;7112 }7113 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);71147115 lst = C_u_i_cdr(lst);7116 }71177118 if(lst!=C_SCHEME_END_OF_LIST)7119 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", lst);71207121 return C_SCHEME_FALSE;7122}712371247125C_regparm C_word C_i_assoc(C_word x, C_word lst)7126{7127 C_word a;71287129 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7130 a = C_u_i_car(lst);71317132 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7133 if(C_equalp(C_u_i_car(a), x)) return a;7134 }7135 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);71367137 lst = C_u_i_cdr(lst);7138 }71397140 if(lst!=C_SCHEME_END_OF_LIST)7141 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", lst);71427143 return C_SCHEME_FALSE;7144}714571467147C_regparm C_word C_i_memq(C_word x, C_word lst)7148{7149 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7150 if(C_u_i_car(lst) == x) return lst;7151 else lst = C_u_i_cdr(lst);7152 }71537154 if(lst!=C_SCHEME_END_OF_LIST)7155 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memq", lst);71567157 return C_SCHEME_FALSE;7158}715971607161C_regparm C_word C_u_i_memq(C_word x, C_word lst)7162{7163 while(!C_immediatep(lst)) {7164 if(C_u_i_car(lst) == x) return lst;7165 else lst = C_u_i_cdr(lst);7166 }71677168 return C_SCHEME_FALSE;7169}717071717172C_regparm C_word C_i_memv(C_word x, C_word lst)7173{7174 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7175 if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;7176 else lst = C_u_i_cdr(lst);7177 }71787179 if(lst!=C_SCHEME_END_OF_LIST)7180 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);71817182 return C_SCHEME_FALSE;7183}718471857186C_regparm C_word C_i_member(C_word x, C_word lst)7187{7188 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7189 if(C_equalp(C_u_i_car(lst), x)) return lst;7190 else lst = C_u_i_cdr(lst);7191 }71927193 if(lst!=C_SCHEME_END_OF_LIST)7194 barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", lst);71957196 return C_SCHEME_FALSE;7197}719871997200/* Inline routines for extended bindings: */72017202C_regparm C_word C_i_check_closure_2(C_word x, C_word loc)7203{7204 if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {7205 error_location = loc;7206 barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);7207 }72087209 return C_SCHEME_UNDEFINED;7210}72117212C_regparm C_word C_i_check_fixnum_2(C_word x, C_word loc)7213{7214 if(!(x & C_FIXNUM_BIT)) {7215 error_location = loc;7216 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);7217 }72187219 return C_SCHEME_UNDEFINED;7220}72217222/* DEPRECATED */7223C_regparm C_word C_i_check_exact_2(C_word x, C_word loc)7224{7225 if(C_u_i_exactp(x) == C_SCHEME_FALSE) {7226 error_location = loc;7227 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR, NULL, x);7228 }72297230 return C_SCHEME_UNDEFINED;7231}723272337234C_regparm C_word C_i_check_inexact_2(C_word x, C_word loc)7235{7236 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {7237 error_location = loc;7238 barf(C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR, NULL, x);7239 }72407241 return C_SCHEME_UNDEFINED;7242}724372447245C_regparm C_word C_i_check_char_2(C_word x, C_word loc)7246{7247 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7248 error_location = loc;7249 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7250 }72517252 return C_SCHEME_UNDEFINED;7253}725472557256C_regparm C_word C_i_check_number_2(C_word x, C_word loc)7257{7258 if (C_i_numberp(x) == C_SCHEME_FALSE) {7259 error_location = loc;7260 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);7261 }72627263 return C_SCHEME_UNDEFINED;7264}726572667267C_regparm C_word C_i_check_string_2(C_word x, C_word loc)7268{7269 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {7270 error_location = loc;7271 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);7272 }72737274 return C_SCHEME_UNDEFINED;7275}727672777278C_regparm C_word C_i_check_bytevector_2(C_word x, C_word loc)7279{7280 if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {7281 error_location = loc;7282 barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);7283 }72847285 return C_SCHEME_UNDEFINED;7286}728772887289C_regparm C_word C_i_check_vector_2(C_word x, C_word loc)7290{7291 if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {7292 error_location = loc;7293 barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);7294 }72957296 return C_SCHEME_UNDEFINED;7297}729872997300C_regparm C_word C_i_check_structure_2(C_word x, C_word st, C_word loc)7301{7302 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) {7303 error_location = loc;7304 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);7305 }73067307 return C_SCHEME_UNDEFINED;7308}730973107311C_regparm C_word C_i_check_pair_2(C_word x, C_word loc)7312{7313 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {7314 error_location = loc;7315 barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);7316 }73177318 return C_SCHEME_UNDEFINED;7319}732073217322C_regparm C_word C_i_check_boolean_2(C_word x, C_word loc)7323{7324 if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {7325 error_location = loc;7326 barf(C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR, NULL, x);7327 }73287329 return C_SCHEME_UNDEFINED;7330}733173327333C_regparm C_word C_i_check_locative_2(C_word x, C_word loc)7334{7335 if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {7336 error_location = loc;7337 barf(C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR, NULL, x);7338 }73397340 return C_SCHEME_UNDEFINED;7341}734273437344C_regparm C_word C_i_check_symbol_2(C_word x, C_word loc)7345{7346 if(!C_truep(C_i_symbolp(x))) {7347 error_location = loc;7348 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);7349 }73507351 return C_SCHEME_UNDEFINED;7352}735373547355C_regparm C_word C_i_check_keyword_2(C_word x, C_word loc)7356{7357 if(!C_truep(C_i_keywordp(x))) {7358 error_location = loc;7359 barf(C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR, NULL, x);7360 }73617362 return C_SCHEME_UNDEFINED;7363}73647365C_regparm C_word C_i_check_list_2(C_word x, C_word loc)7366{7367 if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)) {7368 error_location = loc;7369 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);7370 }73717372 return C_SCHEME_UNDEFINED;7373}737473757376C_regparm C_word C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)7377{73787379 if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {7380 error_location = loc;7381 barf(C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR, NULL, x);7382 }73837384 if((C_block_item(x, 1) & dir) != dir) { /* slot #1: I/O direction mask */7385 error_location = loc;7386 switch (dir) {7387 case C_fix(1):7388 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR, NULL, x);7389 case C_fix(2):7390 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR, NULL, x);7391 default:7392 barf(C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR, NULL, x);7393 }7394 }73957396 if(open == C_SCHEME_TRUE) {7397 if(C_block_item(x, 8) == C_FIXNUM_BIT) { /* slot #8: closed mask */7398 error_location = loc;7399 barf(C_PORT_CLOSED_ERROR, NULL, x);7400 }7401 }74027403 return C_SCHEME_UNDEFINED;7404}740574067407C_regparm C_word C_i_check_range_2(C_word i, C_word f, C_word t, C_word loc)7408{7409 if(!(i & C_FIXNUM_BIT)) {7410 error_location = loc;7411 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);7412 }74137414 int index = C_unfix(i);74157416 if(index < C_unfix(f)) {7417 error_location = loc;7418 barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);7419 }74207421 if(index >= C_unfix(t)) {7422 error_location = loc;7423 barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);7424 }74257426 return C_SCHEME_UNDEFINED;7427}742874297430C_regparm C_word C_i_check_range_including_2(C_word i, C_word f, C_word t, C_word loc)7431{7432 if(!(i & C_FIXNUM_BIT)) {7433 error_location = loc;7434 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);7435 }74367437 int index = C_unfix(i);74387439 if(index < C_unfix(f)) {7440 error_location = loc;7441 barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);7442 }74437444 if(index > C_unfix(t)) {7445 error_location = loc;7446 barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);7447 }74487449 return C_SCHEME_UNDEFINED;7450}745174527453/*XXX these are not correctly named */7454C_regparm C_word C_i_foreign_char_argumentp(C_word x)7455{7456 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)7457 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);74587459 return x;7460}746174627463C_regparm C_word C_i_foreign_fixnum_argumentp(C_word x)7464{7465 if((x & C_FIXNUM_BIT) == 0)7466 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);74677468 return x;7469}747074717472C_regparm C_word C_i_foreign_flonum_argumentp(C_word x)7473{7474 if((x & C_FIXNUM_BIT) != 0) return x;74757476 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7477 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);74787479 return x;7480}748174827483C_regparm C_word C_i_foreign_cplxnum_argumentp(C_word x)7484{7485 if((x & C_FIXNUM_BIT) != 0) return x;74867487 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7488 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);74897490 return x;7491}749274937494C_regparm C_word C_i_foreign_block_argumentp(C_word x)7495{7496 if(C_immediatep(x))7497 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);74987499 return x;7500}750175027503C_regparm C_word C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)7504{7505 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)7506 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, t, x);75077508 return x;7509}751075117512C_regparm C_word C_i_foreign_string_argumentp(C_word x)7513{7514 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)7515 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);75167517 return x;7518}751975207521C_regparm C_word C_i_foreign_symbol_argumentp(C_word x)7522{7523 if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)7524 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);75257526 return x;7527}752875297530C_regparm C_word C_i_foreign_pointer_argumentp(C_word x)7531{7532 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7533 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);75347535 return x;7536}753775387539/* TODO: Is this used? */7540C_regparm C_word C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)7541{7542 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7543 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);75447545 return x;7546}754775487549C_regparm C_word C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)7550{7551 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 07552 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))7553 barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);75547555 return x;7556}75577558C_regparm C_word C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)7559{7560 if((x & C_FIXNUM_BIT) != 0) {7561 if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;7562 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7563 } else if (C_truep(C_i_bignump(x))) {7564 if (C_truep(C_fixnum_lessp(C_i_integer_length(x), bits))) return x;7565 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7566 } else {7567 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);7568 }7569}75707571C_regparm C_word C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)7572{7573 if((x & C_FIXNUM_BIT) != 0) {7574 if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7575 else if(C_ilen(C_unfix(x)) <= C_unfix(bits)) return x;7576 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7577 } else if(C_truep(C_i_bignump(x))) {7578 if(C_bignum_negativep(x)) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7579 else if(integer_length_abs(x) <= C_unfix(bits)) return x;7580 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7581 } else {7582 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7583 }7584}75857586/* I */7587C_regparm C_word C_i_not_pair_p_2(C_word x)7588{7589 return C_mk_bool(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE);7590}759175927593C_regparm C_word C_i_null_list_p(C_word x)7594{7595 if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;7596 else if(!C_immediatep(x) && C_header_type(x) == C_PAIR_TYPE) return C_SCHEME_FALSE;7597 else {7598 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);7599 return C_SCHEME_FALSE;7600 }7601}760276037604C_regparm C_word C_i_string_null_p(C_word x)7605{7606 if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)7607 return C_mk_bool(C_unfix(C_block_item(x, 1)) == 0);7608 else {7609 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);7610 return C_SCHEME_FALSE;7611 }7612}761376147615C_regparm C_word C_i_null_pointerp(C_word x)7616{7617 if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)7618 return C_null_pointerp(x);76197620 barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);7621 return C_SCHEME_FALSE;7622}76237624/* only used here for char comparators below: */7625static C_word check_char_internal(C_word x, C_char *loc)7626{7627 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7628 error_location = intern0(loc);7629 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7630 }76317632 return C_SCHEME_UNDEFINED;7633}76347635C_regparm C_word C_i_char_equalp(C_word x, C_word y)7636{7637 check_char_internal(x, "char=?");7638 check_char_internal(y, "char=?");7639 return C_u_i_char_equalp(x, y);7640}76417642C_regparm C_word C_i_char_greaterp(C_word x, C_word y)7643{7644 check_char_internal(x, "char>?");7645 check_char_internal(y, "char>?");7646 return C_u_i_char_greaterp(x, y);7647}76487649C_regparm C_word C_i_char_lessp(C_word x, C_word y)7650{7651 check_char_internal(x, "char<?");7652 check_char_internal(y, "char<?");7653 return C_u_i_char_lessp(x, y);7654}76557656C_regparm C_word C_i_char_greater_or_equal_p(C_word x, C_word y)7657{7658 check_char_internal(x, "char>=?");7659 check_char_internal(y, "char>=?");7660 return C_u_i_char_greater_or_equal_p(x, y);7661}76627663C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y)7664{7665 check_char_internal(x, "char<=?");7666 check_char_internal(y, "char<=?");7667 return C_u_i_char_less_or_equal_p(x, y);7668}766976707671/* Primitives: */76727673void C_ccall C_apply(C_word c, C_word *av)7674{7675 C_word7676 /* closure = av[ 0 ] */7677 k = av[ 1 ],7678 fn = av[ 2 ];7679 int av2_size, i, n = c - 3;7680 int non_list_args = n - 1;7681 C_word lst, len, *ptr, *av2;76827683 if(c < 4) C_bad_min_argc(c, 4);76847685 if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE)7686 barf(C_NOT_A_CLOSURE_ERROR, "apply", fn);76877688 lst = av[ c - 1 ];7689 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7690 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);76917692 len = C_unfix(C_u_i_length(lst));7693 av2_size = 2 + non_list_args + len;76947695 if(C_demand(av2_size))7696 stack_check_demand = 0;7697 else if(stack_check_demand)7698 C_stack_overflow("apply");7699 else {7700 stack_check_demand = av2_size;7701 C_save_and_reclaim((void *)C_apply, c, av);7702 }77037704 av2 = ptr = C_alloc(av2_size);7705 *(ptr++) = fn;7706 *(ptr++) = k;77077708 if(non_list_args > 0) {7709 C_memcpy(ptr, av + 3, non_list_args * sizeof(C_word));7710 ptr += non_list_args;7711 }77127713 while(len--) {7714 *(ptr++) = C_u_i_car(lst);7715 lst = C_u_i_cdr(lst);7716 }77177718 assert((ptr - av2) == av2_size);77197720 ((C_proc)(void *)C_block_item(fn, 0))(av2_size, av2);7721}772277237724void C_ccall C_call_cc(C_word c, C_word *av)7725{7726 C_word7727 /* closure = av[ 0 ] */7728 k = av[ 1 ],7729 cont = av[ 2 ],7730 *a = C_alloc(C_SIZEOF_CLOSURE(2)),7731 wrapper;7732 void *pr = (void *)C_block_item(cont,0);7733 C_word av2[ 3 ];77347735 if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)7736 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);77377738 /* Check for values-continuation: */7739 if(C_block_item(k, 0) == (C_word)values_continuation)7740 wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);7741 else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);77427743 av2[ 0 ] = cont;7744 av2[ 1 ] = k;7745 av2[ 2 ] = wrapper;7746 ((C_proc)pr)(3, av2);7747}774877497750void C_ccall call_cc_wrapper(C_word c, C_word *av)7751{7752 C_word7753 closure = av[ 0 ],7754 /* av[ 1 ] is current k and ignored */7755 result,7756 k = C_block_item(closure, 1);77577758 if(c != 3) C_bad_argc(c, 3);77597760 result = av[ 2 ];7761 C_kontinue(k, result);7762}776377647765void C_ccall call_cc_values_wrapper(C_word c, C_word *av)7766{7767 C_word7768 closure = av[ 0 ],7769 /* av[ 1 ] is current k and ignored */7770 k = C_block_item(closure, 1),7771 x1,7772 n = c;77737774 av[ 0 ] = k; /* reuse av */7775 C_memmove(av + 1, av + 2, (n - 1) * sizeof(C_word));7776 C_do_apply(n - 1, av);7777}777877797780void C_ccall C_continuation_graft(C_word c, C_word *av)7781{7782 C_word7783 /* self = av[ 0 ] */7784 /* k = av[ 1 ] */7785 kk = av[ 2 ],7786 proc = av[ 3 ];77877788 av[ 0 ] = proc; /* reuse av */7789 av[ 1 ] = C_block_item(kk, 1);7790 ((C_proc)C_fast_retrieve_proc(proc))(2, av);7791}779277937794void C_ccall C_values(C_word c, C_word *av)7795{7796 C_word7797 /* closure = av[ 0 ] */7798 k = av[ 1 ],7799 n = c;78007801 if(c < 2) C_bad_min_argc(c, 2);78027803 /* Check continuation whether it receives multiple values: */7804 if(C_block_item(k, 0) == (C_word)values_continuation) {7805 av[ 0 ] = k; /* reuse av */7806 C_memmove(av + 1, av + 2, (c - 2) * sizeof(C_word));7807 C_do_apply(c - 1, av);7808 }78097810 if(c != 3) {7811#ifdef RELAX_MULTIVAL_CHECK7812 if(c == 2) n = C_SCHEME_UNDEFINED;7813 else n = av[ 2 ];7814#else7815 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7816#endif7817 }7818 else n = av[ 2 ];78197820 C_kontinue(k, n);7821}782278237824void C_ccall C_apply_values(C_word c, C_word *av)7825{7826 C_word7827 /* closure = av[ 0 ] */7828 k = av[ 1 ],7829 lst, len, n;78307831 if(c != 3) C_bad_argc(c, 3);78327833 lst = av[ 2 ];78347835 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7836 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);78377838 /* Check whether continuation receives multiple values: */7839 if(C_block_item(k, 0) == (C_word)values_continuation) {7840 C_word *av2, *ptr;78417842 len = C_unfix(C_u_i_length(lst));7843 n = len + 1;78447845 if(C_demand(n))7846 stack_check_demand = 0;7847 else if(stack_check_demand)7848 C_stack_overflow("apply");7849 else {7850 stack_check_demand = n;7851 C_save_and_reclaim((void *)C_apply_values, c, av);7852 }78537854 av2 = C_alloc(n);7855 av2[ 0 ] = k;7856 ptr = av2 + 1;7857 while(len--) {7858 *(ptr++) = C_u_i_car(lst);7859 lst = C_u_i_cdr(lst);7860 }78617862 C_do_apply(n, av2);7863 }78647865 if(C_immediatep(lst)) {7866#ifdef RELAX_MULTIVAL_CHECK7867 n = C_SCHEME_UNDEFINED;7868#else7869 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7870#endif7871 }7872 else if(C_header_type(lst) == C_PAIR_TYPE) {7873 if(C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)7874 n = C_u_i_car(lst);7875 else {7876#ifdef RELAX_MULTIVAL_CHECK7877 n = C_u_i_car(lst);7878#else7879 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7880#endif7881 }7882 }7883 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);78847885 C_kontinue(k, n);7886}788778887889void C_ccall C_call_with_values(C_word c, C_word *av)7890{7891 C_word7892 /* closure = av[ 0 ] */7893 k = av[ 1 ],7894 thunk,7895 kont,7896 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7897 kk;78987899 if(c != 4) C_bad_argc(c, 4);79007901 thunk = av[ 2 ];7902 kont = av[ 3 ];79037904 if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)7905 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);79067907 if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)7908 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);79097910 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7911 av[ 0 ] = thunk; /* reuse av */7912 av[ 1 ] = kk;7913 C_do_apply(2, av);7914}791579167917void C_ccall C_u_call_with_values(C_word c, C_word *av)7918{7919 C_word7920 /* closure = av[ 0 ] */7921 k = av[ 1 ],7922 thunk = av[ 2 ],7923 kont = av[ 3 ],7924 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7925 kk;79267927 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7928 av[ 0 ] = thunk; /* reuse av */7929 av[ 1 ] = kk;7930 C_do_apply(2, av);7931}793279337934void C_ccall values_continuation(C_word c, C_word *av)7935{7936 C_word7937 closure = av[ 0 ],7938 kont = C_block_item(closure, 1),7939 k = C_block_item(closure, 2),7940 *av2 = C_alloc(c + 1);79417942 av2[ 0 ] = kont;7943 av2[ 1 ] = k;7944 C_memcpy(av2 + 2, av + 1, (c - 1) * sizeof(C_word));7945 C_do_apply(c + 1, av2);7946}79477948static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i)7949{7950 C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab, num, denom, gcd, a_div_g;79517952 switch (i) {7953 case C_fix(0): return C_fix(0);7954 case C_fix(1): return rat;7955 case C_fix(-1):7956 num = C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(rat));7957 return C_ratnum(ptr, num , C_u_i_ratnum_denom(rat));7958 /* default: CONTINUE BELOW */7959 }79607961 num = C_u_i_ratnum_num(rat);7962 denom = C_u_i_ratnum_denom(rat);79637964 /* a/b * c/d = a*c / b*d [with b = 1] */7965 /* = ((a / g) * c) / (d / g) */7966 /* With g = gcd(a, d) and a = x [Knuth, 4.5.1] */7967 gcd = C_s_a_u_i_integer_gcd(&a, 2, i, denom);79687969 /* Calculate a/g (= i/gcd), which will later be multiplied by y */7970 a_div_g = C_s_a_u_i_integer_quotient(&a, 2, i, gcd);7971 if (a_div_g == C_fix(0)) {7972 clear_buffer_object(ab, gcd);7973 return C_fix(0); /* Save some work */7974 }79757976 /* Final numerator = a/g * c (= a_div_g * num) */7977 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g, num);79787979 /* Final denominator = d/g (= denom/gcd) */7980 denom = C_s_a_u_i_integer_quotient(ptr, 2, denom, gcd);79817982 num = move_buffer_object(ptr, ab, num);7983 denom = move_buffer_object(ptr, ab, denom);79847985 clear_buffer_object(ab, gcd);7986 clear_buffer_object(ab, a_div_g);79877988 if (denom == C_fix(1)) return num;7989 else return C_ratnum(ptr, num, denom);7990}79917992static C_word rat_times_rat(C_word **ptr, C_word x, C_word y)7993{7994 C_word ab[C_SIZEOF_FIX_BIGNUM * 6], *a = ab,7995 num, denom, xnum, xdenom, ynum, ydenom,7996 g1, g2, a_div_g1, b_div_g2, c_div_g2, d_div_g1;79977998 xnum = C_u_i_ratnum_num(x);7999 xdenom = C_u_i_ratnum_denom(x);8000 ynum = C_u_i_ratnum_num(y);8001 ydenom = C_u_i_ratnum_denom(y);80028003 /* a/b * c/d = a*c / b*d [generic] */8004 /* = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1)) */8005 /* With g1 = gcd(a, d) and g2 = gcd(b, c) [Knuth, 4.5.1] */8006 g1 = C_s_a_u_i_integer_gcd(&a, 2, xnum, ydenom);8007 g2 = C_s_a_u_i_integer_gcd(&a, 2, ynum, xdenom);80088009 /* Calculate a/g1 (= xnum/g1), which will later be multiplied by c/g2 */8010 a_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, xnum, g1);80118012 /* Calculate c/g2 (= ynum/g2), which will later be multiplied by a/g1 */8013 c_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, ynum, g2);80148015 /* Final numerator = a/g1 * c/g2 */8016 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g1, c_div_g2);80178018 /* Now, do the same for the denominator.... */80198020 /* Calculate b/g2 (= xdenom/g2), which will later be multiplied by d/g1 */8021 b_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g2);80228023 /* Calculate d/g1 (= ydenom/g1), which will later be multiplied by b/g2 */8024 d_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);80258026 /* Final denominator = b/g2 * d/g1 */8027 denom = C_s_a_u_i_integer_times(ptr, 2, b_div_g2, d_div_g1);80288029 num = move_buffer_object(ptr, ab, num);8030 denom = move_buffer_object(ptr, ab, denom);80318032 clear_buffer_object(ab, g1);8033 clear_buffer_object(ab, g2);8034 clear_buffer_object(ab, a_div_g1);8035 clear_buffer_object(ab, b_div_g2);8036 clear_buffer_object(ab, c_div_g2);8037 clear_buffer_object(ab, d_div_g1);80388039 if (denom == C_fix(1)) return num;8040 else return C_ratnum(ptr, num, denom);8041}80428043static C_word8044cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)8045{8046 /* Allocation here is kind of tricky: Each intermediate result can8047 * be at most a ratnum consisting of two bignums (2 digits), so8048 * C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2) = 9 words8049 */8050 C_word ab[(C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2))*6], *a = ab,8051 r1, r2, i1, i2, r, i;80528053 /* a+bi * c+di = (a*c - b*d) + (a*d + b*c)i */8054 /* We call these: r1 = a*c, r2 = b*d, i1 = a*d, i2 = b*c */8055 r1 = C_s_a_i_times(&a, 2, rx, ry);8056 r2 = C_s_a_i_times(&a, 2, ix, iy);8057 i1 = C_s_a_i_times(&a, 2, rx, iy);8058 i2 = C_s_a_i_times(&a, 2, ix, ry);80598060 r = C_s_a_i_minus(ptr, 2, r1, r2);8061 i = C_s_a_i_plus(ptr, 2, i1, i2);80628063 r = move_buffer_object(ptr, ab, r);8064 i = move_buffer_object(ptr, ab, i);80658066 clear_buffer_object(ab, r1);8067 clear_buffer_object(ab, r2);8068 clear_buffer_object(ab, i1);8069 clear_buffer_object(ab, i2);80708071 if (C_truep(C_u_i_zerop2(i))) return r;8072 else return C_cplxnum(ptr, r, i);8073}80748075/* The maximum size this needs is that required to store a complex8076 * number result, where both real and imag parts consist of ratnums.8077 * The maximum size of those ratnums is if they consist of two bignums8078 * from a fixnum multiplication (2 digits each), so we're looking at8079 * C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words!8080 */8081C_regparm C_word8082C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)8083{8084 if (x & C_FIXNUM_BIT) {8085 if (y & C_FIXNUM_BIT) {8086 return C_a_i_fixnum_times(ptr, 2, x, y);8087 } else if (C_immediatep(y)) {8088 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8089 } else if (C_block_header(y) == C_FLONUM_TAG) {8090 return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y));8091 } else if (C_truep(C_bignump(y))) {8092 return C_s_a_u_i_integer_times(ptr, 2, x, y);8093 } else if (C_block_header(y) == C_RATNUM_TAG) {8094 return rat_times_integer(ptr, y, x);8095 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8096 return cplx_times(ptr, x, C_fix(0),8097 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8098 } else {8099 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8100 }8101 } else if (C_immediatep(x)) {8102 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8103 } else if (C_block_header(x) == C_FLONUM_TAG) {8104 if (y & C_FIXNUM_BIT) {8105 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y));8106 } else if (C_immediatep(y)) {8107 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8108 } else if (C_block_header(y) == C_FLONUM_TAG) {8109 return C_a_i_flonum_times(ptr, 2, x, y);8110 } else if (C_truep(C_bignump(y))) {8111 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y));8112 } else if (C_block_header(y) == C_RATNUM_TAG) {8113 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8114 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8115 C_word ab[C_SIZEOF_FLONUM], *a = ab;8116 return cplx_times(ptr, x, C_flonum(&a, 0.0),8117 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8118 } else {8119 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8120 }8121 } else if (C_truep(C_bignump(x))) {8122 if (y & C_FIXNUM_BIT) {8123 return C_s_a_u_i_integer_times(ptr, 2, x, y);8124 } else if (C_immediatep(y)) {8125 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8126 } else if (C_block_header(y) == C_FLONUM_TAG) {8127 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y));8128 } else if (C_truep(C_bignump(y))) {8129 return C_s_a_u_i_integer_times(ptr, 2, x, y);8130 } else if (C_block_header(y) == C_RATNUM_TAG) {8131 return rat_times_integer(ptr, y, x);8132 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8133 return cplx_times(ptr, x, C_fix(0),8134 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8135 } else {8136 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8137 }8138 } else if (C_block_header(x) == C_RATNUM_TAG) {8139 if (y & C_FIXNUM_BIT) {8140 return rat_times_integer(ptr, x, y);8141 } else if (C_immediatep(y)) {8142 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8143 } else if (C_block_header(y) == C_FLONUM_TAG) {8144 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8145 } else if (C_truep(C_bignump(y))) {8146 return rat_times_integer(ptr, x, y);8147 } else if (C_block_header(y) == C_RATNUM_TAG) {8148 return rat_times_rat(ptr, x, y);8149 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8150 return cplx_times(ptr, x, C_fix(0),8151 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8152 } else {8153 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8154 }8155 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8156 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8157 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x),8158 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8159 } else {8160 C_word ab[C_SIZEOF_FLONUM], *a = ab, yi;8161 yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0);8162 return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi);8163 }8164 } else {8165 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8166 }8167}816881698170C_regparm C_word8171C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)8172{8173 if (x & C_FIXNUM_BIT) {8174 if (y & C_FIXNUM_BIT) {8175 return C_a_i_fixnum_times(ptr, 2, x, y);8176 } else {8177 C_word tmp = x; /* swap to ensure x is a bignum and y a fixnum */8178 x = y;8179 y = tmp;8180 }8181 }8182 /* Here, we know for sure that X is a bignum */8183 if (y == C_fix(0)) {8184 return C_fix(0);8185 } else if (y == C_fix(1)) {8186 return x;8187 } else if (y == C_fix(-1)) {8188 return C_s_a_u_i_integer_negate(ptr, 1, x);8189 } else if (y & C_FIXNUM_BIT) { /* Any other fixnum */8190 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y),8191 negp = C_mk_bool((y & C_INT_SIGN_BIT) ?8192 !C_bignum_negativep(x) :8193 C_bignum_negativep(x));81948195 if (C_fitsinbignumhalfdigitp(absy) ||8196 (((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {8197 C_word size, res;8198 C_uword *startr, *endr;8199 int shift;8200 size = C_bignum_size(x) + 1; /* Needs _at most_ one more digit */8201 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);82028203 bignum_digits_destructive_copy(res, x);82048205 startr = C_bignum_digits(res);8206 endr = startr + size - 1;8207 /* Scale up, and sanitise the result. */8208 shift = C_ilen(absy) - 1;8209 if (((C_uword)1 << shift) == absy) { /* Power of two? */8210 *endr = bignum_digits_destructive_shift_left(startr, endr, shift);8211 } else {8212 *endr = bignum_digits_destructive_scale_up_with_carry(startr, endr,8213 absy, 0);8214 }8215 return C_bignum_simplify(res);8216 } else {8217 C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);8218 y = C_a_u_i_fix_to_big(&a, y);8219 return bignum_times_bignum_unsigned(ptr, x, y, negp);8220 }8221 } else {8222 C_word negp = C_bignum_negativep(x) ?8223 !C_bignum_negativep(y) :8224 C_bignum_negativep(y);8225 return bignum_times_bignum_unsigned(ptr, x, y, C_mk_bool(negp));8226 }8227}82288229static C_regparm C_word8230bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8231{8232 C_word size, res = C_SCHEME_FALSE;8233 if (C_bignum_size(y) < C_bignum_size(x)) { /* Ensure size(x) <= size(y) */8234 C_word z = x;8235 x = y;8236 y = z;8237 }82388239 if (C_bignum_size(x) >= C_KARATSUBA_THRESHOLD)8240 res = bignum_times_bignum_karatsuba(ptr, x, y, negp);82418242 if (!C_truep(res)) {8243 size = C_bignum_size(x) + C_bignum_size(y);8244 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_TRUE);8245 bignum_digits_multiply(x, y, res);8246 res = C_bignum_simplify(res);8247 }8248 return res;8249}82508251/* Karatsuba multiplication: invoked when the two numbers are large8252 * enough to make it worthwhile, and we still have enough stack left.8253 * Complexity is O(n^log2(3)), where n is max(len(x), len(y)). The8254 * description in [Knuth, 4.3.3] leaves a lot to be desired. [MCA,8255 * 1.3.2] and [MpNT, 3.2] are a bit easier to understand. We assume8256 * that length(x) <= length(y).8257 */8258static C_regparm C_word8259bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)8260{8261 C_word kab[C_SIZEOF_FIX_BIGNUM*15+C_SIZEOF_BIGNUM(2)*3], *ka = kab, o[18],8262 xhi, xlo, xmid, yhi, ylo, ymid, a, b, c, n, bits;8263 int i = 0;82648265 /* Ran out of stack? Fall back to non-recursive multiplication */8266 C_stack_check1(return C_SCHEME_FALSE);82678268 /* Split |x| in half: <xhi,xlo> and |y|: <yhi,ylo> with len(ylo)=len(xlo) */8269 x = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, x);8270 y = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, y);8271 n = C_fix(C_bignum_size(y) >> 1);8272 xhi = o[i++] = bignum_extract_digits(&ka, 3, x, n, C_SCHEME_FALSE);8273 xlo = o[i++] = bignum_extract_digits(&ka, 3, x, C_fix(0), n);8274 yhi = o[i++] = bignum_extract_digits(&ka, 3, y, n, C_SCHEME_FALSE);8275 ylo = o[i++] = bignum_extract_digits(&ka, 3, y, C_fix(0), n);82768277 /* a = xhi * yhi, b = xlo * ylo, c = (xhi - xlo) * (yhi - ylo) */8278 a = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xhi, yhi);8279 b = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xlo, ylo);8280 xmid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, xhi, xlo);8281 ymid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, yhi, ylo);8282 c = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xmid, ymid);82838284 /* top(x) = a << (bits - 1) and bottom(y) = ((b + (a - c)) << bits) + b */8285 bits = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;8286 x = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, a, C_fix((C_uword)bits << 1));8287 c = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, a, c);8288 c = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, b, c);8289 c = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, c, C_fix(bits));8290 y = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, c, b);8291 /* Finally, return top + bottom, and correct for negative */8292 n = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, x, y);8293 if (C_truep(negp)) n = o[i++] = C_s_a_u_i_integer_negate(&ka, 1, n);82948295 n = move_buffer_object(ptr, kab, n);8296 while(i--) clear_buffer_object(kab, o[i]);8297 return n;8298}82998300void C_ccall C_times(C_word c, C_word *av)8301{8302 /* C_word closure = av[ 0 ]; */8303 C_word k = av[ 1 ];8304 C_word next_val,8305 result = C_fix(1),8306 prev_result = result;8307 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a;83088309 c -= 2;8310 av += 2;83118312 while (c--) {8313 next_val = *(av++);8314 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */8315 result = C_s_a_i_times(&a, 2, result, next_val);8316 result = move_buffer_object(&a, ab[(c+1)&1], result);8317 clear_buffer_object(ab[(c+1)&1], prev_result);8318 prev_result = result;8319 }83208321 C_kontinue(k, result);8322}832383248325static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8326{8327 C_word size, result;8328 C_uword sum, digit, *scan_y, *end_y, *scan_r, *end_r;8329 int carry = 0;83308331 if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(y) <= size(x) */8332 C_word z = x;8333 x = y;8334 y = z;8335 }83368337 size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */8338 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);83398340 scan_y = C_bignum_digits(y);8341 end_y = scan_y + C_bignum_size(y);8342 scan_r = C_bignum_digits(result);8343 end_r = scan_r + C_bignum_size(result);83448345 /* Copy x into r so we can operate on two pointers, which is faster8346 * than three, and we can stop earlier after adding y. It's slower8347 * if x and y have equal length. On average it's slightly faster.8348 */8349 bignum_digits_destructive_copy(result, x);8350 *(end_r-1) = 0; /* Ensure most significant digit is initialised */83518352 /* Move over x and y simultaneously, destructively adding digits w/ carry. */8353 while (scan_y < end_y) {8354 digit = *scan_r;8355 if (carry) {8356 sum = digit + *scan_y++ + 1;8357 carry = sum <= digit;8358 } else {8359 sum = digit + *scan_y++;8360 carry = sum < digit;8361 }8362 (*scan_r++) = sum;8363 }83648365 /* The end of y, the smaller number. Propagate carry into the rest of x. */8366 while (carry) {8367 sum = (*scan_r) + 1;8368 carry = (sum == 0);8369 (*scan_r++) = sum;8370 }8371 assert(scan_r <= end_r);83728373 return C_bignum_simplify(result);8374}83758376static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op)8377{8378 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8379 num, denom, tmp, res;83808381 if (i == C_fix(0)) return rat;83828383 num = C_u_i_ratnum_num(rat);8384 denom = C_u_i_ratnum_denom(rat);83858386 /* a/b [+-] c/d = (a*d [+-] b*c)/(b*d) | d = 1: (num + denom * i) / denom */8387 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8388 res = plusmin_op(&a, 2, num, tmp);8389 res = move_buffer_object(ptr, ab, res);8390 clear_buffer_object(ab, tmp);8391 return C_ratnum(ptr, res, denom);8392}83938394/* This is needed only for minus: plus is commutative but minus isn't. */8395static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat)8396{8397 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8398 num, denom, tmp, res;83998400 num = C_u_i_ratnum_num(rat);8401 denom = C_u_i_ratnum_denom(rat);84028403 if (i == C_fix(0))8404 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, num), denom);84058406 /* a/b - c/d = (a*d - b*c)/(b*d) | b = 1: (denom * i - num) / denom */8407 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8408 res = C_s_a_u_i_integer_minus(&a, 2, tmp, num);8409 res = move_buffer_object(ptr, ab, res);8410 clear_buffer_object(ab, tmp);8411 return C_ratnum(ptr, res, denom);8412}84138414/* This is pretty braindead and ugly */8415static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op)8416{8417 C_word ab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)*2], *a = ab,8418 xnum = C_u_i_ratnum_num(x), ynum = C_u_i_ratnum_num(y),8419 xdenom = C_u_i_ratnum_denom(x), ydenom = C_u_i_ratnum_denom(y),8420 xnorm, ynorm, tmp_r, g1, ydenom_g1, xdenom_g1, norm_sum, g2, len,8421 res_num, res_denom;84228423 /* Knuth, 4.5.1. Start with g1 = gcd(xdenom, ydenom) */8424 g1 = C_s_a_u_i_integer_gcd(&a, 2, xdenom, ydenom);84258426 /* xnorm = xnum * (ydenom/g1) */8427 ydenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);8428 xnorm = C_s_a_u_i_integer_times(&a, 2, xnum, ydenom_g1);84298430 /* ynorm = ynum * (xdenom/g1) */8431 xdenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g1);8432 ynorm = C_s_a_u_i_integer_times(&a, 2, ynum, xdenom_g1);84338434 /* norm_sum = xnorm [+-] ynorm */8435 norm_sum = plusmin_op(&a, 2, xnorm, ynorm);84368437 /* g2 = gcd(norm_sum, g1) */8438 g2 = C_s_a_u_i_integer_gcd(&a, 2, norm_sum, g1);84398440 /* res_num = norm_sum / g2 */8441 res_num = C_s_a_u_i_integer_quotient(ptr, 2, norm_sum, g2);8442 if (res_num == C_fix(0)) {8443 res_denom = C_fix(0); /* No need to calculate denom: we'll return 0 */8444 } else {8445 /* res_denom = xdenom_g1 * (ydenom / g2) */8446 C_word res_tmp_denom = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g2);8447 res_denom = C_s_a_u_i_integer_times(ptr, 2, xdenom_g1, res_tmp_denom);84488449 /* Ensure they're allocated in the correct place */8450 res_num = move_buffer_object(ptr, ab, res_num);8451 res_denom = move_buffer_object(ptr, ab, res_denom);8452 clear_buffer_object(ab, res_tmp_denom);8453 }84548455 clear_buffer_object(ab, xdenom_g1);8456 clear_buffer_object(ab, ydenom_g1);8457 clear_buffer_object(ab, xnorm);8458 clear_buffer_object(ab, ynorm);8459 clear_buffer_object(ab, norm_sum);8460 clear_buffer_object(ab, g1);8461 clear_buffer_object(ab, g2);84628463 switch (res_denom) {8464 case C_fix(0): return C_fix(0);8465 case C_fix(1): return res_num;8466 default: return C_ratnum(ptr, res_num, res_denom);8467 }8468}84698470/* The maximum size this needs is that required to store a complex8471 * number result, where both real and imag parts consist of ratnums.8472 * The maximum size of those ratnums is if they consist of two "fix8473 * bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM *8474 * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!8475 */8476C_regparm C_word8477C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)8478{8479 if (x & C_FIXNUM_BIT) {8480 if (y & C_FIXNUM_BIT) {8481 return C_a_i_fixnum_plus(ptr, 2, x, y);8482 } else if (C_immediatep(y)) {8483 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8484 } else if (C_block_header(y) == C_FLONUM_TAG) {8485 return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y));8486 } else if (C_truep(C_bignump(y))) {8487 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8488 } else if (C_block_header(y) == C_RATNUM_TAG) {8489 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8490 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8491 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8492 imag = C_u_i_cplxnum_imag(y);8493 if (C_truep(C_u_i_inexactp(real_sum)))8494 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8495 return C_cplxnum(ptr, real_sum, imag);8496 } else {8497 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8498 }8499 } else if (C_immediatep(x)) {8500 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8501 } else if (C_block_header(x) == C_FLONUM_TAG) {8502 if (y & C_FIXNUM_BIT) {8503 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y));8504 } else if (C_immediatep(y)) {8505 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8506 } else if (C_block_header(y) == C_FLONUM_TAG) {8507 return C_a_i_flonum_plus(ptr, 2, x, y);8508 } else if (C_truep(C_bignump(y))) {8509 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y));8510 } else if (C_block_header(y) == C_RATNUM_TAG) {8511 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8512 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8513 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8514 imag = C_u_i_cplxnum_imag(y);8515 if (C_truep(C_u_i_inexactp(real_sum)))8516 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8517 return C_cplxnum(ptr, real_sum, imag);8518 } else {8519 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8520 }8521 } else if (C_truep(C_bignump(x))) {8522 if (y & C_FIXNUM_BIT) {8523 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8524 } else if (C_immediatep(y)) {8525 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8526 } else if (C_block_header(y) == C_FLONUM_TAG) {8527 return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y));8528 } else if (C_truep(C_bignump(y))) {8529 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8530 } else if (C_block_header(y) == C_RATNUM_TAG) {8531 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8532 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8533 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8534 imag = C_u_i_cplxnum_imag(y);8535 if (C_truep(C_u_i_inexactp(real_sum)))8536 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8537 return C_cplxnum(ptr, real_sum, imag);8538 } else {8539 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8540 }8541 } else if (C_block_header(x) == C_RATNUM_TAG) {8542 if (y & C_FIXNUM_BIT) {8543 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8544 } else if (C_immediatep(y)) {8545 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8546 } else if (C_block_header(y) == C_FLONUM_TAG) {8547 return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8548 } else if (C_truep(C_bignump(y))) {8549 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8550 } else if (C_block_header(y) == C_RATNUM_TAG) {8551 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus);8552 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8553 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8554 imag = C_u_i_cplxnum_imag(y);8555 if (C_truep(C_u_i_inexactp(real_sum)))8556 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8557 return C_cplxnum(ptr, real_sum, imag);8558 } else {8559 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8560 }8561 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8562 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8563 C_word real_sum, imag_sum;8564 real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y));8565 imag_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y));8566 if (C_truep(C_u_i_zerop2(imag_sum))) return real_sum;8567 else return C_cplxnum(ptr, real_sum, imag_sum);8568 } else {8569 C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y),8570 imag = C_u_i_cplxnum_imag(x);8571 if (C_truep(C_u_i_inexactp(real_sum)))8572 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8573 return C_cplxnum(ptr, real_sum, imag);8574 }8575 } else {8576 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8577 }8578}85798580C_regparm C_word8581C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y)8582{8583 if ((x & y) & C_FIXNUM_BIT) {8584 return C_a_i_fixnum_plus(ptr, 2, x, y);8585 } else {8586 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8587 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8588 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);85898590 if (C_bignum_negativep(x)) {8591 if (C_bignum_negativep(y)) {8592 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8593 } else {8594 return bignum_minus_unsigned(ptr, y, x);8595 }8596 } else {8597 if (C_bignum_negativep(y)) {8598 return bignum_minus_unsigned(ptr, x, y);8599 } else {8600 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8601 }8602 }8603 }8604}86058606void C_ccall C_plus(C_word c, C_word *av)8607{8608 /* C_word closure = av[ 0 ]; */8609 C_word k = av[ 1 ];8610 C_word next_val,8611 result = C_fix(0),8612 prev_result = result;8613 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;86148615 c -= 2;8616 av += 2;86178618 while (c--) {8619 next_val = *(av++);8620 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8621 result = C_s_a_i_plus(&a, 2, result, next_val);8622 result = move_buffer_object(&a, ab[(c+1)&1], result);8623 clear_buffer_object(ab[(c+1)&1], prev_result);8624 prev_result = result;8625 }86268627 C_kontinue(k, result);8628}86298630static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)8631{8632 C_word res, size;8633 C_uword *scan_r, *end_r, *scan_y, *end_y, difference, digit;8634 int borrow = 0;86358636 switch(bignum_cmp_unsigned(x, y)) {8637 case 0: /* x = y, return 0 */8638 return C_fix(0);8639 case -1: /* abs(x) < abs(y), return -(abs(y) - abs(x)) */8640 size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */8641 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_TRUE, C_SCHEME_FALSE);8642 size = y;8643 y = x;8644 x = size;8645 break;8646 case 1: /* abs(x) > abs(y), return abs(x) - abs(y) */8647 default:8648 size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */8649 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);8650 break;8651 }86528653 scan_r = C_bignum_digits(res);8654 end_r = scan_r + C_bignum_size(res);8655 scan_y = C_bignum_digits(y);8656 end_y = scan_y + C_bignum_size(y);86578658 bignum_digits_destructive_copy(res, x); /* See bignum_plus_unsigned */86598660 /* Destructively subtract y's digits w/ borrow from and back into r. */8661 while (scan_y < end_y) {8662 digit = *scan_r;8663 if (borrow) {8664 difference = digit - *scan_y++ - 1;8665 borrow = difference >= digit;8666 } else {8667 difference = digit - *scan_y++;8668 borrow = difference > digit;8669 }8670 (*scan_r++) = difference;8671 }86728673 /* The end of y, the smaller number. Propagate borrow into the rest of x. */8674 while (borrow) {8675 digit = *scan_r;8676 difference = digit - borrow;8677 borrow = difference >= digit;8678 (*scan_r++) = difference;8679 }86808681 assert(scan_r <= end_r);86828683 return C_bignum_simplify(res);8684}86858686/* Like C_s_a_i_plus, this needs at most 29 words */8687C_regparm C_word8688C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)8689{8690 if (x & C_FIXNUM_BIT) {8691 if (y & C_FIXNUM_BIT) {8692 return C_a_i_fixnum_difference(ptr, 2, x, y);8693 } else if (C_immediatep(y)) {8694 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8695 } else if (C_block_header(y) == C_FLONUM_TAG) {8696 return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y));8697 } else if (C_truep(C_bignump(y))) {8698 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8699 } else if (C_block_header(y) == C_RATNUM_TAG) {8700 return integer_minus_rat(ptr, x, y);8701 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8702 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8703 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8704 if (C_truep(C_u_i_inexactp(real_diff)))8705 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8706 return C_cplxnum(ptr, real_diff, imag);8707 } else {8708 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8709 }8710 } else if (C_immediatep(x)) {8711 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8712 } else if (C_block_header(x) == C_FLONUM_TAG) {8713 if (y & C_FIXNUM_BIT) {8714 return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y));8715 } else if (C_immediatep(y)) {8716 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8717 } else if (C_block_header(y) == C_FLONUM_TAG) {8718 return C_a_i_flonum_difference(ptr, 2, x, y);8719 } else if (C_truep(C_bignump(y))) {8720 return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y));8721 } else if (C_block_header(y) == C_RATNUM_TAG) {8722 return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8723 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8724 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8725 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8726 if (C_truep(C_u_i_inexactp(real_diff)))8727 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8728 return C_cplxnum(ptr, real_diff, imag);8729 } else {8730 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8731 }8732 } else if (C_truep(C_bignump(x))) {8733 if (y & C_FIXNUM_BIT) {8734 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8735 } else if (C_immediatep(y)) {8736 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8737 } else if (C_block_header(y) == C_FLONUM_TAG) {8738 return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y));8739 } else if (C_truep(C_bignump(y))) {8740 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8741 } else if (C_block_header(y) == C_RATNUM_TAG) {8742 return integer_minus_rat(ptr, x, y);8743 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8744 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8745 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8746 if (C_truep(C_u_i_inexactp(real_diff)))8747 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8748 return C_cplxnum(ptr, real_diff, imag);8749 } else {8750 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8751 }8752 } else if (C_block_header(x) == C_RATNUM_TAG) {8753 if (y & C_FIXNUM_BIT) {8754 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8755 } else if (C_immediatep(y)) {8756 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8757 } else if (C_block_header(y) == C_FLONUM_TAG) {8758 return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8759 } else if (C_truep(C_bignump(y))) {8760 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8761 } else if (C_block_header(y) == C_RATNUM_TAG) {8762 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus);8763 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8764 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8765 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8766 if (C_truep(C_u_i_inexactp(real_diff)))8767 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8768 return C_cplxnum(ptr, real_diff, imag);8769 } else {8770 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8771 }8772 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8773 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8774 C_word real_diff, imag_diff;8775 real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y));8776 imag_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_imag(x),C_u_i_cplxnum_imag(y));8777 if (C_truep(C_u_i_zerop2(imag_diff))) return real_diff;8778 else return C_cplxnum(ptr, real_diff, imag_diff);8779 } else {8780 C_word real_diff = C_s_a_i_minus(ptr, 2, C_u_i_cplxnum_real(x), y),8781 imag = C_u_i_cplxnum_imag(x);8782 if (C_truep(C_u_i_inexactp(real_diff)))8783 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8784 return C_cplxnum(ptr, real_diff, imag);8785 }8786 } else {8787 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8788 }8789}87908791C_regparm C_word8792C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y)8793{8794 if ((x & y) & C_FIXNUM_BIT) {8795 return C_a_i_fixnum_difference(ptr, 2, x, y);8796 } else {8797 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8798 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8799 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);88008801 if (C_bignum_negativep(x)) {8802 if (C_bignum_negativep(y)) {8803 return bignum_minus_unsigned(ptr, y, x);8804 } else {8805 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8806 }8807 } else {8808 if (C_bignum_negativep(y)) {8809 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8810 } else {8811 return bignum_minus_unsigned(ptr, x, y);8812 }8813 }8814 }8815}88168817void C_ccall C_minus(C_word c, C_word *av)8818{8819 /* C_word closure = av[ 0 ]; */8820 C_word k = av[ 1 ];8821 C_word next_val, result, prev_result;8822 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;88238824 if (c < 3) {8825 C_bad_min_argc(c, 3);8826 } else if (c == 3) {8827 a = ab[0];8828 C_kontinue(k, C_s_a_i_negate(&a, 1, av[ 2 ]));8829 } else {8830 prev_result = result = av[ 2 ];8831 c -= 3;8832 av += 3;88338834 while (c--) {8835 next_val = *(av++);8836 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8837 result = C_s_a_i_minus(&a, 2, result, next_val);8838 result = move_buffer_object(&a, ab[(c+1)&1], result);8839 clear_buffer_object(ab[(c+1)&1], prev_result);8840 prev_result = result;8841 }88428843 C_kontinue(k, result);8844 }8845}884688478848static C_regparm void8849integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8850{8851 if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */8852 if (x & C_FIXNUM_BIT) {8853 /* abs(x) < abs(y), so it will always be [0, x] except for this case: */8854 if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&8855 C_bignum_negated_fitsinfixnump(y)) {8856 if (q != NULL) *q = C_fix(-1);8857 if (r != NULL) *r = C_fix(0);8858 } else {8859 if (q != NULL) *q = C_fix(0);8860 if (r != NULL) *r = x;8861 }8862 } else {8863 bignum_divrem(ptr, x, y, q, r);8864 }8865 } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */8866 if (q != NULL) *q = C_a_i_fixnum_quotient_checked(ptr, 2, x, y);8867 if (r != NULL) *r = C_i_fixnum_remainder_checked(x, y);8868 } else { /* x is bignum, y is fixnum. */8869 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);88708871 if (y == C_fix(1)) {8872 if (q != NULL) *q = x;8873 if (r != NULL) *r = C_fix(0);8874 } else if (y == C_fix(-1)) {8875 if (q != NULL) *q = C_s_a_u_i_integer_negate(ptr, 1, x);8876 if (r != NULL) *r = C_fix(0);8877 } else if (C_fitsinbignumhalfdigitp(absy) ||8878 ((((C_uword)1 << (C_ilen(absy)-1)) == absy) &&8879 C_fitsinfixnump(absy))) {8880 assert(y != C_fix(0)); /* _must_ be checked by caller */8881 if (q != NULL) {8882 bignum_destructive_divide_unsigned_small(ptr, x, y, q, r);8883 } else { /* We assume r isn't NULL here (that makes no sense) */8884 C_word rem;8885 C_uword next_power = (C_uword)1 << (C_ilen(absy)-1);88868887 if (next_power == absy) { /* Is absy a power of two? */8888 rem = *(C_bignum_digits(x)) & (next_power - 1);8889 } else { /* Too bad, we have to do some real work */8890 rem = bignum_remainder_unsigned_halfdigit(x, absy);8891 }8892 *r = C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem);8893 }8894 } else { /* Just divide it as two bignums */8895 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;8896 bignum_divrem(ptr, x, C_a_u_i_fix_to_big(&a, y), q, r);8897 if (q != NULL) *q = move_buffer_object(ptr, ab, *q);8898 if (r != NULL) *r = move_buffer_object(ptr, ab, *r);8899 }8900 }8901}89028903/* This _always_ needs two bignum wrappers in ptr! */8904static C_regparm void8905bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8906{8907 C_word q_negp = C_mk_bool(C_bignum_negativep(y) != C_bignum_negativep(x)),8908 r_negp = C_mk_bool(C_bignum_negativep(x)), res, size;89098910 switch(bignum_cmp_unsigned(x, y)) {8911 case 0:8912 if (q != NULL) *q = C_truep(q_negp) ? C_fix(-1) : C_fix(1);8913 if (r != NULL) *r = C_fix(0);8914 break;8915 case -1:8916 if (q != NULL) *q = C_fix(0);8917 if (r != NULL) *r = x;8918 break;8919 case 1:8920 default:8921 res = C_SCHEME_FALSE;8922 size = C_bignum_size(x) - C_bignum_size(y);8923 if (C_bignum_size(y) > C_BURNIKEL_ZIEGLER_THRESHOLD &&8924 size > C_BURNIKEL_ZIEGLER_THRESHOLD) {8925 res = bignum_divide_burnikel_ziegler(ptr, x, y, q, r);8926 }89278928 if (!C_truep(res)) {8929 bignum_divide_unsigned(ptr, x, y, q, q_negp, r, r_negp);8930 if (q != NULL) *q = C_bignum_simplify(*q);8931 if (r != NULL) *r = C_bignum_simplify(*r);8932 }8933 break;8934 }8935}89368937/* Burnikel-Ziegler recursive division: Split high number (x) in three8938 * or four parts and divide by the lowest number (y), split in two8939 * parts. There are descriptions in [MpNT, 4.2], [MCA, 1.4.3] and the8940 * paper "Fast Recursive Division" by Christoph Burnikel & Joachim8941 * Ziegler is freely available. There is also a description in Karl8942 * Hasselstrom's thesis "Fast Division of Integers".8943 *8944 * The complexity of this is supposedly O(r*s^{log(3)-1} + r*log(s)),8945 * where s is the length of x, and r is the length of y (in digits).8946 *8947 * TODO: See if it's worthwhile to implement "division without remainder"8948 * from the Burnikel-Ziegler paper.8949 */8950static C_regparm C_word8951bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8952{8953 C_word ab[C_SIZEOF_FIX_BIGNUM*9], *a = ab,8954 lab[2][C_SIZEOF_FIX_BIGNUM*10], *la,8955 q_negp = (C_bignum_negativep(y) ? C_mk_nbool(C_bignum_negativep(x)) :8956 C_mk_bool(C_bignum_negativep(x))),8957 r_negp = C_mk_bool(C_bignum_negativep(x)), s, m, n, i, j, l, shift,8958 yhi, ylo, zi, zi_orig, newx, newy, quot, qi, ri;89598960 /* Ran out of stack? Fall back to non-recursive division */8961 C_stack_check1(return C_SCHEME_FALSE);89628963 x = C_s_a_u_i_integer_abs(&a, 1, x);8964 y = C_s_a_u_i_integer_abs(&a, 1, y);89658966 /* Define m as min{2^k|(2^k)*BURNIKEL_ZIEGLER_DIFF_THRESHOLD > s}8967 * This ensures we shift as little as possible (less pressure8968 * on the GC) while maintaining a power of two until we drop8969 * below the threshold, so we can always split N in half.8970 */8971 s = C_bignum_size(y);8972 m = 1 << C_ilen(s / C_BURNIKEL_ZIEGLER_THRESHOLD);8973 j = (s+m-1) / m; /* j = s/m, rounded up */8974 n = j * m;89758976 shift = (C_BIGNUM_DIGIT_LENGTH * n) - integer_length_abs(y);8977 newx = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(shift));8978 newy = C_s_a_i_arithmetic_shift(&a, 2, y, C_fix(shift));8979 if (shift != 0) {8980 clear_buffer_object(ab, x);8981 clear_buffer_object(ab, y);8982 }8983 x = newx;8984 y = newy;89858986 /* l needs to be the smallest value so that a < base^{l*n}/2 */8987 l = (C_bignum_size(x) + n) / n;8988 if ((C_BIGNUM_DIGIT_LENGTH * l) == integer_length_abs(x)) l++;8989 l = nmax(l, 2);89908991 yhi = bignum_extract_digits(&a, 3, y, C_fix(n >> 1), C_SCHEME_FALSE);8992 ylo = bignum_extract_digits(&a, 3, y, C_fix(0), C_fix(n >> 1));89938994 s = (l - 2) * n * C_BIGNUM_DIGIT_LENGTH;8995 zi_orig = zi = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(-s));8996 quot = C_fix(0);89978998 for(i = l - 2; i >= 0; --i) {8999 la = lab[i&1];90009001 burnikel_ziegler_2n_div_1n(&la, zi, y, yhi, ylo, C_fix(n), &qi, &ri);90029003 newx = C_s_a_i_arithmetic_shift(&la, 2, quot, C_fix(n*C_BIGNUM_DIGIT_LENGTH));9004 clear_buffer_object(lab, quot);9005 quot = C_s_a_u_i_integer_plus(&la, 2, newx, qi);9006 move_buffer_object(&la, lab[(i+1)&1], quot);9007 clear_buffer_object(lab, newx);9008 clear_buffer_object(lab, qi);90099010 if (i > 0) { /* Set z_{i-1} = [r{i}, x{i-1}] */9011 newx = bignum_extract_digits(&la, 3, x, C_fix(n * (i-1)), C_fix(n * i));9012 newy = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(n*C_BIGNUM_DIGIT_LENGTH));9013 clear_buffer_object(lab, zi);9014 zi = C_s_a_u_i_integer_plus(&la, 2, newx, newy);9015 move_buffer_object(&la, lab[(i+1)&1], zi);9016 move_buffer_object(&la, lab[(i+1)&1], quot);9017 clear_buffer_object(lab, newx);9018 clear_buffer_object(lab, newy);9019 clear_buffer_object(lab, ri);9020 }9021 }9022 clear_buffer_object(ab, x);9023 clear_buffer_object(ab, y);9024 clear_buffer_object(ab, yhi);9025 clear_buffer_object(ab, ylo);9026 clear_buffer_object(ab, zi_orig);9027 clear_buffer_object(lab, zi);90289029 if (q != NULL) {9030 if (C_truep(q_negp)) {9031 newx = C_s_a_u_i_integer_negate(&la, 1, quot);9032 clear_buffer_object(lab, quot);9033 quot = newx;9034 }9035 *q = move_buffer_object(ptr, lab, quot);9036 }9037 clear_buffer_object(lab, quot);90389039 if (r != NULL) {9040 newx = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(-shift));9041 if (C_truep(r_negp)) {9042 newy = C_s_a_u_i_integer_negate(ptr, 1, newx);9043 clear_buffer_object(lab, newx);9044 newx = newy;9045 }9046 *r = move_buffer_object(ptr, lab, newx);9047 }9048 clear_buffer_object(lab, ri);90499050 return C_SCHEME_TRUE;9051}90529053static C_regparm void9054burnikel_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)9055{9056 C_word kab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)], *ka = kab,9057 lab[2][C_SIZEOF_FIX_BIGNUM*4], *la,9058 size, tmp, less, qhat, rhat, r1, r1a3, i = 0;90599060 size = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;9061 tmp = C_s_a_i_arithmetic_shift(&ka, 2, a12, C_fix(-size));9062 less = C_i_integer_lessp(tmp, b1); /* a1 < b1 ? */9063 clear_buffer_object(kab, tmp);90649065 if (C_truep(less)) {9066 C_word atmpb[C_SIZEOF_FIX_BIGNUM*2], *atmp = atmpb, b11, b12, halfn;90679068 halfn = C_fix(C_unfix(n) >> 1);9069 b11 = bignum_extract_digits(&atmp, 3, b1, halfn, C_SCHEME_FALSE);9070 b12 = bignum_extract_digits(&atmp, 3, b1, C_fix(0), halfn);90719072 burnikel_ziegler_2n_div_1n(&ka, a12, b1, b11, b12, n, &qhat, &r1);9073 qhat = move_buffer_object(&ka, atmpb, qhat);9074 r1 = move_buffer_object(&ka, atmpb, r1);90759076 clear_buffer_object(atmpb, b11);9077 clear_buffer_object(atmpb, b12);9078 } else {9079 C_word atmpb[C_SIZEOF_FIX_BIGNUM*5], *atmp = atmpb, tmp2;90809081 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, C_fix(1), C_fix(size));9082 qhat = C_s_a_u_i_integer_minus(&ka, 2, tmp, C_fix(1)); /* B^n - 1 */9083 qhat = move_buffer_object(&ka, atmpb, qhat);9084 clear_buffer_object(atmpb, tmp);90859086 /* r1 = (a12 - b1*B^n) + b1 */9087 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, b1, C_fix(size));9088 tmp2 = C_s_a_u_i_integer_minus(&atmp, 2, a12, tmp);9089 r1 = C_s_a_u_i_integer_plus(&ka, 2, tmp2, b1);9090 r1 = move_buffer_object(&ka, atmpb, r1);9091 clear_buffer_object(atmpb, tmp);9092 clear_buffer_object(atmpb, tmp2);9093 }90949095 tmp = C_s_a_i_arithmetic_shift(&ka, 2, r1, C_fix(size));9096 clear_buffer_object(kab, r1);9097 r1a3 = C_s_a_u_i_integer_plus(&ka, 2, tmp, a3);9098 b2 = C_s_a_u_i_integer_times(&ka, 2, qhat, b2);90999100 la = lab[0];9101 rhat = C_s_a_u_i_integer_minus(&la, 2, r1a3, b2);9102 rhat = move_buffer_object(&la, kab, rhat);9103 qhat = move_buffer_object(&la, kab, qhat);91049105 clear_buffer_object(kab, tmp);9106 clear_buffer_object(kab, r1a3);9107 clear_buffer_object(kab, b2);91089109 while(C_truep(C_i_negativep(rhat))) {9110 la = lab[(++i)&1];9111 /* rhat += b */9112 r1 = C_s_a_u_i_integer_plus(&la, 2, rhat, b);9113 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9114 clear_buffer_object(lab[(i-1)&1], r1);9115 clear_buffer_object(lab[(i-1)&1], rhat);9116 clear_buffer_object(kab, rhat);9117 rhat = tmp;91189119 /* qhat -= 1 */9120 r1 = C_s_a_u_i_integer_minus(&la, 2, qhat, C_fix(1));9121 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9122 clear_buffer_object(lab[(i-1)&1], r1);9123 clear_buffer_object(lab[(i-1)&1], qhat);9124 clear_buffer_object(kab, qhat);9125 qhat = tmp;9126 }91279128 if (q != NULL) *q = move_buffer_object(ptr, lab, qhat);9129 if (r != NULL) *r = move_buffer_object(ptr, lab, rhat);9130 clear_buffer_object(lab, qhat);9131 clear_buffer_object(lab, rhat);9132}91339134static C_regparm void9135burnikel_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)9136{9137 C_word kab[2][C_SIZEOF_FIX_BIGNUM*7], *ka, a12, a3, a4,9138 q1 = C_fix(0), r1, q2 = C_fix(0), r2, *qp;9139 int stack_full = 0;91409141 C_stack_check1(stack_full = 1);91429143 n = C_unfix(n);9144 if (stack_full || (n & 1) || (n < C_BURNIKEL_ZIEGLER_THRESHOLD)) {9145 integer_divrem(ptr, a, b, q, r);9146 } else {9147 ka = kab[0];9148 a12 = bignum_extract_digits(&ka, 3, a, C_fix(n), C_SCHEME_FALSE);9149 a3 = bignum_extract_digits(&ka, 3, a, C_fix(n >> 1), C_fix(n));91509151 qp = (q == NULL) ? NULL : &q1;9152 ka = kab[1];9153 burnikel_ziegler_3n_div_2n(&ka, a12, a3, b, b1, b2, C_fix(n >> 1), qp, &r1);9154 q1 = move_buffer_object(&ka, kab[0], q1);9155 r1 = move_buffer_object(&ka, kab[0], r1);9156 clear_buffer_object(kab[0], a12);9157 clear_buffer_object(kab[0], a3);91589159 a4 = bignum_extract_digits(&ka, 3, a, C_fix(0), C_fix(n >> 1));91609161 qp = (q == NULL) ? NULL : &q2;9162 ka = kab[0];9163 burnikel_ziegler_3n_div_2n(&ka, r1, a4, b, b1, b2, C_fix(n >> 1), qp, r);9164 if (r != NULL) *r = move_buffer_object(ptr, kab[0], *r);9165 clear_buffer_object(kab[1], r1);91669167 if (q != NULL) {9168 C_word halfn_bits = (n >> 1) * C_BIGNUM_DIGIT_LENGTH;9169 r1 = C_s_a_i_arithmetic_shift(&ka, 2, q1, C_fix(halfn_bits));9170 *q = C_s_a_i_plus(ptr, 2, r1, q2); /* q = [q1, q2] */9171 *q = move_buffer_object(ptr, kab[0], *q);9172 clear_buffer_object(kab[0], r1);9173 clear_buffer_object(kab[1], q1);9174 clear_buffer_object(kab[0], q2);9175 }9176 clear_buffer_object(kab[1], a4);9177 }9178}917991809181static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y)9182{9183 C_uword *start = C_bignum_digits(x),9184 *scan = start + C_bignum_size(x),9185 rem = 0, two_digits;91869187 assert((y > 1) && (C_fitsinbignumhalfdigitp(y)));9188 while (start < scan) {9189 two_digits = (*--scan);9190 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % y;9191 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % y;9192 }9193 return rem;9194}91959196/* There doesn't seem to be a way to return two values from inline functions */9197void C_ccall C_quotient_and_remainder(C_word c, C_word *av)9198{9199 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab,9200 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE,9201 q, r, k, x, y;92029203 if (c != 4) C_bad_argc_2(c, 4, av[ 0 ]);92049205 k = av[ 1 ];9206 x = av[ 2 ];9207 y = av[ 3 ];92089209 if (!C_truep(C_i_integerp(x)))9210 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", x);9211 if (!C_truep(C_i_integerp(y)))9212 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", y);9213 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient&remainder");92149215 if (C_truep(C_i_flonump(x))) {9216 if C_truep(C_i_flonump(y)) {9217 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;92189219 C_modf(dx / dy, &tmp);9220 q = C_flonum(&a, tmp);9221 r = C_flonum(&a, dx - tmp * dy);9222 /* reuse av */9223 av[ 0 ] = C_SCHEME_UNDEFINED;9224 /* av[ 1 ] = k; */ /* stays the same */9225 av[ 2 ] = q;9226 av[ 3 ] = r;9227 C_values(4, av);9228 }9229 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9230 }9231 if (C_truep(C_i_flonump(y))) {9232 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9233 }92349235 integer_divrem(&a, x, y, &q, &r);92369237 if (C_truep(nx) || C_truep(ny)) {9238 C_word newq, newr;9239 newq = C_a_i_exact_to_inexact(&a, 1, q);9240 newr = C_a_i_exact_to_inexact(&a, 1, r);9241 clear_buffer_object(ab, q);9242 clear_buffer_object(ab, r);9243 q = newq;9244 r = newr;92459246 clear_buffer_object(ab, nx);9247 clear_buffer_object(ab, ny);9248 }9249 /* reuse av */9250 av[ 0 ] = C_SCHEME_UNDEFINED;9251 /* av[ 1 ] = k; */ /* stays the same */9252 av[ 2 ] = q;9253 av[ 3 ] = r;9254 C_values(4, av);9255}92569257void C_ccall C_u_integer_quotient_and_remainder(C_word c, C_word *av)9258{9259 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q, r;92609261 if (av[ 3 ] == C_fix(0)) C_div_by_zero_error("quotient&remainder");92629263 integer_divrem(&a, av[ 2 ], av[ 3 ], &q, &r);92649265 /* reuse av */9266 av[ 0 ] = C_SCHEME_UNDEFINED;9267 /* av[ 1 ] = k; */ /* stays the same */9268 av[ 2 ] = q;9269 av[ 3 ] = r;9270 C_values(4, av);9271}92729273C_regparm C_word9274C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)9275{9276 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, r,9277 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;92789279 if (!C_truep(C_i_integerp(x)))9280 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", x);9281 if (!C_truep(C_i_integerp(y)))9282 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", y);9283 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("remainder");92849285 if (C_truep(C_i_flonump(x))) {9286 if C_truep(C_i_flonump(y)) {9287 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;92889289 C_modf(dx / dy, &tmp);9290 return C_flonum(ptr, dx - tmp * dy);9291 }9292 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9293 }9294 if (C_truep(C_i_flonump(y))) {9295 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9296 }92979298 integer_divrem(&a, x, y, NULL, &r);92999300 if (C_truep(nx) || C_truep(ny)) {9301 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9302 clear_buffer_object(ab, r);9303 r = newr;93049305 clear_buffer_object(ab, nx);9306 clear_buffer_object(ab, ny);9307 }9308 return move_buffer_object(ptr, ab, r);9309}93109311C_regparm C_word9312C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)9313{9314 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, r;9315 if (y == C_fix(0)) C_div_by_zero_error("remainder");9316 integer_divrem(&a, x, y, NULL, &r);9317 return move_buffer_object(ptr, ab, r);9318}93199320/* Modulo's sign follows y (whereas remainder's sign follows x) */9321C_regparm C_word9322C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)9323{9324 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r,9325 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;93269327 if (!C_truep(C_i_integerp(x)))9328 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", x);9329 if (!C_truep(C_i_integerp(y)))9330 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", y);9331 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("modulo");93329333 if (C_truep(C_i_flonump(x))) {9334 if C_truep(C_i_flonump(y)) {9335 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;93369337 C_modf(dx / dy, &tmp);9338 tmp = dx - tmp * dy;9339 if ((dx > 0.0) != (dy > 0.0) && tmp != 0.0) {9340 return C_flonum(ptr, tmp + dy);9341 } else {9342 return C_flonum(ptr, tmp);9343 }9344 }9345 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9346 }9347 if (C_truep(C_i_flonump(y))) {9348 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9349 }93509351 integer_divrem(&a, x, y, NULL, &r);9352 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9353 C_word m = C_s_a_i_plus(ptr, 2, r, y);9354 m = move_buffer_object(ptr, ab, m);9355 clear_buffer_object(ab, r);9356 r = m;9357 }93589359 if (C_truep(nx) || C_truep(ny)) {9360 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9361 clear_buffer_object(ab, r);9362 r = newr;93639364 clear_buffer_object(ab, nx);9365 clear_buffer_object(ab, ny);9366 }93679368 return move_buffer_object(ptr, ab, r);9369}93709371C_regparm C_word9372C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)9373{9374 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;9375 if (y == C_fix(0)) C_div_by_zero_error("modulo");93769377 integer_divrem(&a, x, y, NULL, &r);9378 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9379 C_word m = C_s_a_u_i_integer_plus(ptr, 2, r, y);9380 m = move_buffer_object(ptr, ab, m);9381 clear_buffer_object(ab, r);9382 r = m;9383 }9384 return move_buffer_object(ptr, ab, r);9385}93869387C_regparm C_word9388C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)9389{9390 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, q,9391 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;93929393 if (!C_truep(C_i_integerp(x)))9394 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", x);9395 if (!C_truep(C_i_integerp(y)))9396 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", y);9397 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient");93989399 if (C_truep(C_i_flonump(x))) {9400 if C_truep(C_i_flonump(y)) {9401 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;94029403 C_modf(dx / dy, &tmp);9404 return C_flonum(ptr, tmp);9405 }9406 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9407 }9408 if (C_truep(C_i_flonump(y))) {9409 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9410 }94119412 integer_divrem(&a, x, y, &q, NULL);94139414 if (C_truep(nx) || C_truep(ny)) {9415 C_word newq = C_a_i_exact_to_inexact(ptr, 1, q);9416 clear_buffer_object(ab, q);9417 q = newq;94189419 clear_buffer_object(ab, nx);9420 clear_buffer_object(ab, ny);9421 }9422 return move_buffer_object(ptr, ab, q);9423}94249425C_regparm C_word9426C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y)9427{9428 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q;9429 if (y == C_fix(0)) C_div_by_zero_error("quotient");9430 integer_divrem(&a, x, y, &q, NULL);9431 return move_buffer_object(ptr, ab, q);9432}943394349435/* For help understanding this algorithm, see:9436 Knuth, Donald E., "The Art of Computer Programming",9437 volume 2, "Seminumerical Algorithms"9438 section 4.3.1, "Multiple-Precision Arithmetic".94399440 [Yeah, that's a nice book but that particular section is not9441 helpful at all, which is also pointed out by P. Brinch Hansen's9442 "Multiple-Length Division Revisited: A Tour Of The Minefield".9443 That's a more down-to-earth step-by-step explanation of the9444 algorithm. Add to this the C implementation in Hacker's Delight9445 (section 9-2, p141--142) and you may be able to grok this...9446 ...barely, if you're as math-challenged as I am -- sjamaan]94479448 This assumes that numerator >= denominator!9449*/9450static void9451bignum_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)9452{9453 C_word quotient = C_SCHEME_UNDEFINED, remainder = C_SCHEME_UNDEFINED,9454 return_rem = C_mk_nbool(r == NULL), size;94559456 if (q != NULL) {9457 size = C_fix(C_bignum_size(num) + 1 - C_bignum_size(denom));9458 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);9459 }94609461 /* An object is always required to receive the remainder */9462 size = C_fix(C_bignum_size(num) + 1);9463 remainder = C_allocate_scratch_bignum(ptr, size, r_negp, C_SCHEME_FALSE);9464 bignum_destructive_divide_full(num, denom, quotient, remainder, return_rem);94659466 /* Simplification must be done by the caller, for consistency */9467 if (q != NULL) *q = quotient;9468 if (r == NULL) {9469 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(remainder));9470 } else {9471 *r = remainder;9472 }9473}94749475/* Compare two numbers as ratnums. Either may be rat-, fix- or bignums */9476static C_word rat_cmp(C_word x, C_word y)9477{9478 C_word ab[C_SIZEOF_FIX_BIGNUM*4], *a = ab, x1, x2, y1, y2,9479 s, t, ssize, tsize, result, negp;9480 C_uword *scan;94819482 /* Check for 1 or 0; if x or y is this, the other must be the ratnum */9483 if (x == C_fix(0)) { /* Only the sign of y1 matters */9484 return basic_cmp(x, C_u_i_ratnum_num(y), "ratcmp", 0);9485 } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */9486 return basic_cmp(C_u_i_ratnum_denom(y), C_u_i_ratnum_num(y), "ratcmp", 0);9487 } else if (y == C_fix(0)) { /* Only the sign of x1 matters */9488 return basic_cmp(C_u_i_ratnum_num(x), y, "ratcmp", 0);9489 } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */9490 return basic_cmp(C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), "ratcmp", 0);9491 }94929493 /* Extract components x=x1/x2 and y=y1/y2 */9494 if (x & C_FIXNUM_BIT || C_truep(C_bignump(x))) {9495 x1 = x;9496 x2 = C_fix(1);9497 } else {9498 x1 = C_u_i_ratnum_num(x);9499 x2 = C_u_i_ratnum_denom(x);9500 }95019502 if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) {9503 y1 = y;9504 y2 = C_fix(1);9505 } else {9506 y1 = C_u_i_ratnum_num(y);9507 y2 = C_u_i_ratnum_denom(y);9508 }95099510 /* We only want to deal with bignums (this is tricky enough) */9511 if (x1 & C_FIXNUM_BIT) x1 = C_a_u_i_fix_to_big(&a, x1);9512 if (x2 & C_FIXNUM_BIT) x2 = C_a_u_i_fix_to_big(&a, x2);9513 if (y1 & C_FIXNUM_BIT) y1 = C_a_u_i_fix_to_big(&a, y1);9514 if (y2 & C_FIXNUM_BIT) y2 = C_a_u_i_fix_to_big(&a, y2);95159516 /* We multiply using schoolbook method, so this will be very slow in9517 * extreme cases. This is a tradeoff we make so that comparisons9518 * are inlineable, which makes a big difference for the common case.9519 */9520 ssize = C_bignum_size(x1) + C_bignum_size(y2);9521 negp = C_mk_bool(C_bignum_negativep(x1));9522 s = allocate_tmp_bignum(C_fix(ssize), negp, C_SCHEME_TRUE);9523 bignum_digits_multiply(x1, y2, s); /* Swap args if x1 < y2? */95249525 tsize = C_bignum_size(y1) + C_bignum_size(x2);9526 negp = C_mk_bool(C_bignum_negativep(y1));9527 t = allocate_tmp_bignum(C_fix(tsize), negp, C_SCHEME_TRUE);9528 bignum_digits_multiply(y1, x2, t); /* Swap args if y1 < x2? */95299530 /* Shorten the numbers if needed */9531 for (scan = C_bignum_digits(s)+ssize-1; *scan == 0; scan--) ssize--;9532 C_bignum_mutate_size(s, ssize);9533 for (scan = C_bignum_digits(t)+tsize-1; *scan == 0; scan--) tsize--;9534 C_bignum_mutate_size(t, tsize);95359536 result = C_i_bignum_cmp(s, t);95379538 free_tmp_bignum(t);9539 free_tmp_bignum(s);9540 return result;9541}95429543C_regparm double C_bignum_to_double(C_word bignum)9544{9545 double accumulator = 0;9546 C_uword *start = C_bignum_digits(bignum),9547 *scan = start + C_bignum_size(bignum);9548 while (start < scan) {9549 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9550 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9551 accumulator += (*--scan);9552 }9553 return(C_bignum_negativep(bignum) ? -accumulator : accumulator);9554}95559556C_regparm C_word9557C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x)9558{9559 int exponent;9560 double significand = frexp(C_flonum_magnitude(x), &exponent);95619562 assert(C_truep(C_u_i_fpintegerp(x)));95639564 if (exponent <= 0) {9565 return C_fix(0);9566 } else if (exponent == 1) { /* TODO: check significand * 2^exp fits fixnum? */9567 return significand < 0.0 ? C_fix(-1) : C_fix(1);9568 } else {9569 C_word size, negp = C_mk_bool(C_flonum_magnitude(x) < 0.0), result;9570 C_uword *start, *end;95719572 size = C_fix(C_BIGNUM_BITS_TO_DIGITS(exponent));9573 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);95749575 start = C_bignum_digits(result);9576 end = start + C_bignum_size(result);95779578 fabs_frexp_to_digits(exponent, fabs(significand), start, end);9579 return C_bignum_simplify(result);9580 }9581}95829583static void9584fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)9585{9586 C_uword digit, odd_bits = exp % C_BIGNUM_DIGIT_LENGTH;95879588 assert(C_isfinite(sign));9589 assert(0.5 <= sign && sign < 1); /* Guaranteed by frexp() and fabs() */9590 assert((scan - start) == C_BIGNUM_BITS_TO_DIGITS(exp));95919592 if (odd_bits > 0) { /* Handle most significant digit first */9593 sign *= (C_uword)1 << odd_bits;9594 digit = (C_uword)sign;9595 (*--scan) = digit;9596 sign -= (double)digit;9597 }95989599 while (start < scan && sign > 0) {9600 sign *= pow(2.0, C_BIGNUM_DIGIT_LENGTH);9601 digit = (C_uword)sign;9602 (*--scan) = digit;9603 sign -= (double)digit;9604 }96059606 /* Finish up by clearing any remaining, lower, digits */9607 while (start < scan)9608 (*--scan) = 0;9609}96109611/* This is a bit weird: We have to compare flonums as bignums due to9612 * precision loss on 64-bit platforms. For simplicity, we convert9613 * fixnums to bignums here.9614 */9615static C_word int_flo_cmp(C_word intnum, C_word flonum)9616{9617 C_word ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_FLONUM], *a = ab, flo_int, res;9618 double i, f;96199620 f = C_flonum_magnitude(flonum);96219622 if (C_isnan(f)) {9623 return C_SCHEME_FALSE; /* "mu" */9624 } else if (C_isinf(f)) {9625 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9626 } else {9627 f = modf(f, &i);96289629 flo_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));96309631 res = basic_cmp(intnum, flo_int, "int_flo_cmp", 0);9632 clear_buffer_object(ab, flo_int);96339634 if (res == C_fix(0)) /* Use fraction to break tie. If f > 0, x is smaller */9635 return C_fix((f > 0.0) ? -1 : ((f < 0.0) ? 1 : 0));9636 else9637 return res;9638 }9639}96409641/* For convenience (ie, to reduce the degree of mindfuck) */9642static C_word flo_int_cmp(C_word flonum, C_word intnum)9643{9644 C_word res = int_flo_cmp(intnum, flonum);9645 switch(res) {9646 case C_fix(1): return C_fix(-1);9647 case C_fix(-1): return C_fix(1);9648 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9649 }9650}96519652/* This code is a bit tedious, but it makes inline comparisons possible! */9653static C_word rat_flo_cmp(C_word ratnum, C_word flonum)9654{9655 C_word ab[C_SIZEOF_FIX_BIGNUM * 4 + C_SIZEOF_FLONUM], *a = ab,9656 num, denom, i_int, res, nscaled, iscaled, negp, shift_amount;9657 C_uword *scan;9658 double i, f;96599660 f = C_flonum_magnitude(flonum);96619662 if (C_isnan(f)) {9663 return C_SCHEME_FALSE; /* "mu" */9664 } else if (C_isinf(f)) {9665 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9666 } else {9667 /* Scale up the floating-point number to become a whole integer,9668 * and remember power of two (# of bits) to shift the numerator.9669 */9670 shift_amount = 0;96719672 /* TODO: This doesn't work for denormalized flonums! */9673 while (modf(f, &i) != 0.0) {9674 f = ldexp(f, 1);9675 shift_amount++;9676 }96779678 i = f; /* TODO: split i and f so it'll work for denormalized flonums */96799680 num = C_u_i_ratnum_num(ratnum);9681 negp = C_i_negativep(num);96829683 if (C_truep(negp) && i >= 0.0) { /* Save some time if signs differ */9684 return C_fix(-1);9685 } else if (!C_truep(negp) && i <= 0.0) { /* num is never 0 */9686 return C_fix(1);9687 } else {9688 denom = C_u_i_ratnum_denom(ratnum);9689 i_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));96909691 /* Multiply the scaled flonum integer by the denominator, and9692 * shift the numerator so that they may be directly compared. */9693 iscaled = C_s_a_u_i_integer_times(&a, 2, i_int, denom);9694 nscaled = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));96959696 /* Finally, we're ready to compare them! */9697 res = basic_cmp(nscaled, iscaled, "rat_flo_cmp", 0);9698 clear_buffer_object(ab, nscaled);9699 clear_buffer_object(ab, iscaled);9700 clear_buffer_object(ab, i_int);97019702 return res;9703 }9704 }9705}97069707static C_word flo_rat_cmp(C_word flonum, C_word ratnum)9708{9709 C_word res = rat_flo_cmp(ratnum, flonum);9710 switch(res) {9711 case C_fix(1): return C_fix(-1);9712 case C_fix(-1): return C_fix(1);9713 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9714 }9715}97169717/* The primitive comparison operator. eqp should be 1 if we're only9718 * interested in equality testing (can speed things up and in case of9719 * compnums, equality checking is the only available operation). This9720 * may return #f, in case there is no answer (for NaNs) or as a quick9721 * and dirty non-zero answer when eqp is true. Ugly but effective :)9722 */9723static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)9724{9725 if (x & C_FIXNUM_BIT) {9726 if (y & C_FIXNUM_BIT) {9727 return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0));9728 } else if (C_immediatep(y)) {9729 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9730 } else if (C_block_header(y) == C_FLONUM_TAG) {9731 return int_flo_cmp(x, y);9732 } else if (C_truep(C_bignump(y))) {9733 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9734 return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);9735 } else if (C_block_header(y) == C_RATNUM_TAG) {9736 if (eqp) return C_SCHEME_FALSE;9737 else return rat_cmp(x, y);9738 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9739 if (eqp) return C_SCHEME_FALSE;9740 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9741 } else {9742 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9743 }9744 } else if (C_immediatep(x)) {9745 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9746 } else if (C_block_header(x) == C_FLONUM_TAG) {9747 if (y & C_FIXNUM_BIT) {9748 return flo_int_cmp(x, y);9749 } else if (C_immediatep(y)) {9750 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9751 } else if (C_block_header(y) == C_FLONUM_TAG) {9752 double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);9753 if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */9754 else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));9755 } else if (C_truep(C_bignump(y))) {9756 return flo_int_cmp(x, y);9757 } else if (C_block_header(y) == C_RATNUM_TAG) {9758 return flo_rat_cmp(x, y);9759 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9760 if (eqp) return C_SCHEME_FALSE;9761 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9762 } else {9763 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9764 }9765 } else if (C_truep(C_bignump(x))) {9766 if (y & C_FIXNUM_BIT) {9767 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9768 return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));9769 } else if (C_immediatep(y)) {9770 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9771 } else if (C_block_header(y) == C_FLONUM_TAG) {9772 return int_flo_cmp(x, y);9773 } else if (C_truep(C_bignump(y))) {9774 return C_i_bignum_cmp(x, y);9775 } else if (C_block_header(y) == C_RATNUM_TAG) {9776 if (eqp) return C_SCHEME_FALSE;9777 else return rat_cmp(x, y);9778 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9779 if (eqp) return C_SCHEME_FALSE;9780 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9781 } else {9782 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9783 }9784 } else if (C_block_header(x) == C_RATNUM_TAG) {9785 if (y & C_FIXNUM_BIT) {9786 if (eqp) return C_SCHEME_FALSE;9787 else return rat_cmp(x, y);9788 } else if (C_immediatep(y)) {9789 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9790 } else if (C_block_header(y) == C_FLONUM_TAG) {9791 return rat_flo_cmp(x, y);9792 } else if (C_truep(C_bignump(y))) {9793 if (eqp) return C_SCHEME_FALSE;9794 else return rat_cmp(x, y);9795 } else if (C_block_header(y) == C_RATNUM_TAG) {9796 if (eqp) {9797 return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x),9798 C_u_i_ratnum_num(y)),9799 C_i_integer_equalp(C_u_i_ratnum_denom(x),9800 C_u_i_ratnum_denom(y))),9801 C_fix(0));9802 } else {9803 return rat_cmp(x, y);9804 }9805 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9806 if (eqp) return C_SCHEME_FALSE;9807 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9808 } else {9809 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9810 }9811 } else if (C_block_header(x) == C_CPLXNUM_TAG) {9812 if (!eqp) {9813 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x);9814 } else if (y & C_FIXNUM_BIT) {9815 return C_SCHEME_FALSE;9816 } else if (C_immediatep(y)) {9817 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9818 } else if (C_block_header(y) == C_FLONUM_TAG ||9819 C_truep(C_bignump(x)) ||9820 C_block_header(y) == C_RATNUM_TAG) {9821 return C_SCHEME_FALSE;9822 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9823 return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)),9824 C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))),9825 C_fix(0));9826 } else {9827 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9828 }9829 } else {9830 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9831 }9832}98339834static int bignum_cmp_unsigned(C_word x, C_word y)9835{9836 C_word xlen = C_bignum_size(x), ylen = C_bignum_size(y);98379838 if (xlen < ylen) {9839 return -1;9840 } else if (xlen > ylen) {9841 return 1;9842 } else if (x == y) {9843 return 0;9844 } else {9845 C_uword *startx = C_bignum_digits(x),9846 *scanx = startx + xlen,9847 *scany = C_bignum_digits(y) + ylen;98489849 while (startx < scanx) {9850 C_uword xdigit = (*--scanx), ydigit = (*--scany);9851 if (xdigit < ydigit)9852 return -1;9853 if (xdigit > ydigit)9854 return 1;9855 }9856 return 0;9857 }9858}98599860C_regparm C_word C_i_bignum_cmp(C_word x, C_word y)9861{9862 if (C_bignum_negativep(x)) {9863 if (C_bignum_negativep(y)) { /* Largest negative number is smallest */9864 return C_fix(bignum_cmp_unsigned(y, x));9865 } else {9866 return C_fix(-1);9867 }9868 } else {9869 if (C_bignum_negativep(y)) {9870 return C_fix(1);9871 } else {9872 return C_fix(bignum_cmp_unsigned(x, y));9873 }9874 }9875}98769877void C_ccall C_nequalp(C_word c, C_word *av)9878{9879 /* C_word closure = av[ 0 ]; */9880 C_word k = av[ 1 ];9881 C_word x, y, result = C_SCHEME_TRUE;98829883 c -= 2;9884 av += 2;9885 if (c == 0) C_kontinue(k, result);9886 x = *(av++);98879888 if (c == 1 && !C_truep(C_i_numberp(x)))9889 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);98909891 while(--c) {9892 y = *(av++);9893 result = C_i_nequalp(x, y);9894 if (result == C_SCHEME_FALSE) break;9895 }98969897 C_kontinue(k, result);9898}98999900C_regparm C_word C_i_nequalp(C_word x, C_word y)9901{9902 return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));9903}99049905C_regparm C_word C_i_integer_equalp(C_word x, C_word y)9906{9907 if (x & C_FIXNUM_BIT)9908 return C_mk_bool(x == y);9909 else if (y & C_FIXNUM_BIT)9910 return C_SCHEME_FALSE;9911 else9912 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(0));9913}991499159916void C_ccall C_greaterp(C_word c, C_word *av)9917{9918 C_word x, y,9919 /* closure = av[ 0 ] */9920 k = av[ 1 ],9921 result = C_SCHEME_TRUE;99229923 c -= 2;9924 av += 2;9925 if (c == 0) C_kontinue(k, result);99269927 x = *(av++);99289929 if (c == 1 && !C_truep(C_i_numberp(x)))9930 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">", x);99319932 while(--c) {9933 y = *(av++);9934 result = C_i_greaterp(x, y);9935 if (result == C_SCHEME_FALSE) break;9936 x = y;9937 }99389939 C_kontinue(k, result);9940}994199429943C_regparm C_word C_i_greaterp(C_word x, C_word y)9944{9945 return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));9946}99479948C_regparm C_word C_i_integer_greaterp(C_word x, C_word y)9949{9950 if (x & C_FIXNUM_BIT) {9951 if (y & C_FIXNUM_BIT) {9952 return C_mk_bool(C_unfix(x) > C_unfix(y));9953 } else {9954 return C_mk_bool(C_bignum_negativep(y));9955 }9956 } else if (y & C_FIXNUM_BIT) {9957 return C_mk_nbool(C_bignum_negativep(x));9958 } else {9959 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(1));9960 }9961}99629963void C_ccall C_lessp(C_word c, C_word *av)9964{9965 C_word x, y,9966 /* closure = av[ 0 ] */9967 k = av[ 1 ],9968 result = C_SCHEME_TRUE;99699970 c -= 2;9971 av += 2;9972 if (c == 0) C_kontinue(k, result);99739974 x = *(av++);99759976 if (c == 1 && !C_truep(C_i_numberp(x)))9977 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<", x);99789979 while(--c) {9980 y = *(av++);9981 result = C_i_lessp(x, y);9982 if (result == C_SCHEME_FALSE) break;9983 x = y;9984 }99859986 C_kontinue(k, result);9987}998899899990C_regparm C_word C_i_lessp(C_word x, C_word y)9991{9992 return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));9993}99949995C_regparm C_word C_i_integer_lessp(C_word x, C_word y)9996{9997 if (x & C_FIXNUM_BIT) {9998 if (y & C_FIXNUM_BIT) {9999 return C_mk_bool(C_unfix(x) < C_unfix(y));10000 } else {10001 return C_mk_nbool(C_bignum_negativep(y));10002 }10003 } else if (y & C_FIXNUM_BIT) {10004 return C_mk_bool(C_bignum_negativep(x));10005 } else {10006 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(-1));10007 }10008}1000910010void C_ccall C_greater_or_equal_p(C_word c, C_word *av)10011{10012 C_word x, y,10013 /* closure = av[ 0 ] */10014 k = av[ 1 ],10015 result = C_SCHEME_TRUE;1001610017 c -= 2;10018 av += 2;10019 if (c == 0) C_kontinue(k, result);1002010021 x = *(av++);1002210023 if (c == 1 && !C_truep(C_i_numberp(x)))10024 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">=", x);1002510026 while(--c) {10027 y = *(av++);10028 result = C_i_greater_or_equalp(x, y);10029 if (result == C_SCHEME_FALSE) break;10030 x = y;10031 }1003210033 C_kontinue(k, result);10034}100351003610037C_regparm C_word C_i_greater_or_equalp(C_word x, C_word y)10038{10039 C_word res = basic_cmp(x, y, ">=", 0);10040 return C_mk_bool(res == C_fix(0) || res == C_fix(1));10041}1004210043C_regparm C_word C_i_integer_greater_or_equalp(C_word x, C_word y)10044{10045 if (x & C_FIXNUM_BIT) {10046 if (y & C_FIXNUM_BIT) {10047 return C_mk_bool(C_unfix(x) >= C_unfix(y));10048 } else {10049 return C_mk_bool(C_bignum_negativep(y));10050 }10051 } else if (y & C_FIXNUM_BIT) {10052 return C_mk_nbool(C_bignum_negativep(x));10053 } else {10054 C_word res = C_i_bignum_cmp(x, y);10055 return C_mk_bool(res == C_fix(0) || res == C_fix(1));10056 }10057}1005810059void C_ccall C_less_or_equal_p(C_word c, C_word *av)10060{10061 C_word x, y,10062 /* closure = av[ 0 ] */10063 k = av[ 1 ],10064 result = C_SCHEME_TRUE;1006510066 c -= 2;10067 av += 2;10068 if (c == 0) C_kontinue(k, result);1006910070 x = *(av++);1007110072 if (c == 1 && !C_truep(C_i_numberp(x)))10073 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<=", x);1007410075 while(--c) {10076 y = *(av++);10077 result = C_i_less_or_equalp(x, y);10078 if (result == C_SCHEME_FALSE) break;10079 x = y;10080 }1008110082 C_kontinue(k, result);10083}100841008510086C_regparm C_word C_i_less_or_equalp(C_word x, C_word y)10087{10088 C_word res = basic_cmp(x, y, "<=", 0);10089 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10090}100911009210093C_regparm C_word C_i_integer_less_or_equalp(C_word x, C_word y)10094{10095 if (x & C_FIXNUM_BIT) {10096 if (y & C_FIXNUM_BIT) {10097 return C_mk_bool(C_unfix(x) <= C_unfix(y));10098 } else {10099 return C_mk_nbool(C_bignum_negativep(y));10100 }10101 } else if (y & C_FIXNUM_BIT) {10102 return C_mk_bool(C_bignum_negativep(x));10103 } else {10104 C_word res = C_i_bignum_cmp(x, y);10105 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10106 }10107}101081010910110void C_ccall C_gc(C_word c, C_word *av)10111{10112 C_word10113 /* closure = av[ 0 ] */10114 k = av[ 1 ];10115 int f;10116 C_word10117 arg, *p,10118 size = 0;1011910120 if(c == 3) {10121 arg = av[ 2 ];10122 f = C_truep(arg);10123 }10124 else if(c != 2) C_bad_min_argc(c, 2);10125 else f = 1;1012610127 C_save(k);10128 p = C_temporary_stack;1012910130 if(c == 3) {10131 if((arg & C_FIXNUM_BIT) != 0) size = C_unfix(arg);10132 else if(arg == C_SCHEME_END_OF_LIST) size = percentage(heap_size, C_heap_growth);10133 }1013410135 if(size && !C_heap_size_is_fixed) {10136 C_rereclaim2(size, 0);10137 C_temporary_stack = C_temporary_stack_bottom;10138 gc_2(0, p);10139 }10140 else if(f) C_fromspace_top = C_fromspace_limit;1014110142 C_reclaim((void *)gc_2, 1);10143}101441014510146void C_ccall gc_2(C_word c, C_word *av)10147{10148 C_word k = av[ 0 ];10149 C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));10150}101511015210153void C_ccall C_open_file_port(C_word c, C_word *av)10154{10155 C_word10156 /* closure = av[ 0 ] */10157 k = av[ 1 ],10158 port = av[ 2 ],10159 channel = av[ 3 ],10160 mode = av[ 4 ];10161 C_FILEPTR fp = (C_FILEPTR)NULL;10162 C_char *fmode;10163 C_word n, bv, fbv;10164 C_char *buf;10165 C_WCHAR *fbuf;1016610167 switch(channel) {10168 case C_fix(0): fp = C_stdin; break;10169 case C_fix(1): fp = C_stdout; break;10170 case C_fix(2): fp = C_stderr; break;10171 default:10172 bv = C_block_item(channel, 0);10173 buf = C_c_string(bv);10174 fbv = C_block_item(mode, 0);10175 fmode = C_c_string(fbv);10176 if (C_header_size(C_block_item(channel, 0)) - 1 != strlen(buf))10177 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", channel);10178 if (C_header_size(C_block_item(mode, 0)) - 1 != strlen(fmode))10179 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", mode);10180 fbuf = C_OS_FILENAME(bv, 0);10181 fp = C_fopen(fbuf, C_OS_FILENAME(fbv, 1));10182 }1018310184 C_set_block_item(port, 0, (C_word)fp);10185 C_kontinue(k, C_mk_bool(fp != NULL));10186}101871018810189void C_ccall C_allocate_vector(C_word c, C_word *av)10190{10191 C_word10192 /* closure = av[ 0 ] */10193 k = av[ 1 ],10194 size, init, bytes, n, *p;1019510196 if(c != 4) C_bad_argc(c, 4);1019710198 size = av[ 2 ];10199 init = av[ 3 ];10200 n = C_unfix(size);1020110202 if(n > C_HEADER_SIZE_MASK || n < 0)10203 barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1020410205 bytes = C_wordstobytes(n) + sizeof(C_word);1020610207 C_save(k);10208 C_save(size);10209 C_save(init);10210 C_save(C_fix(bytes));1021110212 if(!C_demand(C_bytestowords(bytes))) {10213 /* Allocate on heap: */10214 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10215 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1021610217 C_save(C_SCHEME_TRUE);10218 /* We explicitly pass 5 here, that's the number of things saved.10219 * That's the arguments, plus one additional thing: the mode.10220 */10221 C_reclaim((void *)allocate_vector_2, 5);10222 }1022310224 C_save(C_SCHEME_FALSE);10225 p = C_temporary_stack;10226 C_temporary_stack = C_temporary_stack_bottom;10227 allocate_vector_2(0, p);10228}102291023010231void C_ccall allocate_vector_2(C_word c, C_word *av)10232{10233 C_word10234 mode = av[ 0 ],10235 bytes = C_unfix(av[ 1 ]),10236 init = av[ 2 ],10237 size = C_unfix(av[ 3 ]),10238 k = av[ 4 ],10239 *v0, v;1024010241 if(C_truep(mode)) {10242 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10243 if(C_heap_size_is_fixed)10244 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1024510246 C_save(init);10247 C_save(k);10248 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10249 k = C_restore;10250 init = C_restore;10251 }1025210253 v0 = (C_word *)C_align((C_word)C_fromspace_top);10254 C_fromspace_top += C_align(bytes);10255 }10256 else v0 = C_alloc(C_bytestowords(bytes));1025710258 v = (C_word)v0;10259 *(v0++) = C_VECTOR_TYPE | size;10260 while(size--) *(v0++) = init;10261 C_kontinue(k, v);10262}1026310264void C_ccall C_allocate_bytevector(C_word c, C_word *av)10265{10266 C_word10267 /* closure = av[ 0 ] */10268 k = av[ 1 ],10269 size, init, align8, bytes, str, n, *p;1027010271 if(c != 4) C_bad_argc(c, 4);1027210273 size = av[ 2 ];10274 init = av[ 3 ];10275 n = C_unfix(size);1027610277 if(n > C_HEADER_SIZE_MASK || n < 0)10278 barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1027910280 bytes = n + sizeof(C_word) * 2;1028110282 C_save(k);10283 C_save(size);10284 C_save(init);10285 C_save(C_fix(bytes));1028610287 if(!C_demand(C_bytestowords(bytes))) {10288 /* Allocate on heap: */10289 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10290 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1029110292 C_save(C_SCHEME_TRUE);10293 /* We explicitly pass 5 here, that's the number of things saved.10294 * That's the arguments, plus one additional thing: the mode.10295 */10296 C_reclaim((void *)allocate_bytevector_2, 5);10297 }1029810299 C_save(C_SCHEME_FALSE);10300 p = C_temporary_stack;10301 C_temporary_stack = C_temporary_stack_bottom;10302 allocate_bytevector_2(0, p);10303}103041030510306void C_ccall allocate_bytevector_2(C_word c, C_word *av)10307{10308 C_word10309 mode = av[ 0 ],10310 bytes = C_unfix(av[ 1 ]),10311 init = av[ 2 ],10312 size = C_unfix(av[ 3 ]),10313 k = av[ 4 ],10314 *v0, v;10315 char buf[ 4 ];1031610317 if(C_truep(mode)) {10318 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10319 if(C_heap_size_is_fixed)10320 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1032110322 C_save(init);10323 C_save(k);10324 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10325 k = C_restore;10326 init = C_restore;10327 }1032810329 v0 = (C_word *)C_align((C_word)C_fromspace_top);10330 C_fromspace_top += C_align(bytes);10331 }10332 else v0 = C_alloc(C_bytestowords(bytes));1033310334#ifndef C_SIXTY_FOUR10335 if(C_aligned8(v0)) ++v0;10336#endif1033710338 v = (C_word)v0;10339 *(v0++) = C_BYTEVECTOR_TYPE | size;1034010341 if(C_truep(init)) C_memset(v0, C_unfix(init), size);1034210343 C_kontinue(k, v);10344}1034510346static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)10347{10348 C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),10349 bigvec = (C_word)(mem + C_SIZEOF_BIGNUM_WRAPPER);10350 if (mem == NULL) abort(); /* TODO: panic */1035110352 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));10353 C_set_block_item(bigvec, 0, C_truep(negp));1035410355 if (C_truep(initp)) {10356 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10357 0, C_wordstobytes(C_unfix(size)));10358 }1035910360 return C_a_i_bignum_wrapper(&mem, bigvec);10361}1036210363C_regparm C_word10364C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)10365{10366 C_word big, bigvec = C_scratch_alloc(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));1036710368 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));10369 C_set_block_item(bigvec, 0, C_truep(negp));1037010371 if (C_truep(initp)) {10372 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10373 0, C_wordstobytes(C_unfix(size)));10374 }1037510376 big = C_a_i_bignum_wrapper(ptr, bigvec);10377 C_mutate_scratch_slot(&C_internal_bignum_vector(big), bigvec);10378 return big;10379}1038010381/* Simplification: scan trailing zeroes, then return a fixnum if the10382 * value fits, or trim the bignum's length. If the bignum was stored10383 * in scratch space, we mark it as reclaimable. This means any10384 * references to the original bignum are invalid after simplification!10385 */10386C_regparm C_word C_bignum_simplify(C_word big)10387{10388 C_uword *start = C_bignum_digits(big),10389 *last_digit = start + C_bignum_size(big) - 1,10390 *scan = last_digit, tmp;10391 int length;1039210393 while (scan >= start && *scan == 0)10394 scan--;10395 length = scan - start + 1;1039610397 switch(length) {10398 case 0:10399 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10400 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10401 return C_fix(0);10402 case 1:10403 tmp = *start;10404 if (C_bignum_negativep(big) ?10405 !(tmp & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)tmp) :10406 C_ufitsinfixnump(tmp)) {10407 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10408 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10409 return C_bignum_negativep(big) ? C_fix(-(C_word)tmp) : C_fix(tmp);10410 }10411 /* FALLTHROUGH */10412 default:10413 if (scan < last_digit) C_bignum_mutate_size(big, length);10414 return big;10415 }10416}1041710418static void bignum_digits_destructive_negate(C_word result)10419{10420 C_uword *scan, *end, digit, sum;1042110422 scan = C_bignum_digits(result);10423 end = scan + C_bignum_size(result);1042410425 do {10426 digit = ~*scan;10427 sum = digit + 1;10428 *scan++ = sum;10429 } while (sum == 0 && scan < end);1043010431 for (; scan < end; scan++) {10432 *scan = ~*scan;10433 }10434}1043510436static C_uword10437bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)10438{10439 C_uword digit, p;1044010441 assert(C_fitsinbignumhalfdigitp(carry));10442 assert(C_fitsinbignumhalfdigitp(factor));1044310444 /* See fixnum_times. Substitute xlo = factor, xhi = 0, y = digit10445 * and simplify the result to reduce variable usage.10446 */10447 while (start < end) {10448 digit = (*start);1044910450 p = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;10451 carry = C_BIGNUM_DIGIT_LO_HALF(p);1045210453 p = factor * C_BIGNUM_DIGIT_HI_HALF(digit) + C_BIGNUM_DIGIT_HI_HALF(p);10454 (*start++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), carry);10455 carry = C_BIGNUM_DIGIT_HI_HALF(p);10456 }10457 return carry;10458}1045910460static C_uword10461bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator)10462{10463 C_uword digit, k = 0;10464 C_uhword q_j_hi, q_j_lo;1046510466 /* Single digit divisor case from Hacker's Delight, Figure 9-1,10467 * adapted to modify u[] in-place instead of writing to q[].10468 */10469 while (start < end) {10470 digit = (*--end);1047110472 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_HI_HALF(digit)); /* j */10473 q_j_hi = k / denominator;10474 k -= q_j_hi * denominator;1047510476 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */10477 q_j_lo = k / denominator;10478 k -= q_j_lo * denominator;1047910480 *end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);10481 }10482 return k;10483}1048410485static C_uword10486bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp)10487{10488 int shift_left = C_BIGNUM_DIGIT_LENGTH - shift_right;10489 C_uword digit, carry = negp ? ((~(C_uword)0) << shift_left) : 0;1049010491 assert(shift_right < C_BIGNUM_DIGIT_LENGTH);1049210493 while (start < end) {10494 digit = *(--end);10495 *end = (digit >> shift_right) | carry;10496 carry = digit << shift_left;10497 }10498 return carry >> shift_left; /* The bits that were shifted out to the right */10499}1050010501static C_uword10502bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left)10503{10504 C_uword carry = 0, digit;10505 int shift_right = C_BIGNUM_DIGIT_LENGTH - shift_left;1050610507 assert(shift_left < C_BIGNUM_DIGIT_LENGTH);1050810509 while (start < end) {10510 digit = *start;10511 (*start++) = (digit << shift_left) | carry;10512 carry = digit >> shift_right;10513 }10514 return carry; /* This would end up as most significant digit if it fit */10515}1051610517static C_regparm void10518bignum_digits_multiply(C_word x, C_word y, C_word result)10519{10520 C_uword product,10521 *xd = C_bignum_digits(x),10522 *yd = C_bignum_digits(y),10523 *rd = C_bignum_digits(result);10524 C_uhword carry, yj;10525 /* Lengths in halfwords */10526 int i, j, length_x = C_bignum_size(x) * 2, length_y = C_bignum_size(y) * 2;1052710528 /* From Hacker's Delight, Figure 8-1 (top part) */10529 for (j = 0; j < length_y; ++j) {10530 yj = C_uhword_ref(yd, j);10531 if (yj == 0) continue;10532 carry = 0;10533 for (i = 0; i < length_x; ++i) {10534 product = (C_uword)C_uhword_ref(xd, i) * yj +10535 (C_uword)C_uhword_ref(rd, i + j) + carry;10536 C_uhword_set(rd, i + j, product);10537 carry = C_BIGNUM_DIGIT_HI_HALF(product);10538 }10539 C_uhword_set(rd, j + length_x, carry);10540 }10541}105421054310544/* "small" is either a number that fits a halfdigit, or a power of two */10545static C_regparm void10546bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)10547{10548 C_word size, quotient, q_negp = C_mk_bool((y & C_INT_SIGN_BIT) ?10549 !(C_bignum_negativep(x)) :10550 C_bignum_negativep(x)),10551 r_negp = C_mk_bool(C_bignum_negativep(x));10552 C_uword *start, *end, remainder;10553 int shift_amount;1055410555 size = C_fix(C_bignum_size(x));10556 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);10557 bignum_digits_destructive_copy(quotient, x);1055810559 start = C_bignum_digits(quotient);10560 end = start + C_bignum_size(quotient);1056110562 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);1056310564 shift_amount = C_ilen(y) - 1;10565 if (((C_uword)1 << shift_amount) == y) { /* Power of two? Shift! */10566 remainder = bignum_digits_destructive_shift_right(start,end,shift_amount,0);10567 assert(C_ufitsinfixnump(remainder));10568 } else {10569 remainder = bignum_digits_destructive_scale_down(start, end, y);10570 assert(C_fitsinbignumhalfdigitp(remainder));10571 }1057210573 if (r != NULL) *r = C_truep(r_negp) ? C_fix(-remainder) : C_fix(remainder);10574 /* Calling this function only makes sense if quotient is needed */10575 *q = C_bignum_simplify(quotient);10576}1057710578static C_regparm void10579bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder)10580{10581 C_word length = C_bignum_size(denominator);10582 C_uword d1 = *(C_bignum_digits(denominator) + length - 1),10583 *startr = C_bignum_digits(remainder),10584 *endr = startr + C_bignum_size(remainder);10585 int shift;1058610587 shift = C_BIGNUM_DIGIT_LENGTH - C_ilen(d1); /* nlz */1058810589 /* We have to work on halfdigits, so we shift out only the necessary10590 * amount in order fill out that halfdigit (base is halved).10591 * This trick is shamelessly stolen from Gauche :)10592 * See below for part 2 of the trick.10593 */10594 if (shift >= C_BIGNUM_HALF_DIGIT_LENGTH)10595 shift -= C_BIGNUM_HALF_DIGIT_LENGTH;1059610597 /* Code below won't always set high halfdigit of quotient, so do it here. */10598 if (quotient != C_SCHEME_UNDEFINED)10599 C_bignum_digits(quotient)[C_bignum_size(quotient)-1] = 0;1060010601 bignum_digits_destructive_copy(remainder, numerator);10602 *(endr-1) = 0; /* Ensure most significant digit is initialised */10603 if (shift == 0) { /* Already normalized */10604 bignum_destructive_divide_normalized(remainder, denominator, quotient);10605 } else { /* Requires normalisation; allocate scratch denominator for this */10606 C_uword *startnd;10607 C_word ndenom;1060810609 bignum_digits_destructive_shift_left(startr, endr, shift);1061010611 ndenom = allocate_tmp_bignum(C_fix(length), C_SCHEME_FALSE, C_SCHEME_FALSE);10612 startnd = C_bignum_digits(ndenom);10613 bignum_digits_destructive_copy(ndenom, denominator);10614 bignum_digits_destructive_shift_left(startnd, startnd+length, shift);1061510616 bignum_destructive_divide_normalized(remainder, ndenom, quotient);10617 if (C_truep(return_remainder)) /* Otherwise, don't bother shifting back */10618 bignum_digits_destructive_shift_right(startr, endr, shift, 0);1061910620 free_tmp_bignum(ndenom);10621 }10622}1062310624static C_regparm void10625bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)10626{10627 C_uword *v = C_bignum_digits(big_v),10628 *u = C_bignum_digits(big_u),10629 *q = big_q == C_SCHEME_UNDEFINED ? NULL : C_bignum_digits(big_q),10630 p, /* product of estimated quotient & "denominator" */10631 hat, qhat, rhat, /* estimated quotient and remainder digit */10632 vn_1, vn_2; /* "cached" values v[n-1], v[n-2] */10633 C_word t, k; /* Two helpers: temp/final remainder and "borrow" */10634 /* We use plain ints here, which theoretically may not be enough on10635 * 64-bit for an insanely huge number, but it is a _lot_ faster.10636 */10637 int n = C_bignum_size(big_v) * 2, /* in halfwords */10638 m = (C_bignum_size(big_u) * 2) - 2; /* Correct for extra digit */10639 int i, j; /* loop vars */1064010641 /* Part 2 of Gauche's aforementioned trick: */10642 if (C_uhword_ref(v, n-1) == 0) n--;1064310644 /* These won't change during the loop, but are used in every step. */10645 vn_1 = C_uhword_ref(v, n-1);10646 vn_2 = C_uhword_ref(v, n-2);1064710648 /* See also Hacker's Delight, Figure 9-1. This is almost exactly that. */10649 for (j = m - n; j >= 0; j--) {10650 hat = C_BIGNUM_DIGIT_COMBINE(C_uhword_ref(u, j+n), C_uhword_ref(u, j+n-1));10651 if (hat == 0) {10652 if (q != NULL) C_uhword_set(q, j, 0);10653 continue;10654 }10655 qhat = hat / vn_1;10656 rhat = hat % vn_1;1065710658 /* Two whiles is faster than one big check with an OR. Thanks, Gauche! */10659 while(qhat >= ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) { qhat--; rhat += vn_1; }10660 while(qhat * vn_2 > C_BIGNUM_DIGIT_COMBINE(rhat, C_uhword_ref(u, j+n-2))10661 && rhat < ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) {10662 qhat--;10663 rhat += vn_1;10664 }1066510666 /* Multiply and subtract */10667 k = 0;10668 for (i = 0; i < n; i++) {10669 p = qhat * C_uhword_ref(v, i);10670 t = C_uhword_ref(u, i+j) - k - C_BIGNUM_DIGIT_LO_HALF(p);10671 C_uhword_set(u, i+j, t);10672 k = C_BIGNUM_DIGIT_HI_HALF(p) - (t >> C_BIGNUM_HALF_DIGIT_LENGTH);10673 }10674 t = C_uhword_ref(u,j+n) - k;10675 C_uhword_set(u, j+n, t);1067610677 if (t < 0) { /* Subtracted too much? */10678 qhat--;10679 k = 0;10680 for (i = 0; i < n; i++) {10681 t = (C_uword)C_uhword_ref(u, i+j) + C_uhword_ref(v, i) + k;10682 C_uhword_set(u, i+j, t);10683 k = t >> C_BIGNUM_HALF_DIGIT_LENGTH;10684 }10685 C_uhword_set(u, j+n, (C_uhword_ref(u, j+n) + k));10686 }10687 if (q != NULL) C_uhword_set(q, j, qhat);10688 } /* end j */10689}106901069110692/* XXX this should be an inline_allocate routine */10693void C_ccall C_string_to_symbol(C_word c, C_word *av)10694{10695 C_word10696 /* closure = av[ 0 ] */10697 k = av[ 1 ];10698 int len, key;10699 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;10700 C_char *name;1070110702 b = av[ 2 ];10703 len = C_header_size(b) - 1;10704 name = C_c_string(b);1070510706 key = hash_string(len, name, symbol_table->size, symbol_table->rand);10707 if(!C_truep(s = lookup(key, len, name, symbol_table)))10708 s = add_symbol(&a, key, b, symbol_table);1070910710 C_kontinue(k, s);10711}1071210713/* XXX this should be an inline_allocate routine */10714void C_ccall C_string_to_keyword(C_word c, C_word *av)10715{10716 C_word10717 /* closure = av[ 0 ] */10718 k = av[ 1 ];10719 int len, key;10720 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;10721 C_char *name;1072210723 b = av[ 2 ];10724 len = C_header_size(b) - 1;10725 name = C_c_string(b);10726 key = hash_string(len, name, keyword_table->size, keyword_table->rand);1072710728 if(!C_truep(s = lookup(key, len, name, keyword_table))) {10729 s = add_symbol(&a, key, b, keyword_table);10730 C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */10731 C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */10732 }10733 C_kontinue(k, s);10734}1073510736/* This will usually return a flonum, but it may also return a cplxnum10737 * consisting of two flonums, making for a total of 11 words.10738 */10739C_regparm C_word10740C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)10741{10742 if (n & C_FIXNUM_BIT) {10743 return C_flonum(ptr, (double)C_unfix(n));10744 } else if (C_immediatep(n)) {10745 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10746 } else if (C_block_header(n) == C_FLONUM_TAG) {10747 return n;10748 } else if (C_truep(C_bignump(n))) {10749 return C_a_u_i_big_to_flo(ptr, c, n);10750 } else if (C_block_header(n) == C_CPLXNUM_TAG) {10751 return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)),10752 C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n)));10753 /* The horribly painful case: ratnums */10754 } else if (C_block_header(n) == C_RATNUM_TAG) {10755 /* This tries to keep the numbers within representable ranges and10756 * tries to drop as few significant digits as possible by bringing10757 * the two numbers to within the same powers of two. See10758 * algorithms M & N in Knuth, 4.2.1.10759 */10760 C_word num = C_u_i_ratnum_num(n), denom = C_u_i_ratnum_denom(n),10761 /* e = approx. distance between the numbers in powers of 2.10762 * ie, 2^e-1 < n/d < 2^e+1 (e is the *un*biased value of10763 * e_w in M2. TODO: What if b!=2 (ie, flonum-radix isn't 2)?10764 */10765 e = integer_length_abs(num) - integer_length_abs(denom),10766 ab[C_SIZEOF_FIX_BIGNUM*5+C_SIZEOF_FLONUM], *a = ab, tmp, q, r, len,10767 shift_amount, negp = C_i_integer_negativep(num);10768 C_uword *d;10769 double res, fraction;1077010771 /* Align by shifting the smaller to the size of the larger */10772 if (e < 0) num = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(-e));10773 else if (e > 0) denom = C_s_a_i_arithmetic_shift(&a, 2, denom, C_fix(e));1077410775 /* Here, 1/2 <= n/d < 2 [N3] */10776 if (C_truep(C_i_integer_lessp(num, denom))) { /* n/d < 1? */10777 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(1));10778 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10779 num = tmp;10780 e--;10781 }1078210783 /* Here, 1 <= n/d < 2 (normalized) [N5] */10784 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));1078510786 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));10787 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10788 num = tmp;1078910790 /* Now, calculate round(num/denom). We start with a quotient&remainder */10791 integer_divrem(&a, num, denom, &q, &r);1079210793 /* We multiply the remainder by two to simulate adding 1/2 for10794 * round. However, we don't do it if num = denom (q=1,r=0) */10795 if (!((q == C_fix(1) || q == C_fix(-1)) && r == C_fix(0))) {10796 tmp = C_s_a_i_arithmetic_shift(&a, 2, r, C_fix(1));10797 clear_buffer_object(ab, r); /* "knows" shift creates fresh numbers */10798 r = tmp;10799 }1080010801 /* Now q is the quotient, but to "round" result we need to10802 * adjust. This follows the semantics of the "round" procedure:10803 * Round away from zero on positive numbers (ignoring sign). In10804 * case of exactly halfway, we round up if odd.10805 */10806 tmp = C_a_i_exact_to_inexact(&a, 1, q);10807 fraction = fabs(C_flonum_magnitude(tmp));10808 switch (basic_cmp(r, denom, "", 0)) {10809 case C_fix(0):10810 if (C_truep(C_i_oddp(q))) fraction += 1.0;10811 break;10812 case C_fix(1):10813 fraction += 1.0;10814 break;10815 default: /* if r <= denom, we're done */ break;10816 }1081710818 clear_buffer_object(ab, num);10819 clear_buffer_object(ab, denom);10820 clear_buffer_object(ab, q);10821 clear_buffer_object(ab, r);1082210823 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));10824 res = ldexp(fraction, e - shift_amount);10825 return C_flonum(ptr, C_truep(negp) ? -res : res);10826 } else {10827 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10828 }10829}108301083110832/* this is different from C_a_i_flonum_round, for R5RS compatibility */10833C_regparm C_word C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)10834{10835 double fn, i, f, i2, r;1083610837 fn = C_flonum_magnitude(n);10838 if(fn < 0.0) {10839 f = modf(-fn, &i);10840 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10841 r = -i;10842 else10843 r = -(i + 1.0);10844 }10845 else if(fn == 0.0/* || fn == -0.0*/)10846 r = fn;10847 else {10848 f = modf(fn, &i);10849 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10850 r = i;10851 else10852 r = i + 1.0;10853 }1085410855 return C_flonum(ptr, r);10856}1085710858C_regparm C_word10859C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)10860{10861 double xub, yub, r;1086210863 if (!C_truep(C_u_i_fpintegerp(x)))10864 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);10865 if (!C_truep(C_u_i_fpintegerp(y)))10866 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);1086710868 xub = C_flonum_magnitude(x);10869 yub = C_flonum_magnitude(y);1087010871 if (xub < 0.0) xub = -xub;10872 if (yub < 0.0) yub = -yub;1087310874 while(yub != 0.0) {10875 r = fmod(xub, yub);10876 xub = yub;10877 yub = r;10878 }10879 return C_flonum(p, xub);10880}1088110882/* This is Lehmer's GCD algorithm with Jebelean's quotient test, as10883 * it is presented in the paper "An Analysis of Lehmer’s Euclidean10884 * GCD Algorithm", by J. Sorenson. Fuck the ACM and their goddamn10885 * paywall; you can currently find the paper here:10886 * http://www.csie.nuk.edu.tw/~cychen/gcd/An%20analysis%20of%20Lehmer%27s%20Euclidean%20GCD%20algorithm.pdf10887 * If that URI fails, it's also explained in [MpNT, 5.2]10888 *10889 * The basic idea is to avoid divisions which yield only small10890 * quotients, in which the remainder won't reduce the numbers by10891 * much. This can be detected by dividing only the leading k bits.10892 * In our case, k = C_WORD_SIZE - 2.10893 */10894inline static void lehmer_gcd(C_word **ptr, C_word u, C_word v, C_word *x, C_word *y)10895{10896 int i_even = 1, done = 0;10897 C_word shift_amount = integer_length_abs(u) - (C_WORD_SIZE - 2),10898 ab[C_SIZEOF_BIGNUM(2)*2+C_SIZEOF_FIX_BIGNUM*2], *a = ab,10899 uhat, vhat, qhat, xnext, ynext,10900 xprev = 1, yprev = 0, xcurr = 0, ycurr = 1;1090110902 uhat = C_s_a_i_arithmetic_shift(&a, 2, u, C_fix(-shift_amount));10903 vhat = C_s_a_i_arithmetic_shift(&a, 2, v, C_fix(-shift_amount));10904 assert(uhat & C_FIXNUM_BIT); uhat = C_unfix(uhat);10905 assert(vhat & C_FIXNUM_BIT); vhat = C_unfix(vhat);1090610907 do {10908 qhat = uhat / vhat; /* Estimated quotient for this step */10909 xnext = xprev - qhat * xcurr;10910 ynext = yprev - qhat * ycurr;1091110912 /* Euclidean GCD swap on uhat and vhat (shift_amount is not needed): */10913 shift_amount = vhat;10914 vhat = uhat - qhat * vhat;10915 uhat = shift_amount;1091610917 i_even = !i_even;10918 if (i_even)10919 done = (vhat < -xnext) || ((uhat - vhat) < (ynext - ycurr));10920 else10921 done = (vhat < -ynext) || ((uhat - vhat) < (xnext - xcurr));1092210923 if (!done) {10924 xprev = xcurr; yprev = ycurr;10925 xcurr = xnext; ycurr = ynext;10926 }10927 } while (!done);1092810929 /* x = xprev * u + yprev * v */10930 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xprev), u);10931 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(yprev), v);10932 *x = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10933 *x = move_buffer_object(ptr, ab, *x);10934 clear_buffer_object(ab, uhat);10935 clear_buffer_object(ab, vhat);1093610937 /* y = xcurr * u + ycurr * v */10938 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xcurr), u);10939 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(ycurr), v);10940 *y = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10941 *y = move_buffer_object(ptr, ab, *y);10942 clear_buffer_object(ab, uhat);10943 clear_buffer_object(ab, vhat);10944}1094510946/* Because this must be inlineable (due to + and - using this for10947 * ratnums), we can't use burnikel-ziegler division here, until we10948 * have a C implementation that doesn't consume stack. However,10949 * we *can* use Lehmer's GCD.10950 */10951C_regparm C_word10952C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)10953{10954 C_word ab[2][C_SIZEOF_BIGNUM(2) * 2], *a, newx, newy, size, i = 0;1095510956 if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1095710958 a = ab[i++];10959 x = C_s_a_u_i_integer_abs(&a, 1, x);10960 y = C_s_a_u_i_integer_abs(&a, 1, y);1096110962 if (!C_truep(C_i_integer_greaterp(x, y))) {10963 newx = y; y = x; x = newx; /* Ensure loop invariant: abs(x) >= abs(y) */10964 }1096510966 while(y != C_fix(0)) {10967 assert(integer_length_abs(x) >= integer_length_abs(y));10968 /* x and y are stored in the same buffer, as well as a result */10969 a = ab[i++];10970 if (i == 2) i = 0;1097110972 if (x & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1097310974 /* First, see if we should run a Lehmer step */10975 if ((integer_length_abs(x) - integer_length_abs(y)) < C_HALF_WORD_SIZE) {10976 lehmer_gcd(&a, x, y, &newx, &newy);10977 newx = move_buffer_object(&a, ab[i], newx);10978 newy = move_buffer_object(&a, ab[i], newy);10979 clear_buffer_object(ab[i], x);10980 clear_buffer_object(ab[i], y);10981 x = newx;10982 y = newy;10983 a = ab[i++]; /* Ensure x and y get cleared correctly below */10984 if (i == 2) i = 0;10985 }1098610987 newy = C_s_a_u_i_integer_remainder(&a, 2, x, y);10988 newy = move_buffer_object(&a, ab[i], newy);10989 newx = move_buffer_object(&a, ab[i], y);10990 clear_buffer_object(ab[i], x);10991 clear_buffer_object(ab[i], y);10992 x = newx;10993 y = newy;10994 }1099510996 newx = C_s_a_u_i_integer_abs(ptr, 1, x);10997 newx = move_buffer_object(ptr, ab, newx);10998 clear_buffer_object(ab, x);10999 clear_buffer_object(ab, y);11000 return newx;11001}110021100311004C_regparm C_word11005C_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)11006{11007 if (start == end) {11008 return C_SCHEME_FALSE;11009 } else {11010 size_t nbits;11011 char *s = C_c_string(C_block_item(str, 0));11012 C_word result, size;11013 end = C_unfix(end);11014 start = C_unfix(start);11015 radix = C_unfix(radix);1101611017 assert((radix > 1) && C_fitsinbignumhalfdigitp(radix));1101811019 nbits = (end - start) * C_ilen(radix - 1);11020 size = C_BIGNUM_BITS_TO_DIGITS(nbits);11021 if (size == 1) {11022 result = C_bignum1(ptr, C_truep(negp), 0);11023 } else if (size == 2) {11024 result = C_bignum2(ptr, C_truep(negp), 0, 0);11025 } else {11026 size = C_fix(size);11027 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);11028 }1102911030 return str_to_bignum(result, s + start, s + end, radix);11031 }11032}1103311034inline static int hex_char_to_digit(int ch)11035{11036 if (ch == (int)'#') return 0; /* Hash characters in numbers are mapped to 0 */11037 else if (ch >= (int)'a') return ch - (int)'a' + 10; /* lower hex */11038 else if (ch >= (int)'A') return ch - (int)'A' + 10; /* upper hex */11039 else return ch - (int)'0'; /* decimal (OR INVALID; handled elsewhere) */11040}1104111042/* Write from digit character stream to bignum. Bignum does not need11043 * to be initialised. Returns the bignum, or a fixnum. Assumes the11044 * string contains only digits that fit within radix (checked by11045 * string->number).11046 */11047static C_regparm C_word11048str_to_bignum(C_word bignum, char *str, char *str_end, int radix)11049{11050 int radix_shift, str_digit;11051 C_uword *digits = C_bignum_digits(bignum),11052 *end_digits = digits + C_bignum_size(bignum), big_digit = 0;1105311054 /* Below, we try to save up as much as possible in big_digit, and11055 * only when it exceeds what we would be able to multiply easily, we11056 * scale up the bignum and add what we saved up.11057 */11058 radix_shift = C_ilen(radix) - 1;11059 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11060 int n = 0; /* Number of bits read so far into current big digit */1106111062 /* Read from least to most significant digit to avoid shifting or scaling */11063 while (str_end > str) {11064 str_digit = hex_char_to_digit((int)*--str_end);1106511066 big_digit |= (C_uword)str_digit << n;11067 n += radix_shift;1106811069 if (n >= C_BIGNUM_DIGIT_LENGTH) {11070 n -= C_BIGNUM_DIGIT_LENGTH;11071 *digits++ = big_digit;11072 big_digit = str_digit >> (radix_shift - n);11073 }11074 }11075 assert(n < C_BIGNUM_DIGIT_LENGTH);11076 /* If radix isn't an exact divisor of digit length, write final digit */11077 if (n > 0) *digits++ = big_digit;11078 assert(digits == end_digits);11079 } else { /* Not a power of two */11080 C_uword *last_digit = digits, factor; /* bignum starts as zero */1108111082 do {11083 factor = radix;11084 while (str < str_end && C_fitsinbignumhalfdigitp(factor)) {11085 str_digit = hex_char_to_digit((int)*str++);11086 factor *= radix;11087 big_digit = radix * big_digit + str_digit;11088 }1108911090 big_digit = bignum_digits_destructive_scale_up_with_carry(11091 digits, last_digit, factor / radix, big_digit);1109211093 if (big_digit) {11094 (*last_digit++) = big_digit; /* Move end */11095 big_digit = 0;11096 }11097 } while (str < str_end);1109811099 /* Set remaining digits to zero so bignum_simplify can do its work */11100 assert(last_digit <= end_digits);11101 while (last_digit < end_digits) *last_digit++ = 0;11102 }1110311104 return C_bignum_simplify(bignum);11105}111061110711108static C_regparm double decode_flonum_literal(C_char *str)11109{11110 C_char *eptr;11111 double flo;11112 int len = C_strlen(str);1111311114 /* We only need to be able to parse what C_flonum_to_string() emits,11115 * so we avoid too much error checking.11116 */11117 if (len == 6) { /* Only perform comparisons when necessary */11118 if (!C_strcmp(str, "-inf.0")) return -1.0 / 0.0;11119 if (!C_strcmp(str, "+inf.0")) return 1.0 / 0.0;11120 if (!C_strcmp(str, "+nan.0")) return 0.0 / 0.0;11121 }1112211123 errno = 0;11124 flo = C_strtod(str, &eptr);1112511126 if((flo == HUGE_VAL && errno != 0) ||11127 (flo == -HUGE_VAL && errno != 0) ||11128 (*eptr != '\0' && C_strcmp(eptr, ".0") != 0)) {11129 panic(C_text("could not decode flonum literal"));11130 }1113111132 return flo;11133}111341113511136static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum)11137{11138 static char *digits = "0123456789abcdef";11139 char *p;11140 C_uword shift = C_ilen(base) - 1;11141 int mask = (1 << shift) - 1;11142 if (as_flonum) {11143 buffer[68] = '\0';11144 buffer[67] = '0';11145 buffer[66] = '.';11146 } else {11147 buffer[66] = '\0';11148 }11149 p = buffer + 66;11150 if (mask == base - 1) {11151 do {11152 *(--p) = digits [ num & mask ];11153 num >>= shift;11154 } while (num);11155 } else {11156 do {11157 *(--p) = digits [ num % base ];11158 num /= base;11159 } while (num);11160 }11161 if (negp) *(--p) = '-';11162 return p;11163}111641116511166void C_ccall C_number_to_string(C_word c, C_word *av)11167{11168 C_word radix, num;1116911170 if(c == 3) {11171 radix = C_fix(10);11172 } else if(c == 4) {11173 radix = av[ 3 ];11174 if(!(radix & C_FIXNUM_BIT))11175 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);11176 } else {11177 C_bad_argc(c, 3);11178 }1117911180 num = av[ 2 ];1118111182 if(num & C_FIXNUM_BIT) {11183 C_fixnum_to_string(c, av); /* reuse av */11184 } else if (C_immediatep(num)) {11185 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);11186 } else if(C_block_header(num) == C_FLONUM_TAG) {11187 C_flonum_to_string(c, av); /* reuse av */11188 } else if (C_truep(C_bignump(num))) {11189 C_integer_to_string(c, av); /* reuse av */11190 } else {11191 C_word k = av[ 1 ];11192 try_extended_number("##sys#extended-number->string", 3, k, num, radix);11193 }11194}1119511196void C_ccall C_fixnum_to_string(C_word c, C_word *av)11197{11198 C_char *p;11199 C_word *a,11200 /* self = av[ 0 ] */11201 k = av[ 1 ],11202 num = av[ 2 ],11203 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ])),11204 neg = ((num & C_INT_SIGN_BIT) ? 1 : 0);1120511206 if (radix < 2 || radix > 16) {11207 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11208 }1120911210 num = neg ? -C_unfix(num) : C_unfix(num);11211 p = to_n_nary(num, radix, neg, 0);1121211213 num = C_strlen(p);11214 a = C_alloc(C_SIZEOF_STRING(num));11215 C_kontinue(k, C_string(&a, num, p));11216}1121711218void C_ccall C_flonum_to_string(C_word c, C_word *av)11219{11220 C_char *p;11221 double f, fa, m;11222 C_word *a,11223 /* self = av[ 0 ] */11224 k = av[ 1 ],11225 num = av[ 2 ],11226 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1122711228 f = C_flonum_magnitude(num);11229 fa = fabs(f);1123011231 /* XXX TODO: Should inexacts be printable in other bases than 10?11232 * Perhaps output a string starting with #i?11233 * Right now something like (number->string 1e40 16) results in11234 * a string that can't be read back using string->number.11235 */11236 if((radix < 2) || (radix > 16)){11237 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11238 }1123911240 if(f == 0.0 || (C_modf(f, &m) == 0.0 && log2(fa) < C_WORD_SIZE)) { /* Use fast int code */11241 if(signbit(f)) {11242 p = to_n_nary((C_uword)-f, radix, 1, 1);11243 } else {11244 p = to_n_nary((C_uword)f, radix, 0, 1);11245 }11246 } else if(C_isnan(f)) {11247 p = "+nan.0";11248 } else if(C_isinf(f)) {11249 p = f > 0 ? "+inf.0" : "-inf.0";11250 } else { /* Doesn't fit an unsigned int and not "special"; use system libc */11251 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),11252 /* XXX: flonum_print_precision */11253 (int)C_unfix(C_get_print_precision()), f);11254 buffer[STRING_BUFFER_SIZE-1] = '\0';1125511256 if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {11257 /* Already checked for these, so shouldn't happen */11258 assert(*buffer != 'i'); /* "inf" */11259 assert(*buffer != 'n'); /* "nan" */11260 /* Ensure integral flonums w/o expt are always terminated by .0 */11261#if defined(HAVE_STRLCAT) || !defined(C_strcat)11262 C_strlcat(buffer, C_text(".0"), sizeof(buffer));11263#else11264 C_strcat(buffer, C_text(".0"));11265#endif11266 }11267 p = buffer;11268 }1126911270 radix = C_strlen(p);11271 a = C_alloc(C_SIZEOF_STRING(radix));11272 radix = C_string(&a, radix, p);11273 C_kontinue(k, radix);11274}1127511276void C_ccall C_integer_to_string(C_word c, C_word *av)11277{11278 C_word11279 /* self = av[ 0 ] */11280 k = av[ 1 ],11281 num = av[ 2 ],11282 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1128311284 if (num & C_FIXNUM_BIT) {11285 C_fixnum_to_string(4, av); /* reuse av */11286 } else {11287 int len, radix_shift;11288 size_t nbits;1128911290 if ((radix < 2) || (radix > 16)) {11291 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11292 }1129311294 /* Approximation of the number of radix digits we'll need. We try11295 * to be as precise as possible to avoid memmove overhead at the end11296 * of the non-powers of two part of the conversion procedure, which11297 * we may need to do because we write strings back-to-front, and11298 * pointers must be aligned (even for byte blocks).11299 */11300 len = C_bignum_size(num)-1;1130111302 nbits = (size_t)len * C_BIGNUM_DIGIT_LENGTH;11303 nbits += C_ilen(C_bignum_digits(num)[len]);1130411305 len = C_ilen(radix)-1;11306 len = (nbits + len - 1) / len;11307 len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */1130811309 radix_shift = C_ilen(radix) - 1;11310 if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&11311 /* The power of two fast path is much faster than recursion */11312 ((C_uword)1 << radix_shift) != radix) {11313 try_extended_number("##sys#integer->string/recursive",11314 4, k, num, C_fix(radix), C_fix(len));11315 } else {11316 C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[4];1131711318 kav[ 0 ] = (C_word)NULL; /* No "self" closure */11319 kav[ 1 ] = C_closure(&ka, 4, (C_word)bignum_to_str_2,11320 k, num, C_fix(radix));11321 kav[ 2 ] = C_fix(len + 1);11322 kav[ 3 ] = C_SCHEME_FALSE; /* No initialization */11323 C_allocate_bytevector(4, kav);11324 }11325 }11326}1132711328static void bignum_to_str_2(C_word c, C_word *av)11329{11330 static char *characters = "0123456789abcdef";11331 C_word11332 self = av[ 0 ],11333 string = av[ 1 ],11334 k = C_block_item(self, 1),11335 bignum = C_block_item(self, 2),11336 radix = C_unfix(C_block_item(self, 3));11337 char11338 *buf = C_c_string(string),11339 *index = buf + C_header_size(string) - 2;11340 int radix_shift,11341 negp = (C_bignum_negativep(bignum) ? 1 : 0);11342 C_word us[ 5 ], *a = us;1134311344 *(index + 1) = '\0';11345 radix_shift = C_ilen(radix) - 1;11346 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11347 int radix_mask = radix - 1, big_digit_len = 0, radix_digit;11348 C_uword *scan, *end, big_digit = 0;1134911350 scan = C_bignum_digits(bignum);11351 end = scan + C_bignum_size(bignum);1135211353 while (scan < end) {11354 /* If radix isn't an exact divisor of digit length, handle overlap */11355 if (big_digit_len == 0) {11356 big_digit = *scan++;11357 big_digit_len = C_BIGNUM_DIGIT_LENGTH;11358 } else {11359 assert(index >= buf);11360 radix_digit = big_digit;11361 big_digit = *scan++;11362 radix_digit |= ((unsigned int)big_digit << big_digit_len) & radix_mask;11363 *index-- = characters[radix_digit];11364 big_digit >>= (radix_shift - big_digit_len);11365 big_digit_len = C_BIGNUM_DIGIT_LENGTH - (radix_shift - big_digit_len);11366 }1136711368 while(big_digit_len >= radix_shift && index >= buf) {11369 radix_digit = big_digit & radix_mask;11370 *index-- = characters[radix_digit];11371 big_digit >>= radix_shift;11372 big_digit_len -= radix_shift;11373 }11374 }1137511376 assert(big_digit < radix);1137711378 /* Final digit (like overlap at start of while loop) */11379 if (big_digit) *index-- = characters[big_digit];1138011381 if (negp) {11382 /* Loop above might've overwritten sign position with a zero */11383 if (*(index+1) == '0') *(index+1) = '-';11384 else *index-- = '-';11385 }1138611387 /* Length calculation is always precise for radix powers of two. */11388 assert(index == buf-1);11389 } else {11390 C_uword base, *start, *scan, big_digit;11391 C_word working_copy;11392 int steps, i;1139311394 working_copy = allocate_tmp_bignum(C_fix(C_bignum_size(bignum)),11395 C_mk_bool(negp), C_SCHEME_FALSE);11396 bignum_digits_destructive_copy(working_copy, bignum);1139711398 start = C_bignum_digits(working_copy);1139911400 scan = start + C_bignum_size(bignum);11401 /* Calculate the largest power of radix that fits a halfdigit:11402 * steps = log10(2^halfdigit_bits), base = 10^steps11403 */11404 for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)11405 steps++;1140611407 base /= radix; /* Back down: we overshot in the loop */1140811409 while (scan > start) {11410 big_digit = bignum_digits_destructive_scale_down(start, scan, base);1141111412 if (*(scan-1) == 0) scan--; /* Adjust if we exhausted the highest digit */1141311414 for(i = 0; i < steps && index >= buf; ++i) {11415 C_word tmp = big_digit / radix;11416 *index-- = characters[big_digit - (tmp*radix)]; /* big_digit % radix */11417 big_digit = tmp;11418 }11419 }11420 assert(index >= buf-1);11421 free_tmp_bignum(working_copy);1142211423 /* Move index onto first nonzero digit. We're writing a bignum11424 here: it can't consist of only zeroes. */11425 while(*++index == '0');1142611427 if (negp) *--index = '-';1142811429 /* Shorten with distance between start and index. */11430 if (buf != index) {11431 i = C_header_size(string) - (index - buf);11432 C_memmove(buf, index, i); /* Move start of number to beginning. */11433 buf[ i ] = '\0'; /* terminating 0 */11434 C_block_header(string) = C_BYTEVECTOR_TYPE | i; /* Mutate strlength. */11435 }11436 }1143711438 C_kontinue(k, C_a_ustring(&a, 0, string, C_fix(C_header_size(string) - 1)));11439}114401144111442/* XXX replace with inline routine */11443void C_ccall C_make_structure(C_word c, C_word *av)11444{11445 C_word11446 /* closure = av[ 0 ] */11447 k = av[ 1 ],11448 type = av[ 2 ],11449 size = c - 3,11450 *s, s0;1145111452 if(!C_demand(size + 2))11453 C_save_and_reclaim((void *)C_make_structure, c, av);1145411455 s = C_alloc(C_SIZEOF_STRUCTURE(size + 1)),11456 s0 = (C_word)s;11457 *(s++) = C_STRUCTURE_TYPE | (size + 1);11458 *(s++) = type;11459 av += 3;1146011461 while(size--)11462 *(s++) = *(av++);1146311464 C_kontinue(k, s0);11465}114661146711468/* XXX replace with inline routine */11469void C_ccall C_make_symbol(C_word c, C_word *av)11470{11471 C_word11472 /* closure = av[ 0 ] */11473 k = av[ 1 ],11474 name = av[ 2 ],11475 ab[ C_SIZEOF_SYMBOL ],11476 *a = ab,11477 s0 = (C_word)a;1147811479 *(a++) = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);11480 *(a++) = C_SCHEME_UNBOUND;11481 *(a++) = name;11482 *a = C_SCHEME_END_OF_LIST;11483 C_kontinue(k, s0);11484}114851148611487/* XXX replace with inline routine */11488void C_ccall C_make_pointer(C_word c, C_word *av)11489{11490 C_word11491 /* closure = av[ 0 ] */11492 k = av[ 1 ],11493 ab[ 2 ],11494 *a = ab,11495 p;1149611497 p = C_mpointer(&a, NULL);11498 C_kontinue(k, p);11499}115001150111502/* XXX replace with inline routine */11503void C_ccall C_make_tagged_pointer(C_word c, C_word *av)11504{11505 C_word11506 /* closure = av[ 0 ] */11507 k = av[ 1 ],11508 tag = av[ 2 ],11509 ab[ 3 ],11510 *a = ab,11511 p;1151211513 p = C_taggedmpointer(&a, tag, NULL);11514 C_kontinue(k, p);11515}115161151711518void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)11519{11520 C_word11521 /* closure = av[ 0 ] */11522 k = av[ 1 ],11523 n = av[ 2 ],11524 *p;1152511526 C_save(k);1152711528 if(!C_demand(C_bytestowords(C_unfix(n))))11529 C_reclaim((void *)generic_trampoline, 1);1153011531 p = C_temporary_stack;11532 C_temporary_stack = C_temporary_stack_bottom;11533 generic_trampoline(0, p);11534}115351153611537void C_ccall generic_trampoline(C_word c, C_word *av)11538{11539 C_word k = av[ 0 ];1154011541 C_kontinue(k, C_SCHEME_UNDEFINED);11542}115431154411545void C_ccall C_return_to_host(C_word c, C_word *av)11546{11547 C_word11548 /* closure = av[ 0 ] */11549 k = av[ 1 ];1155011551 return_to_host = 1;11552 C_save(k);11553 C_reclaim((void *)generic_trampoline, 1);11554}115551155611557void C_ccall C_get_symbol_table_info(C_word c, C_word *av)11558{11559 C_word11560 /* closure = av[ 0 ] */11561 k = av[ 1 ];11562 double d1, d2;11563 int n = 0, total;11564 C_SYMBOL_TABLE *stp;11565 C_word11566 x, y,11567 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_VECTOR(4) ],11568 *a = ab;1156911570 for(stp = symbol_table_list; stp != NULL; stp = stp->next)11571 ++n;1157211573 d1 = compute_symbol_table_load(&d2, &total);11574 x = C_flonum(&a, d1); /* load */11575 y = C_flonum(&a, d2); /* avg bucket length */11576 C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));11577}115781157911580void C_ccall C_get_memory_info(C_word c, C_word *av)11581{11582 C_word11583 /* closure = av[ 0 ] */11584 k = av[ 1 ],11585 ab[ C_SIZEOF_VECTOR(2) ],11586 *a = ab;1158711588 C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));11589}115901159111592void C_ccall C_context_switch(C_word c, C_word *av)11593{11594 C_word11595 /* closure = av[ 0 ] */11596 state = av[ 2 ],11597 n = C_header_size(state) - 1,11598 adrs = C_block_item(state, 0),11599 *av2;11600 C_proc tp = (C_proc)C_block_item(adrs,0);1160111602 /* Copy argvector because it may be mutated in-place. The state11603 * vector should not be re-invoked(?), but it can be kept alive11604 * during GC, so the mutated argvector/state slots may turn stale.11605 */11606 av2 = C_alloc(n);11607 C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word));11608 tp(n, av2);11609}116101161111612void C_ccall C_peek_signed_integer(C_word c, C_word *av)11613{11614 C_word11615 /* closure = av[ 0 ] */11616 k = av[ 1 ],11617 v = av[ 2 ],11618 index = av[ 3 ],11619 x = C_block_item(v, C_unfix(index)),11620 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1162111622 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1162311624 C_kontinue(k, C_int_to_num(&a, num));11625}116261162711628void C_ccall C_peek_unsigned_integer(C_word c, C_word *av)11629{11630 C_word11631 /* closure = av[ 0 ] */11632 k = av[ 1 ],11633 v = av[ 2 ],11634 index = av[ 3 ],11635 x = C_block_item(v, C_unfix(index)),11636 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1163711638 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1163911640 C_kontinue(k, C_unsigned_int_to_num(&a, num));11641}1164211643void C_ccall C_peek_int64(C_word c, C_word *av)11644{11645 C_word11646 /* closure = av[ 0 ] */11647 k = av[ 1 ],11648 v = av[ 2 ],11649 index = av[ 3 ],11650 x = C_block_item(v, C_unfix(index)),11651 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1165211653 C_s64 num = ((C_s64 *)C_data_pointer(v))[ C_unfix(index) ];1165411655 C_kontinue(k, C_int64_to_num(&a, num));11656}116571165811659void C_ccall C_peek_uint64(C_word c, C_word *av)11660{11661 C_word11662 /* closure = av[ 0 ] */11663 k = av[ 1 ],11664 v = av[ 2 ],11665 index = av[ 3 ],11666 x = C_block_item(v, C_unfix(index)),11667 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1166811669 C_u64 num = ((C_u64 *)C_data_pointer(v))[ C_unfix(index) ];1167011671 C_kontinue(k, C_uint64_to_num(&a, num));11672}116731167411675void C_ccall C_decode_seconds(C_word c, C_word *av)11676{11677 C_word11678 /* closure = av[ 0 ] */11679 k = av[ 1 ],11680 secs = av[ 2 ],11681 mode = av[ 3 ];11682 time_t tsecs;11683 struct tm *tmt;11684 C_word11685 ab[ C_SIZEOF_VECTOR(10) ],11686 *a = ab,11687 info;1168811689 tsecs = (time_t)C_num_to_int64(secs);1169011691 if(mode == C_SCHEME_FALSE) tmt = C_localtime(&tsecs);11692 else tmt = C_gmtime(&tsecs);1169311694 if(tmt == NULL)11695 C_kontinue(k, C_SCHEME_FALSE);1169611697 info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),11698 C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),11699 C_fix(tmt->tm_wday), C_fix(tmt->tm_yday),11700 tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,11701#ifdef C_GNU_ENV11702 /* negative for west of UTC, but we want positive */11703 C_fix(-tmt->tm_gmtoff)11704#elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)11705 C_fix(mode == C_SCHEME_FALSE ? _timezone : 0) /* does not account for DST */11706#else11707 C_fix(mode == C_SCHEME_FALSE ? timezone : 0) /* does not account for DST */11708#endif11709 );11710 C_kontinue(k, info);11711}117121171311714void C_ccall C_machine_byte_order(C_word c, C_word *av)11715{11716 C_word11717 /* closure = av[ 0 ] */11718 k = av[ 1 ];11719 char *str;11720 C_word *a, s;1172111722 if(c != 2) C_bad_argc(c, 2);1172311724#if defined(C_MACHINE_BYTE_ORDER)11725 str = C_MACHINE_BYTE_ORDER;11726#else11727 C_cblock11728 static C_word one_two_three = 123;11729 str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";11730 C_cblockend;11731#endif1173211733 a = C_alloc(C_SIZEOF_STRING(strlen(str)));11734 s = C_string2(&a, str);1173511736 C_kontinue(k, s);11737}117381173911740void C_ccall C_machine_type(C_word c, C_word *av)11741{11742 C_word11743 /* closure = av[ 0 ] */11744 k = av[ 1 ],11745 *a, s;1174611747 if(c != 2) C_bad_argc(c, 2);1174811749 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_MACHINE_TYPE)));11750 s = C_string2(&a, C_MACHINE_TYPE);1175111752 C_kontinue(k, s);11753}117541175511756void C_ccall C_software_type(C_word c, C_word *av)11757{11758 C_word11759 /* closure = av[ 0 ] */11760 k = av[ 1 ],11761 *a, s;1176211763 if(c != 2) C_bad_argc(c, 2);1176411765 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_TYPE)));11766 s = C_string2(&a, C_SOFTWARE_TYPE);1176711768 C_kontinue(k, s);11769}117701177111772void C_ccall C_build_platform(C_word c, C_word *av)11773{11774 C_word11775 /* closure = av[ 0 ] */11776 k = av[ 1 ],11777 *a, s;1177811779 if(c != 2) C_bad_argc(c, 2);1178011781 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_BUILD_PLATFORM)));11782 s = C_string2(&a, C_BUILD_PLATFORM);1178311784 C_kontinue(k, s);11785}117861178711788void C_ccall C_software_version(C_word c, C_word *av)11789{11790 C_word11791 /* closure = av[ 0 ] */11792 k = av[ 1 ],11793 *a, s;1179411795 if(c != 2) C_bad_argc(c, 2);1179611797 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_VERSION)));11798 s = C_string2(&a, C_SOFTWARE_VERSION);1179911800 C_kontinue(k, s);11801}118021180311804/* Register finalizer: */1180511806void C_ccall C_register_finalizer(C_word c, C_word *av)11807{11808 C_word11809 /* closure = av[ 0 ]) */11810 k = av[ 1 ],11811 x = av[ 2 ],11812 proc = av[ 3 ];1181311814 if(C_immediatep(x) ||11815 (!C_in_stackp(x) && !C_in_heapp(x) && !C_in_scratchspacep(x)))11816 C_kontinue(k, x); /* not GCable */1181711818 C_do_register_finalizer(x, proc);11819 C_kontinue(k, x);11820}118211182211823/*XXX could this be made static? is it used in eggs somewhere?11824 if not, declare as fcall/regparm (and static, remove from chicken.h)11825 */11826void C_ccall C_do_register_finalizer(C_word x, C_word proc)11827{11828 C_word *ptr;11829 int n, i;11830 FINALIZER_NODE *flist;1183111832 if(finalizer_free_list == NULL) {11833 if((flist = (FINALIZER_NODE *)C_malloc(sizeof(FINALIZER_NODE))) == NULL)11834 panic(C_text("out of memory - cannot allocate finalizer node"));1183511836 ++allocated_finalizer_count;11837 }11838 else {11839 flist = finalizer_free_list;11840 finalizer_free_list = flist->next;11841 }1184211843 if(finalizer_list != NULL) finalizer_list->previous = flist;1184411845 flist->previous = NULL;11846 flist->next = finalizer_list;11847 finalizer_list = flist;1184811849 if(C_in_stackp(x)) C_mutate_slot(&flist->item, x);11850 else flist->item = x;1185111852 if(C_in_stackp(proc)) C_mutate_slot(&flist->finalizer, proc);11853 else flist->finalizer = proc;1185411855 ++live_finalizer_count;11856}118571185811859/*XXX same here */11860int C_do_unregister_finalizer(C_word x)11861{11862 int n;11863 FINALIZER_NODE *flist;1186411865 for(flist = finalizer_list; flist != NULL; flist = flist->next) {11866 if(flist->item == x) {11867 if(flist->previous == NULL) finalizer_list = flist->next;11868 else flist->previous->next = flist->next;1186911870 return 1;11871 }11872 }1187311874 return 0;11875}118761187711878/* Dynamic loading of shared objects: */1187911880void C_ccall C_set_dlopen_flags(C_word c, C_word *av)11881{11882 C_word11883 /* closure = av[ 0 ] */11884 k = av[ 1 ],11885 now = av[ 2 ],11886 global = av[ 3 ];1188711888#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)11889 dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);11890#endif11891 C_kontinue(k, C_SCHEME_UNDEFINED);11892}118931189411895void C_ccall C_dload(C_word c, C_word *av)11896{11897 C_word11898 /* closure = av[ 0 ] */11899 k = av[ 1 ],11900 name = av[ 2 ],11901 entry = av[ 3 ];1190211903#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))11904 /* Force minor GC: otherwise the lf may contain pointers to stack-data11905 (stack allocated interned symbols, for example) */11906 C_save_and_reclaim_args((void *)dload_2, 3, k, name, entry);11907#endif1190811909 C_kontinue(k, C_SCHEME_FALSE);11910}119111191211913#ifdef DLOAD_2_DEFINED11914# undef DLOAD_2_DEFINED11915#endif1191611917#if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)11918# ifdef __hpux__11919# define DLOAD_2_DEFINED11920void C_ccall dload_2(C_word c, C_word *av0)11921{11922 void *handle, *p;11923 C_word11924 entry = av0[ 0 ],11925 name = av0[ 1 ],11926 k = av0[ 2 ],,11927 av[ 2 ];11928 C_char *mname = C_c_string(name);1192911930 /*11931 * C_fprintf(C_stderr,11932 * "shl_loading %s : %s\n",11933 * (char *) C_c_string(name),11934 * (char *) C_c_string(entry));11935 */1193611937 if ((handle = (void *) shl_load(mname,11938 BIND_IMMEDIATE | DYNAMIC_PATH,11939 0L)) != NULL) {11940 shl_t shl_handle = (shl_t) handle;1194111942 /*** This version does not check for C_dynamic_and_unsafe. Fix it. */11943 if (shl_findsym(&shl_handle, (char *) C_c_string(entry), TYPE_PROCEDURE, &p) == 0) {11944 current_module_name = C_strdup(mname);11945 current_module_handle = handle;1194611947 if(debug_mode) {11948 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11949 current_module_name, (C_uword)current_module_handle);11950 }1195111952 av[ 0 ] = C_SCHEME_UNDEFINED;11953 av[ 1 ] = k;11954 ((C_proc)p)(2, av); /* doesn't return */11955 } else {11956 C_dlerror = (char *) C_strerror(errno);11957 shl_unload(shl_handle);11958 }11959 } else {11960 C_dlerror = (char *) C_strerror(errno);11961 }1196211963 C_kontinue(k, C_SCHEME_FALSE);11964}11965# endif11966#endif119671196811969#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)11970# ifndef __hpux__11971# define DLOAD_2_DEFINED11972void C_ccall dload_2(C_word c, C_word *av0)11973{11974 void *handle, *p, *p2;11975 C_word11976 entry = av0[ 0 ],11977 name = av0[ 1 ],11978 k = av0[ 2 ],11979 av[ 2 ];11980 C_char *topname = (C_char *)C_c_string(entry);11981 C_char *mname = (C_char *)C_c_string(name);11982 C_char *tmp;11983 int tmp_len = 0;1198411985 if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {11986 if((p = C_dlsym(handle, topname)) == NULL) {11987 tmp_len = C_strlen(topname) + 2;11988 tmp = (C_char *)C_malloc(tmp_len);1198911990 if(tmp == NULL)11991 panic(C_text("out of memory - cannot allocate toplevel name string"));1199211993 C_strlcpy(tmp, C_text("_"), tmp_len);11994 C_strlcat(tmp, topname, tmp_len);11995 p = C_dlsym(handle, tmp);11996 C_free(tmp);11997 }1199811999 if(p != NULL) {12000 current_module_name = C_strdup(mname);12001 current_module_handle = handle;1200212003 if(debug_mode) {12004 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),12005 current_module_name, (C_uword)current_module_handle);12006 }1200712008 av[ 0 ] = C_SCHEME_UNDEFINED;12009 av[ 1 ] = k;12010 ((C_proc)p)(2, av); /* doesn't return */12011 }1201212013 C_dlclose(handle);12014 }1201512016 C_dlerror = (char *)dlerror();12017 C_kontinue(k, C_SCHEME_FALSE);12018}12019# endif12020#endif120211202212023#if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)12024# define DLOAD_2_DEFINED12025void C_ccall dload_2(C_word c, C_word *av0)12026{12027 HINSTANCE handle;12028 FARPROC p = NULL, p2;12029 C_word12030 entry = av0[ 0 ],12031 name = av0[ 1 ],12032 k = av0[ 2 ],12033 av[ 2 ];12034 C_char *topname = (C_char *)C_c_string(entry);12035 C_char *mname = (C_char *)C_c_string(name);1203612037 /* cannot use LoadLibrary on non-DLLs, so we use extension checking */12038 if (C_strlen(mname) >= 5) {12039 C_char *n = mname;12040 int l = C_strlen(mname);12041 if (C_strncmp(".dll", n+l-4, 4) &&12042 C_strncmp(".DLL", n+l-4, 4) &&12043 C_strncmp(".so", n+l-3, 3) &&12044 C_strncmp(".SO", n+l-3, 3))12045 C_kontinue(k, C_SCHEME_FALSE);12046 }1204712048 if((handle = LoadLibrary(mname)) != NULL) {12049 if ((p = GetProcAddress(handle, topname)) != NULL) {12050 current_module_name = C_strdup(mname);12051 current_module_handle = handle;1205212053 if(debug_mode) {12054 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),12055 current_module_name, (C_uword)current_module_handle);12056 }1205712058 av[ 0 ] = C_SCHEME_UNDEFINED;12059 av[ 1 ] = k;12060 ((C_proc)p)(2, av); /* doesn't return */12061 }12062 else FreeLibrary(handle);12063 }1206412065 C_dlerror = (char *) C_strerror(errno);12066 C_kontinue(k, C_SCHEME_FALSE);12067}12068#endif120691207012071void C_ccall C_become(C_word c, C_word *av)12072{12073 C_word12074 /* closure = av[ 0 ] */12075 k = av[ 1 ],12076 table = av[ 2 ],12077 tp, x, old, neu, i, *p;1207812079 i = forwarding_table_size;12080 p = forwarding_table;1208112082 for(tp = table; tp != C_SCHEME_END_OF_LIST; tp = C_u_i_cdr(tp)) {12083 x = C_u_i_car(tp);12084 old = C_u_i_car(x);12085 neu = C_u_i_cdr(x);1208612087 if(i == 0) {12088 if((forwarding_table = (C_word *)realloc(forwarding_table, (forwarding_table_size + 1) * 4 * sizeof(C_word))) == NULL)12089 panic(C_text("out of memory - cannot re-allocate forwarding table"));1209012091 i = forwarding_table_size;12092 p = forwarding_table + forwarding_table_size * 2;12093 forwarding_table_size *= 2;12094 }1209512096 *(p++) = old;12097 *(p++) = neu;12098 --i;12099 }1210012101 *p = 0;12102 C_fromspace_top = C_fromspace_limit;12103 C_save_and_reclaim_args((void *)become_2, 1, k);12104}121051210612107void C_ccall become_2(C_word c, C_word *av)12108{12109 C_word k = av[ 0 ];1211012111 *forwarding_table = 0;12112 C_kontinue(k, C_SCHEME_UNDEFINED);12113}121141211512116C_regparm C_word12117C_a_i_cpu_time(C_word **a, int c, C_word buf)12118{12119 C_word u, s = C_fix(0);1212012121#if defined(C_NONUNIX) || defined(__CYGWIN__)12122 if(CLOCKS_PER_SEC == 1000) u = clock();12123 else u = C_uint64_to_num(a, ((C_u64)clock() / CLOCKS_PER_SEC) * 1000);12124#else12125 struct rusage ru;1212612127 if(C_getrusage(RUSAGE_SELF, &ru) == -1) u = 0;12128 else {12129 u = C_uint64_to_num(a, (C_u64)ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000);12130 s = C_uint64_to_num(a, (C_u64)ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000);12131 }12132#endif1213312134 /* buf must not be in nursery */12135 C_set_block_item(buf, 0, u);12136 C_set_block_item(buf, 1, s);12137 return buf;12138}121391214012141C_regparm C_word C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak)12142{12143 C_word *loc = *a;12144 int offset, i, in = C_unfix(index);12145 *a = loc + C_SIZEOF_LOCATIVE;1214612147 loc[ 0 ] = C_LOCATIVE_TAG;1214812149 switch(C_unfix(type)) {12150 case C_SLOT_LOCATIVE: in *= sizeof(C_word); break;12151 case C_U16_LOCATIVE:12152 case C_S16_LOCATIVE: in *= 2; break;12153 case C_U32_LOCATIVE:12154 case C_F32_LOCATIVE:12155 case C_S32_LOCATIVE: in *= 4; break;12156 case C_U64_LOCATIVE:12157 case C_S64_LOCATIVE:12158 case C_F64_LOCATIVE: in *= 8; break;12159 }1216012161 offset = in + sizeof(C_header);12162 loc[ 1 ] = object + offset;12163 loc[ 2 ] = C_fix(offset);12164 loc[ 3 ] = type;12165 loc[ 4 ] = C_truep(weak) ? C_SCHEME_FALSE : object;1216612167 return (C_word)loc;12168}1216912170C_regparm C_word C_a_i_locative_ref(C_word **a, int c, C_word loc)12171{12172 C_word *ptr;1217312174 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12175 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);1217612177 ptr = (C_word *)C_block_item(loc, 0);1217812179 if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);1218012181 switch(C_unfix(C_block_item(loc, 2))) {12182 case C_SLOT_LOCATIVE: return *ptr;12183 case C_CHAR_LOCATIVE: return C_utf_decode_ptr((C_char *)ptr);12184 case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));12185 case C_S8_LOCATIVE: return C_fix(*((char *)ptr));12186 case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));12187 case C_S16_LOCATIVE: return C_fix(*((short *)ptr));12188 case C_U32_LOCATIVE: return C_unsigned_int_to_num(a, *((C_u32 *)ptr));12189 case C_S32_LOCATIVE: return C_int_to_num(a, *((C_s32 *)ptr));12190 case C_U64_LOCATIVE: return C_uint64_to_num(a, *((C_u64 *)ptr));12191 case C_S64_LOCATIVE: return C_int64_to_num(a, *((C_s64 *)ptr));12192 case C_F32_LOCATIVE: return C_flonum(a, *((float *)ptr));12193 case C_F64_LOCATIVE: return C_flonum(a, *((double *)ptr));12194 default: panic(C_text("bad locative type"));12195 }12196}1219712198C_regparm C_word C_i_locative_set(C_word loc, C_word x)12199{12200 C_word *ptr, val;1220112202 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12203 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);1220412205 ptr = (C_word *)C_block_item(loc, 0);1220612207 if(ptr == NULL)12208 barf(C_LOST_LOCATIVE_ERROR, "locative-set!", loc);1220912210 switch(C_unfix(C_block_item(loc, 2))) {12211 case C_SLOT_LOCATIVE: C_mutate(ptr, x); break;1221212213 case C_CHAR_LOCATIVE:12214 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)12215 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1221612217 /* does not check for exceeded buffer length! */12218 C_utf_encode((C_char *)ptr, C_character_code(x));12219 break;1222012221 case C_U8_LOCATIVE:12222 if((x & C_FIXNUM_BIT) == 0)12223 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1222412225 *((unsigned char *)ptr) = C_unfix(x);12226 break;1222712228 case C_S8_LOCATIVE:12229 if((x & C_FIXNUM_BIT) == 0)12230 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1223112232 *((char *)ptr) = C_unfix(x);12233 break;1223412235 case C_U16_LOCATIVE:12236 if((x & C_FIXNUM_BIT) == 0)12237 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1223812239 *((unsigned short *)ptr) = C_unfix(x);12240 break;1224112242 case C_S16_LOCATIVE:12243 if((x & C_FIXNUM_BIT) == 0)12244 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1224512246 *((short *)ptr) = C_unfix(x);12247 break;1224812249 case C_U32_LOCATIVE:12250 if(!C_truep(C_i_exact_integerp(x)))12251 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1225212253 *((C_u32 *)ptr) = C_num_to_unsigned_int(x);12254 break;1225512256 case C_S32_LOCATIVE:12257 if(!C_truep(C_i_exact_integerp(x)))12258 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1225912260 *((C_s32 *)ptr) = C_num_to_int(x);12261 break;1226212263 case C_U64_LOCATIVE:12264 if(!C_truep(C_i_exact_integerp(x)))12265 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1226612267 *((C_u64 *)ptr) = C_num_to_uint64(x);12268 break;1226912270 case C_S64_LOCATIVE:12271 if(!C_truep(C_i_exact_integerp(x)))12272 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1227312274 *((C_s64 *)ptr) = C_num_to_int64(x);12275 break;1227612277 case C_F32_LOCATIVE:12278 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12279 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1228012281 *((float *)ptr) = C_flonum_magnitude(x);12282 break;1228312284 case C_F64_LOCATIVE:12285 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12286 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1228712288 *((double *)ptr) = C_flonum_magnitude(x);12289 break;1229012291 default: panic(C_text("bad locative type"));12292 }1229312294 return C_SCHEME_UNDEFINED;12295}122961229712298C_regparm C_word C_i_locative_to_object(C_word loc)12299{12300 C_word *ptr;1230112302 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12303 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative->object", loc);1230412305 ptr = (C_word *)C_block_item(loc, 0);1230612307 if(ptr == NULL) return C_SCHEME_FALSE;12308 else return (C_word)ptr - C_unfix(C_block_item(loc, 1));12309}123101231112312C_regparm C_word C_i_locative_index(C_word loc)12313{12314 int bytes;1231512316 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12317 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-index", loc);1231812319 bytes = C_unfix(C_block_item(loc, 1)) - sizeof(C_header);1232012321 switch(C_unfix(C_block_item(loc, 2))) {12322 case C_SLOT_LOCATIVE: return C_fix(bytes/sizeof(C_word)); break;1232312324 case C_CHAR_LOCATIVE:12325 { C_word x = C_i_locative_to_object(loc);12326 if(x == C_SCHEME_FALSE)12327 barf(C_LOST_LOCATIVE_ERROR, "locative-index", loc);12328 return C_fix(C_utf_char_position(x, bytes)); }1232912330 case C_U8_LOCATIVE:12331 case C_S8_LOCATIVE: return C_fix(bytes); break;1233212333 case C_U16_LOCATIVE:12334 case C_S16_LOCATIVE: return C_fix(bytes/2); break;1233512336 case C_U32_LOCATIVE:12337 case C_S32_LOCATIVE:12338 case C_F32_LOCATIVE: return C_fix(bytes/4); break;1233912340 case C_U64_LOCATIVE:12341 case C_S64_LOCATIVE:12342 case C_F64_LOCATIVE: return C_fix(bytes/8); break;1234312344 default: panic(C_text("bad locative type"));12345 }12346}123471234812349/* GC protection of user-variables: */1235012351C_regparm void C_gc_protect(C_word **addr, int n)12352{12353 int k;1235412355 if(collectibles_top + n >= collectibles_limit) {12356 k = collectibles_limit - collectibles;12357 collectibles = (C_word **)C_realloc(collectibles, sizeof(C_word *) * k * 2);1235812359 if(collectibles == NULL)12360 panic(C_text("out of memory - cannot allocate GC protection vector"));1236112362 collectibles_top = collectibles + k;12363 collectibles_limit = collectibles + k * 2;12364 }1236512366 C_memcpy(collectibles_top, addr, n * sizeof(C_word *));12367 collectibles_top += n;12368}123691237012371C_regparm void C_gc_unprotect(int n)12372{12373 collectibles_top -= n;12374}123751237612377/* Map procedure-ptr to id or id to ptr: */1237812379C_char *C_lookup_procedure_id(void *ptr)12380{12381 LF_LIST *lfl;12382 C_PTABLE_ENTRY *pt;1238312384 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12385 pt = lfl->ptable;1238612387 if(pt != NULL) {12388 while(pt->id != NULL) {12389 if(pt->ptr == ptr) return pt->id;12390 else ++pt;12391 }12392 }12393 }1239412395 return NULL;12396}123971239812399void *C_lookup_procedure_ptr(C_char *id)12400{12401 LF_LIST *lfl;12402 C_PTABLE_ENTRY *pt;1240312404 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12405 pt = lfl->ptable;1240612407 if(pt != NULL) {12408 while(pt->id != NULL) {12409 if(!C_strcmp(id, pt->id)) return pt->ptr;12410 else ++pt;12411 }12412 }12413 }1241412415 return NULL;12416}124171241812419void C_ccall C_copy_closure(C_word c, C_word *av)12420{12421 C_word12422 /* closure = av[ 0 ] */12423 k = av[ 1 ],12424 proc = av[ 2 ],12425 *p;12426 int n = C_header_size(proc);1242712428 if(!C_demand(n + 1))12429 C_save_and_reclaim_args((void *)copy_closure_2, 2, proc, k);12430 else {12431 C_save(proc);12432 C_save(k);12433 p = C_temporary_stack;12434 C_temporary_stack = C_temporary_stack_bottom;12435 copy_closure_2(0, p);12436 }12437}124381243912440static void C_ccall copy_closure_2(C_word c, C_word *av)12441{12442 C_word12443 k = av[ 0 ],12444 proc = av[ 1 ];12445 int cells = C_header_size(proc);12446 C_word12447 *ptr = C_alloc(C_SIZEOF_CLOSURE(cells)),12448 *p = ptr;1244912450 *(p++) = C_CLOSURE_TYPE | cells;12451 /* this is only allowed because the storage is freshly allocated: */12452 C_memcpy_slots(p, C_data_pointer(proc), cells);12453 C_kontinue(k, (C_word)ptr);12454}124551245612457/* Ph'nglui mglw'nafh Cthulhu R'lyeh wgah'nagl fhtagn */1245812459void C_ccall C_call_with_cthulhu(C_word c, C_word *av)12460{12461 C_word12462 proc = av[ 2 ],12463 *a = C_alloc(C_SIZEOF_CLOSURE(1)),12464 av2[ 2 ];1246512466 av2[ 0 ] = proc;12467 av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */12468 C_do_apply(2, av2);12469}124701247112472/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)12473 These routines return #f if the operation failed due to overflow.12474 */1247512476C_regparm C_word C_i_o_fixnum_plus(C_word n1, C_word n2)12477{12478 C_word x1, x2, s;1247912480 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1248112482 x1 = C_unfix(n1);12483 x2 = C_unfix(n2);12484 s = x1 + x2;1248512486#ifdef C_SIXTY_FOUR12487 if((((s ^ x1) & (s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12488#else12489 if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12490#endif12491 else return C_fix(s);12492}124931249412495C_regparm C_word C_i_o_fixnum_difference(C_word n1, C_word n2)12496{12497 C_word x1, x2, s;1249812499 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1250012501 x1 = C_unfix(n1);12502 x2 = C_unfix(n2);12503 s = x1 - x2;1250412505#ifdef C_SIXTY_FOUR12506 if((((s ^ x1) & ~(s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12507#else12508 if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12509#endif12510 else return C_fix(s);12511}125121251312514C_regparm C_word C_i_o_fixnum_times(C_word n1, C_word n2)12515{12516 C_word x1, x2;12517 C_uword x1u, x2u;12518#ifdef C_SIXTY_FOUR12519# ifdef C_LLP12520 C_uword c = 1ULL<<63ULL;12521# else12522 C_uword c = 1UL<<63UL;12523# endif12524#else12525 C_uword c = 1UL<<31UL;12526#endif1252712528 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1252912530 if((n1 & C_INT_SIGN_BIT) == (n2 & C_INT_SIGN_BIT)) --c;1253112532 x1 = C_unfix(n1);12533 x2 = C_unfix(n2);12534 x1u = x1 < 0 ? -x1 : x1;12535 x2u = x2 < 0 ? -x2 : x2;1253612537 if(x2u != 0 && x1u > (c / x2u)) return C_SCHEME_FALSE;1253812539 x1 = x1 * x2;1254012541 if(C_fitsinfixnump(x1)) return C_fix(x1);12542 else return C_SCHEME_FALSE;12543}125441254512546C_regparm C_word C_i_o_fixnum_quotient(C_word n1, C_word n2)12547{12548 C_word x1, x2;1254912550 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1255112552 x1 = C_unfix(n1);12553 x2 = C_unfix(n2);1255412555 if(x2 == 0)12556 barf(C_DIVISION_BY_ZERO_ERROR, "fx/?");1255712558#ifdef C_SIXTY_FOUR12559 if(x1 == 0x8000000000000000L && x2 == -1) return C_SCHEME_FALSE;12560#else12561 if(x1 == 0x80000000L && x2 == -1) return C_SCHEME_FALSE;12562#endif1256312564 x1 = x1 / x2;1256512566 if(C_fitsinfixnump(x1)) return C_fix(x1);12567 else return C_SCHEME_FALSE;12568}125691257012571C_regparm C_word C_i_o_fixnum_and(C_word n1, C_word n2)12572{12573 C_uword x1, x2, r;1257412575 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1257612577 x1 = C_unfix(n1);12578 x2 = C_unfix(n2);12579 r = x1 & x2;1258012581 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12582 else return C_fix(r);12583}125841258512586C_regparm C_word C_i_o_fixnum_ior(C_word n1, C_word n2)12587{12588 C_uword x1, x2, r;1258912590 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1259112592 x1 = C_unfix(n1);12593 x2 = C_unfix(n2);12594 r = x1 | x2;1259512596 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12597 else return C_fix(r);12598}125991260012601C_regparm C_word C_i_o_fixnum_xor(C_word n1, C_word n2)12602{12603 C_uword x1, x2, r;1260412605 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1260612607 x1 = C_unfix(n1);12608 x2 = C_unfix(n2);12609 r = x1 ^ x2;1261012611 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12612 else return C_fix(r);12613}126141261512616/* decoding of literals in compressed format */1261712618static C_regparm C_uword decode_size(C_char **str)12619{12620 C_uchar **ustr = (C_uchar **)str;12621 C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */1262212623 size |= (*((*ustr)++) & 0xff) << 8;12624 size |= (*((*ustr)++) & 0xff);12625 return size;12626}126271262812629static C_regparm C_word decode_literal2(C_word **ptr, C_char **str,12630 C_word *dest)12631{12632 C_ulong bits = *((*str)++) & 0xff;12633 C_word *data, *dptr, val;12634 C_uword size;1263512636 /* vvv this can be taken out at a later stage (once it works reliably) vvv */12637 if(bits != 0xfe)12638 panic(C_text("invalid encoded literal format"));1263912640 bits = *((*str)++) & 0xff;12641 /* ^^^ */1264212643#ifdef C_SIXTY_FOUR12644 bits <<= 24 + 32;12645#else12646 bits <<= 24;12647#endif1264812649 if(bits == C_HEADER_BITS_MASK) { /* special/immediate */12650 switch(0xff & *((*str)++)) {12651 case C_BOOLEAN_BITS:12652 return C_mk_bool(*((*str)++));1265312654 case C_CHARACTER_BITS:12655 return C_make_character(decode_size(str));1265612657 case C_SCHEME_END_OF_LIST:12658 case C_SCHEME_UNDEFINED:12659 case C_SCHEME_END_OF_FILE:12660 case C_SCHEME_BROKEN_WEAK_PTR:12661 return (C_word)(*(*str - 1));1266212663 case C_FIXNUM_BIT:12664 val = (C_uword)(signed char)*((*str)++) << 24; /* always big endian */12665 val |= ((C_uword)*((*str)++) & 0xff) << 16;12666 val |= ((C_uword)*((*str)++) & 0xff) << 8;12667 val |= ((C_uword)*((*str)++) & 0xff);12668 return C_fix(val);1266912670/* XXX Handle legacy bignum encoding */12671#ifdef C_SIXTY_FOUR12672 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12673#else12674 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12675#endif12676 bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);12677 break;12678/* XXX */1267912680#ifdef C_SIXTY_FOUR12681 case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12682#else12683 case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12684#endif12685 bits = (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT);12686 break;1268712688 default:12689 panic(C_text("invalid encoded special literal"));12690 }12691 }1269212693#ifndef C_SIXTY_FOUR12694 if((bits & C_8ALIGN_BIT) != 0) {12695 /* Align _data_ on 8-byte boundary: */12696 if(C_aligned8(*ptr)) ++(*ptr);12697 }12698#endif1269912700 val = (C_word)(*ptr);1270112702 if((bits & C_SPECIALBLOCK_BIT) != 0)12703 panic(C_text("literals with special bit cannot be decoded"));1270412705 if(bits == C_FLONUM_TYPE) {12706 val = C_flonum(ptr, decode_flonum_literal(*str));12707 while(*((*str)++) != '\0'); /* skip terminating '\0' */12708 return val;12709 }1271012711 size = decode_size(str);1271212713 switch(bits) {12714 /* This cannot be encoded as a bytevector due to endianness differences */1271512716 /* XXX legacy bignum encoding: */12717 case (C_STRING_TYPE | C_BYTEBLOCK_BIT | C_GC_FORWARDING_BIT): /* This represents "exact int" */12718 /* XXX */12719 case (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */12720 /* bignums are also allocated statically */12721 val = C_static_bignum(ptr, size, *str);12722 *str += size;12723 break;1272412725 /* XXX legacy encoding: */12726 case (C_STRING_TYPE | C_BYTEBLOCK_BIT):12727 /* strings are always allocated statically */12728 val = C_static_string(ptr, size, *str);12729 *str += size;12730 break;12731 /* XXX */1273212733 case C_STRING_TYPE:12734 /* strings are always allocated statically */12735 val = C_static_string(ptr, size - 1, *str);12736 *str += size;12737 break;1273812739 case C_BYTEVECTOR_TYPE:12740 /* ... as are bytevectors */12741 val = C_static_bytevector(ptr, size, *str);12742 *str += size;12743 break;1274412745 case C_SYMBOL_TYPE:12746 if(dest == NULL)12747 panic(C_text("invalid literal symbol destination"));1274812749 if (**str == '\1') {12750 val = C_h_intern(dest, size, ++*str);12751 } else if (**str == '\2') {12752 val = C_h_intern_kw(dest, size, ++*str);12753 } else {12754 C_snprintf(buffer, sizeof(buffer), C_text("Unknown symbol subtype: %d"), (int)**str);12755 panic(buffer);12756 }12757 *str += size;12758 break;1275912760 case C_LAMBDA_INFO_TYPE:12761 /* lambda infos are always allocated statically */12762 val = C_static_lambda_info(ptr, size, *str);12763 *str += size;12764 break;1276512766 default:12767 *((*ptr)++) = C_make_header(bits, size);12768 data = *ptr;1276912770 if((bits & C_BYTEBLOCK_BIT) != 0) {12771 C_memcpy(data, *str, size);12772 size = C_align(size);12773 *str += size;12774 *ptr = (C_word *)C_align((C_word)(*ptr) + size);12775 }12776 else {12777 C_word *dptr = *ptr;12778 *ptr += size;1277912780 while(size--) {12781 *dptr = decode_literal2(ptr, str, dptr);12782 ++dptr;12783 }12784 }12785 }1278612787 return val;12788}127891279012791C_regparm C_word12792C_decode_literal(C_word **ptr, C_char *str)12793{12794 return decode_literal2(ptr, &str, NULL);12795}127961279712798void12799C_use_private_repository(C_char *path)12800{12801 private_repository = path;12802}128031280412805C_char *12806C_private_repository_path()12807{12808 return private_repository;12809}1281012811C_char *12812C_executable_pathname() {12813#ifdef SEARCH_EXE_PATH12814 return C_main_exe == NULL ? NULL : C_strdup(C_main_exe);12815#else12816 return C_resolve_executable_pathname(NULL);12817#endif12818}1281912820C_char *12821C_executable_dirname() {12822 int len;12823 C_char *path;1282412825 if((path = C_executable_pathname()) == NULL)12826 return NULL;1282712828#if defined(_WIN32) && !defined(__CYGWIN__)12829 for(len = C_strlen(path); len >= 0 && path[len] != '\\'; len--);12830#else12831 for(len = C_strlen(path); len >= 0 && path[len] != '/'; len--);12832#endif1283312834 path[len] = '\0';12835 return path;12836}1283712838C_char *12839C_resolve_executable_pathname(C_char *fname)12840{12841 int n;12842 C_WCHAR *buffer = (C_WCHAR *) C_malloc(C_MAX_PATH);1284312844 if(buffer == NULL) return NULL;1284512846#if defined(__linux__) || defined(__sun)12847 C_char linkname[64]; /* /proc/<pid>/exe */12848 pid_t pid = C_getpid();1284912850# ifdef __linux__12851 C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);12852# else12853 C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */12854# endif1285512856 n = C_readlink(linkname, buffer, C_MAX_PATH);12857 if(n < 0 || n >= C_MAX_PATH)12858 goto error;1285912860 buffer[n] = '\0';12861 return buffer;12862#elif defined(_WIN32) && !defined(__CYGWIN__)12863 n = GetModuleFileNameW(NULL, buffer, C_MAX_PATH);12864 if(n == 0 || n >= C_MAX_PATH)12865 goto error;1286612867 C_char *buf2 = C_strdup(C_utf8(buffer));12868 C_free(buffer);12869 return buf2;12870#elif defined(C_MACOSX)12871 C_char buf[C_MAX_PATH];12872 C_u32 size = C_MAX_PATH;1287312874 if(_NSGetExecutablePath(buf, &size) != 0)12875 goto error;1287612877 if(C_realpath(buf, buffer) == NULL)12878 goto error;1287912880 return buffer;12881#elif defined(__HAIKU__)12882{12883 image_info info;12884 int32 cookie = 0;1288512886 while (get_next_image_info(0, &cookie, &info) == B_OK) {12887 if (info.type == B_APP_IMAGE) {12888 C_strlcpy(buffer, info.name, C_MAX_PATH);12889 return buffer;12890 }12891 }12892}12893#elif defined(SEARCH_EXE_PATH)12894 int len;12895 C_char *path, buf[C_MAX_PATH];1289612897 /* no name given (execve) */12898 if(fname == NULL)12899 goto error;1290012901 /* absolute pathname */12902 if(fname[0] == '/') {12903 if(C_realpath(fname, buffer) == NULL)12904 goto error;12905 else12906 return buffer;12907 }1290812909 /* current directory */12910 if(C_strchr(fname, '/') != NULL) {12911 if(C_getcwd(buffer, C_MAX_PATH) == NULL)12912 goto error;1291312914 n = C_snprintf(buf, C_MAX_PATH, "%s/%s", buffer, fname);12915 if(n < 0 || n >= C_MAX_PATH)12916 goto error;1291712918 if(C_access(buf, X_OK) == 0) {12919 if(C_realpath(buf, buffer) == NULL)12920 goto error;12921 else12922 return buffer;12923 }12924 }1292512926 /* walk PATH */12927 if((path = getenv("PATH")) == NULL)12928 goto error;1292912930 do {12931 /* check PATH entry length */12932 len = C_strcspn(path, ":");12933 if(len == 0 || len >= C_MAX_PATH)12934 continue;1293512936 /* "<path>/<fname>" to buf */12937 C_strncpy(buf, path, len);12938 n = C_snprintf(buf + len, C_MAX_PATH - len, "/%s", fname);12939 if(n < 0 || n + len >= C_MAX_PATH)12940 continue;1294112942 if(C_access(buf, X_OK) != 0)12943 continue;1294412945 /* fname found, resolve links */12946 if(C_realpath(buf, buffer) != NULL)12947 return buffer;1294812949 /* seek next entry, skip colon */12950 } while (path += len, *path++);12951#else12952# error "Please either define SEARCH_EXE_PATH in Makefile.<platform> or implement C_resolve_executable_pathname for your platform!"12953#endif1295412955error:12956 C_free(buffer);12957 return NULL;12958}1295912960C_regparm C_word12961C_i_getprop(C_word sym, C_word prop, C_word def)12962{12963 C_word pl = C_symbol_plist(sym);1296412965 while(pl != C_SCHEME_END_OF_LIST) {12966 if(C_block_item(pl, 0) == prop)12967 return C_u_i_car(C_u_i_cdr(pl));12968 else pl = C_u_i_cdr(C_u_i_cdr(pl));12969 }1297012971 return def;12972}129731297412975C_regparm C_word12976C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)12977{12978 C_word pl = C_symbol_plist(sym);1297912980 /* Newly added plist? Ensure the symbol stays! */12981 if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym);1298212983 while(pl != C_SCHEME_END_OF_LIST) {12984 if(C_block_item(pl, 0) == prop) {12985 C_mutate(&C_u_i_car(C_u_i_cdr(pl)), val);12986 return val;12987 }12988 else pl = C_u_i_cdr(C_u_i_cdr(pl));12989 }1299012991 pl = C_a_pair(ptr, val, C_symbol_plist(sym));12992 pl = C_a_pair(ptr, prop, pl);12993 C_mutate_slot(&C_symbol_plist(sym), pl);12994 return val;12995}129961299712998C_regparm C_word12999C_i_get_keyword(C_word kw, C_word args, C_word def)13000{13001 while(!C_immediatep(args)) {13002 if(C_header_type(args) == C_PAIR_TYPE) {13003 if(kw == C_u_i_car(args)) {13004 args = C_u_i_cdr(args);1300513006 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)13007 return def;13008 else return C_u_i_car(args);13009 }13010 else {13011 args = C_u_i_cdr(args);1301213013 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)13014 return def;13015 else args = C_u_i_cdr(args);13016 }13017 }13018 }1301913020 return def;13021}1302213023C_word C_i_dump_statistical_profile()13024{13025 PROFILE_BUCKET *b, *b2, **bp;13026 FILE *fp;13027 C_char *k1, *k2 = NULL;13028 int n;13029 double ms;1303013031 assert(profiling);13032 assert(profile_table != NULL);1303313034 set_profile_timer(0);1303513036 profiling = 0; /* In case a SIGPROF is delivered late */13037 bp = profile_table;1303813039 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("PROFILE.%d"), C_getpid());1304013041 if(debug_mode)13042 C_dbg(C_text("debug"), C_text("dumping statistical profile to `%s'...\n"), buffer);13043 fp = fopen(buffer, "w");13044 if (fp == NULL)13045 panic(C_text("could not write profile!"));1304613047 C_fputs(C_text("statistical\n"), fp);13048 for(n = 0; n < PROFILE_TABLE_SIZE; ++n) {13049 for(b = bp[ n ]; b != NULL; b = b2) {13050 b2 = b->next;1305113052 k1 = b->key;13053 C_fputs(C_text("(|"), fp);13054 /* Dump raw C string as if it were a symbol */13055 while((k2 = C_strpbrk(k1, C_text("\\|"))) != NULL) {13056 C_fwrite(k1, 1, k2-k1, fp);13057 C_fputc('\\', fp);13058 C_fputc(*k2, fp);13059 k1 = k2+1;13060 }13061 C_fputs(k1, fp);13062 ms = (double)b->sample_count * (double)profile_frequency / 1000.0;13063 C_fprintf(fp, C_text("| " UWORD_COUNT_FORMAT_STRING " %lf)\n"),13064 b->call_count, ms);13065 C_free(b);13066 }13067 }1306813069 C_fclose(fp);13070 C_free(profile_table);13071 profile_table = NULL;1307213073 return C_SCHEME_UNDEFINED;13074}1307513076void C_ccall C_dump_heap_state(C_word c, C_word *av)13077{13078 C_word13079 /* closure = av[ 0 ] */13080 k = av[ 1 ];1308113082 /* make sure heap is compacted */13083 C_save(k);13084 C_fromspace_top = C_fromspace_limit; /* force major GC */13085 C_reclaim((void *)dump_heap_state_2, 1);13086}130871308813089static C_ulong13090hdump_hash(C_word key)13091{13092 return (C_ulong)key % HDUMP_TABLE_SIZE;13093}130941309513096static void13097hdump_count(C_word key, int n, int t)13098{13099 HDUMP_BUCKET **bp = hdump_table + hdump_hash(key);13100 HDUMP_BUCKET *b = *bp;1310113102 while(b != NULL) {13103 if(b->key == key) {13104 b->count += n;13105 b->total += t;13106 return;13107 }13108 else b = b->next;13109 }1311013111 b = (HDUMP_BUCKET *)C_malloc(sizeof(HDUMP_BUCKET));1311213113 if(b == 0)13114 panic(C_text("out of memory - can not allocate heap-dump table-bucket"));1311513116 b->next = *bp;13117 b->key = key;13118 *bp = b;13119 b->count = n;13120 b->total = t;13121}131221312313124static void C_ccall dump_heap_state_2(C_word c, C_word *av)13125{13126 C_word k = av[ 0 ];13127 HDUMP_BUCKET *b, *b2, **bp;13128 int n, bytes;13129 C_byte *scan;13130 C_SCHEME_BLOCK *sbp;13131 C_header h;13132 C_word x, key, *p;13133 int imm = 0, blk = 0;1313413135 hdump_table = (HDUMP_BUCKET **)C_malloc(HDUMP_TABLE_SIZE * sizeof(HDUMP_BUCKET *));1313613137 if(hdump_table == NULL)13138 panic(C_text("out of memory - can not allocate heap-dump table"));1313913140 C_memset(hdump_table, 0, sizeof(HDUMP_BUCKET *) * HDUMP_TABLE_SIZE);1314113142 scan = fromspace_start;1314313144 while(scan < C_fromspace_top) {13145 ++blk;13146 sbp = (C_SCHEME_BLOCK *)scan;1314713148 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13149 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1315013151 n = C_header_size(sbp);13152 h = sbp->header;13153 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13154 key = (C_word)(h & C_HEADER_BITS_MASK);13155 p = sbp->data;1315613157 if(key == C_STRUCTURE_TYPE) key = *p;1315813159 hdump_count(key, 1, bytes);1316013161 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {13162 if((h & C_SPECIALBLOCK_BIT) != 0) {13163 --n;13164 ++p;13165 }1316613167 while(n--) {13168 x = *(p++);1316913170 if(C_immediatep(x)) {13171 ++imm;1317213173 if((x & C_FIXNUM_BIT) != 0) key = C_fix(1);13174 else {13175 switch(x & C_IMMEDIATE_TYPE_BITS) {13176 case C_BOOLEAN_BITS: key = C_SCHEME_TRUE; break;13177 case C_CHARACTER_BITS: key = C_make_character('A'); break;13178 default: key = x;13179 }13180 }1318113182 hdump_count(key, 1, 0);13183 }13184 }13185 }1318613187 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13188 }1318913190 bp = hdump_table;13191 /* HACK */13192#define C_WEAK_PAIR_TYPE (C_PAIR_TYPE | C_SPECIALBLOCK_BIT)1319313194 for(n = 0; n < HDUMP_TABLE_SIZE; ++n) {13195 for(b = bp[ n ]; b != NULL; b = b2) {13196 b2 = b->next;1319713198 switch(b->key) {13199 case C_fix(1): C_fprintf(C_stderr, C_text("fixnum ")); break;13200 case C_SCHEME_TRUE: C_fprintf(C_stderr, C_text("boolean ")); break;13201 case C_SCHEME_END_OF_LIST: C_fprintf(C_stderr, C_text("null ")); break;13202 case C_SCHEME_UNDEFINED : C_fprintf(C_stderr, C_text("void ")); break;13203 case C_SCHEME_BROKEN_WEAK_PTR: C_fprintf(C_stderr, C_text("broken weak ptr")); break;13204 case C_make_character('A'): C_fprintf(C_stderr, C_text("character ")); break;13205 case C_SCHEME_END_OF_FILE: C_fprintf(C_stderr, C_text("eof ")); break;13206 case C_SCHEME_UNBOUND: C_fprintf(C_stderr, C_text("unbound ")); break;13207 case C_SYMBOL_TYPE: C_fprintf(C_stderr, C_text("symbol ")); break;13208 case C_STRING_TYPE: C_fprintf(C_stderr, C_text("string ")); break;13209 case C_PAIR_TYPE: C_fprintf(C_stderr, C_text("pair ")); break;13210 case C_CLOSURE_TYPE: C_fprintf(C_stderr, C_text("closure ")); break;13211 case C_FLONUM_TYPE: C_fprintf(C_stderr, C_text("flonum ")); break;13212 case C_PORT_TYPE: C_fprintf(C_stderr, C_text("port ")); break;13213 case C_POINTER_TYPE: C_fprintf(C_stderr, C_text("pointer ")); break;13214 case C_LOCATIVE_TYPE: C_fprintf(C_stderr, C_text("locative ")); break;13215 case C_TAGGED_POINTER_TYPE: C_fprintf(C_stderr, C_text("tagged pointer ")); break;13216 case C_LAMBDA_INFO_TYPE: C_fprintf(C_stderr, C_text("lambda info ")); break;13217 case C_WEAK_PAIR_TYPE: C_fprintf(C_stderr, C_text("weak pair ")); break;13218 case C_VECTOR_TYPE: C_fprintf(C_stderr, C_text("vector ")); break;13219 case C_BYTEVECTOR_TYPE: C_fprintf(C_stderr, C_text("bytevector ")); break;13220 case C_BIGNUM_TYPE: C_fprintf(C_stderr, C_text("bignum ")); break;13221 case C_CPLXNUM_TYPE: C_fprintf(C_stderr, C_text("cplxnum ")); break;13222 case C_RATNUM_TYPE: C_fprintf(C_stderr, C_text("ratnum ")); break;13223 /* XXX this is sort of funny: */13224 case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("bytevector ")); break;13225 default:13226 x = b->key;1322713228 if(!C_immediatep(x) && C_header_bits(x) == C_SYMBOL_TYPE) {13229 x = C_block_item(x, 1);13230 C_fprintf(C_stderr, C_text("`%.*s'"), (int)C_header_size(x), C_c_string(x));13231 }13232 else C_fprintf(C_stderr, C_text("unknown key " UWORD_FORMAT_STRING), (C_uword)b->key);13233 }1323413235 C_fprintf(C_stderr, C_text("\t%d"), b->count);1323613237 if(b->total > 0)13238 C_fprintf(C_stderr, C_text("\t%d bytes"), b->total);1323913240 C_fputc('\n', C_stderr);13241 C_free(b);13242 }13243 }1324413245 C_fprintf(C_stderr, C_text("\ntotal number of blocks: %d, immediates: %d\n"),13246 blk, imm);13247 C_free(hdump_table);13248 C_kontinue(k, C_SCHEME_UNDEFINED);13249}132501325113252static void C_ccall filter_heap_objects_2(C_word c, C_word *av)13253{13254 void *func = C_pointer_address(av[ 0 ]);13255 C_word13256 userarg = av[ 1 ],13257 vector = av[ 2 ],13258 k = av[ 3 ];13259 int n, bytes;13260 C_byte *scan;13261 C_SCHEME_BLOCK *sbp;13262 C_header h;13263 C_word *p;13264 int vecsize = C_header_size(vector);13265 typedef int (*filterfunc)(C_word x, C_word userarg);13266 filterfunc ff = (filterfunc)func;13267 int vcount = 0;1326813269 scan = fromspace_start;1327013271 while(scan < C_fromspace_top) {13272 sbp = (C_SCHEME_BLOCK *)scan;1327313274 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13275 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1327613277 n = C_header_size(sbp);13278 h = sbp->header;13279 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13280 p = sbp->data;1328113282 if(ff((C_word)sbp, userarg)) {13283 if(vcount < vecsize) {13284 C_set_block_item(vector, vcount, (C_word)sbp);13285 ++vcount;13286 }13287 else {13288 C_kontinue(k, C_fix(-1));13289 }13290 }1329113292 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13293 }1329413295 C_kontinue(k, C_fix(vcount));13296}132971329813299void C_ccall C_filter_heap_objects(C_word c, C_word *av)13300{13301 C_word13302 /* closure = av[ 0 ] */13303 k = av[ 1 ],13304 func = av[ 2 ],13305 vector = av[ 3 ],13306 userarg = av[ 4 ];1330713308 /* make sure heap is compacted */13309 C_save(k);13310 C_save(vector);13311 C_save(userarg);13312 C_save(func);13313 C_fromspace_top = C_fromspace_limit; /* force major GC */13314 C_reclaim((void *)filter_heap_objects_2, 4);13315}1331613317C_regparm C_word C_i_process_sleep(C_word n)13318{13319#if defined(_WIN32) && !defined(__CYGWIN__)13320 Sleep(C_unfix(n) * 1000);13321 return C_fix(0);13322#else13323 return C_fix(sleep(C_unfix(n)));13324#endif13325}1332613327C_regparm C_word13328C_i_file_exists_p(C_word name, C_word file, C_word dir)13329{13330#if defined(_WIN32) && !defined(__CYGWIN__)13331 struct _stat64i32 buf;13332#else13333 struct stat buf;13334#endif13335 int res;1333613337 res = C_stat(C_OS_FILENAME(name, 0), &buf);1333813339 if(res != 0) {13340 switch(errno) {13341 case ENOENT: return C_SCHEME_FALSE;13342 case EOVERFLOW: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13343 case ENOTDIR: return C_SCHEME_FALSE;13344 default: return C_fix(res);13345 }13346 }1334713348 switch(buf.st_mode & S_IFMT) {13349 case S_IFDIR: return C_truep(file) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13350 default: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13351 }13352}133531335413355C_regparm C_word13356C_i_pending_interrupt(C_word dummy)13357{13358 if(pending_interrupts_count > 0) {13359 handling_interrupts = 1; /* Lock out further forced GCs until we're done */13360 return C_fix(pending_interrupts[ --pending_interrupts_count ]);13361 } else {13362 handling_interrupts = 0; /* OK, can go on */13363 return C_SCHEME_FALSE;13364 }13365}133661336713368/* random numbers, mostly lifted from13369 https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c13370*/1337113372#ifdef __linux__13373# include <sys/syscall.h>13374#endif133751337613377#if !defined(_WIN32)13378static C_word random_urandom(C_word buf, int count)13379{13380 static int fd = -1;13381 int off = 0, r;1338213383 if(fd == -1) {13384 fd = open("/dev/urandom", O_RDONLY);1338513386 if(fd == -1) return C_SCHEME_FALSE;13387 }1338813389 while(count > 0) {13390 r = read(fd, C_data_pointer(buf) + off, count);1339113392 if(r == -1) {13393 if(errno != EINTR && errno != EAGAIN) return C_SCHEME_FALSE;13394 else r = 0;13395 }1339613397 count -= r;13398 off += r;13399 }1340013401 return C_SCHEME_TRUE;13402}13403#endif134041340513406C_word C_random_bytes(C_word buf, C_word size)13407{13408 int count = C_unfix(size);13409 int r = 0;13410 int off = 0;1341113412#if defined(__OpenBSD__) || defined(__FreeBSD__)13413 arc4random_buf(C_data_pointer(buf), count);13414#elif defined(SYS_getrandom) && defined(__NR_getrandom)13415 static int use_urandom = 0;1341613417 if(use_urandom) return random_urandom(buf, count);1341813419 while(count > 0) {13420 /* GRND_NONBLOCK = 0x0001 */13421 r = syscall(SYS_getrandom, C_data_pointer(buf) + off, count, 1);1342213423 if(r == -1) {13424 if(errno == ENOSYS) {13425 use_urandom = 1;13426 return random_urandom(buf, count);13427 }13428 else if(errno != EINTR) return C_SCHEME_FALSE;13429 else r = 0;13430 }1343113432 count -= r;13433 off += r;13434 }13435#elif defined(_WIN32) && !defined(__CYGWIN__)13436 typedef BOOLEAN (*func)(PVOID, ULONG);13437 static func RtlGenRandom = NULL;1343813439 if(RtlGenRandom == NULL) {13440 HMODULE mod = LoadLibrary("advapi32.dll");1344113442 if(mod == NULL) return C_SCHEME_FALSE;1344313444 if((RtlGenRandom = (func)GetProcAddress(mod, "SystemFunction036")) == NULL)13445 return C_SCHEME_FALSE;13446 }1344713448 if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))13449 return C_SCHEME_FALSE;13450#else13451 return random_urandom(buf, count);13452#endif1345313454 return C_SCHEME_TRUE;13455}134561345713458/* WELL512 pseudo random number generator, see also:13459 https://en.wikipedia.org/wiki/Well_equidistributed_long-period_linear13460 http://lomont.org/Math/Papers/2008/Lomont_PRNG_2008.pdf13461*/1346213463static C_uword random_word(void)13464{13465 C_uword a, b, c, d, r;13466 a = random_state[random_state_index];13467 c = random_state[(random_state_index+13)&15];13468 b = a^c^(a<<16)^(c<<15);13469 c = random_state[(random_state_index+9)&15];13470 c ^= (c>>11);13471 a = random_state[random_state_index] = b^c;13472 d = a^((a<<5)&0xDA442D24UL);13473 random_state_index = (random_state_index + 15)&15;13474 a = random_state[random_state_index];13475 random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);13476 r = random_state[random_state_index];13477 return r;13478}134791348013481static C_uword random_uniform(C_uword bound)13482{13483 C_uword r, min;1348413485 if (bound < 2) return 0;1348613487 min = (1U + ~bound) % bound; /* = 2**<wordsize> mod bound */1348813489 do r = random_word(); while (r < min);1349013491 /* r is now clamped to a set whose size mod upper_bound == 013492 * the worst case (2**<wordsize-1>+1) requires ~ 2 attempts */1349313494 return r % bound;13495}134961349713498C_regparm C_word C_random_fixnum(C_word n)13499{13500 C_word nf;1350113502 if (!(n & C_FIXNUM_BIT))13503 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "pseudo-random-integer", n);1350413505 nf = C_unfix(n);1350613507 if(nf < 0)13508 barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", n, C_fix(0));1350913510 return C_fix(random_uniform(nf));13511}135121351313514C_regparm C_word13515C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)13516{13517 C_uword *start, *end;1351813519 if(C_bignum_negativep(rn))13520 barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", rn, C_fix(0));1352113522 int len = integer_length_abs(rn);13523 C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));13524 C_word result = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);13525 C_uword *p;13526 C_uword highest_word = C_bignum_digits(rn)[C_bignum_size(rn)-1];13527 start = C_bignum_digits(result);13528 end = start + C_bignum_size(result);1352913530 for(p = start; p < (end - 1); ++p) {13531 *p = random_word();13532 len -= sizeof(C_uword);13533 }1353413535 *p = random_uniform(highest_word);13536 return C_bignum_simplify(result);13537}1353813539/*13540 * C_a_i_random_real: Generate a stream of bits uniformly at random and13541 * interpret it as the fractional part of the binary expansion of a13542 * number in [0, 1], 0.00001010011111010100...; then round it.13543 * More information on https://mumble.net/~campbell/2014/04/28/uniform-random-float13544 */1354513546static inline C_u64 random64() {13547#ifdef C_SIXTY_FOUR13548 return random_word();13549#else13550 C_u64 v = 0;13551 v |= ((C_u64) random_word()) << 32;13552 v |= (C_u64) random_word();13553 return v;13554#endif13555}1355613557#if defined(__GNUC__) && !defined(__TINYC__)13558# define clz64 __builtin_clzll13559#else13560/* https://en.wikipedia.org/wiki/Find_first_set#CLZ */13561static const C_uchar clz_table_4bit[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 };1356213563int clz32(C_u32 x)13564{13565 int n;13566 if ((x & 0xFFFF0000) == 0) {n = 16; x <<= 16;} else {n = 0;}13567 if ((x & 0xFF000000) == 0) {n += 8; x <<= 8;}13568 if ((x & 0xF0000000) == 0) {n += 4; x <<= 4;}13569 n += (int)clz_table_4bit[x >> (32-4)];13570 return n;13571}1357213573int clz64(C_u64 x)13574{13575 int y = clz32(x >> 32);1357613577 if(y == 32) return y + clz32(x);1357813579 return y;13580}13581#endif1358213583C_regparm C_word13584C_a_i_random_real(C_word **ptr, C_word n) {13585 int exponent = -64;13586 uint64_t significand;13587 unsigned shift;1358813589 while (C_unlikely((significand = random64()) == 0)) {13590 exponent -= 64;13591 if (C_unlikely(exponent < -1074))13592 return 0;13593 }1359413595 shift = clz64(significand);13596 if (shift != 0) {13597 exponent -= shift;13598 significand <<= shift;13599 significand |= (random64() >> (64 - shift));13600 }1360113602 significand |= 1;13603 return C_flonum(ptr, ldexp((double)significand, exponent));13604}1360513606C_word C_set_random_seed(C_word buf, C_word n)13607{13608 int i, nsu = C_unfix(n) / sizeof(C_uword);13609 int off = 0;1361013611 for(i = 0; i < (C_RANDOM_STATE_SIZE / sizeof(C_uword)); ++i) {13612 if(off >= nsu) off = 0;1361313614 random_state[ i ] = *((C_uword *)C_data_pointer(buf) + off);13615 ++off;13616 }1361713618 random_state_index = 0;13619 return C_SCHEME_FALSE;13620}1362113622C_word C_a_extract_struct_2(C_word **ptr, size_t sz, void *sp)13623{13624 C_word bv = C_scratch_alloc(C_SIZEOF_BYTEVECTOR(sz));13625 C_word w;13626 C_block_header_init(bv, C_make_header(C_BYTEVECTOR_TYPE, sz));13627 C_memcpy(C_data_pointer(bv), sp, sz);13628 w = C_a_i_record2(ptr, 2, C_SCHEME_FALSE, bv);13629 return w;13630}1363113632C_regparm C_word C_i_setenv(C_word var, C_word val)13633{13634#if defined(_WIN32) && !defined(__CYGWIN__)13635 C_WCHAR *wvar = C_utf16(var,0);13636 C_WCHAR *wval = val == C_SCHEME_FALSE ? NULL : C_utf16(val, 1);13637 SetEnvironmentVariableW(wvar, wval);13638 return C_fix(0);13639#elif defined(HAVE_SETENV)13640 C_char *cvar = C_c_string(var);13641 if(val == C_SCHEME_FALSE) unsetenv(C_c_string(var));13642 else setenv(C_c_string(var), C_c_string(val), 1);13643 return(C_fix(0));13644#else13645 char *sx = C_c_string(C_var),13646 *sy = (val == C_SCHEME_FALSE ? "" : C_c_string(val));13647 int n1 = C_strlen(sx), n2 = C_strlen(sy);13648 int buf_len = n1 + n2 + 2;13649 char *buf = (char *)C_malloc(buf_len);13650 if(buf == NULL) return(C_fix(0));13651 else {13652 C_strlcpy(buf, sx, buf_len);13653 C_strlcat(buf, "=", buf_len);13654 C_strlcat(buf, sy, buf_len);13655 return(C_fix(putenv(buf)));13656 }13657#endif13658}1365913660C_char *C_getenv(C_word var)13661{13662#if defined(_WIN32) && !defined(__CYGWIN__)13663 C_WCHAR *wvar = C_utf16(var, 0);13664 if(GetEnvironmentVariableW(wvar, (C_WCHAR *)buffer, STRING_BUFFER_SIZE) ==13665 0) return NULL;13666 return C_utf8((C_WCHAR *)buffer);13667#else13668 return getenv(C_c_string(var));13669#endif13670}1367113672#ifdef HAVE_CRT_EXTERNS_H13673# include <crt_externs.h>13674# define environ (*_NSGetEnviron())13675#elif !defined(_WIN32) || defined(__CYGWIN__)13676extern char **environ;13677#endif1367813679C_char *C_getenventry(int i)13680{13681#if defined(_WIN32) && !defined(__CYGWIN__)13682 C_WCHAR *env = GetEnvironmentStringsW();13683 C_WCHAR *p = env;13684 while(i--) {13685 while(*p != 0) ++p;13686 if(*(++p) == 0) return NULL;13687 }13688 C_char *s = C_strdup(C_utf8(p));13689 FreeEnvironmentStringsW(env);13690 return s;13691#else13692 return environ[ i ] == NULL ? NULL : C_strdup(environ[ i ]);13693#endif13694}