~ 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 if(n >= STRING_BUFFER_SIZE - 1) break;655 *(bptr++) = *(ptr++);656 ++n;657 }658659 if(delim) ++ptr;660661 *bptr = '\0';662 aptr = (C_char*)malloc(n + 1);663 if(!aptr) panic(C_text("cannot allocate argument buffer"));664665 C_strlcpy(aptr, bptr0, n + 1);666 C_main_argv[ C_main_argc++ ] = aptr;667 }668669 C_main_argv[ C_main_argc ] = NULL;670}671672/* simple linear congruential PRNG, to avoid OpenBSD warnings.673 https://stackoverflow.com/questions/26237419/faster-than-rand674*/675676static int g_seed;677678void C_fast_srand(int seed) { g_seed = seed; }679680/* Output value in range [0, 32767] */681int C_fast_rand(void)682{683 g_seed = (214013*g_seed+2531011);684 return (g_seed>>16)&0x7FFF;685}686687688/* Initialize runtime system: */689690int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)691{692 C_SCHEME_BLOCK *k0;693 int i;694#ifdef HAVE_SIGACTION695 struct sigaction sa;696#endif697698 /* FIXME Should have C_tzset in chicken.h? */699#if defined(__MINGW32__)700# if defined(__MINGW64_VERSION_MAJOR)701 ULONGLONG tick_count = GetTickCount64();702# else703 /* mingw doesn't yet have GetTickCount64 support */704 ULONGLONG tick_count = GetTickCount();705# endif706 C_startup_time_sec = tick_count / 1000;707 C_startup_time_msec = tick_count % 1000;708 /* Make sure _tzname, _timezone, and _daylight are set */709 _tzset();710#else711 struct timeval tv;712 C_gettimeofday(&tv, NULL);713 C_startup_time_sec = tv.tv_sec;714 C_startup_time_msec = tv.tv_usec / 1000;715 /* Make sure tzname, timezone, and daylight are set */716 tzset();717#endif718719 if(chicken_is_initialized) return 1;720 else chicken_is_initialized = 1;721722#if defined(__ANDROID__) && defined(DEBUGBUILD)723 debug_mode = 2;724#endif725726 if(debug_mode)727 C_dbg(C_text("debug"), C_text("application startup...\n"));728729 C_panic_hook = usual_panic;730 symbol_table_list = NULL;731732 symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE);733734 if(symbol_table == NULL)735 return 0;736737 keyword_table = C_new_symbol_table("kw", symbols ? symbols / 4 : DEFAULT_KEYWORD_TABLE_SIZE);738739 if(keyword_table == NULL)740 return 0;741742 page_size = 0;743 stack_size = stack ? stack : DEFAULT_STACK_SIZE;744 C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);745746 /* Allocate temporary stack: */747 temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;748 if((C_temporary_stack_limit = (C_word *)C_malloc(temporary_stack_size * sizeof(C_word))) == NULL)749 return 0;750751 C_temporary_stack_bottom = C_temporary_stack_limit + temporary_stack_size;752 C_temporary_stack = C_temporary_stack_bottom;753754 /* Allocate mutation stack: */755 mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));756757 if(mutation_stack_bottom == NULL) return 0;758759 mutation_stack_top = mutation_stack_bottom;760 mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;761 C_gc_mutation_hook = NULL;762 C_gc_trace_hook = NULL;763764 /* Initialize finalizer lists: */765 finalizer_list = NULL;766 finalizer_free_list = NULL;767 pending_finalizer_indices =768 (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));769770 if(pending_finalizer_indices == NULL) return 0;771772 /* Initialize forwarding table: */773 forwarding_table =774 (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));775776 if(forwarding_table == NULL) return 0;777778 *forwarding_table = 0;779 forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;780781 /* Setup collectibles: */782 collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);783784 if(collectibles == NULL) return 0;785786 collectibles_top = collectibles;787 collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;788 gc_root_list = NULL;789790#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)791 dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;792#else793 dlopen_flags = 0;794#endif795796#ifdef HAVE_SIGACTION797 sa.sa_flags = 0;798 sigfillset(&sa.sa_mask); /* See note in C_establish_signal_handler() */799 sa.sa_handler = global_signal_handler;800#endif801802 /* setup signal handlers */803 if(!pass_serious_signals) {804#ifdef HAVE_SIGACTION805 C_sigaction(SIGBUS, &sa, NULL);806 C_sigaction(SIGFPE, &sa, NULL);807 C_sigaction(SIGILL, &sa, NULL);808 C_sigaction(SIGSEGV, &sa, NULL);809#else810 C_signal(SIGBUS, global_signal_handler);811 C_signal(SIGILL, global_signal_handler);812 C_signal(SIGFPE, global_signal_handler);813 C_signal(SIGSEGV, global_signal_handler);814#endif815 }816817 tracked_mutation_count = mutation_count = gc_count_1 = gc_count_1_total = gc_count_2 = maximum_heap_usage = 0;818 lf_list = NULL;819 C_register_lf2(NULL, 0, create_initial_ptable());820 C_restart_trampoline = (void *)toplevel;821 trace_buffer = NULL;822 C_clear_trace_buffer();823 chicken_is_running = chicken_ran_once = 0;824 pending_interrupts_count = 0;825 handling_interrupts = 0;826 last_interrupt_latency = 0;827 C_interrupts_enabled = 1;828 C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;829 C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;830 memset(signal_mapping_table, 0, sizeof(int) * NSIG);831 C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";832 error_location = C_SCHEME_FALSE;833 C_pre_gc_hook = NULL;834 C_post_gc_hook = NULL;835 C_scratchspace_start = NULL;836 C_scratchspace_top = NULL;837 C_scratchspace_limit = NULL;838 C_scratch_usage = 0;839 scratchspace_size = 0;840 live_finalizer_count = 0;841 allocated_finalizer_count = 0;842 current_module_name = NULL;843 current_module_handle = NULL;844 callback_continuation_level = 0;845 weak_pair_chain = (C_word)NULL;846 locative_chain = (C_word)NULL;847 gc_ms = 0;848 if (!random_state_initialized) {849 C_fast_srand(time(NULL));850 random_state_initialized = 1;851 }852853 for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_uword); ++i)854 random_state[ i ] = C_fast_rand();855856 initialize_symbol_table();857858 if (profiling) {859#ifndef C_NONUNIX860# ifdef HAVE_SIGACTION861 C_sigaction(C_PROFILE_SIGNAL, &sa, NULL);862# else863 C_signal(C_PROFILE_SIGNAL, global_signal_handler);864# endif865#endif866867 profile_table = (PROFILE_BUCKET **)C_malloc(PROFILE_TABLE_SIZE * sizeof(PROFILE_BUCKET *));868869 if(profile_table == NULL)870 panic(C_text("out of memory - can not allocate profile table"));871872 C_memset(profile_table, 0, sizeof(PROFILE_BUCKET *) * PROFILE_TABLE_SIZE);873 }874875 /* create k to invoke code for system-startup: */876 k0 = (C_SCHEME_BLOCK *)C_align((C_word)C_fromspace_top);877 C_fromspace_top += C_align(2 * sizeof(C_word));878 k0->header = C_CLOSURE_TYPE | 1;879 C_set_block_item(k0, 0, (C_word)termination_continuation);880 C_save(k0);881 C_save(C_SCHEME_UNDEFINED);882 C_restart_c = 2;883 return 1;884}885886887void *C_get_statistics(void) {888 static void *stats[ 8 ];889890 stats[ 0 ] = fromspace_start;891 stats[ 1 ] = C_fromspace_limit;892 stats[ 2 ] = C_scratchspace_start;893 stats[ 3 ] = C_scratchspace_limit;894 stats[ 4 ] = C_stack_limit;895 stats[ 5 ] = stack_bottom;896 stats[ 6 ] = C_fromspace_top;897 stats[ 7 ] = C_scratchspace_top;898 return stats;899}900901902static C_PTABLE_ENTRY *create_initial_ptable()903{904 /* IMPORTANT: hardcoded table size -905 this must match the number of C_pte calls + 1 (NULL terminator)! */906 C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 64);907 int i = 0;908909 if(pt == NULL)910 panic(C_text("out of memory - cannot create initial ptable"));911912 C_pte(termination_continuation);913 C_pte(callback_return_continuation);914 C_pte(values_continuation);915 C_pte(call_cc_values_wrapper);916 C_pte(call_cc_wrapper);917 C_pte(C_gc);918 C_pte(C_allocate_vector);919 C_pte(C_allocate_bytevector);920 C_pte(C_make_structure);921 C_pte(C_ensure_heap_reserve);922 C_pte(C_return_to_host);923 C_pte(C_get_symbol_table_info);924 C_pte(C_get_memory_info);925 C_pte(C_decode_seconds);926 C_pte(C_stop_timer);927 C_pte(C_dload);928 C_pte(C_set_dlopen_flags);929 C_pte(C_become);930 C_pte(C_apply_values);931 C_pte(C_times);932 C_pte(C_minus);933 C_pte(C_plus);934 C_pte(C_nequalp);935 C_pte(C_greaterp);936 /* IMPORTANT: have you read the comments at the start and the end of this function? */937 C_pte(C_lessp);938 C_pte(C_greater_or_equal_p);939 C_pte(C_less_or_equal_p);940 C_pte(C_number_to_string);941 C_pte(C_make_symbol);942 C_pte(C_string_to_symbol);943 C_pte(C_string_to_keyword);944 C_pte(C_apply);945 C_pte(C_call_cc);946 C_pte(C_values);947 C_pte(C_call_with_values);948 C_pte(C_continuation_graft);949 C_pte(C_open_file_port);950 C_pte(C_software_type);951 C_pte(C_machine_type);952 C_pte(C_machine_byte_order);953 C_pte(C_software_version);954 C_pte(C_build_platform);955 C_pte(C_make_pointer);956 /* IMPORTANT: have you read the comments at the start and the end of this function? */957 C_pte(C_make_tagged_pointer);958 C_pte(C_peek_signed_integer);959 C_pte(C_peek_unsigned_integer);960 C_pte(C_peek_int64);961 C_pte(C_peek_uint64);962 C_pte(C_context_switch);963 C_pte(C_register_finalizer);964 C_pte(C_copy_closure);965 C_pte(C_dump_heap_state);966 C_pte(C_filter_heap_objects);967 C_pte(C_fixnum_to_string);968 C_pte(C_integer_to_string);969 C_pte(C_flonum_to_string);970 C_pte(C_signum);971 C_pte(C_quotient_and_remainder);972 C_pte(C_u_integer_quotient_and_remainder);973 C_pte(C_bitwise_and);974 C_pte(C_bitwise_ior);975 C_pte(C_bitwise_xor);976977 /* IMPORTANT: did you remember the hardcoded pte table size? */978 pt[ i ].id = NULL;979 return pt;980}981982983void *CHICKEN_new_gc_root_2(int finalizable)984{985 C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));986987 if(r == NULL)988 panic(C_text("out of memory - cannot allocate GC root"));989990 r->value = C_SCHEME_UNDEFINED;991 r->next = gc_root_list;992 r->prev = NULL;993 r->finalizable = finalizable;994995 if(gc_root_list != NULL) gc_root_list->prev = r;996997 gc_root_list = r;998 return (void *)r;999}100010011002void *CHICKEN_new_gc_root()1003{1004 return CHICKEN_new_gc_root_2(0);1005}100610071008void *CHICKEN_new_finalizable_gc_root()1009{1010 return CHICKEN_new_gc_root_2(1);1011}101210131014void CHICKEN_delete_gc_root(void *root)1015{1016 C_GC_ROOT *r = (C_GC_ROOT *)root;10171018 if(r->prev == NULL) gc_root_list = r->next;1019 else r->prev->next = r->next;10201021 if(r->next != NULL) r->next->prev = r->prev;10221023 C_free(root);1024}102510261027void *CHICKEN_global_lookup(char *name)1028{1029 int1030 len = C_strlen(name),1031 key = hash_string(len, name, symbol_table->size, symbol_table->rand);1032 C_word s;1033 void *root = CHICKEN_new_gc_root();10341035 if(C_truep(s = lookup(key, len, name, symbol_table))) {1036 if(C_block_item(s, 0) != C_SCHEME_UNBOUND) {1037 CHICKEN_gc_root_set(root, s);1038 return root;1039 }1040 }10411042 return NULL;1043}104410451046int CHICKEN_is_running()1047{1048 return chicken_is_running;1049}105010511052void CHICKEN_interrupt()1053{1054 C_timer_interrupt_counter = 0;1055}105610571058C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)1059{1060 C_SYMBOL_TABLE *stp;1061 int i;10621063 if((stp = C_find_symbol_table(name)) != NULL) return stp;10641065 if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)1066 return NULL;10671068 stp->name = name;1069 stp->size = size;1070 stp->next = symbol_table_list;1071 stp->rand = C_fast_rand();10721073 if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)1074 return NULL;10751076 for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);10771078 symbol_table_list = stp;1079 return stp;1080}108110821083C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)1084{1085 C_SYMBOL_TABLE *stp;10861087 for(stp = symbol_table_list; stp != NULL; stp = stp->next)1088 if(!C_strcmp(name, stp->name)) return stp;10891090 return NULL;1091}109210931094C_regparm C_word C_find_symbol(C_word bv, C_SYMBOL_TABLE *stable)1095{1096 C_char *sptr = C_c_string(bv);1097 int len = C_header_size(bv) - 1;1098 int key;1099 C_word s;11001101 if(stable == NULL) stable = symbol_table;11021103 key = hash_string(len, sptr, stable->size, stable->rand);11041105 if(C_truep(s = lookup(key, len, sptr, stable))) return s;1106 else return C_SCHEME_FALSE;1107}110811091110/* Setup symbol-table with internally used symbols; */11111112void initialize_symbol_table(void)1113{1114 int i;11151116 for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);11171118 /* Obtain reference to hooks for later: */1119 core_provided_symbol = C_intern2(C_heaptop, C_text("##core#provided"));1120 interrupt_hook_symbol = C_intern2(C_heaptop, C_text("##sys#interrupt-hook"));1121 error_hook_symbol = C_intern2(C_heaptop, C_text("##sys#error-hook"));1122 callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);1123 pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));1124 current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);11251126 /* SRFI-4 tags */1127 s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));1128 u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));1129 s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));1130 u32vector_symbol = C_intern2(C_heaptop, C_text("u32vector"));1131 s32vector_symbol = C_intern2(C_heaptop, C_text("s32vector"));1132 u64vector_symbol = C_intern2(C_heaptop, C_text("u64vector"));1133 s64vector_symbol = C_intern2(C_heaptop, C_text("s64vector"));1134 f32vector_symbol = C_intern2(C_heaptop, C_text("f32vector"));1135 f64vector_symbol = C_intern2(C_heaptop, C_text("f64vector"));1136}113711381139C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)1140{1141 C_char *sptr = C_c_string(str);1142 int len = C_header_size(str) - 1;1143 int key;1144 C_word s;11451146 if(kwtable == NULL) kwtable = keyword_table;11471148 key = hash_string(len, sptr, kwtable->size, kwtable->rand);11491150 if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;1151 else return C_SCHEME_FALSE;1152}115311541155void C_ccall sigsegv_trampoline(C_word c, C_word *av)1156{1157 barf(C_MEMORY_VIOLATION_ERROR, NULL);1158}115911601161void C_ccall sigbus_trampoline(C_word c, C_word *av)1162{1163 barf(C_BUS_ERROR, NULL);1164}116511661167void C_ccall sigfpe_trampoline(C_word c, C_word *av)1168{1169 barf(C_FLOATING_POINT_EXCEPTION_ERROR, NULL);1170}117111721173void C_ccall sigill_trampoline(C_word c, C_word *av)1174{1175 barf(C_ILLEGAL_INSTRUCTION_ERROR, NULL);1176}117711781179/* This is called from POSIX signals: */11801181void global_signal_handler(int signum)1182{1183#if defined(HAVE_SIGPROCMASK)1184 if(signum == SIGSEGV || signum == SIGFPE || signum == SIGILL || signum == SIGBUS) {1185 sigset_t sset;11861187 if(serious_signal_occurred || !chicken_is_running) {1188 switch(signum) {1189 case SIGSEGV: panic(C_text("unrecoverable segmentation violation"));1190 case SIGFPE: panic(C_text("unrecoverable floating-point exception"));1191 case SIGILL: panic(C_text("unrecoverable illegal instruction error"));1192 case SIGBUS: panic(C_text("unrecoverable bus error"));1193 default: panic(C_text("unrecoverable serious condition"));1194 }1195 }1196 else serious_signal_occurred = 1;11971198 /* unblock signal to avoid nested invocation of the handler */1199 sigemptyset(&sset);1200 sigaddset(&sset, signum);1201 C_sigprocmask(SIG_UNBLOCK, &sset, NULL);12021203 switch(signum) {1204 case SIGSEGV: C_reclaim(sigsegv_trampoline, 0);1205 case SIGFPE: C_reclaim(sigfpe_trampoline, 0);1206 case SIGILL: C_reclaim(sigill_trampoline, 0);1207 case SIGBUS: C_reclaim(sigbus_trampoline, 0);1208 default: panic(C_text("invalid serious signal"));1209 }1210 }1211#endif12121213 /* TODO: Make full use of sigaction: check that /our/ timer expired */1214 if (signum == C_PROFILE_SIGNAL && profiling) take_profile_sample();1215 else C_raise_interrupt(signal_mapping_table[ signum ]);12161217#ifndef HAVE_SIGACTION1218 /* not necessarily needed, but older UNIXen may not leave the handler installed: */1219 C_signal(signum, global_signal_handler);1220#endif1221}122212231224/* Align memory to page boundary */12251226static void *align_to_page(void *mem)1227{1228 return (void *)C_align((C_uword)mem);1229}123012311232static C_byte *1233heap_alloc (size_t size, C_byte **page_aligned)1234{1235 C_byte *p;1236 p = (C_byte *)C_malloc (size + page_size);12371238 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12391240 return p;1241}124212431244static void1245heap_free (C_byte *ptr, size_t size)1246{1247 C_free (ptr);1248}124912501251static C_byte *1252heap_realloc (C_byte *ptr, size_t old_size,1253 size_t new_size, C_byte **page_aligned)1254{1255 C_byte *p;1256 p = (C_byte *)C_realloc (ptr, new_size + page_size);12571258 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12591260 return p;1261}126212631264/* Modify heap size at runtime: */12651266void C_set_or_change_heap_size(C_word heap, int reintern)1267{1268 C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;1269 C_word size = heap / 2;12701271 if(heap_size_changed && fromspace_start) return;12721273 if(fromspace_start && heap_size >= heap) return;12741275 if(debug_mode)1276 C_dbg(C_text("debug"), C_text("heap resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), heap);12771278 heap_size = heap;12791280 if((ptr1 = heap_realloc (fromspace_start,1281 C_fromspace_limit - fromspace_start,1282 size, &ptr1a)) == NULL ||1283 (ptr2 = heap_realloc (tospace_start,1284 tospace_limit - tospace_start,1285 size, &ptr2a)) == NULL)1286 panic(C_text("out of memory - cannot allocate heap"));12871288 heapspace1 = ptr1;1289 heapspace1_size = size;1290 heapspace2 = ptr2;1291 heapspace2_size = size;1292 fromspace_start = ptr1a;1293 C_fromspace_top = fromspace_start;1294 C_fromspace_limit = fromspace_start + size;1295 tospace_start = ptr2a;1296 tospace_top = tospace_start;1297 tospace_limit = tospace_start + size;1298 mutation_stack_top = mutation_stack_bottom;12991300 if(reintern) initialize_symbol_table();1301}130213031304/* Modify stack-size at runtime: */13051306void C_do_resize_stack(C_word stack)1307{1308 C_uword old = stack_size,1309 diff = stack - old;13101311 if(diff != 0 && !stack_size_changed) {1312 if(debug_mode)1313 C_dbg(C_text("debug"), C_text("stack resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), stack);13141315 stack_size = stack;13161317#if C_STACK_GROWS_DOWNWARD1318 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit - diff);1319#else1320 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit + diff);1321#endif1322 C_stack_limit = C_stack_hard_limit;1323 }1324}132513261327/* Check whether nursery is sufficiently big: */13281329void C_check_nursery_minimum(C_word words)1330{1331 if(words >= C_bytestowords(stack_size))1332 panic(C_text("nursery is too small - try higher setting using the `-:s' option"));1333}13341335C_word C_resize_pending_finalizers(C_word size) {1336 int sz = C_num_to_int(size);13371338 FINALIZER_NODE **newmem =1339 (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));13401341 if (newmem == NULL)1342 return C_SCHEME_FALSE;13431344 pending_finalizer_indices = newmem;1345 C_max_pending_finalizers = sz;1346 return C_SCHEME_TRUE;1347}134813491350/* Parse runtime options from command-line: */13511352void CHICKEN_parse_command_line(int argc, C_char *argv[], C_word *heap, C_word *stack, C_word *symbols)1353{1354 int i;1355 C_char *ptr;1356 C_word x;13571358 C_main_argc = argc;1359 C_main_argv = argv;13601361 *heap = DEFAULT_HEAP_SIZE;1362 *stack = DEFAULT_STACK_SIZE;1363 *symbols = DEFAULT_SYMBOL_TABLE_SIZE;13641365 for(i = 1; i < C_main_argc; ++i) {1366 if (strncmp(C_main_argv[ i ], C_text("-:"), 2))1367 break; /* Stop parsing on first non-runtime option */13681369 ptr = &C_main_argv[ i ][ 2 ];1370 if (*ptr == '\0')1371 break; /* Also stop parsing on first "empty" option (i.e. "-:") */13721373 do {1374 switch(*(ptr++)) {1375 case '?':1376 C_dbg("Runtime options", "\n\n"1377 " -:? display this text\n"1378 " -:c always treat stdin as console\n"1379 " -:d enable debug output\n"1380 " -:D enable more debug output\n"1381 " -:g show GC information\n"1382 " -:o disable stack overflow checks\n"1383 " -:hiSIZE set initial heap size\n"1384 " -:hmSIZE set maximal heap size\n"1385 " -:hfSIZE set minimum unused heap size\n"1386 " -:hgPERCENTAGE set heap growth percentage\n"1387 " -:hsPERCENTAGE set heap shrink percentage\n"1388 " -:huPERCENTAGE set percentage of memory used at which heap will be shrunk\n"1389 " -:hSIZE set fixed heap size\n"1390 " -:r write trace output to stderr\n"1391 " -:RSEED initialize rand() seed with SEED (helpful for benchmark stability)\n"1392 " -:p collect statistical profile and write to file at exit\n"1393 " -:PFREQUENCY like -:p, specifying sampling frequency in us (default: 10000)\n"1394 " -:sSIZE set nursery (stack) size\n"1395 " -:tSIZE set symbol-table size\n"1396 " -:fSIZE set maximal number of pending finalizers\n"1397 " -:x deliver uncaught exceptions of other threads to primordial one\n"1398 " -:B sound bell on major GC\n"1399 " -:G force GUI mode\n"1400 " -:aSIZE set trace-buffer/call-chain size\n"1401 " -:ASIZE set fixed temporary stack size\n"1402 " -:H dump heap state on exit\n"1403 " -:S do not handle segfaults or other serious conditions\n"1404 "\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"1405 " times 1024, 1048576, and 1073741824, respectively.\n\n");1406 C_exit_runtime(C_fix(0));14071408 case 'h':1409 switch(*ptr) {1410 case 'i':1411 *heap = arg_val(ptr + 1);1412 heap_size_changed = 1;1413 goto next;1414 case 'f':1415 C_heap_half_min_free = arg_val(ptr + 1);1416 goto next;1417 case 'g':1418 C_heap_growth = arg_val(ptr + 1);1419 goto next;1420 case 'm':1421 C_maximal_heap_size = arg_val(ptr + 1);1422 goto next;1423 case 's':1424 C_heap_shrinkage = arg_val(ptr + 1);1425 goto next;1426 case 'u':1427 C_heap_shrinkage_used = arg_val(ptr + 1);1428 goto next;1429 default:1430 *heap = arg_val(ptr);1431 heap_size_changed = 1;1432 C_heap_size_is_fixed = 1;1433 goto next;1434 }14351436 case 'o':1437 C_disable_overflow_check = 1;1438 break;14391440 case 'B':1441 gc_bell = 1;1442 break;14431444 case 'G':1445 C_gui_mode = 1;1446 break;14471448 case 'H':1449 dump_heap_on_exit = 1;1450 break;14511452 case 'S':1453 pass_serious_signals = 1;1454 break;14551456 case 's':1457 *stack = arg_val(ptr);1458 stack_size_changed = 1;1459 goto next;14601461 case 'f':1462 C_max_pending_finalizers = arg_val(ptr);1463 goto next;14641465 case 'a':1466 C_trace_buffer_size = arg_val(ptr);1467 goto next;14681469 case 'A':1470 fixed_temporary_stack_size = arg_val(ptr);1471 goto next;14721473 case 't':1474 *symbols = arg_val(ptr);1475 goto next;14761477 case 'c':1478 fake_tty_flag = 1;1479 break;14801481 case 'd':1482 debug_mode = 1;1483 break;14841485 case 'D':1486 debug_mode = 2;1487 break;14881489 case 'g':1490 gc_report_flag = 2;1491 break;14921493 case 'P':1494 profiling = 1;1495 profile_frequency = arg_val(ptr);1496 goto next;14971498 case 'p':1499 profiling = 1;1500 break;15011502 case 'r':1503 show_trace = 1;1504 break;15051506 case 'R':1507 C_fast_srand((unsigned int)arg_val(ptr));1508 random_state_initialized = 1;1509 goto next;15101511 case 'x':1512 C_abort_on_thread_exceptions = 1;1513 break;15141515 default: panic(C_text("illegal runtime option"));1516 }1517 } while(*ptr != '\0');15181519 next:;1520 }1521}152215231524C_word arg_val(C_char *arg)1525{1526 int len;1527 C_char *end;1528 C_long val, mul = 1;15291530 if (arg == NULL) panic(C_text("illegal runtime-option argument"));15311532 len = C_strlen(arg);15331534 if(len < 1) panic(C_text("illegal runtime-option argument"));15351536 switch(arg[ len - 1 ]) {1537 case 'k':1538 case 'K': mul = 1024; break;15391540 case 'm':1541 case 'M': mul = 1024 * 1024; break;15421543 case 'g':1544 case 'G': mul = 1024 * 1024 * 1024; break;15451546 default: mul = 1;1547 }15481549 val = C_strtow(arg, &end, 10);15501551 if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))1552 panic(C_text("invalid runtime-option argument suffix"));15531554 return val * mul;1555}155615571558/* Run embedded code with arguments: */15591560C_word CHICKEN_run(void *toplevel)1561{1562 if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))1563 panic(C_text("could not initialize"));15641565 if(chicken_is_running)1566 panic(C_text("re-invocation of Scheme world while process is already running"));15671568 chicken_is_running = chicken_ran_once = 1;1569 return_to_host = 0;15701571 if(profiling) set_profile_timer(profile_frequency);15721573#if C_STACK_GROWS_DOWNWARD1574 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);1575#else1576 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);1577#endif1578 C_stack_limit = C_stack_hard_limit;15791580 stack_bottom = C_stack_pointer;15811582 if(debug_mode)1583 C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx\n"), (C_word)stack_bottom);15841585 /* The point of (usually) no return... */1586#ifdef HAVE_SIGSETJMP1587 C_sigsetjmp(C_restart, 0);1588#else1589 C_setjmp(C_restart);1590#endif15911592 serious_signal_occurred = 0;15931594 if(!return_to_host) {1595 /* We must copy the argvector onto the stack, because1596 * any subsequent save() will otherwise clobber it.1597 */1598 C_word *p = C_alloc(C_restart_c);1599 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));1600 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));1601 C_temporary_stack = C_temporary_stack_bottom;1602 ((C_proc)C_restart_trampoline)(C_restart_c, p);1603 }16041605 if(profiling) set_profile_timer(0);16061607 chicken_is_running = 0;1608 return C_restore;1609}161016111612C_word CHICKEN_continue(C_word k)1613{1614 if(C_temporary_stack_bottom != C_temporary_stack)1615 panic(C_text("invalid temporary stack level"));16161617 if(!chicken_is_initialized)1618 panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));16191620 C_save(k);1621 return CHICKEN_run(NULL);1622}162316241625/* The final continuation: */16261627void C_ccall termination_continuation(C_word c, C_word *av)1628{1629 if(debug_mode) {1630 C_dbg(C_text("debug"), C_text("application terminated normally\n"));1631 }16321633 C_fflush(NULL);1634 C_exit_runtime(C_fix(0));1635}163616371638/* Signal unrecoverable runtime error: */16391640void panic(C_char *msg)1641{1642 if(C_panic_hook != NULL) C_panic_hook(msg);16431644 usual_panic(msg);1645}164616471648void usual_panic(C_char *msg)1649{1650 C_char *dmp = C_dump_trace(0);16511652 C_dbg_hook(C_SCHEME_UNDEFINED);16531654 if(C_gui_mode) {1655 C_snprintf(buffer, sizeof(buffer), C_text("%s\n\n%s"), msg, dmp);1656#if defined(_WIN32) && !defined(__CYGWIN__)1657 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1658 ExitProcess(1);1659#endif1660 } /* fall through if not WIN32 GUI app */16611662 C_dbg("panic", C_text("%s - execution terminated\n\n%s"), msg, dmp);1663 C_exit_runtime(C_fix(1));1664}166516661667void horror(C_char *msg)1668{1669 C_dbg_hook(C_SCHEME_UNDEFINED);16701671 if(C_gui_mode) {1672 C_snprintf(buffer, sizeof(buffer), C_text("%s"), msg);1673#if defined(_WIN32) && !defined(__CYGWIN__)1674 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1675 ExitProcess(1);1676#endif1677 } /* fall through */16781679 C_dbg("horror", C_text("\n%s - execution terminated"), msg);1680 C_exit_runtime(C_fix(1));1681}168216831684/* Error-hook, called from C-level runtime routines: */16851686void barf(int code, char *loc, ...)1687{1688 C_char *msg;1689 C_word err = error_hook_symbol;1690 int c, i;1691 va_list v;1692 C_word *av;16931694 C_dbg_hook(C_SCHEME_UNDEFINED);16951696 C_temporary_stack = C_temporary_stack_bottom;1697 err = C_block_item(err, 0);16981699 switch(code) {1700 case C_BAD_ARGUMENT_COUNT_ERROR:1701 msg = C_text("bad argument count");1702 c = 3;1703 break;17041705 case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:1706 msg = C_text("too few arguments");1707 c = 3;1708 break;17091710 case C_BAD_ARGUMENT_TYPE_ERROR:1711 msg = C_text("bad argument type");1712 c = 1;1713 break;17141715 case C_UNBOUND_VARIABLE_ERROR:1716 msg = C_text("unbound variable");1717 c = 1;1718 break;17191720 case C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR:1721 msg = C_text("bad argument type - not a keyword");1722 c = 1;1723 break;17241725 case C_OUT_OF_MEMORY_ERROR:1726 msg = C_text("not enough memory");1727 c = 0;1728 break;17291730 case C_DIVISION_BY_ZERO_ERROR:1731 msg = C_text("division by zero");1732 c = 0;1733 break;17341735 case C_OUT_OF_BOUNDS_ERROR:1736 msg = C_text("out of range");1737 c = 2;1738 break;17391740 case C_NOT_A_CLOSURE_ERROR:1741 msg = C_text("call of non-procedure");1742 c = 1;1743 break;17441745 case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:1746 msg = C_text("continuation cannot receive multiple values");1747 c = 1;1748 break;17491750 case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:1751 msg = C_text("bad argument type - not a non-cyclic list");1752 c = 1;1753 break;17541755 case C_TOO_DEEP_RECURSION_ERROR:1756 msg = C_text("recursion too deep");1757 c = 0;1758 break;17591760 case C_CANT_REPRESENT_INEXACT_ERROR:1761 msg = C_text("inexact number cannot be represented as an exact number");1762 c = 1;1763 break;17641765 case C_NOT_A_PROPER_LIST_ERROR:1766 msg = C_text("bad argument type - not a proper list");1767 c = 1;1768 break;17691770 case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:1771 msg = C_text("bad argument type - not a fixnum");1772 c = 1;1773 break;17741775 case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:1776 msg = C_text("bad argument type - not a string");1777 c = 1;1778 break;17791780 case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:1781 msg = C_text("bad argument type - not a pair");1782 c = 1;1783 break;17841785 case C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR:1786 msg = C_text("bad argument type - not a boolean");1787 c = 1;1788 break;17891790 case C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR:1791 msg = C_text("bad argument type - not a locative");1792 c = 1;1793 break;17941795 case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:1796 msg = C_text("bad argument type - not a list");1797 c = 1;1798 break;17991800 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:1801 msg = C_text("bad argument type - not a number");1802 c = 1;1803 break;18041805 case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:1806 msg = C_text("bad argument type - not a symbol");1807 c = 1;1808 break;18091810 case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:1811 msg = C_text("bad argument type - not a vector");1812 c = 1;1813 break;18141815 case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:1816 msg = C_text("bad argument type - not a character");1817 c = 1;1818 break;18191820 case C_STACK_OVERFLOW_ERROR:1821 msg = C_text("stack overflow");1822 c = 0;1823 break;18241825 case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:1826 msg = C_text("bad argument type - not a structure of the required type");1827 c = 2;1828 break;18291830 case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:1831 msg = C_text("bad argument type - not a bytevector");1832 c = 1;1833 break;18341835 case C_LOST_LOCATIVE_ERROR:1836 msg = C_text("locative refers to reclaimed object");1837 c = 1;1838 break;18391840 case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:1841 msg = C_text("bad argument type - not a object");1842 c = 1;1843 break;18441845 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:1846 msg = C_text("bad argument type - not a number vector");1847 c = 2;1848 break;18491850 case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:1851 msg = C_text("bad argument type - not an integer");1852 c = 1;1853 break;18541855 case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:1856 msg = C_text("bad argument type - not an unsigned integer");1857 c = 1;1858 break;18591860 case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:1861 msg = C_text("bad argument type - not a pointer");1862 c = 1;1863 break;18641865 case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:1866 msg = C_text("bad argument type - not a tagged pointer");1867 c = 2;1868 break;18691870 case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:1871 msg = C_text("bad argument type - not a flonum");1872 c = 1;1873 break;18741875 case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:1876 msg = C_text("bad argument type - not a procedure");1877 c = 1;1878 break;18791880 case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:1881 msg = C_text("bad argument type - invalid base");1882 c = 1;1883 break;18841885 case C_CIRCULAR_DATA_ERROR:1886 msg = C_text("recursion too deep or circular data encountered");1887 c = 0;1888 break;18891890 case C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR:1891 msg = C_text("bad argument type - not a port");1892 c = 1;1893 break;18941895 case C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR:1896 msg = C_text("bad argument type - not a port of the correct type");1897 c = 1;1898 break;18991900 case C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR:1901 msg = C_text("bad argument type - not an input-port");1902 c = 1;1903 break;19041905 case C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR:1906 msg = C_text("bad argument type - not an output-port");1907 c = 1;1908 break;19091910 case C_PORT_CLOSED_ERROR:1911 msg = C_text("port already closed");1912 c = 1;1913 break;19141915 case C_ASCIIZ_REPRESENTATION_ERROR:1916 msg = C_text("cannot represent string with NUL bytes as C string");1917 c = 1;1918 break;19191920 case C_MEMORY_VIOLATION_ERROR:1921 msg = C_text("segmentation violation");1922 c = 0;1923 break;19241925 case C_FLOATING_POINT_EXCEPTION_ERROR:1926 msg = C_text("floating point exception");1927 c = 0;1928 break;19291930 case C_ILLEGAL_INSTRUCTION_ERROR:1931 msg = C_text("illegal instruction");1932 c = 0;1933 break;19341935 case C_BUS_ERROR:1936 msg = C_text("bus error");1937 c = 0;1938 break;19391940 case C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR:1941 msg = C_text("bad argument type - not an exact number");1942 c = 1;1943 break;19441945 case C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR:1946 msg = C_text("bad argument type - not an inexact number");1947 c = 1;1948 break;19491950 case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:1951 msg = C_text("bad argument type - not an real");1952 c = 1;1953 break;19541955 case C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR:1956 msg = C_text("bad argument type - complex number has no ordering");1957 c = 1;1958 break;19591960 case C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR:1961 msg = C_text("bad argument type - not an exact integer");1962 c = 1;1963 break;19641965 case C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION:1966 msg = C_text("number does not fit in foreign type");1967 c = 1;1968 break;19691970 case C_BAD_ARGUMENT_TYPE_COMPLEX_ABS:1971 msg = C_text("cannot compute absolute value of complex number");1972 c = 1;1973 break;19741975 case C_REST_ARG_OUT_OF_BOUNDS_ERROR:1976 msg = C_text("attempted rest argument access beyond end of list");1977 c = 3;1978 break;19791980 case C_DECODING_ERROR:1981 msg = C_text("string contains invalid UTF-8 sequence");1982 c = 2;1983 break;19841985 case C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR:1986 msg = C_text("bad argument type - value exceeds numeric range");1987 c = 1;1988 break;19891990 default: panic(C_text("illegal internal error code"));1991 }19921993 if(C_immediatep(err)) {1994 C_dbg(C_text("error"), C_text("%s\n"), msg);1995 panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));1996 } else {1997 av = C_alloc(c + 4);1998 va_start(v, loc);1999 av[ 0 ] = err;2000 /* No continuation is passed: '##sys#error-hook' may not return: */2001 av[ 1 ] = C_SCHEME_UNDEFINED;2002 av[ 2 ] = C_fix(code);20032004 if(loc != NULL)2005 av[ 3 ] = intern0(loc);2006 else {2007 av[ 3 ] = error_location;2008 error_location = C_SCHEME_FALSE;2009 }20102011 for(i = 0; i < c; ++i)2012 av[ i + 4 ] = va_arg(v, C_word);20132014 va_end(v);2015 C_do_apply(c + 4, av);2016 }2017}201820192020/* Never use extended number hook procedure names longer than this! */2021/* Current longest name: ##sys#integer->string/recursive */2022#define MAX_EXTNUM_HOOK_NAME 3220232024/* This exists so that we don't have to create any extra closures */2025static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)2026{2027 static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];2028 int i;2029 va_list v;2030 C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;20312032 ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));20332034 if(!C_immediatep(ext_proc_sym))2035 ext_proc = C_block_item(ext_proc_sym, 0);20362037 if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {2038 C_word *av = C_alloc(c + 1);2039 av[ 0 ] = ext_proc;2040 av[ 1 ] = k;2041 va_start(v, k);20422043 for(i = 0; i < c - 1; ++i)2044 av[ i + 2 ] = va_arg(v, C_word);20452046 va_end(v);2047 C_do_apply(c + 1, av);2048 } else {2049 barf(C_UNBOUND_VARIABLE_ERROR, NULL, ext_proc_sym);2050 }2051}205220532054/* Hook for setting breakpoints */20552056C_word C_dbg_hook(C_word dummy)2057{2058 return dummy;2059}206020612062/* Timing routines: */20632064C_regparm C_u64 C_current_process_milliseconds(void)2065{2066#if defined(__MINGW32__)2067# if defined(__MINGW64_VERSION_MAJOR)2068 ULONGLONG tick_count = GetTickCount64();2069# else2070 ULONGLONG tick_count = GetTickCount();2071# endif2072 return tick_count - (C_startup_time_sec * 1000) - C_startup_time_msec;2073#else2074 struct timeval tv;20752076 if(C_gettimeofday(&tv, NULL) == -1) return 0;2077 else return (tv.tv_sec - C_startup_time_sec) * 1000 + tv.tv_usec / 1000 - C_startup_time_msec;2078#endif2079}208020812082C_regparm time_t C_seconds(C_long *ms)2083{2084#ifdef C_NONUNIX2085 if(ms != NULL) *ms = 0;20862087 return (time_t)(clock() / CLOCKS_PER_SEC);2088#else2089 struct timeval tv;20902091 if(C_gettimeofday(&tv, NULL) == -1) {2092 if(ms != NULL) *ms = 0;20932094 return (time_t)0;2095 }2096 else {2097 if(ms != NULL) *ms = tv.tv_usec / 1000;20982099 return tv.tv_sec;2100 }2101#endif2102}210321042105C_regparm C_u64 C_cpu_milliseconds(void)2106{2107#if defined(C_NONUNIX) || defined(__CYGWIN__)2108 if(CLOCKS_PER_SEC == 1000) return clock();2109 else return ((C_u64)clock() / CLOCKS_PER_SEC) * 1000;2110#else2111 struct rusage ru;21122113 if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;2114 else return (((C_u64)ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 10002115 + ((C_u64)ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000);2116#endif2117}211821192120/* Support code for callbacks: */21212122int C_save_callback_continuation(C_word **ptr, C_word k)2123{2124 C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));21252126 C_mutate_slot(&C_block_item(callback_continuation_stack_symbol, 0), p);2127 return ++callback_continuation_level;2128}212921302131C_word C_restore_callback_continuation(void)2132{2133 /* obsolete, but retained for keeping old code working */2134 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2135 k;21362137 assert(!C_immediatep(p) && C_header_type(p) == C_PAIR_TYPE);2138 k = C_u_i_car(p);21392140 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2141 --callback_continuation_level;2142 return k;2143}214421452146C_word C_restore_callback_continuation2(int level)2147{2148 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2149 k;21502151 if(level != callback_continuation_level || C_immediatep(p) || C_header_type(p) != C_PAIR_TYPE)2152 panic(C_text("unbalanced callback continuation stack"));21532154 k = C_u_i_car(p);21552156 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2157 --callback_continuation_level;2158 return k;2159}216021612162C_word C_callback(C_word closure, int argc)2163{2164#ifdef HAVE_SIGSETJMP2165 sigjmp_buf prev;2166#else2167 jmp_buf prev;2168#endif2169 C_word2170 *a = C_alloc(C_SIZEOF_CLOSURE(2)),2171 k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE),2172 *av;2173 int old = chicken_is_running;21742175 if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)2176 panic(C_text("callback invoked in non-safe context"));21772178 C_memcpy(&prev, &C_restart, sizeof(C_restart));2179 callback_returned_flag = 0;2180 chicken_is_running = 1;2181 av = C_alloc(argc + 2);2182 av[ 0 ] = closure;2183 av[ 1 ] = k;2184 /*XXX is the order of arguments an issue? */2185 C_memcpy(av + 2, C_temporary_stack, argc * sizeof(C_word));2186 C_temporary_stack = C_temporary_stack_bottom;21872188#ifdef HAVE_SIGSETJMP2189 if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc + 2, av);2190#else2191 if(!C_setjmp(C_restart)) C_do_apply(argc + 2, av);2192#endif21932194 serious_signal_occurred = 0;21952196 if(!callback_returned_flag) {2197 /* We must copy the argvector onto the stack, because2198 * any subsequent save() will otherwise clobber it.2199 */2200 C_word *p = C_alloc(C_restart_c);2201 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));2202 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));2203 C_temporary_stack = C_temporary_stack_bottom;2204 ((C_proc)C_restart_trampoline)(C_restart_c, p);2205 }2206 else {2207 C_memcpy(&C_restart, &prev, sizeof(C_restart));2208 callback_returned_flag = 0;2209 }22102211 chicken_is_running = old;2212 return C_restore;2213}221422152216void C_callback_adjust_stack(C_word *a, int size)2217{2218 if(!chicken_is_running && !C_in_stackp((C_word)a)) {2219 if(debug_mode)2220 C_dbg(C_text("debug"),2221 C_text("callback invoked in lower stack region - adjusting limits:\n"2222 "[debug] current: \t%p\n"2223 "[debug] previous: \t%p (bottom) - %p (limit)\n"),2224 a, stack_bottom, C_stack_limit);22252226#if C_STACK_GROWS_DOWNWARD2227 C_stack_hard_limit = (C_word *)((C_byte *)a - stack_size);2228 stack_bottom = a + size;2229#else2230 C_stack_hard_limit = (C_word *)((C_byte *)a + stack_size);2231 stack_bottom = a;2232#endif2233 C_stack_limit = C_stack_hard_limit;22342235 if(debug_mode)2236 C_dbg(C_text("debug"), C_text("new: \t%p (bottom) - %p (limit)\n"),2237 stack_bottom, C_stack_limit);2238 }2239}224022412242C_word C_callback_wrapper(void *proc, int argc)2243{2244 C_word2245 *a = C_alloc(C_SIZEOF_CLOSURE(1)),2246 closure = C_closure(&a, 1, (C_word)proc),2247 result;22482249 result = C_callback(closure, argc);2250 assert(C_temporary_stack == C_temporary_stack_bottom);2251 return result;2252}225322542255void C_ccall callback_return_continuation(C_word c, C_word *av)2256{2257 C_word self = av[0];2258 C_word r = av[1];22592260 if(C_block_item(self, 1) == C_SCHEME_TRUE)2261 panic(C_text("callback returned twice"));22622263 assert(callback_returned_flag == 0);2264 callback_returned_flag = 1;2265 C_set_block_item(self, 1, C_SCHEME_TRUE);2266 C_save(r);2267 C_reclaim(NULL, 0);2268}226922702271/* Register/unregister literal frame: */22722273void C_initialize_lf(C_word *lf, int count)2274{2275 while(count-- > 0)2276 *(lf++) = C_SCHEME_UNBOUND;2277}227822792280void *C_register_lf(C_word *lf, int count)2281{2282 return C_register_lf2(lf, count, NULL);2283}228422852286void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)2287{2288 LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));2289 LF_LIST *np;2290 int status = 0;22912292 node->lf = lf;2293 node->count = count;2294 node->ptable = ptable;2295 node->module_name = current_module_name;2296 node->module_handle = current_module_handle;2297 current_module_handle = NULL;22982299 if(lf_list) lf_list->prev = node;23002301 node->next = lf_list;2302 node->prev = NULL;2303 lf_list = node;2304 return (void *)node;2305}230623072308LF_LIST *find_module_handle(char *name)2309{2310 LF_LIST *np;23112312 for(np = lf_list; np != NULL; np = np->next) {2313 if(np->module_name != NULL && !C_strcmp(np->module_name, name))2314 return np;2315 }23162317 return NULL;2318}231923202321void C_unregister_lf(void *handle)2322{2323 LF_LIST *node = (LF_LIST *) handle;23242325 if (node->next) node->next->prev = node->prev;23262327 if (node->prev) node->prev->next = node->next;23282329 if (lf_list == node) lf_list = node->next;23302331 C_free(node->module_name);2332 C_free(node);2333}233423352336/* Intern symbol into symbol-table: */23372338C_regparm C_word C_intern(C_word **ptr, int len, C_char *str)2339{2340 return C_intern_in(ptr, len, str, symbol_table);2341}234223432344C_regparm C_word C_h_intern(C_word *slot, int len, C_char *str)2345{2346 return C_h_intern_in(slot, len, str, symbol_table);2347}234823492350C_regparm C_word C_intern_kw(C_word **ptr, int len, C_char *str)2351{2352 C_word kw = C_intern_in(ptr, len, str, keyword_table);2353 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2354 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2355 return kw;2356}235723582359C_regparm C_word C_h_intern_kw(C_word *slot, int len, C_char *str)2360{2361 C_word kw = C_h_intern_in(slot, len, str, keyword_table);2362 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2363 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2364 return kw;2365}23662367C_regparm C_word C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)2368{2369 int key;2370 C_word s;23712372 if(stable == NULL) stable = symbol_table;23732374 key = hash_string(len, str, stable->size, stable->rand);23752376 if(C_truep(s = lookup(key, len, str, stable))) return s;23772378 s = C_bytevector(ptr, len + 1, str);2379 return add_symbol(ptr, key, s, stable);2380}238123822383C_regparm C_word C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)2384{2385 /* Intern as usual, but remember slot, and allocate in static2386 * memory. If symbol already exists, replace its string by a fresh2387 * statically allocated string to ensure it never gets collected, as2388 * lf[] entries are not tracked by the GC.2389 */2390 int key;2391 C_word s, bv;23922393 if(stable == NULL) stable = symbol_table;23942395 key = hash_string(len, str, stable->size, stable->rand);23962397 if(C_truep(s = lookup(key, len, str, stable))) {2398 if(C_in_stackp(s)) C_mutate_slot(slot, s);23992400 if(!C_truep(C_permanentp(C_symbol_name(s)))) {2401 /* Replace by statically allocated string, and persist it */2402 bv = C_static_bytevector(C_heaptop, len + 1, str);2403 C_c_bytevector(bv)[ len ] = 0;2404 C_set_block_item(s, 1, bv);2405 C_i_persist_symbol(s);2406 }2407 return s;2408 }24092410 bv = C_static_bytevector(C_heaptop, len + 1, str);2411 C_c_bytevector(bv)[ len ] = 0;2412 return add_symbol(C_heaptop, key, bv, stable);2413}241424152416C_regparm C_word intern0(C_char *str)2417{2418 int len = C_strlen(str);2419 int key = hash_string(len, str, symbol_table->size, symbol_table->rand);2420 C_word s;24212422 if(C_truep(s = lookup(key, len, str, symbol_table))) return s;2423 else return C_SCHEME_FALSE;2424}242524262427C_regparm C_word C_lookup_symbol(C_word sym)2428{2429 int key;2430 C_word bv = C_block_item(sym, 1);2431 int len = C_header_size(bv) - 1;24322433 key = hash_string(len, C_c_string(bv), symbol_table->size, symbol_table->rand);24342435 return lookup(key, len, C_c_string(bv), symbol_table);2436}243724382439C_regparm C_word C_intern2(C_word **ptr, C_char *str)2440{2441 return C_intern_in(ptr, C_strlen(str), str, symbol_table);2442}244324442445C_regparm C_word C_intern3(C_word **ptr, C_char *str, C_word value)2446{2447 C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);24482449 C_mutate(&C_block_item(s,0), value);2450 C_i_persist_symbol(s); /* Symbol has a value now; persist it */2451 return s;2452}245324542455C_regparm C_word hash_string(int len, C_char *str, C_word m, C_word r)2456{2457 C_uword key = r;24582459 while(len--)2460 key ^= (key << 6) + (key >> 2) + *(str++);24612462 return (C_word)(key % (C_uword)m);2463}246424652466C_regparm C_word lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)2467{2468 C_word bucket, last = 0, sym, s;24692470 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2471 bucket = C_block_item(bucket,1)) {2472 sym = C_block_item(bucket,0);24732474 /* If the symbol is unreferenced, drop it: */2475 if (sym == C_SCHEME_BROKEN_WEAK_PTR) {2476 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2477 else stable->table[ key ] = C_block_item(bucket,1);2478 } else {2479 last = bucket;2480 s = C_block_item(sym, 1);24812482 if(C_header_size(s) - 1 == (C_word)len2483 && !C_memcmp(str, (C_char *)C_data_pointer(s), len))2484 return sym;2485 }2486 }24872488 return C_SCHEME_FALSE;2489}24902491/* Mark a symbol as "persistent", to prevent it from being GC'ed */2492C_regparm C_word C_i_persist_symbol(C_word sym)2493{2494 C_word bucket;2495 C_SYMBOL_TABLE *stp;24962497 /* Normally, this will get called with a symbol, but in2498 * C_h_intern_kw we may call it with keywords too.2499 */2500 if(!C_truep(C_i_symbolp(sym)) && !C_truep(C_i_keywordp(sym))) {2501 error_location = C_SCHEME_FALSE;2502 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, sym);2503 }25042505 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2506 bucket = lookup_bucket(sym, stp);25072508 if (C_truep(bucket)) {2509 /* Change weak to strong ref to ensure long-term survival */2510 C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;2511 /* Ensure survival on next minor GC */2512 if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);2513 }2514 }2515 return C_SCHEME_UNDEFINED;2516}25172518/* Possibly remove "persistence" of symbol, to allowed it to be GC'ed.2519 * This is only done if the symbol is unbound, has an empty plist and2520 * is allocated in managed memory.2521 */2522C_regparm C_word C_i_unpersist_symbol(C_word sym)2523{2524 C_word bucket;2525 C_SYMBOL_TABLE *stp;25262527 C_i_check_symbol(sym);25282529 if (C_persistable_symbol(sym) ||2530 C_truep(C_permanentp(C_symbol_name(sym)))) {2531 return C_SCHEME_FALSE;2532 }25332534 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2535 bucket = lookup_bucket(sym, stp);25362537 if (C_truep(bucket)) {2538 /* Turn it into a weak ref */2539 C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;2540 return C_SCHEME_TRUE;2541 }2542 }2543 return C_SCHEME_FALSE;2544}25452546C_regparm C_word lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)2547{2548 C_word bucket, str = C_block_item(sym, 1);2549 int key, len = C_header_size(str) - 1;25502551 if (stable == NULL) stable = symbol_table;25522553 key = hash_string(len, C_c_string(str), stable->size, stable->rand);25542555 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2556 bucket = C_block_item(bucket,1)) {2557 if (C_block_item(bucket,0) == sym) return bucket;2558 }2559 return C_SCHEME_FALSE;2560}256125622563double compute_symbol_table_load(double *avg_bucket_len, int *total_n)2564{2565 C_word bucket, last;2566 int i, j, alen = 0, bcount = 0, total = 0;25672568 for(i = 0; i < symbol_table->size; ++i) {2569 last = 0;2570 j = 0;2571 for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST;2572 bucket = C_block_item(bucket,1)) {2573 /* If the symbol is unreferenced, drop it: */2574 if (C_block_item(bucket,0) == C_SCHEME_BROKEN_WEAK_PTR) {2575 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2576 else symbol_table->table[ i ] = C_block_item(bucket,1);2577 } else {2578 last = bucket;2579 ++j;2580 }2581 }25822583 if(j > 0) {2584 alen += j;2585 ++bcount;2586 }25872588 total += j;2589 }25902591 if(avg_bucket_len != NULL)2592 *avg_bucket_len = (double)alen / (double)bcount;25932594 *total_n = total;25952596 /* return load: */2597 return (double)total / (double)symbol_table->size;2598}259926002601C_word add_symbol(C_word **ptr, C_word key, C_word bv, C_SYMBOL_TABLE *stable)2602{2603 C_word bucket, sym, b2, *p;26042605 p = *ptr;2606 sym = (C_word)p;2607 p += C_SIZEOF_SYMBOL;2608 C_block_header_init(sym, C_SYMBOL_TAG);2609 C_set_block_item(sym, 0, C_SCHEME_UNBOUND);2610 C_set_block_item(sym, 1, bv);2611 C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);2612 *ptr = p;2613 b2 = stable->table[ key ]; /* previous bucket */26142615 /* Create new weak or strong bucket depending on persistability */2616 if (C_truep(C_permanentp(bv))) {2617 bucket = C_a_pair(ptr, sym, b2);2618 } else {2619 bucket = C_a_weak_pair(ptr, sym, b2);2620 }26212622 if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);2623 else {2624 /* If a stack-allocated bucket was here, and we allocate from2625 heap-top (say, in a toplevel literal frame allocation) then we have2626 to inform the memory manager that a 2nd gen. block points to a2627 1st gen. block, hence the mutation: */2628 C_mutate(&C_block_item(bucket,1), b2);2629 stable->table[ key ] = bucket;2630 }26312632 return sym;2633}263426352636C_regparm int C_in_stackp(C_word x)2637{2638 C_word *ptr = (C_word *)(C_uword)x;26392640#if C_STACK_GROWS_DOWNWARD2641 return ptr >= C_stack_pointer_test && ptr <= stack_bottom;2642#else2643 return ptr < C_stack_pointer_test && ptr >= stack_bottom;2644#endif2645}264626472648C_regparm int C_in_heapp(C_word x)2649{2650 C_byte *ptr = (C_byte *)(C_uword)x;2651 return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||2652 (ptr >= tospace_start && ptr < tospace_limit);2653}26542655/* Only used during major GC (heap realloc) */2656static C_regparm int C_in_new_heapp(C_word x)2657{2658 C_byte *ptr = (C_byte *)(C_uword)x;2659 return (ptr >= new_tospace_start && ptr < new_tospace_limit);2660}26612662C_regparm int C_in_fromspacep(C_word x)2663{2664 C_byte *ptr = (C_byte *)(C_uword)x;2665 return (ptr >= fromspace_start && ptr < C_fromspace_limit);2666}26672668C_regparm int C_in_scratchspacep(C_word x)2669{2670 C_word *ptr = (C_word *)(C_uword)x;2671 return (ptr >= C_scratchspace_start && ptr < C_scratchspace_limit);2672}26732674/* Cons the rest-aguments together: */26752676C_regparm C_word C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)2677{2678 C_word2679 x = C_SCHEME_END_OF_LIST,2680 *p = *ptr;2681 C_SCHEME_BLOCK *node;26822683 av += c;26842685 while(--c >= n) {2686 node = (C_SCHEME_BLOCK *)p;2687 p += 3;2688 node->header = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2689 node->data[ 0 ] = *(--av);2690 node->data[ 1 ] = x;2691 x = (C_word)node;2692 }26932694 *ptr = p;2695 return x;2696}269726982699/* Print error messages and exit: */27002701void C_bad_memory(void)2702{2703 panic(C_text("there is not enough stack-space to run this executable"));2704}270527062707void C_bad_memory_2(void)2708{2709 panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));2710}271127122713/* The following two can be thrown out in the next release... */27142715void C_bad_argc(int c, int n)2716{2717 C_bad_argc_2(c, n, C_SCHEME_FALSE);2718}271927202721void C_bad_min_argc(int c, int n)2722{2723 C_bad_min_argc_2(c, n, C_SCHEME_FALSE);2724}272527262727void C_bad_argc_2(int c, int n, C_word closure)2728{2729 barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2730}273127322733void C_bad_min_argc_2(int c, int n, C_word closure)2734{2735 barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2736}273727382739void C_stack_overflow(C_char *loc)2740{2741 barf(C_STACK_OVERFLOW_ERROR, loc);2742}274327442745void C_no_closure_error(C_word x)2746{2747 barf(C_NOT_A_CLOSURE_ERROR, NULL, x);2748}274927502751void C_div_by_zero_error(C_char *loc)2752{2753 barf(C_DIVISION_BY_ZERO_ERROR, loc);2754}27552756void C_unimplemented(C_char *msg)2757{2758 C_fprintf(C_stderr, C_text("Error: unimplemented feature: %s\n"), msg);2759 C_fflush(NULL);2760 C_exit_runtime(C_fix(EX_SOFTWARE));2761}27622763void C_not_an_integer_error(C_char *loc, C_word x)2764{2765 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);2766}27672768void C_not_an_uinteger_error(C_char *loc, C_word x)2769{2770 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x);2771}27722773void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka)2774{2775 C_rest_arg_out_of_bounds_error_2(c, n, ka, C_SCHEME_FALSE);2776}27772778void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure)2779{2780 barf(C_REST_ARG_OUT_OF_BOUNDS_ERROR, NULL, C_u_fixnum_difference(c, ka), C_u_fixnum_difference(n, ka), closure);2781}27822783/* Allocate and initialize record: */27842785C_regparm C_word C_string(C_word **ptr, int len, C_char *str)2786{2787 C_word buf = C_bytevector(ptr, len + 1, str);2788 C_word s = (C_word)(*ptr);2789 int n;2790 *ptr += 5; /* C_SIZEOF_STRING */2791 C_c_bytevector(buf)[ len ] = 0;2792 C_block_header_init(s, C_STRING_TAG);2793 C_set_block_item(s, 0, buf);2794 n = C_utf_count((C_char *)C_data_pointer(buf), len);2795 C_set_block_item(s, 1, C_fix(n));2796 C_set_block_item(s, 2, C_fix(0));2797 C_set_block_item(s, 3, C_fix(0));2798 return s;2799}28002801C_regparm C_word C_static_string(C_word **ptr, int len, C_char *str)2802{2803 C_word buf = C_static_bytevector(ptr, len + 1, str);2804 C_word s = (C_word)(*ptr);2805 int n;2806 *ptr += 5; /* C_SIZEOF_STRING */2807 C_c_bytevector(buf)[ len ] = 0;2808 C_block_header_init(s, C_STRING_TAG);2809 C_set_block_item(s, 0, buf);2810 n = C_utf_count((C_char *)C_data_pointer(buf), len);2811 C_set_block_item(s, 1, C_fix(n));2812 C_set_block_item(s, 2, C_fix(0));2813 C_set_block_item(s, 3, C_fix(0));2814 return s;2815}28162817C_regparm C_word C_static_bignum(C_word **ptr, int len, C_char *str)2818{2819 C_word *dptr, bignum, bigvec, retval, size, negp = 0;28202821 if (*str == '+' || *str == '-') {2822 negp = ((*str++) == '-') ? 1 : 0;2823 --len;2824 }2825 size = C_BIGNUM_BITS_TO_DIGITS((unsigned int)len << 2);28262827 dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(size)));2828 if(dptr == NULL)2829 panic(C_text("out of memory - cannot allocate static bignum"));28302831 bigvec = (C_word)dptr;2832 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(size + 1));2833 C_set_block_item(bigvec, 0, negp);2834 /* This needs to be allocated at ptr, not dptr, because GC moves type tag */2835 bignum = C_a_i_bignum_wrapper(ptr, bigvec);28362837 retval = str_to_bignum(bignum, str, str + len, 16);2838 if (retval & C_FIXNUM_BIT)2839 C_free(dptr); /* Might have been simplified */2840 return retval;2841}28422843C_regparm C_word C_static_lambda_info(C_word **ptr, int len, C_char *str)2844{2845 int dlen = sizeof(C_header) + C_align(len);2846 void *dptr = C_malloc(dlen);2847 C_word strblock;28482849 if(dptr == NULL)2850 panic(C_text("out of memory - cannot allocate static lambda info"));28512852 strblock = (C_word)dptr;2853 C_block_header_init(strblock, C_LAMBDA_INFO_TYPE | len);2854 C_memcpy(C_data_pointer(strblock), str, len);2855 return strblock;2856}285728582859C_regparm C_word C_bytevector(C_word **ptr, int len, C_char *str)2860{2861 C_word block = (C_word)(*ptr);2862 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));2863 C_block_header_init(block, C_BYTEVECTOR_TYPE | len);2864 C_memcpy(C_data_pointer(block), str, len);2865 return block;2866}286728682869C_regparm C_word C_static_bytevector(C_word **ptr, int len, C_char *str)2870{2871 /* we need to add 4 here, as utf8_decode does 3-byte lookahead */2872 C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len + 4));2873 C_word block;28742875 if(dptr == NULL)2876 panic(C_text("out of memory - cannot allocate static bytevector"));28772878 block = (C_word)dptr;2879 C_block_header_init(block, C_BYTEVECTOR_TYPE | len);2880 C_memcpy(C_data_pointer(block), str, len);2881 return block;2882}288328842885C_regparm C_word C_pbytevector(int len, C_char *str)2886{2887 C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));28882889 if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent bytevector"));28902891 pbv->header = C_BYTEVECTOR_TYPE | len;2892 C_memcpy(pbv->data, str, len);2893 return (C_word)pbv;2894}289528962897C_regparm C_word C_string2(C_word **ptr, C_char *str)2898{2899 C_word strblock = (C_word)(*ptr);2900 int len;29012902 if(str == NULL) return C_SCHEME_FALSE;29032904 len = C_strlen(str);2905 return C_string(ptr, len, str);2906}290729082909C_regparm C_word C_string2_safe(C_word **ptr, int max, C_char *str)2910{2911 C_word strblock = (C_word)(*ptr);2912 int len;29132914 if(str == NULL) return C_SCHEME_FALSE;29152916 len = C_strlen(str);29172918 if(len >= max) {2919 C_snprintf(buffer, sizeof(buffer), C_text("foreign string result exceeded maximum of %d bytes"), max);2920 panic(buffer);2921 }29222923 return C_string(ptr, len, str);2924}292529262927C_word C_closure(C_word **ptr, int cells, C_word proc, ...)2928{2929 va_list va;2930 C_word *p = *ptr,2931 *p0 = p;29322933 *p = C_CLOSURE_TYPE | cells;2934 *(++p) = proc;29352936 for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));29372938 va_end(va);2939 *ptr = p + 1;2940 return (C_word)p0;2941}294229432944C_regparm C_word C_number(C_word **ptr, double n)2945{2946 C_word2947 *p = *ptr,2948 *p0;2949 double m;29502951 if(n <= (double)C_MOST_POSITIVE_FIXNUM2952 && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0) {2953 return C_fix(n);2954 }29552956#ifndef C_SIXTY_FOUR2957#ifndef C_DOUBLE_IS_32_BITS2958 /* Align double on 8-byte boundary: */2959 if(C_aligned8(p)) ++p;2960#endif2961#endif29622963 p0 = p;2964 *(p++) = C_FLONUM_TAG;2965 *((double *)p) = n;2966 *ptr = p + sizeof(double) / sizeof(C_word);2967 return (C_word)p0;2968}296929702971C_regparm C_word C_mpointer(C_word **ptr, void *mp)2972{2973 C_word2974 *p = *ptr,2975 *p0 = p;29762977 *(p++) = C_POINTER_TYPE | 1;2978 *((void **)p) = mp;2979 *ptr = p + 1;2980 return (C_word)p0;2981}298229832984C_regparm C_word C_mpointer_or_false(C_word **ptr, void *mp)2985{2986 C_word2987 *p = *ptr,2988 *p0 = p;29892990 if(mp == NULL) return C_SCHEME_FALSE;29912992 *(p++) = C_POINTER_TYPE | 1;2993 *((void **)p) = mp;2994 *ptr = p + 1;2995 return (C_word)p0;2996}299729982999C_regparm C_word C_taggedmpointer(C_word **ptr, C_word tag, void *mp)3000{3001 C_word3002 *p = *ptr,3003 *p0 = p;30043005 *(p++) = C_TAGGED_POINTER_TAG;3006 *((void **)p) = mp;3007 *(++p) = tag;3008 *ptr = p + 1;3009 return (C_word)p0;3010}301130123013C_regparm C_word C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)3014{3015 C_word3016 *p = *ptr,3017 *p0 = p;30183019 if(mp == NULL) return C_SCHEME_FALSE;30203021 *(p++) = C_TAGGED_POINTER_TAG;3022 *((void **)p) = mp;3023 *(++p) = tag;3024 *ptr = p + 1;3025 return (C_word)p0;3026}302730283029C_word C_vector(C_word **ptr, int n, ...)3030{3031 va_list v;3032 C_word3033 *p = *ptr,3034 *p0 = p;30353036 *(p++) = C_VECTOR_TYPE | n;3037 va_start(v, n);30383039 while(n--)3040 *(p++) = va_arg(v, C_word);30413042 *ptr = p;3043 va_end(v);3044 return (C_word)p0;3045}304630473048C_word C_structure(C_word **ptr, int n, ...)3049{3050 va_list v;3051 C_word *p = *ptr,3052 *p0 = p;30533054 *(p++) = C_STRUCTURE_TYPE | n;3055 va_start(v, n);30563057 while(n--)3058 *(p++) = va_arg(v, C_word);30593060 *ptr = p;3061 va_end(v);3062 return (C_word)p0;3063}306430653066C_regparm C_word3067C_mutate_slot(C_word *slot, C_word val)3068{3069 unsigned int mssize, newmssize, bytes;30703071 ++mutation_count;3072 /* Mutation stack exists to track mutations pointing from elsewhere3073 * into nursery. Stuff pointing anywhere else can be skipped, as3074 * well as mutations on nursery objects.3075 */3076 if(C_in_stackp((C_word)slot) || (!C_in_stackp(val) && !C_in_scratchspacep(val)))3077 return *slot = val;30783079#ifdef C_GC_HOOKS3080 if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;3081#endif30823083 if(mutation_stack_top >= mutation_stack_limit) {3084 assert(mutation_stack_top == mutation_stack_limit);3085 mssize = mutation_stack_top - mutation_stack_bottom;3086 newmssize = mssize * 2;3087 bytes = newmssize * sizeof(C_word *);30883089 if(debug_mode)3090 C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),3091 (mssize * sizeof(C_word *)) / 1024, bytes / 1024);30923093 mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, bytes);30943095 if(mutation_stack_bottom == NULL)3096 panic(C_text("out of memory - cannot re-allocate mutation stack"));30973098 mutation_stack_limit = mutation_stack_bottom + newmssize;3099 mutation_stack_top = mutation_stack_bottom + mssize;3100 }31013102 *(mutation_stack_top++) = slot;3103 ++tracked_mutation_count;3104 return *slot = val;3105}31063107/* Allocate memory in scratch space, "size" is in words, like C_alloc.3108 * The memory in the scratch space is laid out as follows: First,3109 * there's a count that indicates how big the object originally was,3110 * followed by a pointer to the slot in the object which points to the3111 * object in scratch space, finally followed by the object itself.3112 * The reason we store the slot pointer is so that we can figure out3113 * whether the object is still "live" when reallocating; that's3114 * because we don't have a saved continuation from where we can trace3115 * the live data. The reason we store the total length of the object3116 * is because we may be mutating in-place the lengths of the stored3117 * objects, and we need to know how much to skip over while scanning.3118 *3119 * If the allocating function returns, it *must* first mark all the3120 * values in scratch space as reclaimable. This is needed because3121 * there is no way to distinguish between a stale pointer into scratch3122 * space that's still somewhere on the stack in "uninitialized" memory3123 * versus a word that's been recycled by the next called function,3124 * which now holds a value that happens to have the same bit pattern3125 * but represents another thing entirely.3126 */3127C_regparm C_word C_scratch_alloc(C_uword size)3128{3129 C_word result;31303131 if (C_scratchspace_top == NULL || C_scratchspace_top + size + 2 >= C_scratchspace_limit) {3132 C_word *new_scratch_start, *new_scratch_top, *new_scratch_limit;3133 C_uword needed = C_scratch_usage + size + 2,3134 new_size = nmax(scratchspace_size << 1, 2UL << C_ilen(needed));31353136 /* Shrink if the needed size is much smaller, but not below minimum */3137 if (needed < (new_size >> 4)) new_size >>= 1;3138 new_size = nmax(new_size, DEFAULT_SCRATCH_SPACE_SIZE);31393140 /* TODO: Maybe we should work with two semispaces to reduce mallocs? */3141 new_scratch_start = (C_word *)C_malloc(C_wordstobytes(new_size));3142 if (new_scratch_start == NULL)3143 panic(C_text("out of memory - cannot (re-)allocate scratch space"));3144 new_scratch_top = new_scratch_start;3145 new_scratch_limit = new_scratch_start + new_size;31463147 if(debug_mode) {3148 C_dbg(C_text("debug"), C_text("resizing scratchspace dynamically from "3149 UWORD_COUNT_FORMAT_STRING "k to "3150 UWORD_COUNT_FORMAT_STRING "k ...\n"),3151 C_wordstobytes(scratchspace_size) / 1024,3152 C_wordstobytes(new_size) / 1024);3153 }31543155 if(gc_report_flag) {3156 C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING3157 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3158 (C_word)C_scratchspace_start, (C_word)C_scratchspace_limit);3159 C_dbg(C_text("GC"), C_text("(new) scratchspace: \tstart=" UWORD_FORMAT_STRING3160 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3161 (C_word)new_scratch_start, (C_word)new_scratch_limit);3162 }31633164 /* Move scratch data into new space and mutate slots pointing there.3165 * This is basically a much-simplified version of really_mark.3166 */3167 if (C_scratchspace_start != NULL) {3168 C_word val, *sscan, *slot;3169 C_uword n, words;3170 C_header h;3171 C_SCHEME_BLOCK *p, *p2;31723173 sscan = C_scratchspace_start;31743175 while (sscan < C_scratchspace_top) {3176 words = *sscan;3177 slot = (C_word *)*(sscan+1);31783179 if (*(sscan+2) == ALIGNMENT_HOLE_MARKER) val = (C_word)(sscan+3);3180 else val = (C_word)(sscan+2);31813182 sscan += words + 2;31833184 p = (C_SCHEME_BLOCK *)val;3185 h = p->header;3186 if (is_fptr(h)) /* TODO: Support scratch->scratch pointers? */3187 panic(C_text("Unexpected forwarding pointer in scratch space"));31883189 p2 = (C_SCHEME_BLOCK *)(new_scratch_top+2);31903191#ifndef C_SIXTY_FOUR3192 if ((h & C_8ALIGN_BIT) && C_aligned8(p2) &&3193 (C_word *)p2 < new_scratch_limit) {3194 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3195 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3196 }3197#endif31983199 /* If orig slot still points here, copy data and update it */3200 if (slot != NULL) {3201 assert(*slot == val);3202 n = C_header_size(p);3203 n = (h & C_BYTEBLOCK_BIT) ? C_bytestowords(n) : n;32043205 *slot = (C_word)p2;3206 /* size = header plus block size plus optional alignment hole */3207 *new_scratch_top = ((C_word *)p2-(C_word *)new_scratch_top-2) + n + 1;3208 *(new_scratch_top+1) = (C_word)slot;32093210 new_scratch_top = (C_word *)p2 + n + 1;3211 if(new_scratch_top > new_scratch_limit)3212 panic(C_text("out of memory - scratch space full while resizing"));32133214 p2->header = h;3215 p->header = ptr_to_fptr((C_uword)p2);3216 C_memcpy(p2->data, p->data, C_wordstobytes(n));3217 }3218 }3219 free(C_scratchspace_start);3220 }3221 C_scratchspace_start = new_scratch_start;3222 C_scratchspace_top = new_scratch_top;3223 C_scratchspace_limit = new_scratch_limit;3224 /* Scratch space is now tightly packed */3225 C_scratch_usage = (new_scratch_top - new_scratch_start);3226 scratchspace_size = new_size;3227 }3228 assert(C_scratchspace_top + size + 2 <= C_scratchspace_limit);32293230 *C_scratchspace_top = size;3231 *(C_scratchspace_top+1) = (C_word)NULL; /* Nothing points here 'til mutated */3232 result = (C_word)(C_scratchspace_top+2);3233 C_scratchspace_top += size + 2;3234 /* This will only be marked as "used" when it's claimed by a pointer */3235 /* C_scratch_usage += size + 2; */3236 return result;3237}32383239/* Given a root object, scan its slots recursively (the objects3240 * themselves should be shallow and non-recursive), and migrate every3241 * object stored between the memory boundaries to the supplied3242 * pointer. Scratch data pointed to by objects between the memory3243 * boundaries is updated to point to the new memory region. If the3244 * supplied pointer is NULL, the scratch memory is marked reclaimable.3245 */3246C_regparm C_word3247C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)3248{3249 C_word size, header, *data, *p = NULL, obj_in_buffer;32503251 if (C_immediatep(obj)) return obj;32523253 size = C_header_size(obj);3254 header = C_block_header(obj);3255 data = C_data_pointer(obj);3256 obj_in_buffer = (obj >= (C_word)start && obj < (C_word)end);32573258 /* Only copy object if we have a target pointer and it's in the buffer */3259 if (ptr != NULL && obj_in_buffer) {3260 p = *ptr;3261 obj = (C_word)p; /* Return the object's new location at the end */3262 }32633264 if (p != NULL) *p++ = header;32653266 if (header & C_BYTEBLOCK_BIT) {3267 if (p != NULL) {3268 *ptr = (C_word *)((C_byte *)(*ptr) + sizeof(C_header) + C_align(size));3269 C_memcpy(p, data, size);3270 }3271 } else {3272 if (p != NULL) *ptr += size + 1;32733274 if(header & C_SPECIALBLOCK_BIT) {3275 if (p != NULL) *(p++) = *data;3276 size--;3277 data++;3278 }32793280 /* TODO: See if we can somehow make this use Cheney's algorithm */3281 while(size--) {3282 C_word slot = *data;32833284 if(!C_immediatep(slot)) {3285 if (C_in_scratchspacep(slot)) {3286 if (obj_in_buffer) { /* Otherwise, don't touch scratch backpointer */3287 /* TODO: Support recursing into objects in scratch space? */3288 C_word *sp = (C_word *)slot;32893290 if (*(sp-1) == ALIGNMENT_HOLE_MARKER) --sp;3291 if (*(sp-1) != (C_word)NULL && p == NULL)3292 C_scratch_usage -= *(sp-2) + 2;3293 *(sp-1) = (C_word)p; /* This is why we traverse even if p = NULL */32943295 *data = C_SCHEME_UNBOUND; /* Ensure old reference is killed dead */3296 }3297 } else { /* Slot is not a scratchspace object: check sub-objects */3298 slot = C_migrate_buffer_object(ptr, start, end, slot);3299 }3300 }3301 if (p != NULL) *(p++) = slot;3302 else *data = slot; /* Sub-object may have moved! */3303 data++;3304 }3305 }3306 return obj; /* Should be NULL if ptr was NULL */3307}33083309/* Register an object's slot as holding data to scratch space. Only3310 * one slot can point to a scratch space object; the object in scratch3311 * space is preceded by a pointer that points to this slot (or NULL).3312 */3313C_regparm C_word C_mutate_scratch_slot(C_word *slot, C_word val)3314{3315 C_word *ptr = (C_word *)val;3316 assert(C_in_scratchspacep(val));3317/* XXX assert(slot == NULL || C_in_stackp((C_word)slot));3318*/3319 if (*(ptr-1) == ALIGNMENT_HOLE_MARKER) --ptr;3320 if (*(ptr-1) == (C_word)NULL && slot != NULL)3321 C_scratch_usage += *(ptr-2) + 2;3322 if (*(ptr-1) != (C_word)NULL && slot == NULL)3323 C_scratch_usage -= *(ptr-2) + 2;3324 *(ptr-1) = (C_word)slot; /* Remember the slot pointing here, for realloc */3325 if (slot != NULL) *slot = val;3326 return val;3327}33283329/* Initiate garbage collection: */333033313332void C_save_and_reclaim(void *trampoline, int n, C_word *av)3333{3334 C_word new_size = nmax((C_word)1 << C_ilen(n), DEFAULT_TEMPORARY_STACK_SIZE);33353336 assert(av > C_temporary_stack_bottom || av < C_temporary_stack_limit);3337 assert(C_temporary_stack == C_temporary_stack_bottom);33383339 /* Don't *immediately* slam back to default size */3340 if (new_size < temporary_stack_size / 4)3341 new_size = temporary_stack_size >> 1;33423343 if (new_size != temporary_stack_size) {33443345 if(fixed_temporary_stack_size)3346 panic(C_text("fixed temporary stack overflow (\"apply\" called with too many arguments?)"));33473348 if(gc_report_flag) {3349 C_dbg(C_text("GC"), C_text("resizing temporary stack dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),3350 C_wordstobytes(temporary_stack_size) / 1024,3351 C_wordstobytes(new_size) / 1024);3352 }33533354 C_free(C_temporary_stack_limit);33553356 if((C_temporary_stack_limit = (C_word *)C_malloc(new_size * sizeof(C_word))) == NULL)3357 panic(C_text("out of memory - could not resize temporary stack"));33583359 C_temporary_stack_bottom = C_temporary_stack_limit + new_size;3360 C_temporary_stack = C_temporary_stack_bottom;3361 temporary_stack_size = new_size;3362 }33633364 C_temporary_stack = C_temporary_stack_bottom - n;33653366 assert(C_temporary_stack >= C_temporary_stack_limit);33673368 C_memmove(C_temporary_stack, av, n * sizeof(C_word));3369 C_reclaim(trampoline, n);3370}337133723373void C_save_and_reclaim_args(void *trampoline, int n, ...)3374{3375 va_list v;3376 int i;33773378 va_start(v, n);33793380 for(i = 0; i < n; ++i)3381 C_save(va_arg(v, C_word));33823383 va_end(v);3384 C_reclaim(trampoline, n);3385}338633873388#ifdef __SUNPRO_C3389static void _mark(C_word *x, C_byte *s, C_byte **t, C_byte *l) { \3390 C_word *_x = (x), _val = *_x; \3391 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3392}3393#else3394# define _mark(x,s,t,l) \3395 C_cblock \3396 C_word *_x = (x), _val = *_x; \3397 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3398 C_cblockend3399#endif34003401/* NOTE: This macro is particularly unhygienic! */3402#define mark(x) _mark(x, tgt_space_start, tgt_space_top, tgt_space_limit)34033404C_regparm void C_reclaim(void *trampoline, C_word c)3405{3406 int i, j, fcount;3407 C_uword count;3408 C_word **msp, last;3409 C_byte *tmp, *start;3410 C_GC_ROOT *gcrp;3411 double tgc = 0;3412 volatile int finalizers_checked;3413 FINALIZER_NODE *flist;3414 C_DEBUG_INFO cell;3415 C_byte *tgt_space_start, **tgt_space_top, *tgt_space_limit;34163417 /* assert(C_timer_interrupt_counter >= 0); */34183419 if(pending_interrupts_count > 0 && C_interrupts_enabled) {3420 stack_check_demand = 0; /* forget demand: we're not going to gc yet */3421 handle_interrupt(trampoline);3422 }34233424 cell.enabled = 0;3425 cell.event = C_DEBUG_GC;3426 cell.loc = "<runtime>";3427 cell.val = "GC_MINOR";3428 C_debugger(&cell, 0, NULL);34293430 /* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */3431 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);34323433 finalizers_checked = 0;3434 C_restart_trampoline = trampoline;3435 C_restart_c = c;3436 gc_mode = GC_MINOR;3437 tgt_space_start = fromspace_start;3438 tgt_space_top = &C_fromspace_top;3439 tgt_space_limit = C_fromspace_limit;3440 weak_pair_chain = (C_word)NULL;3441 locative_chain = (C_word)NULL;34423443 start = C_fromspace_top;34443445 /* Entry point for second-level GC (on explicit request or because of full fromspace): */3446#ifdef HAVE_SIGSETJMP3447 if(C_sigsetjmp(gc_restart, 0) || start >= C_fromspace_limit) {3448#else3449 if(C_setjmp(gc_restart) || start >= C_fromspace_limit) {3450#endif3451 if(gc_bell) {3452 C_putchar(7);3453 C_fflush(stdout);3454 }34553456 tgc = C_cpu_milliseconds();34573458 if(gc_mode == GC_REALLOC) {3459 cell.val = "GC_REALLOC";3460 C_debugger(&cell, 0, NULL);3461 C_rereclaim2(percentage(heap_size, C_heap_growth), 0);3462 gc_mode = GC_MAJOR;34633464 tgt_space_start = tospace_start;3465 tgt_space_top = &tospace_top;3466 tgt_space_limit= tospace_limit;34673468 count = (C_uword)tospace_top - (C_uword)tospace_start;3469 goto never_mind_edsger;3470 }34713472 start = (C_byte *)C_align((C_uword)tospace_top);3473 gc_mode = GC_MAJOR;3474 tgt_space_start = tospace_start;3475 tgt_space_top = &tospace_top;3476 tgt_space_limit= tospace_limit;3477 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into tospace */3478 locative_chain = (C_word)NULL; /* same for locatives */34793480 cell.val = "GC_MAJOR";3481 C_debugger(&cell, 0, NULL);34823483 mark_live_heap_only_objects(tgt_space_start, tgt_space_top, tgt_space_limit);34843485 /* mark normal GC roots (see below for finalizer handling): */3486 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3487 if(!gcrp->finalizable) mark(&gcrp->value);3488 }3489 }3490 else {3491 /* Mark mutated slots: */3492 for(msp = mutation_stack_bottom; msp < mutation_stack_top; ++msp)3493 mark(*msp);3494 }34953496 mark_live_objects(tgt_space_start, tgt_space_top, tgt_space_limit);34973498 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);3499 if(gc_mode == GC_MINOR) count = (C_uword)*tgt_space_top - (C_uword)start;3500 start = *tgt_space_top;35013502 if(gc_mode == GC_MINOR) {3503 ++gc_count_1;3504 ++gc_count_1_total;3505 update_locatives(GC_MINOR, start, *tgt_space_top);3506 update_weak_pairs(GC_MINOR, start, *tgt_space_top);3507 }3508 else {3509 /* Mark finalizer list and remember pointers to non-forwarded items: */3510 last = C_block_item(pending_finalizers_symbol, 0);35113512 if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {3513 /* still finalizers pending: just mark table items... */3514 if(gc_report_flag)3515 C_dbg(C_text("GC"), C_text("%d finalized item(s) still pending\n"), j);35163517 j = fcount = 0;35183519 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3520 mark(&flist->item);3521 mark(&flist->finalizer);3522 ++fcount;3523 }35243525 /* mark finalizable GC roots: */3526 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3527 if(gcrp->finalizable) mark(&gcrp->value);3528 }35293530 if(gc_report_flag && fcount > 0)3531 C_dbg(C_text("GC"), C_text("%d finalizer value(s) marked\n"), fcount);3532 }3533 else {3534 j = fcount = 0;35353536 /* move into pending */3537 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3538 if(j < C_max_pending_finalizers) {3539 if(!is_fptr(C_block_header(flist->item)))3540 pending_finalizer_indices[ j++ ] = flist;3541 }3542 }35433544 /* mark */3545 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3546 mark(&flist->item);3547 mark(&flist->finalizer);3548 }35493550 /* mark finalizable GC roots: */3551 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3552 if(gcrp->finalizable) mark(&gcrp->value);3553 }3554 }35553556 pending_finalizer_count = j;3557 finalizers_checked = 1;35583559 if(pending_finalizer_count > 0 && gc_report_flag)3560 C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),3561 pending_finalizer_count, live_finalizer_count);35623563 /* Once more mark nested objects after (maybe) copying finalizer objects: */3564 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);35653566 /* Copy finalized items with remembered indices into `##sys#pending-finalizers'3567 (and release finalizer node): */3568 if(pending_finalizer_count > 0) {3569 if(gc_report_flag)3570 C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count);35713572 last = C_block_item(pending_finalizers_symbol, 0);3573 assert(C_block_item(last, 0) == C_fix(0));3574 C_set_block_item(last, 0, C_fix(pending_finalizer_count));35753576 for(i = 0; i < pending_finalizer_count; ++i) {3577 flist = pending_finalizer_indices[ i ];3578 C_set_block_item(last, 1 + i * 2, flist->item);3579 C_set_block_item(last, 2 + i * 2, flist->finalizer);35803581 if(flist->previous != NULL) flist->previous->next = flist->next;3582 else finalizer_list = flist->next;35833584 if(flist->next != NULL) flist->next->previous = flist->previous;35853586 flist->next = finalizer_free_list;3587 flist->previous = NULL;3588 finalizer_free_list = flist;3589 --live_finalizer_count;3590 }3591 }35923593 update_locatives(gc_mode, start, *tgt_space_top);3594 update_weak_pairs(gc_mode, start, *tgt_space_top);35953596 count = (C_uword)tospace_top - (C_uword)tospace_start; // Actual used, < heap_size/235973598 {3599 C_uword min_half = count + C_heap_half_min_free;3600 C_uword low_half = percentage(heap_size/2, C_heap_shrinkage_used);3601 C_uword grown = percentage(heap_size, C_heap_growth);3602 C_uword shrunk = percentage(heap_size, C_heap_shrinkage);36033604 if (count < low_half) {3605 heap_shrink_counter++;3606 } else {3607 heap_shrink_counter = 0;3608 }36093610 /*** isn't gc_mode always GC_MAJOR here? */3611 if(gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3612 C_heap_shrinkage > 0 &&3613 // This prevents grow, shrink, grow, shrink... spam3614 HEAP_SHRINK_COUNTS < heap_shrink_counter &&3615 (min_half * 2) <= shrunk && // Min. size trumps shrinkage3616 heap_size > MINIMAL_HEAP_SIZE) {3617 if(gc_report_flag) {3618 C_dbg(C_text("GC"), C_text("Heap low water mark hit (%d%%), shrinking...\n"),3619 C_heap_shrinkage_used);3620 }3621 heap_shrink_counter = 0;3622 C_rereclaim2(shrunk, 0);3623 } else if (gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3624 (heap_size / 2) < min_half) {3625 if(gc_report_flag) {3626 C_dbg(C_text("GC"), C_text("Heap high water mark hit, growing...\n"));3627 }3628 heap_shrink_counter = 0;3629 C_rereclaim2(grown, 0);3630 } else {3631 C_fromspace_top = tospace_top;3632 tmp = fromspace_start;3633 fromspace_start = tospace_start;3634 tospace_start = tospace_top = tmp;3635 tmp = C_fromspace_limit;3636 C_fromspace_limit = tospace_limit;3637 tospace_limit = tmp;3638 }3639 }36403641 never_mind_edsger:3642 ++gc_count_2;3643 }36443645 if(gc_mode == GC_MAJOR) {3646 tgc = C_cpu_milliseconds() - tgc;3647 gc_ms += tgc;3648 timer_accumulated_gc_ms += tgc;3649 }36503651 /* Display GC report:3652 Note: stubbornly writes to stderr - there is no provision for other output-ports */3653 if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {3654 C_dbg(C_text("GC"), C_text("level %d\tgcs(minor) %d\tgcs(major) %d\n"),3655 gc_mode, gc_count_1, gc_count_2);3656 i = (C_uword)C_stack_pointer;36573658#if C_STACK_GROWS_DOWNWARD3659 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3660 (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);3661#else3662 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3663 (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);3664#endif36653666 if(gc_mode == GC_MINOR)3667 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);36683669 C_fputc('\n', C_stderr);3670 C_dbg("GC", C_text(" from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3671 (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);36723673 if(gc_mode == GC_MAJOR)3674 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);36753676 C_fputc('\n', C_stderr);3677 C_dbg("GC", C_text(" to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),3678 (C_uword)tospace_start, (C_uword)tospace_top,3679 (C_uword)tospace_limit);3680 }36813682 /* GC will have copied any live objects out of scratch space: clear it */3683 if (C_scratchspace_start != C_scratchspace_top) {3684 /* And drop the scratchspace in case of a major or reallocating collection */3685 if (gc_mode != GC_MINOR) {3686 C_free(C_scratchspace_start);3687 C_scratchspace_start = NULL;3688 C_scratchspace_limit = NULL;3689 scratchspace_size = 0;3690 }3691 C_scratchspace_top = C_scratchspace_start;3692 C_scratch_usage = 0;3693 }36943695 if(gc_mode == GC_MAJOR) {3696 gc_count_1 = 0;3697 maximum_heap_usage = count > maximum_heap_usage ? count : maximum_heap_usage;3698 }36993700 if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);37013702 /* Unwind stack completely */3703#ifdef HAVE_SIGSETJMP3704 C_siglongjmp(C_restart, 1);3705#else3706 C_longjmp(C_restart, 1);3707#endif3708}370937103711/* Mark live objects which can exist in the nursery and/or the heap */3712static C_regparm void mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3713{3714 C_word *p;3715 TRACE_INFO *tinfo;37163717 assert(C_temporary_stack >= C_temporary_stack_limit);37183719 /* Mark live values from the currently running closure: */3720 for(p = C_temporary_stack; p < C_temporary_stack_bottom; ++p)3721 mark(p);37223723 /* Clear the mutated slot stack: */3724 mutation_stack_top = mutation_stack_bottom;37253726 /* Mark trace-buffer: */3727 for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {3728 mark(&tinfo->cooked_location);3729 mark(&tinfo->cooked1);3730 mark(&tinfo->cooked2);3731 mark(&tinfo->thread);3732 }3733}373437353736/*3737 * Mark all live *heap* objects that don't need GC mode-specific3738 * treatment. Thus, no finalizers or other GC roots.3739 *3740 * Finalizers are excluded because these need special handling:3741 * finalizers referring to dead objects must be marked and queued.3742 * However, *pending* finalizers (for objects previously determined3743 * to be collectable) are marked so that these objects stick around3744 * until after the finalizer has been run.3745 *3746 * This function does not need to be called on a minor GC, since these3747 * objects won't ever exist in the nursery.3748 */3749static C_regparm void mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3750{3751 LF_LIST *lfn;3752 C_word *p, **msp, last;3753 unsigned int i;3754 C_SYMBOL_TABLE *stp;37553756 /* Mark items in forwarding table: */3757 for(p = forwarding_table; *p != 0; p += 2) {3758 last = p[ 1 ];3759 mark(&p[ 1 ]);3760 C_block_header(p[ 0 ]) = C_block_header(last);3761 }37623763 /* Mark literal frames: */3764 for(lfn = lf_list; lfn != NULL; lfn = lfn->next)3765 for(i = 0; i < (unsigned int)lfn->count; ++i)3766 mark(&lfn->lf[i]);37673768 /* Mark symbol tables: */3769 for(stp = symbol_table_list; stp != NULL; stp = stp->next)3770 for(i = 0; i < stp->size; ++i)3771 mark(&stp->table[i]);37723773 /* Mark collectibles: */3774 for(msp = collectibles; msp < collectibles_top; ++msp)3775 if(*msp != NULL) mark(*msp);37763777 /* Mark system globals */3778 mark(&core_provided_symbol);3779 mark(&interrupt_hook_symbol);3780 mark(&error_hook_symbol);3781 mark(&callback_continuation_stack_symbol);3782 mark(&pending_finalizers_symbol);3783 mark(¤t_thread_symbol);37843785 mark(&s8vector_symbol);3786 mark(&u16vector_symbol);3787 mark(&s16vector_symbol);3788 mark(&u32vector_symbol);3789 mark(&s32vector_symbol);3790 mark(&u64vector_symbol);3791 mark(&s64vector_symbol);3792 mark(&f32vector_symbol);3793 mark(&f64vector_symbol);3794}379537963797/*3798 * Mark nested values in already moved (i.e., marked) blocks in3799 * breadth-first manner (Cheney's algorithm).3800 */3801static 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)3802{3803 int n;3804 C_word bytes;3805 C_word *p;3806 C_header h;3807 C_SCHEME_BLOCK *bp;38083809 while(heap_scan_top < *tgt_space_top) {3810 bp = (C_SCHEME_BLOCK *)heap_scan_top;38113812 if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)3813 bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);38143815 n = C_header_size(bp);3816 h = bp->header;3817 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);3818 p = bp->data;38193820 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {3821 if(h & C_SPECIALBLOCK_BIT) {3822 --n;3823 ++p;3824 }38253826 while(n--) mark(p++);3827 }38283829 heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);3830 }3831}383238333834static C_regparm void really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3835{3836 C_word val;3837 C_uword n, bytes;3838 C_header h;3839 C_SCHEME_BLOCK *p, *p2;38403841 val = *x;38423843 if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_scratchspacep(val)) {3844#ifdef C_GC_HOOKS3845 if(C_gc_trace_hook != NULL)3846 C_gc_trace_hook(x, gc_mode);3847#endif3848 return;3849 }38503851 p = (C_SCHEME_BLOCK *)val;3852 h = p->header;38533854 while(is_fptr(h)) { /* TODO: Pass in fptr chain limit? */3855 val = fptr_to_ptr(h);3856 p = (C_SCHEME_BLOCK *)val;3857 h = p->header;3858 }38593860 /* Already in target space, probably as result of chasing fptrs */3861 if ((C_uword)val >= (C_uword)tgt_space_start && (C_uword)val < (C_uword)*tgt_space_top) {3862 *x = val;3863 return;3864 }38653866 p2 = (C_SCHEME_BLOCK *)C_align((C_uword)*tgt_space_top);38673868#ifndef C_SIXTY_FOUR3869 if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tgt_space_limit) {3870 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3871 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3872 }3873#endif38743875 n = C_header_size(p);3876 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);38773878 if(C_unlikely(((C_byte *)p2 + bytes + sizeof(C_word)) > tgt_space_limit)) {3879 if (gc_mode == GC_MAJOR) {3880 /* Detect impossibilities before GC_REALLOC to preserve state: */3881 if (C_in_stackp((C_word)p) && bytes > stack_size)3882 panic(C_text("Detected corrupted data in stack"));3883 if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))3884 panic(C_text("Detected corrupted data in heap"));3885 if(C_heap_size_is_fixed)3886 panic(C_text("out of memory - heap full"));38873888 gc_mode = GC_REALLOC;3889 } else if (gc_mode == GC_REALLOC) {3890 if (new_tospace_top > new_tospace_limit) {3891 panic(C_text("out of memory - heap full while resizing"));3892 }3893 }3894#ifdef HAVE_SIGSETJMP3895 C_siglongjmp(gc_restart, 1);3896#else3897 C_longjmp(gc_restart, 1);3898#endif3899 }39003901 *tgt_space_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);39023903 *x = (C_word)p2;3904 p2->header = h;3905 p->header = ptr_to_fptr((C_uword)p2);3906 C_memcpy(p2->data, p->data, bytes);3907 if (h == C_WEAK_PAIR_TAG && !C_immediatep(p2->data[0])) {3908 p->data[0] = weak_pair_chain; /* "Recycle" the weak pair's CAR to point to prev head */3909 weak_pair_chain = (C_word)p; /* Make this fwd ptr the new head of the weak pair chain */3910 } else if (h == C_LOCATIVE_TAG) {3911 p->data[0] = locative_chain; /* "Recycle" the locative pointer field to point to prev head */3912 locative_chain = (C_word)p; /* Make this fwd ptr the new head of the locative chain */3913 }3914}391539163917/* Do a major GC into a freshly allocated heap: */39183919#define remark(x) _mark(x, new_tospace_start, &new_tospace_top, new_tospace_limit)39203921C_regparm void C_rereclaim2(C_uword size, int relative_resize)3922{3923 int i;3924 C_GC_ROOT *gcrp;3925 FINALIZER_NODE *flist;3926 C_byte *new_heapspace, *start;3927 size_t new_heapspace_size;39283929 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);39303931 /*3932 * Normally, size is "absolute": it indicates the desired size of3933 * the entire new heap. With relative_resize, size is a demanded3934 * increase of the heap, so we'll have to add it. This calculation3935 * doubles the current heap size because heap_size is already both3936 * halves. We add size*2 because we'll eventually divide the size3937 * by 2 for both halves. We also add stack_size*2 because all the3938 * nursery data is also copied to the heap on GC, and the requested3939 * memory "size" must be available after the GC.3940 */3941 if(relative_resize) size = (heap_size + size + stack_size) * 2;39423943 if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;39443945 /*3946 * When heap grows, ensure it's enough to accommodate first3947 * generation (nursery). Because we're calculating the total heap3948 * size here (fromspace *AND* tospace), we have to double the stack3949 * size, otherwise we'd accommodate only half the stack in the tospace.3950 */3951 if(size > heap_size && size - heap_size < stack_size * 2)3952 size = heap_size + stack_size * 2;39533954 /*3955 * The heap has grown but we've already hit the maximal size with the current3956 * heap, we can't do anything else but panic.3957 */3958 if(size > heap_size && heap_size >= C_maximal_heap_size)3959 panic(C_text("out of memory - heap has reached its maximum size"));39603961 if(size > C_maximal_heap_size) size = C_maximal_heap_size;39623963 if(debug_mode) {3964 C_dbg(C_text("debug"), C_text("resizing heap dynamically from "3965 UWORD_COUNT_FORMAT_STRING "k to "3966 UWORD_COUNT_FORMAT_STRING "k ...\n"),3967 heap_size / 1024, size / 1024);3968 }39693970 if(gc_report_flag) {3971 C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING3972 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3973 (C_word)fromspace_start, (C_word)C_fromspace_limit);3974 C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING3975 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3976 (C_word)tospace_start, (C_word)tospace_limit);3977 }39783979 heap_size = size; /* Total heap size of the two halves... */3980 size /= 2; /* ...each half is this big */39813982 /*3983 * Start by allocating the new heap's fromspace. After remarking,3984 * allocate the other half of the new heap (its tospace).3985 *3986 * To clarify: what we call "new_space" here is what will eventually3987 * be cycled over to "fromspace" when re-reclamation has finished3988 * (that is, after the old one has been freed).3989 */3990 if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)3991 panic(C_text("out of memory - cannot allocate heap segment"));3992 new_heapspace_size = size;39933994 new_tospace_top = new_tospace_start;3995 new_tospace_limit = new_tospace_start + size;3996 start = new_tospace_top;3997 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into new heap */3998 locative_chain = (C_word)NULL; /* same for locatives */39994000 /* Mark standard live objects in nursery and heap */4001 mark_live_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);4002 mark_live_heap_only_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);40034004 /* Mark finalizer table: */4005 for(flist = finalizer_list; flist != NULL; flist = flist->next) {4006 remark(&flist->item);4007 remark(&flist->finalizer);4008 }40094010 /* Mark *all* GC roots */4011 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {4012 remark(&gcrp->value);4013 }40144015 /* Mark nested values in already moved (marked) blocks in breadth-first manner: */4016 mark_nested_objects(start, new_tospace_start, &new_tospace_top, new_tospace_limit);4017 update_locatives(GC_REALLOC, new_tospace_top, new_tospace_top);4018 update_weak_pairs(GC_REALLOC, new_tospace_top, new_tospace_top);40194020 heap_free (heapspace1, heapspace1_size);4021 heap_free (heapspace2, heapspace2_size);40224023 if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)4024 panic(C_text("out of memory - cannot allocate next heap segment"));4025 heapspace2_size = size;40264027 heapspace1 = new_heapspace;4028 heapspace1_size = new_heapspace_size;4029 tospace_limit = tospace_start + size;4030 tospace_top = tospace_start;4031 fromspace_start = new_tospace_start;4032 C_fromspace_top = new_tospace_top;4033 C_fromspace_limit = new_tospace_limit;40344035 if(gc_report_flag) {4036 C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);4037 C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING4038 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4039 (C_word)fromspace_start, (C_word)C_fromspace_limit);4040 C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING4041 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4042 (C_word)tospace_start, (C_word)tospace_limit);4043 }40444045 if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);4046}404740484049/* When a weak pair is encountered by GC, it turns it into a4050 * forwarding reference as usual, but then it re-uses the now-defunct4051 * pair's CAR field. It clobbers that field with a plain C pointer to4052 * the current "weak pair chain". Then, the weak pair chain is4053 * updated to point to this new forwarding pointer, creating a crude4054 * linked list of sorts.4055 *4056 * We can get away with this because the slots of an object are4057 * unused/dead when it is turned into a forwarding pointer - the4058 * forwarding pointer itself is just a header, but those data fields4059 * remain allocated. Since the weak pair chain is a linked list that4060 * can *only* contain weak-pairs-turned-forwarding-pointer, we may4061 * freely access the first slot of such forwarding pointers.4062 */4063static C_regparm void update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end)4064{4065 int weakn = 0;4066 C_word p, pair, car, h;4067 C_byte *car_ptr;40684069 /* NOTE: Don't use C_block_item() because it asserts the block is4070 * big enough in DEBUGBUILD, but forwarding pointers have size 0.4071 */4072 for (p = weak_pair_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4073 /* NOTE: We only chain up the weak pairs' forwarding pointers into4074 * the new space. This is safe because already forwarded weak4075 * pairs in nursery/fromspace will be forwarded *again* into4076 * tospace/new heap. That forwarding pointer is chained up.4077 * Still-unforwarded weak pairs will be forwarded straight to the4078 * new space, and also chained up.4079 */4080 h = C_block_header(p);4081 assert(is_fptr(h));4082 pair = fptr_to_ptr(h);4083 assert(!is_fptr(C_block_header(pair)));40844085 /* The pair itself should be live */4086 assert((mode == GC_MINOR && !C_in_stackp(pair)) ||4087 (mode == GC_MAJOR && !C_in_stackp(pair) && !C_in_fromspacep(pair)) ||4088 (mode == GC_REALLOC && !C_in_stackp(pair) && !C_in_heapp(pair))); /* NB: *old* heap! */40894090 car = C_block_item(pair, 0);4091 assert(!C_immediatep(car)); /* should be ensured when adding it to the chain */4092 h = C_block_header(car);4093 while (is_fptr(h)) {4094 car = fptr_to_ptr(h);4095 h = C_block_header(car);4096 }40974098 car_ptr = (C_byte *)(C_uword)car;4099 /* If the car is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4100 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4101 if((mode == GC_MINOR && C_in_stackp(car)) ||4102 (mode == GC_MAJOR && (C_in_stackp(car) || C_in_fromspacep(car) || (car_ptr >= undead_start && car_ptr < undead_end))) ||4103 (mode == GC_REALLOC && (C_in_stackp(car) || C_in_heapp(car) || (car_ptr >= undead_start && car_ptr < undead_end)))) { /* NB: *old* heap! */41044105 C_set_block_item(pair, 0, C_SCHEME_BROKEN_WEAK_PTR);4106 ++weakn;4107 } else {4108 /* Might have moved, re-set the car to the target value */4109 C_set_block_item(pair, 0, car);4110 }4111 }4112 weak_pair_chain = (C_word)NULL;4113 if(gc_report_flag && weakn)4114 C_dbg("GC", C_text("%d recoverable weak pairs found\n"), weakn);4115}41164117/* Same as weak pairs (see above), but for locatives. Note that this4118 * also includes non-weak locatives, as these point *into* an object,4119 * so the updating of that pointer is not handled by the GC proper4120 * (which only deals with full objects).4121 */4122static C_regparm void update_locatives(int mode, C_byte *undead_start, C_byte *undead_end)4123{4124 int weakn = 0;4125 C_word p, loc, ptr, obj, h, offset;4126 C_byte *obj_ptr;41274128 for (p = locative_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4129 h = C_block_header(p);4130 assert(is_fptr(h));4131 loc = fptr_to_ptr(h);4132 assert(!is_fptr(C_block_header(loc)));41334134 /* The locative object itself should be live */4135 assert((mode == GC_MINOR && !C_in_stackp(loc)) ||4136 (mode == GC_MAJOR && !C_in_stackp(loc) && !C_in_fromspacep(loc)) ||4137 (mode == GC_REALLOC && !C_in_stackp(loc) && !C_in_heapp(loc))); /* NB: *old* heap! */41384139 ptr = C_block_item(loc, 0); /* fix up ptr */4140 if (ptr == 0) continue; /* Skip already dropped weak locatives */4141 offset = C_unfix(C_block_item(loc, 1));4142 obj = ptr - offset;41434144 h = C_block_header(obj);4145 while (is_fptr(h)) {4146 obj = fptr_to_ptr(h);4147 h = C_block_header(obj);4148 }41494150 obj_ptr = (C_byte *)(C_uword)obj;4151 /* If the object is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4152 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4153 if((mode == GC_MINOR && C_in_stackp(obj)) ||4154 (mode == GC_MAJOR && (C_in_stackp(obj) || C_in_fromspacep(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end))) ||4155 (mode == GC_REALLOC && (C_in_stackp(obj) || C_in_heapp(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end)))) { /* NB: *old* heap! */41564157 /* NOTE: This does *not* use BROKEN_WEAK_POINTER. This slot4158 * holds an unaligned raw C pointer, not a Scheme object */4159 C_set_block_item(loc, 0, 0);4160 ++weakn;4161 } else {4162 /* Might have moved, re-set the object to the target value */4163 C_set_block_item(loc, 0, obj + offset);4164 }4165 }4166 locative_chain = (C_word)NULL;4167 if(gc_report_flag && weakn)4168 C_dbg("GC", C_text("%d recoverable weak locatives found\n"), weakn);4169}417041714172void handle_interrupt(void *trampoline)4173{4174 C_word *p, h, reason, state, proc, n;4175 double c;4176 C_word av[ 4 ];41774178 /* Build vector with context information: */4179 n = C_temporary_stack_bottom - C_temporary_stack;4180 p = C_alloc(C_SIZEOF_VECTOR(2) + C_SIZEOF_VECTOR(n));4181 proc = (C_word)p;4182 *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | sizeof(C_word);4183 *(p++) = (C_word)trampoline;4184 state = (C_word)p;4185 *(p++) = C_VECTOR_TYPE | (n + 1);4186 *(p++) = proc;4187 C_memcpy(p, C_temporary_stack, n * sizeof(C_word));41884189 /* Restore state to the one at the time of the interrupt: */4190 C_temporary_stack = C_temporary_stack_bottom;4191 C_stack_limit = C_stack_hard_limit;41924193 /* Invoke high-level interrupt handler: */4194 reason = C_fix(pending_interrupts[ --pending_interrupts_count ]);4195 proc = C_block_item(interrupt_hook_symbol, 0);41964197 if(C_immediatep(proc))4198 panic(C_text("`##sys#interrupt-hook' is not defined"));41994200 c = C_cpu_milliseconds() - interrupt_time;4201 last_interrupt_latency = c;4202 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4203 /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */4204 av[ 0 ] = proc;4205 av[ 1 ] = C_SCHEME_UNDEFINED;4206 av[ 2 ] = reason;4207 av[ 3 ] = state;4208 C_do_apply(4, av);4209}421042114212void4213C_unbound_variable(C_word sym)4214{4215 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);4216}421742184219void4220C_decoding_error(C_word str, C_word index)4221{4222 barf(C_DECODING_ERROR, NULL, str, index);4223}422442254226/* XXX: This needs to be given a better name.4227 C_retrieve used to exist but it just called C_fast_retrieve */4228C_regparm C_word C_retrieve2(C_word val, char *name)4229{4230 C_word *p;4231 int len;42324233 if(val == C_SCHEME_UNBOUND) {4234 len = C_strlen(name);4235 /* this is ok: we won't return from `C_retrieve2'4236 * (or the value isn't needed). */4237 p = C_alloc(C_SIZEOF_STRING(len));4238 C_unbound_variable(C_string2(&p, name));4239 }42404241 return val;4242}424342444245void C_ccall C_invalid_procedure(C_word c, C_word *av)4246{4247 C_word self = av[0];4248 barf(C_NOT_A_CLOSURE_ERROR, NULL, self);4249}425042514252C_regparm void *C_retrieve2_symbol_proc(C_word val, char *name)4253{4254 C_word *p;4255 int len;42564257 if(val == C_SCHEME_UNBOUND) {4258 len = C_strlen(name);4259 /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */4260 p = C_alloc(C_SIZEOF_STRING(len));4261 barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));4262 }42634264 return C_fast_retrieve_proc(val);4265}42664267#ifdef C_NONUNIX4268VOID CALLBACK win_timer(PVOID data_ignored, BOOLEAN wait_or_fired)4269{4270 if (profiling) take_profile_sample();4271}4272#endif42734274static void set_profile_timer(C_uword freq)4275{4276#ifdef C_NONUNIX4277 static HANDLE timer = NULL;42784279 if (freq == 0) {4280 assert(timer != NULL);4281 if (!DeleteTimerQueueTimer(NULL, timer, NULL)) goto error;4282 timer = NULL;4283 } else if (freq < 1000) {4284 panic(C_text("On Windows, sampling can only be done in milliseconds"));4285 } else {4286 if (!CreateTimerQueueTimer(&timer, NULL, win_timer, NULL, 0, freq/1000, 0))4287 goto error;4288 }4289#else4290 struct itimerval itv;42914292 itv.it_value.tv_sec = freq / 1000000;4293 itv.it_value.tv_usec = freq % 1000000;4294 itv.it_interval.tv_sec = itv.it_value.tv_sec;4295 itv.it_interval.tv_usec = itv.it_value.tv_usec;42964297 if (setitimer(C_PROFILE_TIMER, &itv, NULL) == -1) goto error;4298#endif42994300 return;43014302error:4303 if (freq == 0) panic(C_text("error clearing timer for profiling"));4304 else panic(C_text("error setting timer for profiling"));4305}43064307/* Bump profile count for current top of trace buffer */4308static void take_profile_sample()4309{4310 PROFILE_BUCKET **bp, *b;4311 C_char *key;4312 TRACE_INFO *tb;4313 /* To count distinct calls of a procedure, remember last call */4314 static C_char *prev_key = NULL;4315 static TRACE_INFO *prev_tb = NULL;43164317 /* trace_buffer_top points *beyond* the topmost entry: Go back one */4318 if (trace_buffer_top == trace_buffer) {4319 if (!trace_buffer_full) return; /* No data yet */4320 tb = trace_buffer_limit - 1;4321 } else {4322 tb = trace_buffer_top - 1;4323 }43244325 if (tb->raw_location != NULL) {4326 key = tb->raw_location;4327 } else {4328 key = "<eval>"; /* Location string is GCable, can't use it */4329 }43304331 /* We could also just hash the pointer but that's a bit trickier */4332 bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0);4333 b = *bp;43344335 /* First try to find pre-existing item in hash table */4336 while(b != NULL) {4337 if(b->key == key) {4338 b->sample_count++;4339 if (prev_key != key && prev_tb != tb)4340 b->call_count++;4341 goto done;4342 }4343 else b = b->next;4344 }43454346 /* Not found, allocate a new item and use it as bucket's new head */4347 b = next_profile_bucket;4348 next_profile_bucket = NULL;43494350 assert(b != NULL);43514352 b->next = *bp;4353 b->key = key;4354 *bp = b;4355 b->sample_count = 1;4356 b->call_count = 1;43574358done:4359 prev_tb = tb;4360 prev_key = key;4361}436243634364C_regparm void C_trace(C_char *name)4365{4366 C_word thread;43674368 if(show_trace) {4369 C_fputs(name, C_stderr);4370 C_fputc('\n', C_stderr);4371 }43724373 /*4374 * When profiling, pre-allocate profile bucket if necessary. This4375 * is used in the signal handler, because it may not malloc.4376 */4377 if(profiling && next_profile_bucket == NULL) {4378 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4379 if (next_profile_bucket == NULL) {4380 panic(C_text("out of memory - cannot allocate profile table-bucket"));4381 }4382 }43834384 if(trace_buffer_top >= trace_buffer_limit) {4385 trace_buffer_top = trace_buffer;4386 trace_buffer_full = 1;4387 }43884389 trace_buffer_top->raw_location = name;4390 trace_buffer_top->cooked_location = C_SCHEME_FALSE;4391 trace_buffer_top->cooked1 = C_SCHEME_FALSE;4392 trace_buffer_top->cooked2 = C_SCHEME_FALSE;4393 thread = C_block_item(current_thread_symbol, 0);4394 trace_buffer_top->thread = C_and(C_blockp(thread), C_thread_id(thread));4395 ++trace_buffer_top;4396}439743984399C_regparm C_word C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)4400{4401 /* See above */4402 if(profiling && next_profile_bucket == NULL) {4403 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4404 if (next_profile_bucket == NULL) {4405 panic(C_text("out of memory - cannot allocate profile table-bucket"));4406 }4407 }44084409 if(trace_buffer_top >= trace_buffer_limit) {4410 trace_buffer_top = trace_buffer;4411 trace_buffer_full = 1;4412 }44134414 trace_buffer_top->raw_location = raw;4415 trace_buffer_top->cooked_location = l;4416 trace_buffer_top->cooked1 = x;4417 trace_buffer_top->cooked2 = y;4418 trace_buffer_top->thread = t;4419 ++trace_buffer_top;4420 return x;4421}442244234424C_char *C_dump_trace(int start)4425{4426 TRACE_INFO *ptr;4427 C_char *result;4428 int i, result_len;44294430 result_len = STRING_BUFFER_SIZE;4431 if((result = (char *)C_malloc(result_len)) == NULL)4432 horror(C_text("out of memory - cannot allocate trace-dump buffer"));44334434 *result = '\0';44354436 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4437 if(trace_buffer_full) {4438 i = C_trace_buffer_size;4439 C_strlcat(result, C_text("...more...\n"), result_len);4440 }4441 else i = trace_buffer_top - trace_buffer;44424443 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4444 ptr += start;4445 i -= start;44464447 for(;i--; ++ptr) {4448 if(ptr >= trace_buffer_limit) ptr = trace_buffer;44494450 if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {4451 result_len = C_strlen(result) * 2;4452 result = C_realloc(result, result_len);4453 if(result == NULL)4454 horror(C_text("out of memory - cannot reallocate trace-dump buffer"));4455 }44564457 if (ptr->raw_location != NULL) {4458 C_strlcat(result, ptr->raw_location, result_len);4459 } else if (ptr->cooked_location != C_SCHEME_FALSE) {4460 C_word bv = C_block_item(ptr->cooked_location, 0);4461 C_strlcat(result, C_c_string(bv), nmin(C_header_size(bv) - 1, result_len));4462 } else {4463 C_strlcat(result, "<unknown>", result_len);4464 }44654466 if(i > 0) C_strlcat(result, "\n", result_len);4467 else C_strlcat(result, " \t<--\n", result_len);4468 }4469 }44704471 return result;4472}447344744475C_regparm void C_clear_trace_buffer(void)4476{4477 int i, old_profiling = profiling;44784479 profiling = 0;44804481 if(trace_buffer == NULL) {4482 if(C_trace_buffer_size < MIN_TRACE_BUFFER_SIZE)4483 C_trace_buffer_size = MIN_TRACE_BUFFER_SIZE;44844485 trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);44864487 if(trace_buffer == NULL)4488 panic(C_text("out of memory - cannot allocate trace-buffer"));4489 }44904491 trace_buffer_top = trace_buffer;4492 trace_buffer_limit = trace_buffer + C_trace_buffer_size;4493 trace_buffer_full = 0;44944495 for(i = 0; i < C_trace_buffer_size; ++i) {4496 trace_buffer[ i ].raw_location = NULL;4497 trace_buffer[ i ].cooked_location = C_SCHEME_FALSE;4498 trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;4499 trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;4500 trace_buffer[ i ].thread = C_SCHEME_FALSE;4501 }45024503 profiling = old_profiling;4504}45054506C_word C_resize_trace_buffer(C_word size) {4507 int old_size = C_trace_buffer_size, old_profiling = profiling;4508 assert(trace_buffer);4509 profiling = 0;4510 free(trace_buffer);4511 trace_buffer = NULL;4512 C_trace_buffer_size = C_unfix(size);4513 C_clear_trace_buffer();4514 profiling = old_profiling;4515 return(C_fix(old_size));4516}45174518C_word C_fetch_trace(C_word starti, C_word buffer)4519{4520 TRACE_INFO *ptr;4521 int i, p = 0, start = C_unfix(starti);45224523 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4524 if(trace_buffer_full) i = C_trace_buffer_size;4525 else i = trace_buffer_top - trace_buffer;45264527 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4528 if(start < 0) start = 0;4529 if(start > i) start = i;4530 ptr += start;4531 i -= start;45324533 if(C_header_size(buffer) < i * 5)4534 panic(C_text("destination buffer too small for call-chain"));45354536 for(;i--; ++ptr) {4537 if(ptr >= trace_buffer_limit) ptr = trace_buffer;45384539 /* outside-pointer, will be ignored by GC */4540 C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw_location);45414542 /* subject to GC */4543 C_mutate(&C_block_item(buffer, p++), ptr->cooked_location);4544 C_mutate(&C_block_item(buffer, p++), ptr->cooked1);4545 C_mutate(&C_block_item(buffer, p++), ptr->cooked2);4546 C_mutate(&C_block_item(buffer, p++), ptr->thread);4547 }4548 }45494550 return C_fix(p);4551}45524553C_regparm C_word C_u_i_bytevector_hash(C_word str, C_word start, C_word end, C_word rnd)4554{4555 int len = C_header_size(str);4556 C_char *ptr = C_c_string(str);4557 return C_fix(hash_string(C_unfix(end) - C_unfix(start), ptr + C_unfix(start), C_MOST_POSITIVE_FIXNUM, C_unfix(rnd)));4558}45594560C_regparm void C_toplevel_entry(C_char *name)4561{4562 if(debug_mode)4563 C_dbg(C_text("debug"), C_text("entering %s...\n"), name);4564}45654566C_regparm C_word C_a_i_provide(C_word **a, int c, C_word id)4567{4568 if (debug_mode == 2) {4569 C_word str = C_block_item(id, 1);4570 C_dbg(C_text("debug"), C_text("providing %s...\n"), C_c_string(str));4571 }4572 return C_a_i_putprop(a, 3, core_provided_symbol, id, C_SCHEME_TRUE);4573}45744575C_regparm C_word C_i_providedp(C_word id)4576{4577 return C_i_getprop(core_provided_symbol, id, C_SCHEME_FALSE);4578}45794580C_word C_halt(C_word msg)4581{4582 C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;45834584 if(C_gui_mode) {4585 if(msg != C_SCHEME_FALSE) {4586 int n = C_header_size(msg);45874588 if (n >= sizeof(buffer))4589 n = sizeof(buffer) - 1;4590 C_strlcpy(buffer, (C_char *)C_data_pointer(msg), n);4591 /* XXX msg isn't checked for NUL bytes, but we can't barf here either! */4592 }4593 else C_strlcpy(buffer, C_text("(aborted)"), sizeof(buffer));45944595 C_strlcat(buffer, C_text("\n\n"), sizeof(buffer));45964597 if(dmp != NULL) C_strlcat(buffer, dmp, sizeof(buffer));45984599#if defined(_WIN32) && !defined(__CYGWIN__)4600 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);4601 ExitProcess(1);4602#endif4603 } /* otherwise fall through */46044605 if(msg != C_SCHEME_FALSE) {4606 C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);4607 C_fputc('\n', C_stderr);4608 }46094610 if(dmp != NULL)4611 C_dbg("", C_text("\n%s"), dmp);46124613 C_fflush(NULL);4614 C_exit_runtime(C_fix(EX_SOFTWARE));4615 return 0;4616}461746184619C_word C_message(C_word msg)4620{4621 C_word m = C_block_item(msg, 0);4622 unsigned int n = C_header_size(m);4623 /*4624 * Strictly speaking this isn't necessary for the non-gui-mode,4625 * but let's try and keep this consistent across modes.4626 */4627 if (C_memchr(C_c_string(m), '\0', n - 1) != NULL)4628 barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);46294630 if(C_gui_mode) {4631 if (n >= sizeof(buffer))4632 n = sizeof(buffer) - 1;4633 C_strncpy(buffer, C_c_string(m), n);4634 buffer[ n ] = '\0';4635#if defined(_WIN32) && !defined(__CYGWIN__)4636 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONEXCLAMATION);4637 return C_SCHEME_UNDEFINED;4638#endif4639 } /* fall through */46404641 C_fwrite(C_c_string(m), n, sizeof(C_char), stdout);4642 C_putchar('\n');4643 return C_SCHEME_UNDEFINED;4644}464546464647C_regparm C_word C_equalp(C_word x, C_word y)4648{4649 C_header header;4650 C_word bits, n, i;46514652 C_stack_check1(barf(C_CIRCULAR_DATA_ERROR, "equal?"));46534654 loop:4655 if(x == y) return 1;46564657 if(C_immediatep(x) || C_immediatep(y)) return 0;46584659 /* NOTE: Extra check at the end is special consideration for pairs being equal to weak pairs */4660 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;4661 else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {4662 if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)4663 return C_ub_i_flonum_eqvp(C_flonum_magnitude(x),4664 C_flonum_magnitude(y));4665 else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);4666 }4667 else if(C_header_bits(x) == C_STRING_TYPE)4668 return C_equalp(C_block_item(x, 0), C_block_item(y, 0));4669 else if(header == C_SYMBOL_TAG) return 0;4670 else {4671 i = 0;4672 n = header & C_HEADER_SIZE_MASK;46734674 if(bits & C_SPECIALBLOCK_BIT) {4675 /* do not recurse into closures */4676 if(C_header_bits(x) == C_CLOSURE_TYPE)4677 return !C_memcmp(C_data_pointer(x), C_data_pointer(y), n * sizeof(C_word));4678 else if(C_block_item(x, 0) != C_block_item(y, 0)) return 0;4679 else ++i;46804681 if(n == 1) return 1;4682 }46834684 if(--n < 0) return 1;46854686 while(i < n)4687 if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;4688 else ++i;46894690 x = C_block_item(x, i);4691 y = C_block_item(y, i);4692 goto loop;4693 }4694}469546964697C_regparm C_word C_set_gc_report(C_word flag)4698{4699 if(flag == C_SCHEME_FALSE) gc_report_flag = 0;4700 else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;4701 else gc_report_flag = 1;47024703 return C_SCHEME_UNDEFINED;4704}47054706C_regparm C_word C_i_accumulated_gc_time(void)4707{4708 double tgc;47094710 tgc = timer_accumulated_gc_ms;4711 timer_accumulated_gc_ms = 0;4712 return C_fix(tgc);4713}47144715C_regparm C_word C_start_timer(void)4716{4717 tracked_mutation_count = 0;4718 mutation_count = 0;4719 gc_count_1_total = 0;4720 gc_count_2 = 0;4721 timer_start_ms = C_cpu_milliseconds();4722 gc_ms = 0;4723 maximum_heap_usage = 0;4724 return C_SCHEME_UNDEFINED;4725}472647274728void C_ccall C_stop_timer(C_word c, C_word *av)4729{4730 C_word4731 closure = av[ 0 ],4732 k = av[ 1 ];4733 double t0 = C_cpu_milliseconds() - timer_start_ms;4734 C_word4735 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_BIGNUM(1) + C_SIZEOF_VECTOR(7) ],4736 *a = ab,4737 elapsed = C_flonum(&a, t0 / 1000.0),4738 gc_time = C_flonum(&a, gc_ms / 1000.0),4739 heap_usage = C_unsigned_int_to_num(&a, maximum_heap_usage),4740 info;47414742 info = C_vector(&a, 7, elapsed, gc_time, C_fix(mutation_count),4743 C_fix(tracked_mutation_count), C_fix(gc_count_1_total),4744 C_fix(gc_count_2), heap_usage);4745 C_kontinue(k, info);4746}474747484749C_word C_exit_runtime(C_word code)4750{4751 C__exit(C_unfix(code));4752}475347544755C_regparm C_word C_set_print_precision(C_word n)4756{4757 flonum_print_precision = C_unfix(n);4758 return C_SCHEME_UNDEFINED;4759}476047614762C_regparm C_word C_get_print_precision(void)4763{4764 return C_fix(flonum_print_precision);4765}476647674768C_regparm C_word C_read_char(C_word port)4769{4770 C_FILEPTR fp = C_port_file(port);4771 C_char buf[ 5 ];4772 int n = 0, r, c;47734774 do {4775 c = C_getc(fp);47764777 if(c == EOF) {4778 if(ferror(fp)) {4779 clearerr(fp);4780 if(n == 0) return C_fix(-1);4781 }4782 /* Found here:4783 http://mail.python.org/pipermail/python-bugs-list/2002-July/012579.html */4784#if defined(_WIN32) && !defined(__CYGWIN__)4785 else if(GetLastError() == ERROR_OPERATION_ABORTED) {4786 if(n == 0) return C_fix(-1);4787 }4788#endif4789 else if(n == 0) return C_SCHEME_END_OF_FILE;4790 }47914792 if(n == 0) r = C_utf_expect(c);4793 buf[ n++ ] = c;4794 } while(n < r);47954796 return C_utf_decode_ptr(buf);4797}479847994800C_regparm C_word C_execute_shell_command(C_word string)4801{4802 C_word bv = C_block_item(string, 0);4803 int n = C_header_size(bv);4804 char *buf = buffer;48054806 /* Windows doc says to flush all output streams before calling system.4807 Probably a good idea for all platforms. */4808 (void)fflush(NULL);48094810 if(n >= STRING_BUFFER_SIZE) {4811 if((buf = (char *)C_malloc(n + 1)) == NULL)4812 barf(C_OUT_OF_MEMORY_ERROR, "system");4813 }48144815 C_memcpy(buf, C_data_pointer(bv), n); /* includes 0 */4816 if (n - 1 != strlen(buf))4817 barf(C_ASCIIZ_REPRESENTATION_ERROR, "system", string);48184819 n = C_system(C_OS_FILENAME(bv, 0));48204821 if(buf != buffer) C_free(buf);48224823 return C_fix(n);4824}48254826/*4827 * TODO: Implement something for Windows that supports selecting on4828 * arbitrary fds (there, select() only works on network sockets and4829 * poll() is not available at all).4830 */4831C_regparm int C_check_fd_ready(int fd)4832{4833#ifdef NO_POSIX_POLL4834 fd_set in;4835 struct timeval tm;4836 int rv;4837 FD_ZERO(&in);4838 FD_SET(fd, &in);4839 tm.tv_sec = tm.tv_usec = 0;4840 rv = select(fd + 1, &in, NULL, NULL, &tm);4841 if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }4842 return rv;4843#else4844 struct pollfd ps;4845 ps.fd = fd;4846 ps.events = POLLIN;4847 return poll(&ps, 1, 0);4848#endif4849}48504851C_regparm C_word C_char_ready_p(C_word port)4852{4853#if defined(C_NONUNIX)4854 /* The best we can currently do on Windows... */4855 return C_SCHEME_TRUE;4856#else4857 int fd = C_fileno(C_port_file(port));4858 return C_mk_bool(C_check_fd_ready(fd) == 1);4859#endif4860}48614862C_regparm C_word C_i_tty_forcedp(void)4863{4864 return C_mk_bool(fake_tty_flag);4865}48664867C_regparm C_word C_i_debug_modep(void)4868{4869 return C_mk_bool(debug_mode);4870}48714872C_regparm C_word C_i_dump_heap_on_exitp(void)4873{4874 return C_mk_bool(dump_heap_on_exit);4875}48764877C_regparm C_word C_i_profilingp(void)4878{4879 return C_mk_bool(profiling);4880}48814882C_regparm C_word C_i_live_finalizer_count(void)4883{4884 return C_fix(live_finalizer_count);4885}48864887C_regparm C_word C_i_allocated_finalizer_count(void)4888{4889 return C_fix(allocated_finalizer_count);4890}489148924893C_regparm void C_raise_interrupt(int reason)4894{4895 if(C_interrupts_enabled) {4896 if(pending_interrupts_count == 0 && !handling_interrupts) {4897 pending_interrupts[ pending_interrupts_count++ ] = reason;4898 /*4899 * Force the next "soft" stack check to fail by faking a "full"4900 * stack. This causes save_and_reclaim() to be called, which4901 * invokes handle_interrupt(), which restores the stack limit.4902 */4903 C_stack_limit = stack_bottom;4904 interrupt_time = C_cpu_milliseconds();4905 } else if(pending_interrupts_count < MAX_PENDING_INTERRUPTS) {4906 int i;4907 /*4908 * Drop signals if too many, but don't queue up multiple entries4909 * for the same signal.4910 */4911 for (i = 0; i < pending_interrupts_count; ++i) {4912 if (pending_interrupts[i] == reason)4913 return;4914 }4915 pending_interrupts[ pending_interrupts_count++ ] = reason;4916 }4917 }4918}491949204921C_regparm C_word C_enable_interrupts(void)4922{4923 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4924 /* assert(C_timer_interrupt_counter > 0); */4925 C_interrupts_enabled = 1;4926 return C_SCHEME_UNDEFINED;4927}492849294930C_regparm C_word C_disable_interrupts(void)4931{4932 C_interrupts_enabled = 0;4933 return C_SCHEME_UNDEFINED;4934}493549364937C_regparm C_word C_establish_signal_handler(C_word signum, C_word reason)4938{4939 int sig = C_unfix(signum);4940#if defined(HAVE_SIGACTION)4941 struct sigaction newsig;4942#endif49434944 if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);4945 else if(reason == C_SCHEME_TRUE) C_signal(sig, SIG_DFL);4946 else {4947 signal_mapping_table[ sig ] = C_unfix(reason);4948#if defined(HAVE_SIGACTION)4949 newsig.sa_flags = 0;4950 /* The global signal handler is used for all signals, and4951 manipulates a single queue. Don't allow other signals to4952 concurrently arrive while it's doing this, to avoid races. */4953 sigfillset(&newsig.sa_mask);4954 newsig.sa_handler = global_signal_handler;4955 C_sigaction(sig, &newsig, NULL);4956#else4957 C_signal(sig, global_signal_handler);4958#endif4959 }49604961 return C_SCHEME_UNDEFINED;4962}496349644965/* Copy blocks into collected or static memory: */49664967C_regparm C_word C_copy_block(C_word from, C_word to)4968{4969 int n = C_header_size(from);4970 C_long bytes;49714972 if(C_header_bits(from) & C_BYTEBLOCK_BIT) {4973 bytes = n;4974 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4975 }4976 else {4977 bytes = C_wordstobytes(n);4978 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4979 }49804981 return to;4982}498349844985C_regparm C_word C_evict_block(C_word from, C_word ptr)4986{4987 int n = C_header_size(from);4988 C_long bytes;4989 C_word *p = (C_word *)C_pointer_address(ptr);49904991 if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;4992 else bytes = C_wordstobytes(n);49934994 C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4995 return (C_word)p;4996}499749984999/* Inline versions of some standard procedures: */50005001C_regparm C_word C_i_listp(C_word x)5002{5003 C_word fast = x, slow = x;50045005 while(fast != C_SCHEME_END_OF_LIST)5006 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5007 fast = C_u_i_cdr(fast);50085009 if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;5010 else if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5011 fast = C_u_i_cdr(fast);5012 slow = C_u_i_cdr(slow);50135014 if(fast == slow) return C_SCHEME_FALSE;5015 }5016 else return C_SCHEME_FALSE;5017 }5018 else return C_SCHEME_FALSE;50195020 return C_SCHEME_TRUE;5021}50225023C_regparm C_word C_i_s8vectorp(C_word x)5024{5025 return C_i_structurep(x, s8vector_symbol);5026}50275028C_regparm C_word C_i_u16vectorp(C_word x)5029{5030 return C_i_structurep(x, u16vector_symbol);5031}50325033C_regparm C_word C_i_s16vectorp(C_word x)5034{5035 return C_i_structurep(x, s16vector_symbol);5036}50375038C_regparm C_word C_i_u32vectorp(C_word x)5039{5040 return C_i_structurep(x, u32vector_symbol);5041}50425043C_regparm C_word C_i_s32vectorp(C_word x)5044{5045 return C_i_structurep(x, s32vector_symbol);5046}50475048C_regparm C_word C_i_u64vectorp(C_word x)5049{5050 return C_i_structurep(x, u64vector_symbol);5051}50525053C_regparm C_word C_i_s64vectorp(C_word x)5054{5055 return C_i_structurep(x, s64vector_symbol);5056}50575058C_regparm C_word C_i_f32vectorp(C_word x)5059{5060 return C_i_structurep(x, f32vector_symbol);5061}50625063C_regparm C_word C_i_f64vectorp(C_word x)5064{5065 return C_i_structurep(x, f64vector_symbol);5066}506750685069C_regparm C_word C_i_string_equal_p(C_word x, C_word y)5070{5071 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5072 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);50735074 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5075 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);50765077 return C_utf_equal(x, y);5078}507950805081C_regparm C_word C_i_string_ci_equal_p(C_word x, C_word y)5082{5083 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5084 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);50855086 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5087 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);50885089 return C_utf_equal_ci(x, y);5090}509150925093C_word C_a_i_list(C_word **a, int c, ...)5094{5095 va_list v;5096 C_word x, last, current,5097 first = C_SCHEME_END_OF_LIST;50985099 va_start(v, c);51005101 for(last = C_SCHEME_UNDEFINED; c--; last = current) {5102 x = va_arg(v, C_word);5103 current = C_a_pair(a, x, C_SCHEME_END_OF_LIST);51045105 if(last != C_SCHEME_UNDEFINED)5106 C_set_block_item(last, 1, current);5107 else first = current;5108 }51095110 va_end(v);5111 return first;5112}511351145115C_word C_a_i_string(C_word **a, int c, ...)5116{5117 va_list v;5118 C_word x, s, b;5119 char *p;5120 int len;51215122 s = (C_word)(*a);5123 *a = (C_word *)((C_word)(*a) + sizeof(C_word) * 5); /* C_SIZEOF_STRING */5124 b = (C_word)(*a);51255126 C_block_header_init(s, C_STRING_TAG);5127 C_set_block_item(s, 0, b);5128 C_set_block_item(s, 1, C_fix(c));5129 C_set_block_item(s, 2, C_fix(0));5130 C_set_block_item(s, 3, C_fix(0));5131 p = (char *)C_data_pointer(b);5132 va_start(v, c);51335134 for(; c; c--) {5135 x = va_arg(v, C_word);51365137 if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)5138 p = C_utf_encode(p, C_character_code(x));5139 else break;5140 }51415142 len = p - (char *)C_data_pointer(b) + 1;5143 *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(len));5144 *p = '\0';5145 C_block_header_init(b, C_BYTEVECTOR_TYPE | len);5146 va_end(v);5147 if (c) barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);5148 return s;5149}515051515152C_word C_a_i_record(C_word **ptr, int n, ...)5153{5154 va_list v;5155 C_word *p = *ptr,5156 *p0 = p;51575158 *(p++) = C_STRUCTURE_TYPE | n;5159 va_start(v, n);51605161 while(n--)5162 *(p++) = va_arg(v, C_word);51635164 *ptr = p;5165 va_end(v);5166 return (C_word)p0;5167}516851695170C_word C_a_i_port(C_word **ptr, int n)5171{5172 C_word5173 *p = *ptr,5174 *p0 = p;5175 int i;51765177 *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);5178 *(p++) = (C_word)NULL;51795180 for(i = 0; i < C_SIZEOF_PORT - 2; ++i)5181 *(p++) = C_SCHEME_FALSE;51825183 *ptr = p;5184 return (C_word)p0;5185}518651875188C_regparm C_word C_a_i_bytevector(C_word **ptr, int c, C_word num)5189{5190 C_word *p = *ptr,5191 *p0;5192 int n = C_unfix(num);51935194#ifndef C_SIXTY_FOUR5195 /* Align on 8-byte boundary: */5196 if(C_aligned8(p)) ++p;5197#endif51985199 p0 = p;5200 *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);5201 *ptr = p + n;5202 return (C_word)p0;5203}520452055206C_word C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)5207{5208 C_word5209 *p = *ptr,5210 *p0 = p;5211 void *mp;52125213 if(C_immediatep(x)) mp = NULL;5214 else if((C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);5215 else mp = C_data_pointer(x);52165217 *(p++) = C_POINTER_TYPE | 1;5218 *((void **)p) = mp;5219 *ptr = p + 1;5220 return (C_word)p0;5221}52225223C_regparm C_word C_i_nanp(C_word x)5224{5225 if (x & C_FIXNUM_BIT) {5226 return C_SCHEME_FALSE;5227 } else if (C_immediatep(x)) {5228 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5229 } else if (C_block_header(x) == C_FLONUM_TAG) {5230 return C_u_i_flonum_nanp(x);5231 } else if (C_truep(C_bignump(x))) {5232 return C_SCHEME_FALSE;5233 } else if (C_block_header(x) == C_RATNUM_TAG) {5234 return C_SCHEME_FALSE;5235 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5236 return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) ||5237 C_truep(C_i_nanp(C_u_i_cplxnum_imag(x))));5238 } else {5239 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5240 }5241}52425243C_regparm C_word C_i_finitep(C_word x)5244{5245 if (x & C_FIXNUM_BIT) {5246 return C_SCHEME_TRUE;5247 } else if (C_immediatep(x)) {5248 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5249 } else if (C_block_header(x) == C_FLONUM_TAG) {5250 return C_u_i_flonum_finitep(x);5251 } else if (C_truep(C_bignump(x))) {5252 return C_SCHEME_TRUE;5253 } else if (C_block_header(x) == C_RATNUM_TAG) {5254 return C_SCHEME_TRUE;5255 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5256 return C_and(C_i_finitep(C_u_i_cplxnum_real(x)),5257 C_i_finitep(C_u_i_cplxnum_imag(x)));5258 } else {5259 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5260 }5261}52625263C_regparm C_word C_i_infinitep(C_word x)5264{5265 if (x & C_FIXNUM_BIT) {5266 return C_SCHEME_FALSE;5267 } else if (C_immediatep(x)) {5268 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5269 } else if (C_block_header(x) == C_FLONUM_TAG) {5270 return C_u_i_flonum_infinitep(x);5271 } else if (C_truep(C_bignump(x))) {5272 return C_SCHEME_FALSE;5273 } else if (C_block_header(x) == C_RATNUM_TAG) {5274 return C_SCHEME_FALSE;5275 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5276 return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) ||5277 C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x))));5278 } else {5279 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5280 }5281}52825283C_regparm C_word C_i_exactp(C_word x)5284{5285 if (x & C_FIXNUM_BIT) {5286 return C_SCHEME_TRUE;5287 } else if (C_immediatep(x)) {5288 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5289 } else if (C_block_header(x) == C_FLONUM_TAG) {5290 return C_SCHEME_FALSE;5291 } else if (C_truep(C_bignump(x))) {5292 return C_SCHEME_TRUE;5293 } else if (C_block_header(x) == C_RATNUM_TAG) {5294 return C_SCHEME_TRUE;5295 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5296 return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5297 } else {5298 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5299 }5300}530153025303C_regparm C_word C_i_inexactp(C_word x)5304{5305 if (x & C_FIXNUM_BIT) {5306 return C_SCHEME_FALSE;5307 } else if (C_immediatep(x)) {5308 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5309 } else if (C_block_header(x) == C_FLONUM_TAG) {5310 return C_SCHEME_TRUE;5311 } else if (C_truep(C_bignump(x))) {5312 return C_SCHEME_FALSE;5313 } else if (C_block_header(x) == C_RATNUM_TAG) {5314 return C_SCHEME_FALSE;5315 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5316 return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5317 } else {5318 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5319 }5320}532153225323C_regparm C_word C_i_zerop(C_word x)5324{5325 if (x & C_FIXNUM_BIT) {5326 return C_mk_bool(x == C_fix(0));5327 } else if (C_immediatep(x)) {5328 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5329 } else if (C_block_header(x) == C_FLONUM_TAG) {5330 return C_mk_bool(C_flonum_magnitude(x) == 0.0);5331 } else if (C_block_header(x) == C_BIGNUM_TAG ||5332 C_block_header(x) == C_RATNUM_TAG ||5333 C_block_header(x) == C_CPLXNUM_TAG) {5334 return C_SCHEME_FALSE;5335 } else {5336 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5337 }5338}533953405341C_regparm C_word C_i_positivep(C_word x)5342{5343 if (x & C_FIXNUM_BIT)5344 return C_i_fixnum_positivep(x);5345 else if (C_immediatep(x))5346 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5347 else if (C_block_header(x) == C_FLONUM_TAG)5348 return C_mk_bool(C_flonum_magnitude(x) > 0.0);5349 else if (C_truep(C_bignump(x)))5350 return C_mk_nbool(C_bignum_negativep(x));5351 else if (C_block_header(x) == C_RATNUM_TAG)5352 return C_i_integer_positivep(C_u_i_ratnum_num(x));5353 else if (C_block_header(x) == C_CPLXNUM_TAG)5354 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x);5355 else5356 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5357}53585359C_regparm C_word C_i_integer_positivep(C_word x)5360{5361 if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);5362 else return C_mk_nbool(C_bignum_negativep(x));5363}53645365C_regparm C_word C_i_negativep(C_word x)5366{5367 if (x & C_FIXNUM_BIT)5368 return C_i_fixnum_negativep(x);5369 else if (C_immediatep(x))5370 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", 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_bool(C_bignum_negativep(x));5375 else if (C_block_header(x) == C_RATNUM_TAG)5376 return C_i_integer_negativep(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, "negative?", x);5379 else5380 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5381}538253835384C_regparm C_word C_i_integer_negativep(C_word x)5385{5386 if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);5387 else return C_mk_bool(C_bignum_negativep(x));5388}538953905391C_regparm C_word C_i_evenp(C_word x)5392{5393 if(x & C_FIXNUM_BIT) {5394 return C_i_fixnumevenp(x);5395 } else if(C_immediatep(x)) {5396 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5397 } else if (C_block_header(x) == C_FLONUM_TAG) {5398 double val, dummy;5399 val = C_flonum_magnitude(x);5400 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5401 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5402 else5403 return C_mk_bool(fmod(val, 2.0) == 0.0);5404 } else if (C_truep(C_bignump(x))) {5405 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5406 } else { /* No need to try extended number */5407 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5408 }5409}54105411C_regparm C_word C_i_integer_evenp(C_word x)5412{5413 if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);5414 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5415}541654175418C_regparm C_word C_i_oddp(C_word x)5419{5420 if(x & C_FIXNUM_BIT) {5421 return C_i_fixnumoddp(x);5422 } else if(C_immediatep(x)) {5423 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5424 } else if(C_block_header(x) == C_FLONUM_TAG) {5425 double val, dummy;5426 val = C_flonum_magnitude(x);5427 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5428 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5429 else5430 return C_mk_bool(fmod(val, 2.0) != 0.0);5431 } else if (C_truep(C_bignump(x))) {5432 return C_mk_bool(C_bignum_digits(x)[0] & 1);5433 } else {5434 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5435 }5436}543754385439C_regparm C_word C_i_integer_oddp(C_word x)5440{5441 if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);5442 return C_mk_bool(C_bignum_digits(x)[0] & 1);5443}544454455446C_regparm C_word C_i_car(C_word x)5447{5448 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5449 barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);54505451 return C_u_i_car(x);5452}545354545455C_regparm C_word C_i_cdr(C_word x)5456{5457 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5458 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);54595460 return C_u_i_cdr(x);5461}546254635464C_regparm C_word C_i_caar(C_word x)5465{5466 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5467 bad:5468 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x);5469 }54705471 x = C_u_i_car(x);54725473 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;54745475 return C_u_i_car(x);5476}547754785479C_regparm C_word C_i_cadr(C_word x)5480{5481 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5482 bad:5483 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);5484 }54855486 x = C_u_i_cdr(x);54875488 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;54895490 return C_u_i_car(x);5491}549254935494C_regparm C_word C_i_cdar(C_word x)5495{5496 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5497 bad:5498 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x);5499 }55005501 x = C_u_i_car(x);55025503 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55045505 return C_u_i_cdr(x);5506}550755085509C_regparm C_word C_i_cddr(C_word x)5510{5511 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5512 bad:5513 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);5514 }55155516 x = C_u_i_cdr(x);5517 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55185519 return C_u_i_cdr(x);5520}552155225523C_regparm C_word C_i_caddr(C_word x)5524{5525 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5526 bad:5527 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);5528 }55295530 x = C_u_i_cdr(x);5531 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5532 x = C_u_i_cdr(x);5533 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55345535 return C_u_i_car(x);5536}553755385539C_regparm C_word C_i_cdddr(C_word x)5540{5541 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5542 bad:5543 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);5544 }55455546 x = C_u_i_cdr(x);5547 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5548 x = C_u_i_cdr(x);5549 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55505551 return C_u_i_cdr(x);5552}555355545555C_regparm C_word C_i_cadddr(C_word x)5556{5557 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5558 bad:5559 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);5560 }55615562 x = C_u_i_cdr(x);5563 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5564 x = C_u_i_cdr(x);5565 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5566 x = C_u_i_cdr(x);5567 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55685569 return C_u_i_car(x);5570}557155725573C_regparm C_word C_i_cddddr(C_word x)5574{5575 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5576 bad:5577 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);5578 }55795580 x = C_u_i_cdr(x);5581 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5582 x = C_u_i_cdr(x);5583 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5584 x = C_u_i_cdr(x);5585 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55865587 return C_u_i_cdr(x);5588}558955905591C_regparm C_word C_i_list_tail(C_word lst, C_word i)5592{5593 C_word lst0 = lst;5594 int n;55955596 if(lst != C_SCHEME_END_OF_LIST &&5597 (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))5598 barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst);55995600 if(i & C_FIXNUM_BIT) n = C_unfix(i);5601 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);56025603 while(n--) {5604 if(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)5605 barf(C_OUT_OF_BOUNDS_ERROR, "list-tail", lst0, i);56065607 lst = C_u_i_cdr(lst);5608 }56095610 return lst;5611}561256135614C_regparm C_word C_i_vector_ref(C_word v, C_word i)5615{5616 int j;56175618 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5619 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);56205621 if(i & C_FIXNUM_BIT) {5622 j = C_unfix(i);56235624 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_BOUNDS_ERROR, "vector-ref", v, i);56255626 return C_block_item(v, j);5627 }56285629 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);5630 return C_SCHEME_UNDEFINED;5631}56325633C_regparm C_word C_i_bytevector_ref(C_word v, C_word i)5634{5635 int j;56365637 if(!C_truep(C_bytevectorp(v)))5638 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", v);56395640 if(i & C_FIXNUM_BIT) {5641 j = C_unfix(i);56425643 if(j < 0 || j >= C_header_size(v))5644 barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-ref", v, i);56455646 return C_fix(((unsigned char *)C_data_pointer(v))[j]);5647 }56485649 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", i);5650 return C_SCHEME_UNDEFINED;5651}56525653C_regparm C_word C_i_s8vector_ref(C_word v, C_word i)5654{5655 int j;56565657 if(!C_truep(C_i_s8vectorp(v)))5658 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", v);56595660 if(i & C_FIXNUM_BIT) {5661 j = C_unfix(i);56625663 if(j < 0 || j >= C_header_size(C_block_item(v, 1)))5664 barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-ref", v, i);56655666 return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);5667 }56685669 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);5670 return C_SCHEME_UNDEFINED;5671}56725673C_regparm C_word C_i_u16vector_ref(C_word v, C_word i)5674{5675 int j;56765677 if(!C_truep(C_i_u16vectorp(v)))5678 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", v);56795680 if(i & C_FIXNUM_BIT) {5681 j = C_unfix(i);56825683 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))5684 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);56855686 return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);5687 }56885689 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);5690 return C_SCHEME_UNDEFINED;5691}56925693C_regparm C_word C_i_s16vector_ref(C_word v, C_word i)5694{5695 C_word size;5696 int j;56975698 if(C_immediatep(v) || C_header_bits(v) != C_STRUCTURE_TYPE ||5699 C_header_size(v) != 2 || C_block_item(v, 0) != s16vector_symbol)5700 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", v);57015702 if(i & C_FIXNUM_BIT) {5703 j = C_unfix(i);57045705 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))5706 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);57075708 return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);5709 }57105711 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);5712 return C_SCHEME_UNDEFINED;5713}57145715C_regparm C_word C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5716{5717 int j;57185719 if(!C_truep(C_i_u32vectorp(v)))5720 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", v);57215722 if(i & C_FIXNUM_BIT) {5723 j = C_unfix(i);57245725 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5726 barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-ref", v, i);57275728 return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);5729 }57305731 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);5732 return C_SCHEME_UNDEFINED;5733}57345735C_regparm C_word C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5736{5737 int j;57385739 if(!C_truep(C_i_s32vectorp(v)))5740 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", v);57415742 if(i & C_FIXNUM_BIT) {5743 j = C_unfix(i);57445745 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5746 barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-ref", v, i);57475748 return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);5749 }57505751 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);5752 return C_SCHEME_UNDEFINED;5753}57545755C_regparm C_word C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5756{5757 int j;57585759 if(!C_truep(C_i_u64vectorp(v)))5760 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", v);57615762 if(i & C_FIXNUM_BIT) {5763 j = C_unfix(i);57645765 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5766 barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-ref", v, i);57675768 return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);5769 }57705771 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);5772 return C_SCHEME_UNDEFINED;5773}57745775C_regparm C_word C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5776{5777 int j;57785779 if(!C_truep(C_i_s64vectorp(v)))5780 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", v);57815782 if(i & C_FIXNUM_BIT) {5783 j = C_unfix(i);57845785 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5786 barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-ref", v, i);57875788 return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);5789 }57905791 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);5792 return C_SCHEME_UNDEFINED;5793}57945795C_regparm C_word C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5796{5797 int j;57985799 if(!C_truep(C_i_f32vectorp(v)))5800 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", v);58015802 if(i & C_FIXNUM_BIT) {5803 j = C_unfix(i);58045805 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5806 barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-ref", v, i);58075808 return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);5809 }58105811 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);5812 return C_SCHEME_UNDEFINED;5813}58145815C_regparm C_word C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5816{5817 C_word size;5818 int j;58195820 if(!C_truep(C_i_f64vectorp(v)))5821 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", v);58225823 if(i & C_FIXNUM_BIT) {5824 j = C_unfix(i);58255826 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5827 barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-ref", v, i);58285829 return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);5830 }58315832 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);5833 return C_SCHEME_UNDEFINED;5834}583558365837C_regparm C_word C_i_block_ref(C_word x, C_word i)5838{5839 int j;58405841 if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)5842 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);58435844 if(i & C_FIXNUM_BIT) {5845 j = C_unfix(i);58465847 if(j < 0 || j >= C_header_size(x))5848 barf(C_OUT_OF_BOUNDS_ERROR, "##sys#block-ref", x, i);58495850 return C_block_item(x, j);5851 }58525853 barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);5854 return C_SCHEME_UNDEFINED;5855}585658575858C_regparm C_word C_i_string_set(C_word s, C_word i, C_word c)5859{5860 int j;58615862 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5863 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);58645865 if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)5866 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);58675868 if(i & C_FIXNUM_BIT) {5869 j = C_unfix(i);58705871 if(j < 0 || j >= C_unfix(C_block_item(s, 1)))5872 barf(C_OUT_OF_BOUNDS_ERROR, "string-set!", s, i);58735874 return C_utf_setsubchar(s, i, c);5875 }58765877 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);5878 return C_SCHEME_UNDEFINED;5879}588058815882C_regparm C_word C_i_string_ref(C_word s, C_word i)5883{5884 int j;58855886 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5887 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);58885889 if(i & C_FIXNUM_BIT) {5890 j = C_unfix(i);58915892 if(j < 0 || j >= C_unfix(C_block_item(s, 1)))5893 barf(C_OUT_OF_BOUNDS_ERROR, "string-ref", s, i);58945895 return C_utf_subchar(s, i);5896 }58975898 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);5899 return C_SCHEME_UNDEFINED;5900}590159025903C_regparm C_word C_i_vector_length(C_word v)5904{5905 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5906 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);59075908 return C_fix(C_header_size(v));5909}59105911C_regparm C_word C_i_bytevector_length(C_word v)5912{5913 if(C_immediatep(v) || !C_truep(C_bytevectorp(v)))5914 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-length", v);59155916 return C_fix(C_header_size(v));5917}59185919C_regparm C_word C_i_s8vector_length(C_word v)5920{5921 if(!C_truep(C_i_s8vectorp(v)))5922 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);59235924 return C_fix(C_header_size(C_block_item(v, 1)));5925}59265927C_regparm C_word C_i_u16vector_length(C_word v)5928{5929 if(!C_truep(C_i_u16vectorp(v)))5930 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);59315932 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5933}59345935C_regparm C_word C_i_s16vector_length(C_word v)5936{5937 if(!C_truep(C_i_s16vectorp(v)))5938 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);59395940 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5941}59425943C_regparm C_word C_i_u32vector_length(C_word v)5944{5945 if(!C_truep(C_i_u32vectorp(v)))5946 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);59475948 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5949}59505951C_regparm C_word C_i_s32vector_length(C_word v)5952{5953 if(!C_truep(C_i_s32vectorp(v)))5954 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);59555956 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5957}59585959C_regparm C_word C_i_u64vector_length(C_word v)5960{5961 if(!C_truep(C_i_u64vectorp(v)))5962 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);59635964 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5965}59665967C_regparm C_word C_i_s64vector_length(C_word v)5968{5969 if(!C_truep(C_i_s64vectorp(v)))5970 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);59715972 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5973}597459755976C_regparm C_word C_i_f32vector_length(C_word v)5977{5978 if(!C_truep(C_i_f32vectorp(v)))5979 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);59805981 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5982}59835984C_regparm C_word C_i_f64vector_length(C_word v)5985{5986 if(!C_truep(C_i_f64vectorp(v)))5987 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);59885989 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5990}599159925993C_regparm C_word C_i_string_length(C_word s)5994{5995 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5996 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);59975998 return C_block_item(s, 1);5999}600060016002C_regparm C_word C_i_length(C_word lst)6003{6004 C_word fast = lst, slow = lst;6005 int n = 0;60066007 while(slow != C_SCHEME_END_OF_LIST) {6008 if(fast != C_SCHEME_END_OF_LIST) {6009 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6010 fast = C_u_i_cdr(fast);60116012 if(fast != C_SCHEME_END_OF_LIST) {6013 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6014 fast = C_u_i_cdr(fast);6015 }6016 else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);6017 }60186019 if(fast == slow)6020 barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);6021 }6022 }60236024 if(C_immediatep(slow) || C_header_type(slow) != C_PAIR_TYPE)6025 barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);60266027 slow = C_u_i_cdr(slow);6028 ++n;6029 }60306031 return C_fix(n);6032}603360346035C_regparm C_word C_u_i_length(C_word lst)6036{6037 int n = 0;60386039 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {6040 lst = C_u_i_cdr(lst);6041 ++n;6042 }60436044 return C_fix(n);6045}60466047C_regparm C_word C_i_set_car(C_word x, C_word val)6048{6049 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6050 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);60516052 C_mutate(&C_u_i_car(x), val);6053 return C_SCHEME_UNDEFINED;6054}605560566057C_regparm C_word C_i_set_cdr(C_word x, C_word val)6058{6059 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6060 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);60616062 C_mutate(&C_u_i_cdr(x), val);6063 return C_SCHEME_UNDEFINED;6064}606560666067C_regparm C_word C_i_vector_set(C_word v, C_word i, C_word x)6068{6069 int j;60706071 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)6072 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);60736074 if(i & C_FIXNUM_BIT) {6075 j = C_unfix(i);60766077 if(j < 0 || j >= C_header_size(v))6078 barf(C_OUT_OF_BOUNDS_ERROR, "vector-set!", v, i);60796080 C_mutate(&C_block_item(v, j), x);6081 }6082 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);60836084 return C_SCHEME_UNDEFINED;6085}60866087C_regparm C_word C_i_bytevector_set(C_word v, C_word i, C_word x)6088{6089 int j;6090 C_word n;60916092 if(!C_truep(C_bytevectorp(v)))6093 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-set!", v);60946095 if(i & C_FIXNUM_BIT) {6096 j = C_unfix(i);60976098 if(j < 0 || j >= C_header_size(v))6099 barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-set!", v, i);61006101 if(x & C_FIXNUM_BIT) {6102 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6103 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "bytevector-u8-set!", x);6104 }6105 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", x);6106 }6107 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", i);61086109 ((signed char *)C_data_pointer(v))[j] = n;6110 return C_SCHEME_UNDEFINED;6111}61126113C_regparm C_word C_i_s8vector_set(C_word v, C_word i, C_word x)6114{6115 int j;6116 C_word n;61176118 if(!C_truep(C_i_s8vectorp(v)))6119 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", v);61206121 if(i & C_FIXNUM_BIT) {6122 j = C_unfix(i);61236124 if(j < 0 || j >= C_header_size(C_block_item(v, 1)))6125 barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-set!", v, i);61266127 if(x & C_FIXNUM_BIT) {6128 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6129 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s8vector-set!", x);6130 }6131 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);6132 }6133 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", i);61346135 ((signed char *)C_data_pointer(C_block_item(v, 1)))[j] = n;6136 return C_SCHEME_UNDEFINED;6137}61386139C_regparm C_word C_i_u16vector_set(C_word v, C_word i, C_word x)6140{6141 int j;6142 C_word n;61436144 if(!C_truep(C_i_u16vectorp(v)))6145 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", v);61466147 if(i & C_FIXNUM_BIT) {6148 j = C_unfix(i);61496150 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))6151 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);61526153 if(x & C_FIXNUM_BIT) {6154 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);6155 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u16vector-set!", x);6156 }6157 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);6158 }6159 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", i);61606161 ((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6162 return C_SCHEME_UNDEFINED;6163}61646165C_regparm C_word C_i_s16vector_set(C_word v, C_word i, C_word x)6166{6167 int j;6168 C_word n;61696170 if(!C_truep(C_i_s16vectorp(v)))6171 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", v);61726173 if(i & C_FIXNUM_BIT) {6174 j = C_unfix(i);61756176 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))6177 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);61786179 if(x & C_FIXNUM_BIT) {6180 if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);6181 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s16vector-set!", x);6182 }6183 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);6184 }6185 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", i);61866187 ((short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6188 return C_SCHEME_UNDEFINED;6189}61906191C_regparm C_word C_i_u32vector_set(C_word v, C_word i, C_word x)6192{6193 int j;6194 C_u32 n;61956196 if(!C_truep(C_i_u32vectorp(v)))6197 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", v);61986199 if(i & C_FIXNUM_BIT) {6200 j = C_unfix(i);62016202 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6203 barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-set!", v, i);62046205 if(C_truep(C_i_exact_integerp(x))) {6206 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);6207 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u32vector-set!", x);6208 }6209 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);6210 }6211 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", i);62126213 ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6214 return C_SCHEME_UNDEFINED;6215}62166217C_regparm C_word C_i_s32vector_set(C_word v, C_word i, C_word x)6218{6219 int j;6220 C_s32 n;62216222 if(!C_truep(C_i_s32vectorp(v)))6223 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", v);62246225 if(i & C_FIXNUM_BIT) {6226 j = C_unfix(i);62276228 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6229 barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-set!", v, i);62306231 if(C_truep(C_i_exact_integerp(x))) {6232 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);6233 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s32vector-set!", x);6234 }6235 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);6236 }6237 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", i);62386239 ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6240 return C_SCHEME_UNDEFINED;6241}62426243C_regparm C_word C_i_u64vector_set(C_word v, C_word i, C_word x)6244{6245 int j;6246 C_u64 n;62476248 if(!C_truep(C_i_u64vectorp(v)))6249 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", v);62506251 if(i & C_FIXNUM_BIT) {6252 j = C_unfix(i);62536254 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6255 barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-set!", v, i);62566257 if(C_truep(C_i_exact_integerp(x))) {6258 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);6259 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u64vector-set!", x);6260 }6261 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);6262 }6263 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", i);62646265 ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6266 return C_SCHEME_UNDEFINED;6267}62686269C_regparm C_word C_i_s64vector_set(C_word v, C_word i, C_word x)6270{6271 int j;6272 C_s64 n;62736274 if(!C_truep(C_i_s64vectorp(v)))6275 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", v);62766277 if(i & C_FIXNUM_BIT) {6278 j = C_unfix(i);62796280 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6281 barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-set!", v, i);62826283 if(C_truep(C_i_exact_integerp(x))) {6284 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);6285 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s64vector-set!", x);6286 }6287 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);6288 }6289 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", i);62906291 ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6292 return C_SCHEME_UNDEFINED;6293}62946295C_regparm C_word C_i_f32vector_set(C_word v, C_word i, C_word x)6296{6297 int j;6298 double f;62996300 if(!C_truep(C_i_f32vectorp(v)))6301 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", v);63026303 if(i & C_FIXNUM_BIT) {6304 j = C_unfix(i);63056306 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6307 barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-set!", v, i);63086309 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6310 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6311 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6312 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f32vector-set!", x);6313 }6314 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);63156316 ((float *)C_data_pointer(C_block_item(v, 1)))[j] = (float)f;6317 return C_SCHEME_UNDEFINED;6318}63196320C_regparm C_word C_i_f64vector_set(C_word v, C_word i, C_word x)6321{6322 int j;6323 double f;63246325 if(!C_truep(C_i_f64vectorp(v)))6326 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", v);63276328 if(i & C_FIXNUM_BIT) {6329 j = C_unfix(i);63306331 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6332 barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-set!", v, i);63336334 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6335 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6336 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6337 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f64vector-set!", x);63386339 }6340 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);63416342 ((double *)C_data_pointer(C_block_item(v, 1)))[j] = f;6343 return C_SCHEME_UNDEFINED;6344}634563466347/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */6348C_regparm C_word6349C_s_a_i_abs(C_word **ptr, C_word n, C_word x)6350{6351 if (x & C_FIXNUM_BIT) {6352 return C_a_i_fixnum_abs(ptr, 1, x);6353 } else if (C_immediatep(x)) {6354 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6355 } else if (C_block_header(x) == C_FLONUM_TAG) {6356 return C_a_i_flonum_abs(ptr, 1, x);6357 } else if (C_truep(C_bignump(x))) {6358 return C_s_a_u_i_integer_abs(ptr, 1, x);6359 } else if (C_block_header(x) == C_RATNUM_TAG) {6360 return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)),6361 C_u_i_ratnum_denom(x));6362 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6363 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x);6364 } else {6365 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6366 }6367}63686369void C_ccall C_signum(C_word c, C_word *av)6370{6371 C_word k = av[ 1 ], x, y;63726373 if (c != 3) C_bad_argc_2(c, 3, av[ 0 ]);63746375 x = av[ 2 ];6376 y = av[ 3 ];63776378 if (x & C_FIXNUM_BIT) {6379 C_kontinue(k, C_i_fixnum_signum(x));6380 } else if (C_immediatep(x)) {6381 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);6382 } else if (C_block_header(x) == C_FLONUM_TAG) {6383 C_word *a = C_alloc(C_SIZEOF_FLONUM);6384 C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));6385 } else if (C_truep(C_bignump(x))) {6386 C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));6387 } else {6388 try_extended_number("##sys#extended-signum", 2, k, x);6389 }6390}639163926393/* The maximum this can allocate is a cplxnum which consists of two6394 * ratnums that consist of 2 fix bignums each. So that's6395 * C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!6396 */6397C_regparm C_word6398C_s_a_i_negate(C_word **ptr, C_word n, C_word x)6399{6400 if (x & C_FIXNUM_BIT) {6401 return C_a_i_fixnum_negate(ptr, 1, x);6402 } else if (C_immediatep(x)) {6403 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6404 } else if (C_block_header(x) == C_FLONUM_TAG) {6405 return C_a_i_flonum_negate(ptr, 1, x);6406 } else if (C_truep(C_bignump(x))) {6407 return C_s_a_u_i_integer_negate(ptr, 1, x);6408 } else if (C_block_header(x) == C_RATNUM_TAG) {6409 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)),6410 C_u_i_ratnum_denom(x));6411 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6412 return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)),6413 C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x)));6414 } else {6415 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6416 }6417}64186419/* Copy all the digits from source to target, obliterating what was6420 * there. If target is larger than source, the most significant6421 * digits will remain untouched.6422 */6423inline static void bignum_digits_destructive_copy(C_word target, C_word source)6424{6425 C_memcpy(C_bignum_digits(target), C_bignum_digits(source),6426 C_wordstobytes(C_bignum_size(source)));6427}64286429C_regparm C_word6430C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)6431{6432 if (x & C_FIXNUM_BIT) {6433 return C_a_i_fixnum_negate(ptr, 1, x);6434 } else {6435 if (C_bignum_negated_fitsinfixnump(x)) {6436 return C_fix(C_MOST_NEGATIVE_FIXNUM);6437 } else {6438 C_word res, negp = C_mk_nbool(C_bignum_negativep(x)),6439 size = C_fix(C_bignum_size(x));6440 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);6441 bignum_digits_destructive_copy(res, x);6442 return C_bignum_simplify(res);6443 }6444 }6445}644664476448/* Faster version that ignores sign */6449inline static int integer_length_abs(C_word x)6450{6451 if (x & C_FIXNUM_BIT) {6452 return C_ilen(C_wabs(C_unfix(x)));6453 } else {6454 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6455 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6456 last_digit_length = C_ilen(*last_digit);6457 return result + last_digit_length;6458 }6459}64606461C_regparm C_word C_i_integer_length(C_word x)6462{6463 if (x & C_FIXNUM_BIT) {6464 return C_i_fixnum_length(x);6465 } else if (C_truep(C_i_bignump(x))) {6466 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6467 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6468 last_digit_length = C_ilen(*last_digit);64696470 /* If *only* the highest bit is set, negating will give one less bit */6471 if (C_bignum_negativep(x) &&6472 *last_digit == ((C_uword)1 << (last_digit_length-1))) {6473 C_uword *startx = C_bignum_digits(x);6474 while (startx < last_digit && *startx == 0) ++startx;6475 if (startx == last_digit) result--;6476 }6477 return C_fix(result + last_digit_length);6478 } else {6479 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "integer-length", x);6480 }6481}64826483/* This is currently only used by Karatsuba multiplication and6484 * Burnikel-Ziegler division. */6485static C_regparm C_word6486bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end)6487{6488 if (x & C_FIXNUM_BIT) { /* Needed? */6489 if (C_unfix(start) == 0 && (end == C_SCHEME_FALSE || C_unfix(end) > 0))6490 return x;6491 else6492 return C_fix(0);6493 } else {6494 C_word negp, size;64956496 negp = C_mk_bool(C_bignum_negativep(x)); /* Always false */64976498 start = C_unfix(start);6499 /* We might get passed larger values than actually fits; pad w/ zeroes */6500 if (end == C_SCHEME_FALSE) end = C_bignum_size(x);6501 else end = nmin(C_unfix(end), C_bignum_size(x));6502 assert(start >= 0);65036504 size = end - start;65056506 if (size == 0 || start >= C_bignum_size(x)) {6507 return C_fix(0);6508 } else {6509 C_uword res, *res_digits, *x_digits;6510 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6511 res_digits = C_bignum_digits(res);6512 x_digits = C_bignum_digits(x);6513 /* Can't use bignum_digits_destructive_copy because that assumes6514 * target is at least as big as source.6515 */6516 C_memcpy(res_digits, x_digits + start, C_wordstobytes(end - start));6517 return C_bignum_simplify(res);6518 }6519 }6520}65216522/* This returns a tmp bignum negated copy of X (must be freed!) when6523 * the number is negative, or #f if it doesn't need to be negated.6524 * The size can be larger or smaller than X (it may be 1-padded).6525 */6526inline static C_word maybe_negate_bignum_for_bitwise_op(C_word x, C_word size)6527{6528 C_word nx = C_SCHEME_FALSE, xsize;6529 if (C_bignum_negativep(x)) {6530 nx = allocate_tmp_bignum(C_fix(size), C_SCHEME_FALSE, C_SCHEME_FALSE);6531 xsize = C_bignum_size(x);6532 /* Copy up until requested size, and init any remaining upper digits */6533 C_memcpy(C_bignum_digits(nx), C_bignum_digits(x),6534 C_wordstobytes(nmin(size, xsize)));6535 if (size > xsize)6536 C_memset(C_bignum_digits(nx)+xsize, 0, C_wordstobytes(size-xsize));6537 bignum_digits_destructive_negate(nx);6538 }6539 return nx;6540}65416542/* DEPRECATED */6543C_regparm C_word C_i_bit_to_bool(C_word n, C_word i)6544{6545 if (!C_truep(C_i_exact_integerp(n))) {6546 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit->boolean", n);6547 } else if (!(i & C_FIXNUM_BIT)) {6548 if (!C_immediatep(i) && C_truep(C_bignump(i)) && !C_bignum_negativep(i)) {6549 return C_i_integer_negativep(n); /* A bit silly, but strictly correct */6550 } else {6551 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6552 }6553 } else if (i & C_INT_SIGN_BIT) {6554 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6555 } else {6556 i = C_unfix(i);6557 if (n & C_FIXNUM_BIT) {6558 if (i >= C_WORD_SIZE) return C_mk_bool(n & C_INT_SIGN_BIT);6559 else return C_mk_bool((C_unfix(n) & ((C_uword)1 << i)) != 0);6560 } else {6561 C_word nn, d;6562 d = i / C_BIGNUM_DIGIT_LENGTH;6563 if (d >= C_bignum_size(n)) return C_mk_bool(C_bignum_negativep(n));65646565 if (C_truep(nn = maybe_negate_bignum_for_bitwise_op(n, d+1))) n = nn;65666567 i %= C_BIGNUM_DIGIT_LENGTH;6568 d = C_mk_bool((C_bignum_digits(n)[d] & (C_uword)1 << i) != 0);6569 if (C_truep(nn)) free_tmp_bignum(nn);6570 return d;6571 }6572 }6573}65746575C_regparm C_word6576C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)6577{6578 if ((x & y) & C_FIXNUM_BIT) {6579 return C_u_fixnum_and(x, y);6580 } else if (!C_truep(C_i_exact_integerp(x))) {6581 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", x);6582 } else if (!C_truep(C_i_exact_integerp(y))) {6583 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", y);6584 } else {6585 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6586 C_uword *scanr, *endr, *scans1, *ends1, *scans2;65876588 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6589 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);65906591 negp = C_mk_bool(C_bignum_negativep(x) && C_bignum_negativep(y));6592 /* Allow negative 1-bits to propagate */6593 if (C_bignum_negativep(x) || C_bignum_negativep(y))6594 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6595 else6596 size = nmin(C_bignum_size(x), C_bignum_size(y));65976598 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6599 scanr = C_bignum_digits(res);6600 endr = scanr + C_bignum_size(res);66016602 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6603 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;66046605 if (C_bignum_size(x) < C_bignum_size(y)) {6606 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6607 scans2 = C_bignum_digits(y);6608 } else {6609 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6610 scans2 = C_bignum_digits(x);6611 }66126613 while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;6614 C_memset(scanr, 0, C_wordstobytes(endr - scanr));66156616 if (C_truep(nx)) free_tmp_bignum(nx);6617 if (C_truep(ny)) free_tmp_bignum(ny);6618 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);66196620 return C_bignum_simplify(res);6621 }6622}66236624void C_ccall C_bitwise_and(C_word c, C_word *av)6625{6626 /* C_word closure = av[ 0 ]; */6627 C_word k = av[ 1 ];6628 C_word next_val, result, prev_result;6629 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;66306631 c -= 2;6632 av += 2;66336634 if (c == 0) C_kontinue(k, C_fix(-1));66356636 prev_result = result = *(av++);66376638 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6639 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", result);66406641 while (c--) {6642 next_val = *(av++);6643 a = ab[c&1]; /* One may hold last iteration result, the other is unused */6644 result = C_s_a_i_bitwise_and(&a, 2, result, next_val);6645 result = move_buffer_object(&a, ab[(c+1)&1], result);6646 clear_buffer_object(ab[(c+1)&1], prev_result);6647 prev_result = result;6648 }66496650 C_kontinue(k, result);6651}66526653C_regparm C_word6654C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)6655{6656 if ((x & y) & C_FIXNUM_BIT) {6657 return C_u_fixnum_or(x, y);6658 } else if (!C_truep(C_i_exact_integerp(x))) {6659 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", x);6660 } else if (!C_truep(C_i_exact_integerp(y))) {6661 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", y);6662 } else {6663 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6664 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;66656666 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6667 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);66686669 negp = C_mk_bool(C_bignum_negativep(x) || C_bignum_negativep(y));6670 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6671 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6672 scanr = C_bignum_digits(res);6673 endr = scanr + C_bignum_size(res);66746675 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6676 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;66776678 if (C_bignum_size(x) < C_bignum_size(y)) {6679 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6680 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6681 } else {6682 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6683 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6684 }66856686 while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;6687 while (scans2 < ends2) *scanr++ = *scans2++;6688 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6689 assert(scanr == endr);66906691 if (C_truep(nx)) free_tmp_bignum(nx);6692 if (C_truep(ny)) free_tmp_bignum(ny);6693 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);66946695 return C_bignum_simplify(res);6696 }6697}66986699void C_ccall C_bitwise_ior(C_word c, C_word *av)6700{6701 /* C_word closure = av[ 0 ]; */6702 C_word k = av[ 1 ];6703 C_word next_val, result, prev_result;6704 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;67056706 c -= 2;6707 av += 2;67086709 if (c == 0) C_kontinue(k, C_fix(0));67106711 prev_result = result = *(av++);67126713 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6714 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", result);67156716 while (c--) {6717 next_val = *(av++);6718 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6719 result = C_s_a_i_bitwise_ior(&a, 2, result, next_val);6720 result = move_buffer_object(&a, ab[(c+1)&1], result);6721 clear_buffer_object(ab[(c+1)&1], prev_result);6722 prev_result = result;6723 }67246725 C_kontinue(k, result);6726}67276728C_regparm C_word6729C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)6730{6731 if ((x & y) & C_FIXNUM_BIT) {6732 return C_fixnum_xor(x, y);6733 } else if (!C_truep(C_i_exact_integerp(x))) {6734 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", x);6735 } else if (!C_truep(C_i_exact_integerp(y))) {6736 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", y);6737 } else {6738 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6739 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;67406741 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6742 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);67436744 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6745 negp = C_mk_bool(C_bignum_negativep(x) != C_bignum_negativep(y));6746 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6747 scanr = C_bignum_digits(res);6748 endr = scanr + C_bignum_size(res);67496750 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6751 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;67526753 if (C_bignum_size(x) < C_bignum_size(y)) {6754 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6755 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6756 } else {6757 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6758 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6759 }67606761 while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;6762 while (scans2 < ends2) *scanr++ = *scans2++;6763 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6764 assert(scanr == endr);67656766 if (C_truep(nx)) free_tmp_bignum(nx);6767 if (C_truep(ny)) free_tmp_bignum(ny);6768 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);67696770 return C_bignum_simplify(res);6771 }6772}67736774void C_ccall C_bitwise_xor(C_word c, C_word *av)6775{6776 /* C_word closure = av[ 0 ]; */6777 C_word k = av[ 1 ];6778 C_word next_val, result, prev_result;6779 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;67806781 c -= 2;6782 av += 2;67836784 if (c == 0) C_kontinue(k, C_fix(0));67856786 prev_result = result = *(av++);67876788 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6789 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", result);67906791 while (c--) {6792 next_val = *(av++);6793 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6794 result = C_s_a_i_bitwise_xor(&a, 2, result, next_val);6795 result = move_buffer_object(&a, ab[(c+1)&1], result);6796 clear_buffer_object(ab[(c+1)&1], prev_result);6797 prev_result = result;6798 }67996800 C_kontinue(k, result);6801}68026803C_regparm C_word6804C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)6805{6806 if (!C_truep(C_i_exact_integerp(x))) {6807 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-not", x);6808 } else {6809 return C_s_a_u_i_integer_minus(ptr, 2, C_fix(-1), x);6810 }6811}68126813C_regparm C_word6814C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)6815{6816 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, size, negp, res,6817 digit_offset, bit_offset;68186819 if (!(y & C_FIXNUM_BIT))6820 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", y);68216822 y = C_unfix(y);6823 if (y == 0 || x == C_fix(0)) { /* Done (no shift) */6824 return x;6825 } else if (x & C_FIXNUM_BIT) {6826 if (y < 0) {6827 /* Don't shift more than a word's length (that's undefined in C!) */6828 if (-y < C_WORD_SIZE) {6829 return C_fix(C_unfix(x) >> -y);6830 } else {6831 return (x < 0) ? C_fix(-1) : C_fix(0);6832 }6833 } else if (y > 0 && y < C_WORD_SIZE-2 &&6834 /* After shifting, the length still fits a fixnum */6835 (C_ilen(C_unfix(x)) + y) < C_WORD_SIZE-2) {6836 return C_fix((C_uword)C_unfix(x) << y);6837 } else {6838 x = C_a_u_i_fix_to_big(&a, x);6839 }6840 } else if (!C_truep(C_i_bignump(x))) {6841 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "arithmetic-shift", x);6842 }68436844 negp = C_mk_bool(C_bignum_negativep(x));68456846 if (y > 0) { /* Shift left */6847 C_uword *startr, *startx, *endx, *endr;68486849 digit_offset = y / C_BIGNUM_DIGIT_LENGTH;6850 bit_offset = y % C_BIGNUM_DIGIT_LENGTH;68516852 size = C_fix(C_bignum_size(x) + digit_offset + 1);6853 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);68546855 startr = C_bignum_digits(res);6856 endr = startr + C_bignum_size(res);68576858 startx = C_bignum_digits(x);6859 endx = startx + C_bignum_size(x);68606861 /* Initialize only the lower digits we're skipping and the MSD */6862 C_memset(startr, 0, C_wordstobytes(digit_offset));6863 *(endr-1) = 0;6864 startr += digit_offset;6865 /* Can't use bignum_digits_destructive_copy because it assumes6866 * we want to copy from the start.6867 */6868 C_memcpy(startr, startx, C_wordstobytes(endx-startx));6869 if(bit_offset > 0)6870 bignum_digits_destructive_shift_left(startr, endr, bit_offset);68716872 return C_bignum_simplify(res);6873 } else if (-y >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) {6874 /* All bits are shifted out, just return 0 or -1 */6875 return C_truep(negp) ? C_fix(-1) : C_fix(0);6876 } else { /* Shift right */6877 C_uword *startr, *startx, *endr;6878 C_word nx;68796880 digit_offset = -y / C_BIGNUM_DIGIT_LENGTH;6881 bit_offset = -y % C_BIGNUM_DIGIT_LENGTH;68826883 size = C_fix(C_bignum_size(x) - digit_offset);6884 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);68856886 startr = C_bignum_digits(res);6887 endr = startr + C_bignum_size(res);68886889 size = C_bignum_size(x) + 1;6890 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) {6891 startx = C_bignum_digits(nx) + digit_offset;6892 } else {6893 startx = C_bignum_digits(x) + digit_offset;6894 }6895 /* Can't use bignum_digits_destructive_copy because that assumes6896 * target is at least as big as source.6897 */6898 C_memcpy(startr, startx, C_wordstobytes(endr-startr));6899 if(bit_offset > 0)6900 bignum_digits_destructive_shift_right(startr,endr,bit_offset,C_truep(nx));69016902 if (C_truep(nx)) {6903 free_tmp_bignum(nx);6904 bignum_digits_destructive_negate(res);6905 }6906 return C_bignum_simplify(res);6907 }6908}690969106911C_regparm C_word C_a_i_exp(C_word **a, int c, C_word n)6912{6913 double f;69146915 C_check_real(n, "exp", f);6916 return C_flonum(a, C_exp(f));6917}691869196920C_regparm C_word C_a_i_log(C_word **a, int c, C_word n)6921{6922 double f;69236924 C_check_real(n, "log", f);6925 return C_flonum(a, C_log(f));6926}692769286929C_regparm C_word C_a_i_sin(C_word **a, int c, C_word n)6930{6931 double f;69326933 C_check_real(n, "sin", f);6934 return C_flonum(a, C_sin(f));6935}693669376938C_regparm C_word C_a_i_cos(C_word **a, int c, C_word n)6939{6940 double f;69416942 C_check_real(n, "cos", f);6943 return C_flonum(a, C_cos(f));6944}694569466947C_regparm C_word C_a_i_tan(C_word **a, int c, C_word n)6948{6949 double f;69506951 C_check_real(n, "tan", f);6952 return C_flonum(a, C_tan(f));6953}695469556956C_regparm C_word C_a_i_asin(C_word **a, int c, C_word n)6957{6958 double f;69596960 C_check_real(n, "asin", f);6961 return C_flonum(a, C_asin(f));6962}696369646965C_regparm C_word C_a_i_acos(C_word **a, int c, C_word n)6966{6967 double f;69686969 C_check_real(n, "acos", f);6970 return C_flonum(a, C_acos(f));6971}697269736974C_regparm C_word C_a_i_atan(C_word **a, int c, C_word n)6975{6976 double f;69776978 C_check_real(n, "atan", f);6979 return C_flonum(a, C_atan(f));6980}698169826983C_regparm C_word C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)6984{6985 double f1, f2;69866987 C_check_real(n1, "atan", f1);6988 C_check_real(n2, "atan", f2);6989 return C_flonum(a, C_atan2(f1, f2));6990}699169926993C_regparm C_word C_a_i_sinh(C_word **a, int c, C_word n)6994{6995 double f;69966997 C_check_real(n, "sinh", f);6998 return C_flonum(a, C_sinh(f));6999}700070017002C_regparm C_word C_a_i_cosh(C_word **a, int c, C_word n)7003{7004 double f;70057006 C_check_real(n, "cosh", f);7007 return C_flonum(a, C_cosh(f));7008}700970107011C_regparm C_word C_a_i_tanh(C_word **a, int c, C_word n)7012{7013 double f;70147015 C_check_real(n, "tanh", f);7016 return C_flonum(a, C_tanh(f));7017}701870197020C_regparm C_word C_a_i_asinh(C_word **a, int c, C_word n)7021{7022 double f;70237024 C_check_real(n, "asinh", f);7025 return C_flonum(a, C_asinh(f));7026}702770287029C_regparm C_word C_a_i_acosh(C_word **a, int c, C_word n)7030{7031 double f;70327033 C_check_real(n, "acosh", f);7034 return C_flonum(a, C_acosh(f));7035}703670377038C_regparm C_word C_a_i_atanh(C_word **a, int c, C_word n)7039{7040 double f;70417042 C_check_real(n, "atanh", f);7043 return C_flonum(a, C_atanh(f));7044}704570467047C_regparm C_word C_a_i_sqrt(C_word **a, int c, C_word n)7048{7049 double f;70507051 C_check_real(n, "sqrt", f);7052 return C_flonum(a, C_sqrt(f));7053}705470557056C_regparm C_word C_i_assq(C_word x, C_word lst)7057{7058 C_word a;70597060 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7061 a = C_u_i_car(lst);70627063 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7064 if(C_u_i_car(a) == x) return a;7065 }7066 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);70677068 lst = C_u_i_cdr(lst);7069 }70707071 if(lst!=C_SCHEME_END_OF_LIST)7072 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", lst);70737074 return C_SCHEME_FALSE;7075}707670777078C_regparm C_word C_i_assv(C_word x, C_word lst)7079{7080 C_word a;70817082 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7083 a = C_u_i_car(lst);70847085 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7086 if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;7087 }7088 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);70897090 lst = C_u_i_cdr(lst);7091 }70927093 if(lst!=C_SCHEME_END_OF_LIST)7094 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", lst);70957096 return C_SCHEME_FALSE;7097}709870997100C_regparm C_word C_i_assoc(C_word x, C_word lst)7101{7102 C_word a;71037104 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7105 a = C_u_i_car(lst);71067107 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7108 if(C_equalp(C_u_i_car(a), x)) return a;7109 }7110 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);71117112 lst = C_u_i_cdr(lst);7113 }71147115 if(lst!=C_SCHEME_END_OF_LIST)7116 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", lst);71177118 return C_SCHEME_FALSE;7119}712071217122C_regparm C_word C_i_memq(C_word x, C_word lst)7123{7124 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7125 if(C_u_i_car(lst) == x) return lst;7126 else lst = C_u_i_cdr(lst);7127 }71287129 if(lst!=C_SCHEME_END_OF_LIST)7130 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memq", lst);71317132 return C_SCHEME_FALSE;7133}713471357136C_regparm C_word C_u_i_memq(C_word x, C_word lst)7137{7138 while(!C_immediatep(lst)) {7139 if(C_u_i_car(lst) == x) return lst;7140 else lst = C_u_i_cdr(lst);7141 }71427143 return C_SCHEME_FALSE;7144}714571467147C_regparm C_word C_i_memv(C_word x, C_word lst)7148{7149 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7150 if(C_truep(C_i_eqvp(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, "memv", lst);71567157 return C_SCHEME_FALSE;7158}715971607161C_regparm C_word C_i_member(C_word x, C_word lst)7162{7163 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7164 if(C_equalp(C_u_i_car(lst), x)) return lst;7165 else lst = C_u_i_cdr(lst);7166 }71677168 if(lst!=C_SCHEME_END_OF_LIST)7169 barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", lst);71707171 return C_SCHEME_FALSE;7172}717371747175/* Inline routines for extended bindings: */71767177C_regparm C_word C_i_check_closure_2(C_word x, C_word loc)7178{7179 if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {7180 error_location = loc;7181 barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);7182 }71837184 return C_SCHEME_UNDEFINED;7185}71867187C_regparm C_word C_i_check_fixnum_2(C_word x, C_word loc)7188{7189 if(!(x & C_FIXNUM_BIT)) {7190 error_location = loc;7191 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);7192 }71937194 return C_SCHEME_UNDEFINED;7195}719671977198C_regparm C_word C_i_check_inexact_2(C_word x, C_word loc)7199{7200 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {7201 error_location = loc;7202 barf(C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR, NULL, x);7203 }72047205 return C_SCHEME_UNDEFINED;7206}720772087209C_regparm C_word C_i_check_char_2(C_word x, C_word loc)7210{7211 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7212 error_location = loc;7213 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7214 }72157216 return C_SCHEME_UNDEFINED;7217}721872197220C_regparm C_word C_i_check_number_2(C_word x, C_word loc)7221{7222 if (C_i_numberp(x) == C_SCHEME_FALSE) {7223 error_location = loc;7224 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);7225 }72267227 return C_SCHEME_UNDEFINED;7228}722972307231C_regparm C_word C_i_check_string_2(C_word x, C_word loc)7232{7233 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {7234 error_location = loc;7235 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);7236 }72377238 return C_SCHEME_UNDEFINED;7239}724072417242C_regparm C_word C_i_check_bytevector_2(C_word x, C_word loc)7243{7244 if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {7245 error_location = loc;7246 barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);7247 }72487249 return C_SCHEME_UNDEFINED;7250}725172527253C_regparm C_word C_i_check_vector_2(C_word x, C_word loc)7254{7255 if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {7256 error_location = loc;7257 barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);7258 }72597260 return C_SCHEME_UNDEFINED;7261}726272637264C_regparm C_word C_i_check_structure_2(C_word x, C_word st, C_word loc)7265{7266 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) {7267 error_location = loc;7268 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);7269 }72707271 return C_SCHEME_UNDEFINED;7272}727372747275C_regparm C_word C_i_check_pair_2(C_word x, C_word loc)7276{7277 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {7278 error_location = loc;7279 barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);7280 }72817282 return C_SCHEME_UNDEFINED;7283}728472857286C_regparm C_word C_i_check_boolean_2(C_word x, C_word loc)7287{7288 if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {7289 error_location = loc;7290 barf(C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR, NULL, x);7291 }72927293 return C_SCHEME_UNDEFINED;7294}729572967297C_regparm C_word C_i_check_locative_2(C_word x, C_word loc)7298{7299 if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {7300 error_location = loc;7301 barf(C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR, NULL, x);7302 }73037304 return C_SCHEME_UNDEFINED;7305}730673077308C_regparm C_word C_i_check_symbol_2(C_word x, C_word loc)7309{7310 if(!C_truep(C_i_symbolp(x))) {7311 error_location = loc;7312 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);7313 }73147315 return C_SCHEME_UNDEFINED;7316}731773187319C_regparm C_word C_i_check_keyword_2(C_word x, C_word loc)7320{7321 if(!C_truep(C_i_keywordp(x))) {7322 error_location = loc;7323 barf(C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR, NULL, x);7324 }73257326 return C_SCHEME_UNDEFINED;7327}73287329C_regparm C_word C_i_check_list_2(C_word x, C_word loc)7330{7331 if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)) {7332 error_location = loc;7333 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);7334 }73357336 return C_SCHEME_UNDEFINED;7337}733873397340C_regparm C_word C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)7341{73427343 if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {7344 error_location = loc;7345 barf(C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR, NULL, x);7346 }73477348 if((C_block_item(x, 1) & dir) != dir) { /* slot #1: I/O direction mask */7349 error_location = loc;7350 switch (dir) {7351 case C_fix(1):7352 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR, NULL, x);7353 case C_fix(2):7354 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR, NULL, x);7355 default:7356 barf(C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR, NULL, x);7357 }7358 }73597360 if(open == C_SCHEME_TRUE) {7361 if(C_block_item(x, 8) == C_FIXNUM_BIT) { /* slot #8: closed mask */7362 error_location = loc;7363 barf(C_PORT_CLOSED_ERROR, NULL, x);7364 }7365 }73667367 return C_SCHEME_UNDEFINED;7368}736973707371C_regparm C_word C_i_check_range_2(C_word i, C_word f, C_word t, C_word loc)7372{7373 if(!(i & C_FIXNUM_BIT)) {7374 error_location = loc;7375 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);7376 }73777378 int index = C_unfix(i);73797380 if(index < C_unfix(f)) {7381 error_location = loc;7382 barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);7383 }73847385 if(index >= C_unfix(t)) {7386 error_location = loc;7387 barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);7388 }73897390 return C_SCHEME_UNDEFINED;7391}739273937394C_regparm C_word C_i_check_range_including_2(C_word i, C_word f, C_word t, C_word loc)7395{7396 if(!(i & C_FIXNUM_BIT)) {7397 error_location = loc;7398 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);7399 }74007401 int index = C_unfix(i);74027403 if(index < C_unfix(f)) {7404 error_location = loc;7405 barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);7406 }74077408 if(index > C_unfix(t)) {7409 error_location = loc;7410 barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);7411 }74127413 return C_SCHEME_UNDEFINED;7414}741574167417/*XXX these are not correctly named */7418C_regparm C_word C_i_foreign_char_argumentp(C_word x)7419{7420 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)7421 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);74227423 return x;7424}742574267427C_regparm C_word C_i_foreign_fixnum_argumentp(C_word x)7428{7429 if((x & C_FIXNUM_BIT) == 0)7430 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);74317432 return x;7433}743474357436C_regparm C_word C_i_foreign_flonum_argumentp(C_word x)7437{7438 if((x & C_FIXNUM_BIT) != 0) return x;74397440 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7441 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);74427443 return x;7444}744574467447C_regparm C_word C_i_foreign_cplxnum_argumentp(C_word x)7448{7449 if((x & C_FIXNUM_BIT) != 0) return x;74507451 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7452 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);74537454 return x;7455}745674577458C_regparm C_word C_i_foreign_block_argumentp(C_word x)7459{7460 if(C_immediatep(x))7461 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);74627463 return x;7464}746574667467C_regparm C_word C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)7468{7469 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)7470 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, t, x);74717472 return x;7473}747474757476C_regparm C_word C_i_foreign_string_argumentp(C_word x)7477{7478 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)7479 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);74807481 return x;7482}748374847485C_regparm C_word C_i_foreign_symbol_argumentp(C_word x)7486{7487 if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)7488 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);74897490 return x;7491}749274937494C_regparm C_word C_i_foreign_pointer_argumentp(C_word x)7495{7496 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7497 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);74987499 return x;7500}750175027503/* TODO: Is this used? */7504C_regparm C_word C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)7505{7506 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7507 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);75087509 return x;7510}751175127513C_regparm C_word C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)7514{7515 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 07516 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))7517 barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);75187519 return x;7520}75217522C_regparm C_word C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)7523{7524 if((x & C_FIXNUM_BIT) != 0) {7525 if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;7526 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7527 } else if (C_truep(C_i_bignump(x))) {7528 if (C_truep(C_fixnum_lessp(C_i_integer_length(x), bits))) return x;7529 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7530 } else {7531 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);7532 }7533}75347535C_regparm C_word C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)7536{7537 if((x & C_FIXNUM_BIT) != 0) {7538 if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7539 else if(C_ilen(C_unfix(x)) <= C_unfix(bits)) return x;7540 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7541 } else if(C_truep(C_i_bignump(x))) {7542 if(C_bignum_negativep(x)) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7543 else if(integer_length_abs(x) <= C_unfix(bits)) return x;7544 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7545 } else {7546 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7547 }7548}75497550/* I */7551C_regparm C_word C_i_not_pair_p_2(C_word x)7552{7553 return C_mk_bool(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE);7554}755575567557C_regparm C_word C_i_null_list_p(C_word x)7558{7559 if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;7560 else if(!C_immediatep(x) && C_header_type(x) == C_PAIR_TYPE) return C_SCHEME_FALSE;7561 else {7562 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);7563 return C_SCHEME_FALSE;7564 }7565}756675677568C_regparm C_word C_i_string_null_p(C_word x)7569{7570 if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)7571 return C_mk_bool(C_unfix(C_block_item(x, 1)) == 0);7572 else {7573 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);7574 return C_SCHEME_FALSE;7575 }7576}757775787579C_regparm C_word C_i_null_pointerp(C_word x)7580{7581 if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)7582 return C_null_pointerp(x);75837584 barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);7585 return C_SCHEME_FALSE;7586}75877588/* only used here for char comparators below: */7589static C_word check_char_internal(C_word x, C_char *loc)7590{7591 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7592 error_location = intern0(loc);7593 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7594 }75957596 return C_SCHEME_UNDEFINED;7597}75987599C_regparm C_word C_i_char_equalp(C_word x, C_word y)7600{7601 check_char_internal(x, "char=?");7602 check_char_internal(y, "char=?");7603 return C_u_i_char_equalp(x, y);7604}76057606C_regparm C_word C_i_char_greaterp(C_word x, C_word y)7607{7608 check_char_internal(x, "char>?");7609 check_char_internal(y, "char>?");7610 return C_u_i_char_greaterp(x, y);7611}76127613C_regparm C_word C_i_char_lessp(C_word x, C_word y)7614{7615 check_char_internal(x, "char<?");7616 check_char_internal(y, "char<?");7617 return C_u_i_char_lessp(x, y);7618}76197620C_regparm C_word C_i_char_greater_or_equal_p(C_word x, C_word y)7621{7622 check_char_internal(x, "char>=?");7623 check_char_internal(y, "char>=?");7624 return C_u_i_char_greater_or_equal_p(x, y);7625}76267627C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y)7628{7629 check_char_internal(x, "char<=?");7630 check_char_internal(y, "char<=?");7631 return C_u_i_char_less_or_equal_p(x, y);7632}763376347635/* Primitives: */76367637void C_ccall C_apply(C_word c, C_word *av)7638{7639 C_word7640 /* closure = av[ 0 ] */7641 k = av[ 1 ],7642 fn = av[ 2 ];7643 int av2_size, i, n = c - 3;7644 int non_list_args = n - 1;7645 C_word lst, len, *ptr, *av2;76467647 if(c < 4) C_bad_min_argc(c, 4);76487649 if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE)7650 barf(C_NOT_A_CLOSURE_ERROR, "apply", fn);76517652 lst = av[ c - 1 ];7653 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7654 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);76557656 len = C_unfix(C_u_i_length(lst));7657 av2_size = 2 + non_list_args + len;76587659 if(C_demand(av2_size))7660 stack_check_demand = 0;7661 else if(stack_check_demand)7662 C_stack_overflow("apply");7663 else {7664 stack_check_demand = av2_size;7665 C_save_and_reclaim((void *)C_apply, c, av);7666 }76677668 av2 = ptr = C_alloc(av2_size);7669 *(ptr++) = fn;7670 *(ptr++) = k;76717672 if(non_list_args > 0) {7673 C_memcpy(ptr, av + 3, non_list_args * sizeof(C_word));7674 ptr += non_list_args;7675 }76767677 while(len--) {7678 *(ptr++) = C_u_i_car(lst);7679 lst = C_u_i_cdr(lst);7680 }76817682 assert((ptr - av2) == av2_size);76837684 ((C_proc)(void *)C_block_item(fn, 0))(av2_size, av2);7685}768676877688void C_ccall C_call_cc(C_word c, C_word *av)7689{7690 C_word7691 /* closure = av[ 0 ] */7692 k = av[ 1 ],7693 cont = av[ 2 ],7694 *a = C_alloc(C_SIZEOF_CLOSURE(2)),7695 wrapper;7696 void *pr = (void *)C_block_item(cont,0);7697 C_word av2[ 3 ];76987699 if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)7700 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);77017702 /* Check for values-continuation: */7703 if(C_block_item(k, 0) == (C_word)values_continuation)7704 wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);7705 else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);77067707 av2[ 0 ] = cont;7708 av2[ 1 ] = k;7709 av2[ 2 ] = wrapper;7710 ((C_proc)pr)(3, av2);7711}771277137714void C_ccall call_cc_wrapper(C_word c, C_word *av)7715{7716 C_word7717 closure = av[ 0 ],7718 /* av[ 1 ] is current k and ignored */7719 result,7720 k = C_block_item(closure, 1);77217722 if(c != 3) C_bad_argc(c, 3);77237724 result = av[ 2 ];7725 C_kontinue(k, result);7726}772777287729void C_ccall call_cc_values_wrapper(C_word c, C_word *av)7730{7731 C_word7732 closure = av[ 0 ],7733 /* av[ 1 ] is current k and ignored */7734 k = C_block_item(closure, 1),7735 x1,7736 n = c;77377738 av[ 0 ] = k; /* reuse av */7739 C_memmove(av + 1, av + 2, (n - 1) * sizeof(C_word));7740 C_do_apply(n - 1, av);7741}774277437744void C_ccall C_continuation_graft(C_word c, C_word *av)7745{7746 C_word7747 /* self = av[ 0 ] */7748 /* k = av[ 1 ] */7749 kk = av[ 2 ],7750 proc = av[ 3 ];77517752 av[ 0 ] = proc; /* reuse av */7753 av[ 1 ] = C_block_item(kk, 1);7754 ((C_proc)C_fast_retrieve_proc(proc))(2, av);7755}775677577758void C_ccall C_values(C_word c, C_word *av)7759{7760 C_word7761 /* closure = av[ 0 ] */7762 k = av[ 1 ],7763 n = c;77647765 if(c < 2) C_bad_min_argc(c, 2);77667767 /* Check continuation whether it receives multiple values: */7768 if(C_block_item(k, 0) == (C_word)values_continuation) {7769 av[ 0 ] = k; /* reuse av */7770 C_memmove(av + 1, av + 2, (c - 2) * sizeof(C_word));7771 C_do_apply(c - 1, av);7772 }77737774 if(c != 3) {7775#ifdef RELAX_MULTIVAL_CHECK7776 if(c == 2) n = C_SCHEME_UNDEFINED;7777 else n = av[ 2 ];7778#else7779 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7780#endif7781 }7782 else n = av[ 2 ];77837784 C_kontinue(k, n);7785}778677877788void C_ccall C_apply_values(C_word c, C_word *av)7789{7790 C_word7791 /* closure = av[ 0 ] */7792 k = av[ 1 ],7793 lst, len, n;77947795 if(c != 3) C_bad_argc(c, 3);77967797 lst = av[ 2 ];77987799 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7800 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);78017802 /* Check whether continuation receives multiple values: */7803 if(C_block_item(k, 0) == (C_word)values_continuation) {7804 C_word *av2, *ptr;78057806 len = C_unfix(C_u_i_length(lst));7807 n = len + 1;78087809 if(C_demand(n))7810 stack_check_demand = 0;7811 else if(stack_check_demand)7812 C_stack_overflow("apply");7813 else {7814 stack_check_demand = n;7815 C_save_and_reclaim((void *)C_apply_values, c, av);7816 }78177818 av2 = C_alloc(n);7819 av2[ 0 ] = k;7820 ptr = av2 + 1;7821 while(len--) {7822 *(ptr++) = C_u_i_car(lst);7823 lst = C_u_i_cdr(lst);7824 }78257826 C_do_apply(n, av2);7827 }78287829 if(C_immediatep(lst)) {7830#ifdef RELAX_MULTIVAL_CHECK7831 n = C_SCHEME_UNDEFINED;7832#else7833 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7834#endif7835 }7836 else if(C_header_type(lst) == C_PAIR_TYPE) {7837 if(C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)7838 n = C_u_i_car(lst);7839 else {7840#ifdef RELAX_MULTIVAL_CHECK7841 n = C_u_i_car(lst);7842#else7843 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7844#endif7845 }7846 }7847 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);78487849 C_kontinue(k, n);7850}785178527853void C_ccall C_call_with_values(C_word c, C_word *av)7854{7855 C_word7856 /* closure = av[ 0 ] */7857 k = av[ 1 ],7858 thunk,7859 kont,7860 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7861 kk;78627863 if(c != 4) C_bad_argc(c, 4);78647865 thunk = av[ 2 ];7866 kont = av[ 3 ];78677868 if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)7869 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);78707871 if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)7872 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);78737874 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7875 av[ 0 ] = thunk; /* reuse av */7876 av[ 1 ] = kk;7877 C_do_apply(2, av);7878}787978807881void C_ccall C_u_call_with_values(C_word c, C_word *av)7882{7883 C_word7884 /* closure = av[ 0 ] */7885 k = av[ 1 ],7886 thunk = av[ 2 ],7887 kont = av[ 3 ],7888 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7889 kk;78907891 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7892 av[ 0 ] = thunk; /* reuse av */7893 av[ 1 ] = kk;7894 C_do_apply(2, av);7895}789678977898void C_ccall values_continuation(C_word c, C_word *av)7899{7900 C_word7901 closure = av[ 0 ],7902 kont = C_block_item(closure, 1),7903 k = C_block_item(closure, 2),7904 *av2 = C_alloc(c + 1);79057906 av2[ 0 ] = kont;7907 av2[ 1 ] = k;7908 C_memcpy(av2 + 2, av + 1, (c - 1) * sizeof(C_word));7909 C_do_apply(c + 1, av2);7910}79117912static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i)7913{7914 C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab, num, denom, gcd, a_div_g;79157916 switch (i) {7917 case C_fix(0): return C_fix(0);7918 case C_fix(1): return rat;7919 case C_fix(-1):7920 num = C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(rat));7921 return C_ratnum(ptr, num , C_u_i_ratnum_denom(rat));7922 /* default: CONTINUE BELOW */7923 }79247925 num = C_u_i_ratnum_num(rat);7926 denom = C_u_i_ratnum_denom(rat);79277928 /* a/b * c/d = a*c / b*d [with b = 1] */7929 /* = ((a / g) * c) / (d / g) */7930 /* With g = gcd(a, d) and a = x [Knuth, 4.5.1] */7931 gcd = C_s_a_u_i_integer_gcd(&a, 2, i, denom);79327933 /* Calculate a/g (= i/gcd), which will later be multiplied by y */7934 a_div_g = C_s_a_u_i_integer_quotient(&a, 2, i, gcd);7935 if (a_div_g == C_fix(0)) {7936 clear_buffer_object(ab, gcd);7937 return C_fix(0); /* Save some work */7938 }79397940 /* Final numerator = a/g * c (= a_div_g * num) */7941 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g, num);79427943 /* Final denominator = d/g (= denom/gcd) */7944 denom = C_s_a_u_i_integer_quotient(ptr, 2, denom, gcd);79457946 num = move_buffer_object(ptr, ab, num);7947 denom = move_buffer_object(ptr, ab, denom);79487949 clear_buffer_object(ab, gcd);7950 clear_buffer_object(ab, a_div_g);79517952 if (denom == C_fix(1)) return num;7953 else return C_ratnum(ptr, num, denom);7954}79557956static C_word rat_times_rat(C_word **ptr, C_word x, C_word y)7957{7958 C_word ab[C_SIZEOF_FIX_BIGNUM * 6], *a = ab,7959 num, denom, xnum, xdenom, ynum, ydenom,7960 g1, g2, a_div_g1, b_div_g2, c_div_g2, d_div_g1;79617962 xnum = C_u_i_ratnum_num(x);7963 xdenom = C_u_i_ratnum_denom(x);7964 ynum = C_u_i_ratnum_num(y);7965 ydenom = C_u_i_ratnum_denom(y);79667967 /* a/b * c/d = a*c / b*d [generic] */7968 /* = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1)) */7969 /* With g1 = gcd(a, d) and g2 = gcd(b, c) [Knuth, 4.5.1] */7970 g1 = C_s_a_u_i_integer_gcd(&a, 2, xnum, ydenom);7971 g2 = C_s_a_u_i_integer_gcd(&a, 2, ynum, xdenom);79727973 /* Calculate a/g1 (= xnum/g1), which will later be multiplied by c/g2 */7974 a_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, xnum, g1);79757976 /* Calculate c/g2 (= ynum/g2), which will later be multiplied by a/g1 */7977 c_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, ynum, g2);79787979 /* Final numerator = a/g1 * c/g2 */7980 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g1, c_div_g2);79817982 /* Now, do the same for the denominator.... */79837984 /* Calculate b/g2 (= xdenom/g2), which will later be multiplied by d/g1 */7985 b_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g2);79867987 /* Calculate d/g1 (= ydenom/g1), which will later be multiplied by b/g2 */7988 d_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);79897990 /* Final denominator = b/g2 * d/g1 */7991 denom = C_s_a_u_i_integer_times(ptr, 2, b_div_g2, d_div_g1);79927993 num = move_buffer_object(ptr, ab, num);7994 denom = move_buffer_object(ptr, ab, denom);79957996 clear_buffer_object(ab, g1);7997 clear_buffer_object(ab, g2);7998 clear_buffer_object(ab, a_div_g1);7999 clear_buffer_object(ab, b_div_g2);8000 clear_buffer_object(ab, c_div_g2);8001 clear_buffer_object(ab, d_div_g1);80028003 if (denom == C_fix(1)) return num;8004 else return C_ratnum(ptr, num, denom);8005}80068007static C_word8008cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)8009{8010 /* Allocation here is kind of tricky: Each intermediate result can8011 * be at most a ratnum consisting of two bignums (2 digits), so8012 * C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2) = 9 words8013 */8014 C_word ab[(C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2))*6], *a = ab,8015 r1, r2, i1, i2, r, i;80168017 /* a+bi * c+di = (a*c - b*d) + (a*d + b*c)i */8018 /* We call these: r1 = a*c, r2 = b*d, i1 = a*d, i2 = b*c */8019 r1 = C_s_a_i_times(&a, 2, rx, ry);8020 r2 = C_s_a_i_times(&a, 2, ix, iy);8021 i1 = C_s_a_i_times(&a, 2, rx, iy);8022 i2 = C_s_a_i_times(&a, 2, ix, ry);80238024 r = C_s_a_i_minus(ptr, 2, r1, r2);8025 i = C_s_a_i_plus(ptr, 2, i1, i2);80268027 r = move_buffer_object(ptr, ab, r);8028 i = move_buffer_object(ptr, ab, i);80298030 clear_buffer_object(ab, r1);8031 clear_buffer_object(ab, r2);8032 clear_buffer_object(ab, i1);8033 clear_buffer_object(ab, i2);80348035 if (C_truep(C_u_i_zerop2(i))) return r;8036 else return C_cplxnum(ptr, r, i);8037}80388039/* The maximum size this needs is that required to store a complex8040 * number result, where both real and imag parts consist of ratnums.8041 * The maximum size of those ratnums is if they consist of two bignums8042 * from a fixnum multiplication (2 digits each), so we're looking at8043 * C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words!8044 */8045C_regparm C_word8046C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)8047{8048 if (x & C_FIXNUM_BIT) {8049 if (y & C_FIXNUM_BIT) {8050 return C_a_i_fixnum_times(ptr, 2, x, y);8051 } else if (C_immediatep(y)) {8052 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8053 } else if (C_block_header(y) == C_FLONUM_TAG) {8054 return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y));8055 } else if (C_truep(C_bignump(y))) {8056 return C_s_a_u_i_integer_times(ptr, 2, x, y);8057 } else if (C_block_header(y) == C_RATNUM_TAG) {8058 return rat_times_integer(ptr, y, x);8059 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8060 C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));8061 C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));8062 return C_cplxnum(ptr, r, i);8063 } else {8064 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8065 }8066 } else if (C_immediatep(x)) {8067 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8068 } else if (C_block_header(x) == C_FLONUM_TAG) {8069 if (y & C_FIXNUM_BIT) {8070 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y));8071 } else if (C_immediatep(y)) {8072 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8073 } else if (C_block_header(y) == C_FLONUM_TAG) {8074 return C_a_i_flonum_times(ptr, 2, x, y);8075 } else if (C_truep(C_bignump(y))) {8076 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y));8077 } else if (C_block_header(y) == C_RATNUM_TAG) {8078 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8079 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8080 C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));8081 C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));8082 return C_cplxnum(ptr, r, i);8083 } else {8084 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8085 }8086 } else if (C_truep(C_bignump(x))) {8087 if (y & C_FIXNUM_BIT) {8088 return C_s_a_u_i_integer_times(ptr, 2, x, y);8089 } else if (C_immediatep(y)) {8090 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8091 } else if (C_block_header(y) == C_FLONUM_TAG) {8092 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y));8093 } else if (C_truep(C_bignump(y))) {8094 return C_s_a_u_i_integer_times(ptr, 2, x, y);8095 } else if (C_block_header(y) == C_RATNUM_TAG) {8096 return rat_times_integer(ptr, y, x);8097 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8098 C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));8099 C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));8100 return C_cplxnum(ptr, r, i);8101 } else {8102 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8103 }8104 } else if (C_block_header(x) == C_RATNUM_TAG) {8105 if (y & C_FIXNUM_BIT) {8106 return rat_times_integer(ptr, x, y);8107 } else if (C_immediatep(y)) {8108 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8109 } else if (C_block_header(y) == C_FLONUM_TAG) {8110 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8111 } else if (C_truep(C_bignump(y))) {8112 return rat_times_integer(ptr, x, y);8113 } else if (C_block_header(y) == C_RATNUM_TAG) {8114 return rat_times_rat(ptr, x, y);8115 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8116 C_word r = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_real(y));8117 C_word i = C_s_a_i_times(ptr, 2, x, C_u_i_cplxnum_imag(y));8118 return C_cplxnum(ptr, r, i);8119 } else {8120 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8121 }8122 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8123 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8124 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x),8125 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8126 } else {8127 C_word r = C_s_a_i_times(ptr, 2, y, C_u_i_cplxnum_real(x));8128 C_word i = C_s_a_i_times(ptr, 2, y, C_u_i_cplxnum_imag(x));8129 return C_cplxnum(ptr, r, i);8130 }8131 } else {8132 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8133 }8134}813581368137C_regparm C_word8138C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)8139{8140 if (x & C_FIXNUM_BIT) {8141 if (y & C_FIXNUM_BIT) {8142 return C_a_i_fixnum_times(ptr, 2, x, y);8143 } else {8144 C_word tmp = x; /* swap to ensure x is a bignum and y a fixnum */8145 x = y;8146 y = tmp;8147 }8148 }8149 /* Here, we know for sure that X is a bignum */8150 if (y == C_fix(0)) {8151 return C_fix(0);8152 } else if (y == C_fix(1)) {8153 return x;8154 } else if (y == C_fix(-1)) {8155 return C_s_a_u_i_integer_negate(ptr, 1, x);8156 } else if (y & C_FIXNUM_BIT) { /* Any other fixnum */8157 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y),8158 negp = C_mk_bool((y & C_INT_SIGN_BIT) ?8159 !C_bignum_negativep(x) :8160 C_bignum_negativep(x));81618162 if (C_fitsinbignumhalfdigitp(absy) ||8163 (((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {8164 C_word size, res;8165 C_uword *startr, *endr;8166 int shift;8167 size = C_bignum_size(x) + 1; /* Needs _at most_ one more digit */8168 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);81698170 bignum_digits_destructive_copy(res, x);81718172 startr = C_bignum_digits(res);8173 endr = startr + size - 1;8174 /* Scale up, and sanitise the result. */8175 shift = C_ilen(absy) - 1;8176 if (((C_uword)1 << shift) == absy) { /* Power of two? */8177 *endr = bignum_digits_destructive_shift_left(startr, endr, shift);8178 } else {8179 *endr = bignum_digits_destructive_scale_up_with_carry(startr, endr,8180 absy, 0);8181 }8182 return C_bignum_simplify(res);8183 } else {8184 C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);8185 y = C_a_u_i_fix_to_big(&a, y);8186 return bignum_times_bignum_unsigned(ptr, x, y, negp);8187 }8188 } else {8189 C_word negp = C_bignum_negativep(x) ?8190 !C_bignum_negativep(y) :8191 C_bignum_negativep(y);8192 return bignum_times_bignum_unsigned(ptr, x, y, C_mk_bool(negp));8193 }8194}81958196static C_regparm C_word8197bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8198{8199 C_word size, res = C_SCHEME_FALSE;8200 if (C_bignum_size(y) < C_bignum_size(x)) { /* Ensure size(x) <= size(y) */8201 C_word z = x;8202 x = y;8203 y = z;8204 }82058206 if (C_bignum_size(x) >= C_KARATSUBA_THRESHOLD)8207 res = bignum_times_bignum_karatsuba(ptr, x, y, negp);82088209 if (!C_truep(res)) {8210 size = C_bignum_size(x) + C_bignum_size(y);8211 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_TRUE);8212 bignum_digits_multiply(x, y, res);8213 res = C_bignum_simplify(res);8214 }8215 return res;8216}82178218/* Karatsuba multiplication: invoked when the two numbers are large8219 * enough to make it worthwhile, and we still have enough stack left.8220 * Complexity is O(n^log2(3)), where n is max(len(x), len(y)). The8221 * description in [Knuth, 4.3.3] leaves a lot to be desired. [MCA,8222 * 1.3.2] and [MpNT, 3.2] are a bit easier to understand. We assume8223 * that length(x) <= length(y).8224 */8225static C_regparm C_word8226bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)8227{8228 C_word kab[C_SIZEOF_FIX_BIGNUM*15+C_SIZEOF_BIGNUM(2)*3], *ka = kab, o[18],8229 xhi, xlo, xmid, yhi, ylo, ymid, a, b, c, n, bits;8230 int i = 0;82318232 /* Ran out of stack? Fall back to non-recursive multiplication */8233 C_stack_check1(return C_SCHEME_FALSE);82348235 /* Split |x| in half: <xhi,xlo> and |y|: <yhi,ylo> with len(ylo)=len(xlo) */8236 x = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, x);8237 y = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, y);8238 n = C_fix(C_bignum_size(y) >> 1);8239 xhi = o[i++] = bignum_extract_digits(&ka, 3, x, n, C_SCHEME_FALSE);8240 xlo = o[i++] = bignum_extract_digits(&ka, 3, x, C_fix(0), n);8241 yhi = o[i++] = bignum_extract_digits(&ka, 3, y, n, C_SCHEME_FALSE);8242 ylo = o[i++] = bignum_extract_digits(&ka, 3, y, C_fix(0), n);82438244 /* a = xhi * yhi, b = xlo * ylo, c = (xhi - xlo) * (yhi - ylo) */8245 a = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xhi, yhi);8246 b = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xlo, ylo);8247 xmid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, xhi, xlo);8248 ymid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, yhi, ylo);8249 c = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xmid, ymid);82508251 /* top(x) = a << (bits - 1) and bottom(y) = ((b + (a - c)) << bits) + b */8252 bits = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;8253 x = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, a, C_fix((C_uword)bits << 1));8254 c = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, a, c);8255 c = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, b, c);8256 c = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, c, C_fix(bits));8257 y = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, c, b);8258 /* Finally, return top + bottom, and correct for negative */8259 n = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, x, y);8260 if (C_truep(negp)) n = o[i++] = C_s_a_u_i_integer_negate(&ka, 1, n);82618262 n = move_buffer_object(ptr, kab, n);8263 while(i--) clear_buffer_object(kab, o[i]);8264 return n;8265}82668267void C_ccall C_times(C_word c, C_word *av)8268{8269 /* C_word closure = av[ 0 ]; */8270 C_word k = av[ 1 ];8271 C_word next_val,8272 result = C_fix(1),8273 prev_result = result;8274 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a;82758276 c -= 2;8277 av += 2;82788279 while (c--) {8280 next_val = *(av++);8281 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */8282 result = C_s_a_i_times(&a, 2, result, next_val);8283 result = move_buffer_object(&a, ab[(c+1)&1], result);8284 clear_buffer_object(ab[(c+1)&1], prev_result);8285 prev_result = result;8286 }82878288 C_kontinue(k, result);8289}829082918292static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8293{8294 C_word size, result;8295 C_uword sum, digit, *scan_y, *end_y, *scan_r, *end_r;8296 int carry = 0;82978298 if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(y) <= size(x) */8299 C_word z = x;8300 x = y;8301 y = z;8302 }83038304 size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */8305 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);83068307 scan_y = C_bignum_digits(y);8308 end_y = scan_y + C_bignum_size(y);8309 scan_r = C_bignum_digits(result);8310 end_r = scan_r + C_bignum_size(result);83118312 /* Copy x into r so we can operate on two pointers, which is faster8313 * than three, and we can stop earlier after adding y. It's slower8314 * if x and y have equal length. On average it's slightly faster.8315 */8316 bignum_digits_destructive_copy(result, x);8317 *(end_r-1) = 0; /* Ensure most significant digit is initialised */83188319 /* Move over x and y simultaneously, destructively adding digits w/ carry. */8320 while (scan_y < end_y) {8321 digit = *scan_r;8322 if (carry) {8323 sum = digit + *scan_y++ + 1;8324 carry = sum <= digit;8325 } else {8326 sum = digit + *scan_y++;8327 carry = sum < digit;8328 }8329 (*scan_r++) = sum;8330 }83318332 /* The end of y, the smaller number. Propagate carry into the rest of x. */8333 while (carry) {8334 sum = (*scan_r) + 1;8335 carry = (sum == 0);8336 (*scan_r++) = sum;8337 }8338 assert(scan_r <= end_r);83398340 return C_bignum_simplify(result);8341}83428343static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op)8344{8345 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8346 num, denom, tmp, res;83478348 if (i == C_fix(0)) return rat;83498350 num = C_u_i_ratnum_num(rat);8351 denom = C_u_i_ratnum_denom(rat);83528353 /* a/b [+-] c/d = (a*d [+-] b*c)/(b*d) | d = 1: (num + denom * i) / denom */8354 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8355 res = plusmin_op(&a, 2, num, tmp);8356 res = move_buffer_object(ptr, ab, res);8357 clear_buffer_object(ab, tmp);8358 return C_ratnum(ptr, res, denom);8359}83608361/* This is needed only for minus: plus is commutative but minus isn't. */8362static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat)8363{8364 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8365 num, denom, tmp, res;83668367 num = C_u_i_ratnum_num(rat);8368 denom = C_u_i_ratnum_denom(rat);83698370 if (i == C_fix(0))8371 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, num), denom);83728373 /* a/b - c/d = (a*d - b*c)/(b*d) | b = 1: (denom * i - num) / denom */8374 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8375 res = C_s_a_u_i_integer_minus(&a, 2, tmp, num);8376 res = move_buffer_object(ptr, ab, res);8377 clear_buffer_object(ab, tmp);8378 return C_ratnum(ptr, res, denom);8379}83808381/* This is pretty braindead and ugly */8382static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op)8383{8384 C_word ab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)*2], *a = ab,8385 xnum = C_u_i_ratnum_num(x), ynum = C_u_i_ratnum_num(y),8386 xdenom = C_u_i_ratnum_denom(x), ydenom = C_u_i_ratnum_denom(y),8387 xnorm, ynorm, tmp_r, g1, ydenom_g1, xdenom_g1, norm_sum, g2, len,8388 res_num, res_denom;83898390 /* Knuth, 4.5.1. Start with g1 = gcd(xdenom, ydenom) */8391 g1 = C_s_a_u_i_integer_gcd(&a, 2, xdenom, ydenom);83928393 /* xnorm = xnum * (ydenom/g1) */8394 ydenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);8395 xnorm = C_s_a_u_i_integer_times(&a, 2, xnum, ydenom_g1);83968397 /* ynorm = ynum * (xdenom/g1) */8398 xdenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g1);8399 ynorm = C_s_a_u_i_integer_times(&a, 2, ynum, xdenom_g1);84008401 /* norm_sum = xnorm [+-] ynorm */8402 norm_sum = plusmin_op(&a, 2, xnorm, ynorm);84038404 /* g2 = gcd(norm_sum, g1) */8405 g2 = C_s_a_u_i_integer_gcd(&a, 2, norm_sum, g1);84068407 /* res_num = norm_sum / g2 */8408 res_num = C_s_a_u_i_integer_quotient(ptr, 2, norm_sum, g2);8409 if (res_num == C_fix(0)) {8410 res_denom = C_fix(0); /* No need to calculate denom: we'll return 0 */8411 } else {8412 /* res_denom = xdenom_g1 * (ydenom / g2) */8413 C_word res_tmp_denom = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g2);8414 res_denom = C_s_a_u_i_integer_times(ptr, 2, xdenom_g1, res_tmp_denom);84158416 /* Ensure they're allocated in the correct place */8417 res_num = move_buffer_object(ptr, ab, res_num);8418 res_denom = move_buffer_object(ptr, ab, res_denom);8419 clear_buffer_object(ab, res_tmp_denom);8420 }84218422 clear_buffer_object(ab, xdenom_g1);8423 clear_buffer_object(ab, ydenom_g1);8424 clear_buffer_object(ab, xnorm);8425 clear_buffer_object(ab, ynorm);8426 clear_buffer_object(ab, norm_sum);8427 clear_buffer_object(ab, g1);8428 clear_buffer_object(ab, g2);84298430 switch (res_denom) {8431 case C_fix(0): return C_fix(0);8432 case C_fix(1): return res_num;8433 default: return C_ratnum(ptr, res_num, res_denom);8434 }8435}84368437/* The maximum size this needs is that required to store a complex8438 * number result, where both real and imag parts consist of ratnums.8439 * The maximum size of those ratnums is if they consist of two "fix8440 * bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM *8441 * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!8442 */8443C_regparm C_word8444C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)8445{8446 if (x & C_FIXNUM_BIT) {8447 if (y & C_FIXNUM_BIT) {8448 return C_a_i_fixnum_plus(ptr, 2, x, y);8449 } else if (C_immediatep(y)) {8450 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8451 } else if (C_block_header(y) == C_FLONUM_TAG) {8452 return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y));8453 } else if (C_truep(C_bignump(y))) {8454 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8455 } else if (C_block_header(y) == C_RATNUM_TAG) {8456 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8457 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8458 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8459 imag = C_u_i_cplxnum_imag(y);8460 if (C_truep(C_u_i_inexactp(real_sum)))8461 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8462 return C_cplxnum(ptr, real_sum, imag);8463 } else {8464 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8465 }8466 } else if (C_immediatep(x)) {8467 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8468 } else if (C_block_header(x) == C_FLONUM_TAG) {8469 if (y & C_FIXNUM_BIT) {8470 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y));8471 } else if (C_immediatep(y)) {8472 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8473 } else if (C_block_header(y) == C_FLONUM_TAG) {8474 return C_a_i_flonum_plus(ptr, 2, x, y);8475 } else if (C_truep(C_bignump(y))) {8476 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y));8477 } else if (C_block_header(y) == C_RATNUM_TAG) {8478 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8479 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8480 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8481 imag = C_u_i_cplxnum_imag(y);8482 if (C_truep(C_u_i_inexactp(real_sum)))8483 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8484 return C_cplxnum(ptr, real_sum, imag);8485 } else {8486 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8487 }8488 } else if (C_truep(C_bignump(x))) {8489 if (y & C_FIXNUM_BIT) {8490 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8491 } else if (C_immediatep(y)) {8492 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8493 } else if (C_block_header(y) == C_FLONUM_TAG) {8494 return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y));8495 } else if (C_truep(C_bignump(y))) {8496 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8497 } else if (C_block_header(y) == C_RATNUM_TAG) {8498 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8499 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8500 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8501 imag = C_u_i_cplxnum_imag(y);8502 if (C_truep(C_u_i_inexactp(real_sum)))8503 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8504 return C_cplxnum(ptr, real_sum, imag);8505 } else {8506 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8507 }8508 } else if (C_block_header(x) == C_RATNUM_TAG) {8509 if (y & C_FIXNUM_BIT) {8510 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8511 } else if (C_immediatep(y)) {8512 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8513 } else if (C_block_header(y) == C_FLONUM_TAG) {8514 return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8515 } else if (C_truep(C_bignump(y))) {8516 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8517 } else if (C_block_header(y) == C_RATNUM_TAG) {8518 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus);8519 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8520 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8521 imag = C_u_i_cplxnum_imag(y);8522 if (C_truep(C_u_i_inexactp(real_sum)))8523 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8524 return C_cplxnum(ptr, real_sum, imag);8525 } else {8526 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8527 }8528 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8529 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8530 C_word real_sum, imag_sum;8531 real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y));8532 imag_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y));8533 if (C_truep(C_u_i_zerop2(imag_sum))) return real_sum;8534 else return C_cplxnum(ptr, real_sum, imag_sum);8535 } else {8536 C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y),8537 imag = C_u_i_cplxnum_imag(x);8538 if (C_truep(C_u_i_inexactp(real_sum)))8539 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8540 return C_cplxnum(ptr, real_sum, imag);8541 }8542 } else {8543 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8544 }8545}85468547C_regparm C_word8548C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y)8549{8550 if ((x & y) & C_FIXNUM_BIT) {8551 return C_a_i_fixnum_plus(ptr, 2, x, y);8552 } else {8553 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8554 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8555 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);85568557 if (C_bignum_negativep(x)) {8558 if (C_bignum_negativep(y)) {8559 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8560 } else {8561 return bignum_minus_unsigned(ptr, y, x);8562 }8563 } else {8564 if (C_bignum_negativep(y)) {8565 return bignum_minus_unsigned(ptr, x, y);8566 } else {8567 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8568 }8569 }8570 }8571}85728573void C_ccall C_plus(C_word c, C_word *av)8574{8575 /* C_word closure = av[ 0 ]; */8576 C_word k = av[ 1 ];8577 C_word next_val,8578 result = C_fix(0),8579 prev_result = result;8580 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;85818582 c -= 2;8583 av += 2;85848585 while (c--) {8586 next_val = *(av++);8587 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8588 result = C_s_a_i_plus(&a, 2, result, next_val);8589 result = move_buffer_object(&a, ab[(c+1)&1], result);8590 clear_buffer_object(ab[(c+1)&1], prev_result);8591 prev_result = result;8592 }85938594 C_kontinue(k, result);8595}85968597static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)8598{8599 C_word res, size;8600 C_uword *scan_r, *end_r, *scan_y, *end_y, difference, digit;8601 int borrow = 0;86028603 switch(bignum_cmp_unsigned(x, y)) {8604 case 0: /* x = y, return 0 */8605 return C_fix(0);8606 case -1: /* abs(x) < abs(y), return -(abs(y) - abs(x)) */8607 size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */8608 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_TRUE, C_SCHEME_FALSE);8609 size = y;8610 y = x;8611 x = size;8612 break;8613 case 1: /* abs(x) > abs(y), return abs(x) - abs(y) */8614 default:8615 size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */8616 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);8617 break;8618 }86198620 scan_r = C_bignum_digits(res);8621 end_r = scan_r + C_bignum_size(res);8622 scan_y = C_bignum_digits(y);8623 end_y = scan_y + C_bignum_size(y);86248625 bignum_digits_destructive_copy(res, x); /* See bignum_plus_unsigned */86268627 /* Destructively subtract y's digits w/ borrow from and back into r. */8628 while (scan_y < end_y) {8629 digit = *scan_r;8630 if (borrow) {8631 difference = digit - *scan_y++ - 1;8632 borrow = difference >= digit;8633 } else {8634 difference = digit - *scan_y++;8635 borrow = difference > digit;8636 }8637 (*scan_r++) = difference;8638 }86398640 /* The end of y, the smaller number. Propagate borrow into the rest of x. */8641 while (borrow) {8642 digit = *scan_r;8643 difference = digit - borrow;8644 borrow = difference >= digit;8645 (*scan_r++) = difference;8646 }86478648 assert(scan_r <= end_r);86498650 return C_bignum_simplify(res);8651}86528653/* Like C_s_a_i_plus, this needs at most 29 words */8654C_regparm C_word8655C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)8656{8657 if (x & C_FIXNUM_BIT) {8658 if (y & C_FIXNUM_BIT) {8659 return C_a_i_fixnum_difference(ptr, 2, x, y);8660 } else if (C_immediatep(y)) {8661 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8662 } else if (C_block_header(y) == C_FLONUM_TAG) {8663 return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y));8664 } else if (C_truep(C_bignump(y))) {8665 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8666 } else if (C_block_header(y) == C_RATNUM_TAG) {8667 return integer_minus_rat(ptr, x, y);8668 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8669 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8670 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8671 if (C_truep(C_u_i_inexactp(real_diff)))8672 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8673 return C_cplxnum(ptr, real_diff, imag);8674 } else {8675 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8676 }8677 } else if (C_immediatep(x)) {8678 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8679 } else if (C_block_header(x) == C_FLONUM_TAG) {8680 if (y & C_FIXNUM_BIT) {8681 return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y));8682 } else if (C_immediatep(y)) {8683 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8684 } else if (C_block_header(y) == C_FLONUM_TAG) {8685 return C_a_i_flonum_difference(ptr, 2, x, y);8686 } else if (C_truep(C_bignump(y))) {8687 return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y));8688 } else if (C_block_header(y) == C_RATNUM_TAG) {8689 return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8690 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8691 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8692 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8693 if (C_truep(C_u_i_inexactp(real_diff)))8694 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8695 return C_cplxnum(ptr, real_diff, imag);8696 } else {8697 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8698 }8699 } else if (C_truep(C_bignump(x))) {8700 if (y & C_FIXNUM_BIT) {8701 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8702 } else if (C_immediatep(y)) {8703 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8704 } else if (C_block_header(y) == C_FLONUM_TAG) {8705 return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y));8706 } else if (C_truep(C_bignump(y))) {8707 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8708 } else if (C_block_header(y) == C_RATNUM_TAG) {8709 return integer_minus_rat(ptr, x, y);8710 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8711 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8712 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8713 if (C_truep(C_u_i_inexactp(real_diff)))8714 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8715 return C_cplxnum(ptr, real_diff, imag);8716 } else {8717 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8718 }8719 } else if (C_block_header(x) == C_RATNUM_TAG) {8720 if (y & C_FIXNUM_BIT) {8721 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8722 } else if (C_immediatep(y)) {8723 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8724 } else if (C_block_header(y) == C_FLONUM_TAG) {8725 return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8726 } else if (C_truep(C_bignump(y))) {8727 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8728 } else if (C_block_header(y) == C_RATNUM_TAG) {8729 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus);8730 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8731 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8732 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8733 if (C_truep(C_u_i_inexactp(real_diff)))8734 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8735 return C_cplxnum(ptr, real_diff, imag);8736 } else {8737 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8738 }8739 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8740 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8741 C_word real_diff, imag_diff;8742 real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y));8743 imag_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_imag(x),C_u_i_cplxnum_imag(y));8744 if (C_truep(C_u_i_zerop2(imag_diff))) return real_diff;8745 else return C_cplxnum(ptr, real_diff, imag_diff);8746 } else {8747 C_word real_diff = C_s_a_i_minus(ptr, 2, C_u_i_cplxnum_real(x), y),8748 imag = C_u_i_cplxnum_imag(x);8749 if (C_truep(C_u_i_inexactp(real_diff)))8750 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8751 return C_cplxnum(ptr, real_diff, imag);8752 }8753 } else {8754 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8755 }8756}87578758C_regparm C_word8759C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y)8760{8761 if ((x & y) & C_FIXNUM_BIT) {8762 return C_a_i_fixnum_difference(ptr, 2, x, y);8763 } else {8764 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8765 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8766 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);87678768 if (C_bignum_negativep(x)) {8769 if (C_bignum_negativep(y)) {8770 return bignum_minus_unsigned(ptr, y, x);8771 } else {8772 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8773 }8774 } else {8775 if (C_bignum_negativep(y)) {8776 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8777 } else {8778 return bignum_minus_unsigned(ptr, x, y);8779 }8780 }8781 }8782}87838784void C_ccall C_minus(C_word c, C_word *av)8785{8786 /* C_word closure = av[ 0 ]; */8787 C_word k = av[ 1 ];8788 C_word next_val, result, prev_result;8789 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;87908791 if (c < 3) {8792 C_bad_min_argc(c, 3);8793 } else if (c == 3) {8794 a = ab[0];8795 C_kontinue(k, C_s_a_i_negate(&a, 1, av[ 2 ]));8796 } else {8797 prev_result = result = av[ 2 ];8798 c -= 3;8799 av += 3;88008801 while (c--) {8802 next_val = *(av++);8803 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8804 result = C_s_a_i_minus(&a, 2, result, next_val);8805 result = move_buffer_object(&a, ab[(c+1)&1], result);8806 clear_buffer_object(ab[(c+1)&1], prev_result);8807 prev_result = result;8808 }88098810 C_kontinue(k, result);8811 }8812}881388148815static C_regparm void8816integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8817{8818 if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */8819 if (x & C_FIXNUM_BIT) {8820 /* abs(x) < abs(y), so it will always be [0, x] except for this case: */8821 if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&8822 C_bignum_negated_fitsinfixnump(y)) {8823 if (q != NULL) *q = C_fix(-1);8824 if (r != NULL) *r = C_fix(0);8825 } else {8826 if (q != NULL) *q = C_fix(0);8827 if (r != NULL) *r = x;8828 }8829 } else {8830 bignum_divrem(ptr, x, y, q, r);8831 }8832 } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */8833 if (q != NULL) *q = C_a_i_fixnum_quotient_checked(ptr, 2, x, y);8834 if (r != NULL) *r = C_i_fixnum_remainder_checked(x, y);8835 } else { /* x is bignum, y is fixnum. */8836 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);88378838 if (y == C_fix(1)) {8839 if (q != NULL) *q = x;8840 if (r != NULL) *r = C_fix(0);8841 } else if (y == C_fix(-1)) {8842 if (q != NULL) *q = C_s_a_u_i_integer_negate(ptr, 1, x);8843 if (r != NULL) *r = C_fix(0);8844 } else if (C_fitsinbignumhalfdigitp(absy) ||8845 ((((C_uword)1 << (C_ilen(absy)-1)) == absy) &&8846 C_fitsinfixnump(absy))) {8847 assert(y != C_fix(0)); /* _must_ be checked by caller */8848 if (q != NULL) {8849 bignum_destructive_divide_unsigned_small(ptr, x, y, q, r);8850 } else { /* We assume r isn't NULL here (that makes no sense) */8851 C_word rem;8852 C_uword next_power = (C_uword)1 << (C_ilen(absy)-1);88538854 if (next_power == absy) { /* Is absy a power of two? */8855 rem = *(C_bignum_digits(x)) & (next_power - 1);8856 } else { /* Too bad, we have to do some real work */8857 rem = bignum_remainder_unsigned_halfdigit(x, absy);8858 }8859 *r = C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem);8860 }8861 } else { /* Just divide it as two bignums */8862 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;8863 bignum_divrem(ptr, x, C_a_u_i_fix_to_big(&a, y), q, r);8864 if (q != NULL) *q = move_buffer_object(ptr, ab, *q);8865 if (r != NULL) *r = move_buffer_object(ptr, ab, *r);8866 }8867 }8868}88698870/* This _always_ needs two bignum wrappers in ptr! */8871static C_regparm void8872bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8873{8874 C_word q_negp = C_mk_bool(C_bignum_negativep(y) != C_bignum_negativep(x)),8875 r_negp = C_mk_bool(C_bignum_negativep(x)), res, size;88768877 switch(bignum_cmp_unsigned(x, y)) {8878 case 0:8879 if (q != NULL) *q = C_truep(q_negp) ? C_fix(-1) : C_fix(1);8880 if (r != NULL) *r = C_fix(0);8881 break;8882 case -1:8883 if (q != NULL) *q = C_fix(0);8884 if (r != NULL) *r = x;8885 break;8886 case 1:8887 default:8888 res = C_SCHEME_FALSE;8889 size = C_bignum_size(x) - C_bignum_size(y);8890 if (C_bignum_size(y) > C_BURNIKEL_ZIEGLER_THRESHOLD &&8891 size > C_BURNIKEL_ZIEGLER_THRESHOLD) {8892 res = bignum_divide_burnikel_ziegler(ptr, x, y, q, r);8893 }88948895 if (!C_truep(res)) {8896 bignum_divide_unsigned(ptr, x, y, q, q_negp, r, r_negp);8897 if (q != NULL) *q = C_bignum_simplify(*q);8898 if (r != NULL) *r = C_bignum_simplify(*r);8899 }8900 break;8901 }8902}89038904/* Burnikel-Ziegler recursive division: Split high number (x) in three8905 * or four parts and divide by the lowest number (y), split in two8906 * parts. There are descriptions in [MpNT, 4.2], [MCA, 1.4.3] and the8907 * paper "Fast Recursive Division" by Christoph Burnikel & Joachim8908 * Ziegler is freely available. There is also a description in Karl8909 * Hasselstrom's thesis "Fast Division of Integers".8910 *8911 * The complexity of this is supposedly O(r*s^{log(3)-1} + r*log(s)),8912 * where s is the length of x, and r is the length of y (in digits).8913 *8914 * TODO: See if it's worthwhile to implement "division without remainder"8915 * from the Burnikel-Ziegler paper.8916 */8917static C_regparm C_word8918bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8919{8920 C_word ab[C_SIZEOF_FIX_BIGNUM*9], *a = ab,8921 lab[2][C_SIZEOF_FIX_BIGNUM*10], *la,8922 q_negp = (C_bignum_negativep(y) ? C_mk_nbool(C_bignum_negativep(x)) :8923 C_mk_bool(C_bignum_negativep(x))),8924 r_negp = C_mk_bool(C_bignum_negativep(x)), s, m, n, i, j, l, shift,8925 yhi, ylo, zi, zi_orig, newx, newy, quot, qi, ri;89268927 /* Ran out of stack? Fall back to non-recursive division */8928 C_stack_check1(return C_SCHEME_FALSE);89298930 x = C_s_a_u_i_integer_abs(&a, 1, x);8931 y = C_s_a_u_i_integer_abs(&a, 1, y);89328933 /* Define m as min{2^k|(2^k)*BURNIKEL_ZIEGLER_DIFF_THRESHOLD > s}8934 * This ensures we shift as little as possible (less pressure8935 * on the GC) while maintaining a power of two until we drop8936 * below the threshold, so we can always split N in half.8937 */8938 s = C_bignum_size(y);8939 m = 1 << C_ilen(s / C_BURNIKEL_ZIEGLER_THRESHOLD);8940 j = (s+m-1) / m; /* j = s/m, rounded up */8941 n = j * m;89428943 shift = (C_BIGNUM_DIGIT_LENGTH * n) - integer_length_abs(y);8944 newx = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(shift));8945 newy = C_s_a_i_arithmetic_shift(&a, 2, y, C_fix(shift));8946 if (shift != 0) {8947 clear_buffer_object(ab, x);8948 clear_buffer_object(ab, y);8949 }8950 x = newx;8951 y = newy;89528953 /* l needs to be the smallest value so that a < base^{l*n}/2 */8954 l = (C_bignum_size(x) + n) / n;8955 if ((C_BIGNUM_DIGIT_LENGTH * l) == integer_length_abs(x)) l++;8956 l = nmax(l, 2);89578958 yhi = bignum_extract_digits(&a, 3, y, C_fix(n >> 1), C_SCHEME_FALSE);8959 ylo = bignum_extract_digits(&a, 3, y, C_fix(0), C_fix(n >> 1));89608961 s = (l - 2) * n * C_BIGNUM_DIGIT_LENGTH;8962 zi_orig = zi = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(-s));8963 quot = C_fix(0);89648965 for(i = l - 2; i >= 0; --i) {8966 la = lab[i&1];89678968 burnikel_ziegler_2n_div_1n(&la, zi, y, yhi, ylo, C_fix(n), &qi, &ri);89698970 newx = C_s_a_i_arithmetic_shift(&la, 2, quot, C_fix(n*C_BIGNUM_DIGIT_LENGTH));8971 clear_buffer_object(lab, quot);8972 quot = C_s_a_u_i_integer_plus(&la, 2, newx, qi);8973 move_buffer_object(&la, lab[(i+1)&1], quot);8974 clear_buffer_object(lab, newx);8975 clear_buffer_object(lab, qi);89768977 if (i > 0) { /* Set z_{i-1} = [r{i}, x{i-1}] */8978 newx = bignum_extract_digits(&la, 3, x, C_fix(n * (i-1)), C_fix(n * i));8979 newy = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(n*C_BIGNUM_DIGIT_LENGTH));8980 clear_buffer_object(lab, zi);8981 zi = C_s_a_u_i_integer_plus(&la, 2, newx, newy);8982 move_buffer_object(&la, lab[(i+1)&1], zi);8983 move_buffer_object(&la, lab[(i+1)&1], quot);8984 clear_buffer_object(lab, newx);8985 clear_buffer_object(lab, newy);8986 clear_buffer_object(lab, ri);8987 }8988 }8989 clear_buffer_object(ab, x);8990 clear_buffer_object(ab, y);8991 clear_buffer_object(ab, yhi);8992 clear_buffer_object(ab, ylo);8993 clear_buffer_object(ab, zi_orig);8994 clear_buffer_object(lab, zi);89958996 if (q != NULL) {8997 if (C_truep(q_negp)) {8998 newx = C_s_a_u_i_integer_negate(&la, 1, quot);8999 clear_buffer_object(lab, quot);9000 quot = newx;9001 }9002 *q = move_buffer_object(ptr, lab, quot);9003 }9004 clear_buffer_object(lab, quot);90059006 if (r != NULL) {9007 newx = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(-shift));9008 if (C_truep(r_negp)) {9009 newy = C_s_a_u_i_integer_negate(ptr, 1, newx);9010 clear_buffer_object(lab, newx);9011 newx = newy;9012 }9013 *r = move_buffer_object(ptr, lab, newx);9014 }9015 clear_buffer_object(lab, ri);90169017 return C_SCHEME_TRUE;9018}90199020static C_regparm void9021burnikel_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)9022{9023 C_word kab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)], *ka = kab,9024 lab[2][C_SIZEOF_FIX_BIGNUM*4], *la,9025 size, tmp, less, qhat, rhat, r1, r1a3, i = 0;90269027 size = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;9028 tmp = C_s_a_i_arithmetic_shift(&ka, 2, a12, C_fix(-size));9029 less = C_i_integer_lessp(tmp, b1); /* a1 < b1 ? */9030 clear_buffer_object(kab, tmp);90319032 if (C_truep(less)) {9033 C_word atmpb[C_SIZEOF_FIX_BIGNUM*2], *atmp = atmpb, b11, b12, halfn;90349035 halfn = C_fix(C_unfix(n) >> 1);9036 b11 = bignum_extract_digits(&atmp, 3, b1, halfn, C_SCHEME_FALSE);9037 b12 = bignum_extract_digits(&atmp, 3, b1, C_fix(0), halfn);90389039 burnikel_ziegler_2n_div_1n(&ka, a12, b1, b11, b12, n, &qhat, &r1);9040 qhat = move_buffer_object(&ka, atmpb, qhat);9041 r1 = move_buffer_object(&ka, atmpb, r1);90429043 clear_buffer_object(atmpb, b11);9044 clear_buffer_object(atmpb, b12);9045 } else {9046 C_word atmpb[C_SIZEOF_FIX_BIGNUM*5], *atmp = atmpb, tmp2;90479048 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, C_fix(1), C_fix(size));9049 qhat = C_s_a_u_i_integer_minus(&ka, 2, tmp, C_fix(1)); /* B^n - 1 */9050 qhat = move_buffer_object(&ka, atmpb, qhat);9051 clear_buffer_object(atmpb, tmp);90529053 /* r1 = (a12 - b1*B^n) + b1 */9054 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, b1, C_fix(size));9055 tmp2 = C_s_a_u_i_integer_minus(&atmp, 2, a12, tmp);9056 r1 = C_s_a_u_i_integer_plus(&ka, 2, tmp2, b1);9057 r1 = move_buffer_object(&ka, atmpb, r1);9058 clear_buffer_object(atmpb, tmp);9059 clear_buffer_object(atmpb, tmp2);9060 }90619062 tmp = C_s_a_i_arithmetic_shift(&ka, 2, r1, C_fix(size));9063 clear_buffer_object(kab, r1);9064 r1a3 = C_s_a_u_i_integer_plus(&ka, 2, tmp, a3);9065 b2 = C_s_a_u_i_integer_times(&ka, 2, qhat, b2);90669067 la = lab[0];9068 rhat = C_s_a_u_i_integer_minus(&la, 2, r1a3, b2);9069 rhat = move_buffer_object(&la, kab, rhat);9070 qhat = move_buffer_object(&la, kab, qhat);90719072 clear_buffer_object(kab, tmp);9073 clear_buffer_object(kab, r1a3);9074 clear_buffer_object(kab, b2);90759076 while(C_truep(C_i_negativep(rhat))) {9077 la = lab[(++i)&1];9078 /* rhat += b */9079 r1 = C_s_a_u_i_integer_plus(&la, 2, rhat, b);9080 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9081 clear_buffer_object(lab[(i-1)&1], r1);9082 clear_buffer_object(lab[(i-1)&1], rhat);9083 clear_buffer_object(kab, rhat);9084 rhat = tmp;90859086 /* qhat -= 1 */9087 r1 = C_s_a_u_i_integer_minus(&la, 2, qhat, C_fix(1));9088 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9089 clear_buffer_object(lab[(i-1)&1], r1);9090 clear_buffer_object(lab[(i-1)&1], qhat);9091 clear_buffer_object(kab, qhat);9092 qhat = tmp;9093 }90949095 if (q != NULL) *q = move_buffer_object(ptr, lab, qhat);9096 if (r != NULL) *r = move_buffer_object(ptr, lab, rhat);9097 clear_buffer_object(lab, qhat);9098 clear_buffer_object(lab, rhat);9099}91009101static C_regparm void9102burnikel_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)9103{9104 C_word kab[2][C_SIZEOF_FIX_BIGNUM*7], *ka, a12, a3, a4,9105 q1 = C_fix(0), r1, q2 = C_fix(0), r2, *qp;9106 int stack_full = 0;91079108 C_stack_check1(stack_full = 1);91099110 n = C_unfix(n);9111 if (stack_full || (n & 1) || (n < C_BURNIKEL_ZIEGLER_THRESHOLD)) {9112 integer_divrem(ptr, a, b, q, r);9113 } else {9114 ka = kab[0];9115 a12 = bignum_extract_digits(&ka, 3, a, C_fix(n), C_SCHEME_FALSE);9116 a3 = bignum_extract_digits(&ka, 3, a, C_fix(n >> 1), C_fix(n));91179118 qp = (q == NULL) ? NULL : &q1;9119 ka = kab[1];9120 burnikel_ziegler_3n_div_2n(&ka, a12, a3, b, b1, b2, C_fix(n >> 1), qp, &r1);9121 q1 = move_buffer_object(&ka, kab[0], q1);9122 r1 = move_buffer_object(&ka, kab[0], r1);9123 clear_buffer_object(kab[0], a12);9124 clear_buffer_object(kab[0], a3);91259126 a4 = bignum_extract_digits(&ka, 3, a, C_fix(0), C_fix(n >> 1));91279128 qp = (q == NULL) ? NULL : &q2;9129 ka = kab[0];9130 burnikel_ziegler_3n_div_2n(&ka, r1, a4, b, b1, b2, C_fix(n >> 1), qp, r);9131 if (r != NULL) *r = move_buffer_object(ptr, kab[0], *r);9132 clear_buffer_object(kab[1], r1);91339134 if (q != NULL) {9135 C_word halfn_bits = (n >> 1) * C_BIGNUM_DIGIT_LENGTH;9136 r1 = C_s_a_i_arithmetic_shift(&ka, 2, q1, C_fix(halfn_bits));9137 *q = C_s_a_i_plus(ptr, 2, r1, q2); /* q = [q1, q2] */9138 *q = move_buffer_object(ptr, kab[0], *q);9139 clear_buffer_object(kab[0], r1);9140 clear_buffer_object(kab[1], q1);9141 clear_buffer_object(kab[0], q2);9142 }9143 clear_buffer_object(kab[1], a4);9144 }9145}914691479148static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y)9149{9150 C_uword *start = C_bignum_digits(x),9151 *scan = start + C_bignum_size(x),9152 rem = 0, two_digits;91539154 assert((y > 1) && (C_fitsinbignumhalfdigitp(y)));9155 while (start < scan) {9156 two_digits = (*--scan);9157 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % y;9158 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % y;9159 }9160 return rem;9161}91629163/* There doesn't seem to be a way to return two values from inline functions */9164void C_ccall C_quotient_and_remainder(C_word c, C_word *av)9165{9166 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab,9167 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE,9168 q, r, k, x, y;91699170 if (c != 4) C_bad_argc_2(c, 4, av[ 0 ]);91719172 k = av[ 1 ];9173 x = av[ 2 ];9174 y = av[ 3 ];91759176 if (!C_truep(C_i_integerp(x)))9177 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", x);9178 if (!C_truep(C_i_integerp(y)))9179 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", y);9180 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient&remainder");91819182 if (C_truep(C_i_flonump(x))) {9183 if C_truep(C_i_flonump(y)) {9184 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;91859186 C_modf(dx / dy, &tmp);9187 q = C_flonum(&a, tmp);9188 r = C_flonum(&a, dx - tmp * dy);9189 /* reuse av */9190 av[ 0 ] = C_SCHEME_UNDEFINED;9191 /* av[ 1 ] = k; */ /* stays the same */9192 av[ 2 ] = q;9193 av[ 3 ] = r;9194 C_values(4, av);9195 }9196 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9197 }9198 if (C_truep(C_i_flonump(y))) {9199 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9200 }92019202 integer_divrem(&a, x, y, &q, &r);92039204 if (C_truep(nx) || C_truep(ny)) {9205 C_word newq, newr;9206 newq = C_a_i_exact_to_inexact(&a, 1, q);9207 newr = C_a_i_exact_to_inexact(&a, 1, r);9208 clear_buffer_object(ab, q);9209 clear_buffer_object(ab, r);9210 q = newq;9211 r = newr;92129213 clear_buffer_object(ab, nx);9214 clear_buffer_object(ab, ny);9215 }9216 /* reuse av */9217 av[ 0 ] = C_SCHEME_UNDEFINED;9218 /* av[ 1 ] = k; */ /* stays the same */9219 av[ 2 ] = q;9220 av[ 3 ] = r;9221 C_values(4, av);9222}92239224void C_ccall C_u_integer_quotient_and_remainder(C_word c, C_word *av)9225{9226 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q, r;92279228 if (av[ 3 ] == C_fix(0)) C_div_by_zero_error("quotient&remainder");92299230 integer_divrem(&a, av[ 2 ], av[ 3 ], &q, &r);92319232 /* reuse av */9233 av[ 0 ] = C_SCHEME_UNDEFINED;9234 /* av[ 1 ] = k; */ /* stays the same */9235 av[ 2 ] = q;9236 av[ 3 ] = r;9237 C_values(4, av);9238}92399240C_regparm C_word9241C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)9242{9243 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, r,9244 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;92459246 if (!C_truep(C_i_integerp(x)))9247 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", x);9248 if (!C_truep(C_i_integerp(y)))9249 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", y);9250 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("remainder");92519252 if (C_truep(C_i_flonump(x))) {9253 if C_truep(C_i_flonump(y)) {9254 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;92559256 C_modf(dx / dy, &tmp);9257 return C_flonum(ptr, dx - tmp * dy);9258 }9259 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9260 }9261 if (C_truep(C_i_flonump(y))) {9262 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9263 }92649265 integer_divrem(&a, x, y, NULL, &r);92669267 if (C_truep(nx) || C_truep(ny)) {9268 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9269 clear_buffer_object(ab, r);9270 r = newr;92719272 clear_buffer_object(ab, nx);9273 clear_buffer_object(ab, ny);9274 }9275 return move_buffer_object(ptr, ab, r);9276}92779278C_regparm C_word9279C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)9280{9281 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, r;9282 if (y == C_fix(0)) C_div_by_zero_error("remainder");9283 integer_divrem(&a, x, y, NULL, &r);9284 return move_buffer_object(ptr, ab, r);9285}92869287/* Modulo's sign follows y (whereas remainder's sign follows x) */9288C_regparm C_word9289C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)9290{9291 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r,9292 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;92939294 if (!C_truep(C_i_integerp(x)))9295 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", x);9296 if (!C_truep(C_i_integerp(y)))9297 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", y);9298 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("modulo");92999300 if (C_truep(C_i_flonump(x))) {9301 if C_truep(C_i_flonump(y)) {9302 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;93039304 C_modf(dx / dy, &tmp);9305 tmp = dx - tmp * dy;9306 if ((dx > 0.0) != (dy > 0.0) && tmp != 0.0) {9307 return C_flonum(ptr, tmp + dy);9308 } else {9309 return C_flonum(ptr, tmp);9310 }9311 }9312 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9313 }9314 if (C_truep(C_i_flonump(y))) {9315 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9316 }93179318 integer_divrem(&a, x, y, NULL, &r);9319 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9320 C_word m = C_s_a_i_plus(ptr, 2, r, y);9321 m = move_buffer_object(ptr, ab, m);9322 clear_buffer_object(ab, r);9323 r = m;9324 }93259326 if (C_truep(nx) || C_truep(ny)) {9327 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9328 clear_buffer_object(ab, r);9329 r = newr;93309331 clear_buffer_object(ab, nx);9332 clear_buffer_object(ab, ny);9333 }93349335 return move_buffer_object(ptr, ab, r);9336}93379338C_regparm C_word9339C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)9340{9341 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;9342 if (y == C_fix(0)) C_div_by_zero_error("modulo");93439344 integer_divrem(&a, x, y, NULL, &r);9345 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9346 C_word m = C_s_a_u_i_integer_plus(ptr, 2, r, y);9347 m = move_buffer_object(ptr, ab, m);9348 clear_buffer_object(ab, r);9349 r = m;9350 }9351 return move_buffer_object(ptr, ab, r);9352}93539354C_regparm C_word9355C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)9356{9357 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, q,9358 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;93599360 if (!C_truep(C_i_integerp(x)))9361 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", x);9362 if (!C_truep(C_i_integerp(y)))9363 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", y);9364 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient");93659366 if (C_truep(C_i_flonump(x))) {9367 if C_truep(C_i_flonump(y)) {9368 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;93699370 C_modf(dx / dy, &tmp);9371 return C_flonum(ptr, tmp);9372 }9373 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9374 }9375 if (C_truep(C_i_flonump(y))) {9376 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9377 }93789379 integer_divrem(&a, x, y, &q, NULL);93809381 if (C_truep(nx) || C_truep(ny)) {9382 C_word newq = C_a_i_exact_to_inexact(ptr, 1, q);9383 clear_buffer_object(ab, q);9384 q = newq;93859386 clear_buffer_object(ab, nx);9387 clear_buffer_object(ab, ny);9388 }9389 return move_buffer_object(ptr, ab, q);9390}93919392C_regparm C_word9393C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y)9394{9395 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q;9396 if (y == C_fix(0)) C_div_by_zero_error("quotient");9397 integer_divrem(&a, x, y, &q, NULL);9398 return move_buffer_object(ptr, ab, q);9399}940094019402/* For help understanding this algorithm, see:9403 Knuth, Donald E., "The Art of Computer Programming",9404 volume 2, "Seminumerical Algorithms"9405 section 4.3.1, "Multiple-Precision Arithmetic".94069407 [Yeah, that's a nice book but that particular section is not9408 helpful at all, which is also pointed out by P. Brinch Hansen's9409 "Multiple-Length Division Revisited: A Tour Of The Minefield".9410 That's a more down-to-earth step-by-step explanation of the9411 algorithm. Add to this the C implementation in Hacker's Delight9412 (section 9-2, p141--142) and you may be able to grok this...9413 ...barely, if you're as math-challenged as I am -- sjamaan]94149415 This assumes that numerator >= denominator!9416*/9417static void9418bignum_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)9419{9420 C_word quotient = C_SCHEME_UNDEFINED, remainder = C_SCHEME_UNDEFINED,9421 return_rem = C_mk_nbool(r == NULL), size;94229423 if (q != NULL) {9424 size = C_fix(C_bignum_size(num) + 1 - C_bignum_size(denom));9425 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);9426 }94279428 /* An object is always required to receive the remainder */9429 size = C_fix(C_bignum_size(num) + 1);9430 remainder = C_allocate_scratch_bignum(ptr, size, r_negp, C_SCHEME_FALSE);9431 bignum_destructive_divide_full(num, denom, quotient, remainder, return_rem);94329433 /* Simplification must be done by the caller, for consistency */9434 if (q != NULL) *q = quotient;9435 if (r == NULL) {9436 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(remainder));9437 } else {9438 *r = remainder;9439 }9440}94419442/* Compare two numbers as ratnums. Either may be rat-, fix- or bignums */9443static C_word rat_cmp(C_word x, C_word y)9444{9445 C_word ab[C_SIZEOF_FIX_BIGNUM*4], *a = ab, x1, x2, y1, y2,9446 s, t, ssize, tsize, result, negp;9447 C_uword *scan;94489449 /* Check for 1 or 0; if x or y is this, the other must be the ratnum */9450 if (x == C_fix(0)) { /* Only the sign of y1 matters */9451 return basic_cmp(x, C_u_i_ratnum_num(y), "ratcmp", 0);9452 } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */9453 return basic_cmp(C_u_i_ratnum_denom(y), C_u_i_ratnum_num(y), "ratcmp", 0);9454 } else if (y == C_fix(0)) { /* Only the sign of x1 matters */9455 return basic_cmp(C_u_i_ratnum_num(x), y, "ratcmp", 0);9456 } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */9457 return basic_cmp(C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), "ratcmp", 0);9458 }94599460 /* Extract components x=x1/x2 and y=y1/y2 */9461 if (x & C_FIXNUM_BIT || C_truep(C_bignump(x))) {9462 x1 = x;9463 x2 = C_fix(1);9464 } else {9465 x1 = C_u_i_ratnum_num(x);9466 x2 = C_u_i_ratnum_denom(x);9467 }94689469 if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) {9470 y1 = y;9471 y2 = C_fix(1);9472 } else {9473 y1 = C_u_i_ratnum_num(y);9474 y2 = C_u_i_ratnum_denom(y);9475 }94769477 /* We only want to deal with bignums (this is tricky enough) */9478 if (x1 & C_FIXNUM_BIT) x1 = C_a_u_i_fix_to_big(&a, x1);9479 if (x2 & C_FIXNUM_BIT) x2 = C_a_u_i_fix_to_big(&a, x2);9480 if (y1 & C_FIXNUM_BIT) y1 = C_a_u_i_fix_to_big(&a, y1);9481 if (y2 & C_FIXNUM_BIT) y2 = C_a_u_i_fix_to_big(&a, y2);94829483 /* We multiply using schoolbook method, so this will be very slow in9484 * extreme cases. This is a tradeoff we make so that comparisons9485 * are inlineable, which makes a big difference for the common case.9486 */9487 ssize = C_bignum_size(x1) + C_bignum_size(y2);9488 negp = C_mk_bool(C_bignum_negativep(x1));9489 s = allocate_tmp_bignum(C_fix(ssize), negp, C_SCHEME_TRUE);9490 bignum_digits_multiply(x1, y2, s); /* Swap args if x1 < y2? */94919492 tsize = C_bignum_size(y1) + C_bignum_size(x2);9493 negp = C_mk_bool(C_bignum_negativep(y1));9494 t = allocate_tmp_bignum(C_fix(tsize), negp, C_SCHEME_TRUE);9495 bignum_digits_multiply(y1, x2, t); /* Swap args if y1 < x2? */94969497 /* Shorten the numbers if needed */9498 for (scan = C_bignum_digits(s)+ssize-1; *scan == 0; scan--) ssize--;9499 C_bignum_mutate_size(s, ssize);9500 for (scan = C_bignum_digits(t)+tsize-1; *scan == 0; scan--) tsize--;9501 C_bignum_mutate_size(t, tsize);95029503 result = C_i_bignum_cmp(s, t);95049505 free_tmp_bignum(t);9506 free_tmp_bignum(s);9507 return result;9508}95099510C_regparm double C_bignum_to_double(C_word bignum)9511{9512 double accumulator = 0;9513 C_uword *start = C_bignum_digits(bignum),9514 *scan = start + C_bignum_size(bignum);9515 while (start < scan) {9516 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9517 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9518 accumulator += (*--scan);9519 }9520 return(C_bignum_negativep(bignum) ? -accumulator : accumulator);9521}95229523C_regparm C_word9524C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x)9525{9526 int exponent;9527 double significand = frexp(C_flonum_magnitude(x), &exponent);95289529 assert(C_truep(C_u_i_fpintegerp(x)));95309531 if (exponent <= 0) {9532 return C_fix(0);9533 } else if (exponent == 1) { /* TODO: check significand * 2^exp fits fixnum? */9534 return significand < 0.0 ? C_fix(-1) : C_fix(1);9535 } else {9536 C_word size, negp = C_mk_bool(C_flonum_magnitude(x) < 0.0), result;9537 C_uword *start, *end;95389539 size = C_fix(C_BIGNUM_BITS_TO_DIGITS(exponent));9540 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);95419542 start = C_bignum_digits(result);9543 end = start + C_bignum_size(result);95449545 fabs_frexp_to_digits(exponent, fabs(significand), start, end);9546 return C_bignum_simplify(result);9547 }9548}95499550static void9551fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)9552{9553 C_uword digit, odd_bits = exp % C_BIGNUM_DIGIT_LENGTH;95549555 assert(C_isfinite(sign));9556 assert(0.5 <= sign && sign < 1); /* Guaranteed by frexp() and fabs() */9557 assert((scan - start) == C_BIGNUM_BITS_TO_DIGITS(exp));95589559 if (odd_bits > 0) { /* Handle most significant digit first */9560 sign *= (C_uword)1 << odd_bits;9561 digit = (C_uword)sign;9562 (*--scan) = digit;9563 sign -= (double)digit;9564 }95659566 while (start < scan && sign > 0) {9567 sign *= pow(2.0, C_BIGNUM_DIGIT_LENGTH);9568 digit = (C_uword)sign;9569 (*--scan) = digit;9570 sign -= (double)digit;9571 }95729573 /* Finish up by clearing any remaining, lower, digits */9574 while (start < scan)9575 (*--scan) = 0;9576}95779578/* This is a bit weird: We have to compare flonums as bignums due to9579 * precision loss on 64-bit platforms. For simplicity, we convert9580 * fixnums to bignums here.9581 */9582static C_word int_flo_cmp(C_word intnum, C_word flonum)9583{9584 C_word ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_FLONUM], *a = ab, flo_int, res;9585 double i, f;95869587 f = C_flonum_magnitude(flonum);95889589 if (C_isnan(f)) {9590 return C_SCHEME_FALSE; /* "mu" */9591 } else if (C_isinf(f)) {9592 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9593 } else {9594 f = modf(f, &i);95959596 flo_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));95979598 res = basic_cmp(intnum, flo_int, "int_flo_cmp", 0);9599 clear_buffer_object(ab, flo_int);96009601 if (res == C_fix(0)) /* Use fraction to break tie. If f > 0, x is smaller */9602 return C_fix((f > 0.0) ? -1 : ((f < 0.0) ? 1 : 0));9603 else9604 return res;9605 }9606}96079608/* For convenience (ie, to reduce the degree of mindfuck) */9609static C_word flo_int_cmp(C_word flonum, C_word intnum)9610{9611 C_word res = int_flo_cmp(intnum, flonum);9612 switch(res) {9613 case C_fix(1): return C_fix(-1);9614 case C_fix(-1): return C_fix(1);9615 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9616 }9617}96189619/* This code is a bit tedious, but it makes inline comparisons possible! */9620static C_word rat_flo_cmp(C_word ratnum, C_word flonum)9621{9622 C_word ab[C_SIZEOF_FIX_BIGNUM * 4 + C_SIZEOF_FLONUM], *a = ab,9623 num, denom, i_int, res, nscaled, iscaled, negp, shift_amount;9624 C_uword *scan;9625 double i, f;96269627 f = C_flonum_magnitude(flonum);96289629 if (C_isnan(f)) {9630 return C_SCHEME_FALSE; /* "mu" */9631 } else if (C_isinf(f)) {9632 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9633 } else {9634 /* Scale up the floating-point number to become a whole integer,9635 * and remember power of two (# of bits) to shift the numerator.9636 */9637 shift_amount = 0;96389639 /* TODO: This doesn't work for denormalized flonums! */9640 while (modf(f, &i) != 0.0) {9641 f = ldexp(f, 1);9642 shift_amount++;9643 }96449645 i = f; /* TODO: split i and f so it'll work for denormalized flonums */96469647 num = C_u_i_ratnum_num(ratnum);9648 negp = C_i_negativep(num);96499650 if (C_truep(negp) && i >= 0.0) { /* Save some time if signs differ */9651 return C_fix(-1);9652 } else if (!C_truep(negp) && i <= 0.0) { /* num is never 0 */9653 return C_fix(1);9654 } else {9655 denom = C_u_i_ratnum_denom(ratnum);9656 i_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));96579658 /* Multiply the scaled flonum integer by the denominator, and9659 * shift the numerator so that they may be directly compared. */9660 iscaled = C_s_a_u_i_integer_times(&a, 2, i_int, denom);9661 nscaled = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));96629663 /* Finally, we're ready to compare them! */9664 res = basic_cmp(nscaled, iscaled, "rat_flo_cmp", 0);9665 clear_buffer_object(ab, nscaled);9666 clear_buffer_object(ab, iscaled);9667 clear_buffer_object(ab, i_int);96689669 return res;9670 }9671 }9672}96739674static C_word flo_rat_cmp(C_word flonum, C_word ratnum)9675{9676 C_word res = rat_flo_cmp(ratnum, flonum);9677 switch(res) {9678 case C_fix(1): return C_fix(-1);9679 case C_fix(-1): return C_fix(1);9680 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9681 }9682}96839684/* The primitive comparison operator. eqp should be 1 if we're only9685 * interested in equality testing (can speed things up and in case of9686 * compnums, equality checking is the only available operation). This9687 * may return #f, in case there is no answer (for NaNs) or as a quick9688 * and dirty non-zero answer when eqp is true. Ugly but effective :)9689 */9690static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)9691{9692 if (x & C_FIXNUM_BIT) {9693 if (y & C_FIXNUM_BIT) {9694 return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0));9695 } else if (C_immediatep(y)) {9696 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9697 } else if (C_block_header(y) == C_FLONUM_TAG) {9698 return int_flo_cmp(x, y);9699 } else if (C_truep(C_bignump(y))) {9700 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9701 return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);9702 } else if (C_block_header(y) == C_RATNUM_TAG) {9703 if (eqp) return C_SCHEME_FALSE;9704 else return rat_cmp(x, y);9705 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9706 if (eqp) return C_SCHEME_FALSE;9707 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9708 } else {9709 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9710 }9711 } else if (C_immediatep(x)) {9712 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9713 } else if (C_block_header(x) == C_FLONUM_TAG) {9714 if (y & C_FIXNUM_BIT) {9715 return flo_int_cmp(x, y);9716 } else if (C_immediatep(y)) {9717 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9718 } else if (C_block_header(y) == C_FLONUM_TAG) {9719 double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);9720 if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */9721 else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));9722 } else if (C_truep(C_bignump(y))) {9723 return flo_int_cmp(x, y);9724 } else if (C_block_header(y) == C_RATNUM_TAG) {9725 return flo_rat_cmp(x, y);9726 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9727 if (eqp) return C_SCHEME_FALSE;9728 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9729 } else {9730 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9731 }9732 } else if (C_truep(C_bignump(x))) {9733 if (y & C_FIXNUM_BIT) {9734 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9735 return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));9736 } else if (C_immediatep(y)) {9737 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9738 } else if (C_block_header(y) == C_FLONUM_TAG) {9739 return int_flo_cmp(x, y);9740 } else if (C_truep(C_bignump(y))) {9741 return C_i_bignum_cmp(x, y);9742 } else if (C_block_header(y) == C_RATNUM_TAG) {9743 if (eqp) return C_SCHEME_FALSE;9744 else return rat_cmp(x, y);9745 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9746 if (eqp) return C_SCHEME_FALSE;9747 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9748 } else {9749 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9750 }9751 } else if (C_block_header(x) == C_RATNUM_TAG) {9752 if (y & C_FIXNUM_BIT) {9753 if (eqp) return C_SCHEME_FALSE;9754 else return rat_cmp(x, y);9755 } else if (C_immediatep(y)) {9756 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9757 } else if (C_block_header(y) == C_FLONUM_TAG) {9758 return rat_flo_cmp(x, y);9759 } else if (C_truep(C_bignump(y))) {9760 if (eqp) return C_SCHEME_FALSE;9761 else return rat_cmp(x, y);9762 } else if (C_block_header(y) == C_RATNUM_TAG) {9763 if (eqp) {9764 return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x),9765 C_u_i_ratnum_num(y)),9766 C_i_integer_equalp(C_u_i_ratnum_denom(x),9767 C_u_i_ratnum_denom(y))),9768 C_fix(0));9769 } else {9770 return rat_cmp(x, y);9771 }9772 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9773 if (eqp) return C_SCHEME_FALSE;9774 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9775 } else {9776 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9777 }9778 } else if (C_block_header(x) == C_CPLXNUM_TAG) {9779 if (!eqp) {9780 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x);9781 } else if (y & C_FIXNUM_BIT) {9782 return C_SCHEME_FALSE;9783 } else if (C_immediatep(y)) {9784 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9785 } else if (C_block_header(y) == C_FLONUM_TAG ||9786 C_truep(C_bignump(y)) ||9787 C_block_header(y) == C_RATNUM_TAG) {9788 return C_SCHEME_FALSE;9789 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9790 return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)),9791 C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))),9792 C_fix(0));9793 } else {9794 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9795 }9796 } else {9797 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9798 }9799}98009801static int bignum_cmp_unsigned(C_word x, C_word y)9802{9803 C_word xlen = C_bignum_size(x), ylen = C_bignum_size(y);98049805 if (xlen < ylen) {9806 return -1;9807 } else if (xlen > ylen) {9808 return 1;9809 } else if (x == y) {9810 return 0;9811 } else {9812 C_uword *startx = C_bignum_digits(x),9813 *scanx = startx + xlen,9814 *scany = C_bignum_digits(y) + ylen;98159816 while (startx < scanx) {9817 C_uword xdigit = (*--scanx), ydigit = (*--scany);9818 if (xdigit < ydigit)9819 return -1;9820 if (xdigit > ydigit)9821 return 1;9822 }9823 return 0;9824 }9825}98269827C_regparm C_word C_i_bignum_cmp(C_word x, C_word y)9828{9829 if (C_bignum_negativep(x)) {9830 if (C_bignum_negativep(y)) { /* Largest negative number is smallest */9831 return C_fix(bignum_cmp_unsigned(y, x));9832 } else {9833 return C_fix(-1);9834 }9835 } else {9836 if (C_bignum_negativep(y)) {9837 return C_fix(1);9838 } else {9839 return C_fix(bignum_cmp_unsigned(x, y));9840 }9841 }9842}98439844void C_ccall C_nequalp(C_word c, C_word *av)9845{9846 /* C_word closure = av[ 0 ]; */9847 C_word k = av[ 1 ];9848 C_word x, y, result = C_SCHEME_TRUE;98499850 c -= 2;9851 av += 2;9852 if (c == 0) C_kontinue(k, result);9853 x = *(av++);98549855 if (c == 1 && !C_truep(C_i_numberp(x)))9856 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);98579858 while(--c) {9859 y = *(av++);9860 result = C_i_nequalp(x, y);9861 if (result == C_SCHEME_FALSE) break;9862 }98639864 C_kontinue(k, result);9865}98669867C_regparm C_word C_i_nequalp(C_word x, C_word y)9868{9869 return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));9870}98719872C_regparm C_word C_i_integer_equalp(C_word x, C_word y)9873{9874 if (x & C_FIXNUM_BIT)9875 return C_mk_bool(x == y);9876 else if (y & C_FIXNUM_BIT)9877 return C_SCHEME_FALSE;9878 else9879 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(0));9880}988198829883void C_ccall C_greaterp(C_word c, C_word *av)9884{9885 C_word x, y,9886 /* closure = av[ 0 ] */9887 k = av[ 1 ],9888 result = C_SCHEME_TRUE;98899890 c -= 2;9891 av += 2;9892 if (c == 0) C_kontinue(k, result);98939894 x = *(av++);98959896 if (c == 1 && !C_truep(C_i_numberp(x)))9897 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">", x);98989899 while(--c) {9900 y = *(av++);9901 result = C_i_greaterp(x, y);9902 if (result == C_SCHEME_FALSE) break;9903 x = y;9904 }99059906 C_kontinue(k, result);9907}990899099910C_regparm C_word C_i_greaterp(C_word x, C_word y)9911{9912 return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));9913}99149915C_regparm C_word C_i_integer_greaterp(C_word x, C_word y)9916{9917 if (x & C_FIXNUM_BIT) {9918 if (y & C_FIXNUM_BIT) {9919 return C_mk_bool(C_unfix(x) > C_unfix(y));9920 } else {9921 return C_mk_bool(C_bignum_negativep(y));9922 }9923 } else if (y & C_FIXNUM_BIT) {9924 return C_mk_nbool(C_bignum_negativep(x));9925 } else {9926 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(1));9927 }9928}99299930void C_ccall C_lessp(C_word c, C_word *av)9931{9932 C_word x, y,9933 /* closure = av[ 0 ] */9934 k = av[ 1 ],9935 result = C_SCHEME_TRUE;99369937 c -= 2;9938 av += 2;9939 if (c == 0) C_kontinue(k, result);99409941 x = *(av++);99429943 if (c == 1 && !C_truep(C_i_numberp(x)))9944 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<", x);99459946 while(--c) {9947 y = *(av++);9948 result = C_i_lessp(x, y);9949 if (result == C_SCHEME_FALSE) break;9950 x = y;9951 }99529953 C_kontinue(k, result);9954}995599569957C_regparm C_word C_i_lessp(C_word x, C_word y)9958{9959 return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));9960}99619962C_regparm C_word C_i_integer_lessp(C_word x, C_word y)9963{9964 if (x & C_FIXNUM_BIT) {9965 if (y & C_FIXNUM_BIT) {9966 return C_mk_bool(C_unfix(x) < C_unfix(y));9967 } else {9968 return C_mk_nbool(C_bignum_negativep(y));9969 }9970 } else if (y & C_FIXNUM_BIT) {9971 return C_mk_bool(C_bignum_negativep(x));9972 } else {9973 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(-1));9974 }9975}99769977void C_ccall C_greater_or_equal_p(C_word c, C_word *av)9978{9979 C_word x, y,9980 /* closure = av[ 0 ] */9981 k = av[ 1 ],9982 result = C_SCHEME_TRUE;99839984 c -= 2;9985 av += 2;9986 if (c == 0) C_kontinue(k, result);99879988 x = *(av++);99899990 if (c == 1 && !C_truep(C_i_numberp(x)))9991 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">=", x);99929993 while(--c) {9994 y = *(av++);9995 result = C_i_greater_or_equalp(x, y);9996 if (result == C_SCHEME_FALSE) break;9997 x = y;9998 }999910000 C_kontinue(k, result);10001}100021000310004C_regparm C_word C_i_greater_or_equalp(C_word x, C_word y)10005{10006 C_word res = basic_cmp(x, y, ">=", 0);10007 return C_mk_bool(res == C_fix(0) || res == C_fix(1));10008}1000910010C_regparm C_word C_i_integer_greater_or_equalp(C_word x, C_word y)10011{10012 if (x & C_FIXNUM_BIT) {10013 if (y & C_FIXNUM_BIT) {10014 return C_mk_bool(C_unfix(x) >= C_unfix(y));10015 } else {10016 return C_mk_bool(C_bignum_negativep(y));10017 }10018 } else if (y & C_FIXNUM_BIT) {10019 return C_mk_nbool(C_bignum_negativep(x));10020 } else {10021 C_word res = C_i_bignum_cmp(x, y);10022 return C_mk_bool(res == C_fix(0) || res == C_fix(1));10023 }10024}1002510026void C_ccall C_less_or_equal_p(C_word c, C_word *av)10027{10028 C_word x, y,10029 /* closure = av[ 0 ] */10030 k = av[ 1 ],10031 result = C_SCHEME_TRUE;1003210033 c -= 2;10034 av += 2;10035 if (c == 0) C_kontinue(k, result);1003610037 x = *(av++);1003810039 if (c == 1 && !C_truep(C_i_numberp(x)))10040 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<=", x);1004110042 while(--c) {10043 y = *(av++);10044 result = C_i_less_or_equalp(x, y);10045 if (result == C_SCHEME_FALSE) break;10046 x = y;10047 }1004810049 C_kontinue(k, result);10050}100511005210053C_regparm C_word C_i_less_or_equalp(C_word x, C_word y)10054{10055 C_word res = basic_cmp(x, y, "<=", 0);10056 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10057}100581005910060C_regparm C_word C_i_integer_less_or_equalp(C_word x, C_word y)10061{10062 if (x & C_FIXNUM_BIT) {10063 if (y & C_FIXNUM_BIT) {10064 return C_mk_bool(C_unfix(x) <= C_unfix(y));10065 } else {10066 return C_mk_nbool(C_bignum_negativep(y));10067 }10068 } else if (y & C_FIXNUM_BIT) {10069 return C_mk_bool(C_bignum_negativep(x));10070 } else {10071 C_word res = C_i_bignum_cmp(x, y);10072 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10073 }10074}100751007610077void C_ccall C_gc(C_word c, C_word *av)10078{10079 C_word10080 /* closure = av[ 0 ] */10081 k = av[ 1 ];10082 int f;10083 C_word10084 arg, *p,10085 size = 0;1008610087 if(c == 3) {10088 arg = av[ 2 ];10089 f = C_truep(arg);10090 }10091 else if(c != 2) C_bad_min_argc(c, 2);10092 else f = 1;1009310094 C_save(k);10095 p = C_temporary_stack;1009610097 if(c == 3) {10098 if((arg & C_FIXNUM_BIT) != 0) size = C_unfix(arg);10099 else if(arg == C_SCHEME_END_OF_LIST) size = percentage(heap_size, C_heap_growth);10100 }1010110102 if(size && !C_heap_size_is_fixed) {10103 C_rereclaim2(size, 0);10104 C_temporary_stack = C_temporary_stack_bottom;10105 gc_2(0, p);10106 }10107 else if(f) C_fromspace_top = C_fromspace_limit;1010810109 C_reclaim((void *)gc_2, 1);10110}101111011210113void C_ccall gc_2(C_word c, C_word *av)10114{10115 C_word k = av[ 0 ];10116 C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));10117}101181011910120void C_ccall C_open_file_port(C_word c, C_word *av)10121{10122 C_word10123 /* closure = av[ 0 ] */10124 k = av[ 1 ],10125 port = av[ 2 ],10126 channel = av[ 3 ],10127 mode = av[ 4 ];10128 C_FILEPTR fp = (C_FILEPTR)NULL;10129 C_char *fmode;10130 C_word n, bv, fbv;10131 C_char *buf;10132 C_WCHAR *fbuf;1013310134 switch(channel) {10135 case C_fix(0): fp = C_stdin; break;10136 case C_fix(1): fp = C_stdout; break;10137 case C_fix(2): fp = C_stderr; break;10138 default:10139 bv = C_block_item(channel, 0);10140 buf = C_c_string(bv);10141 fbv = C_block_item(mode, 0);10142 fmode = C_c_string(fbv);10143 if (C_header_size(C_block_item(channel, 0)) - 1 != strlen(buf))10144 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", channel);10145 if (C_header_size(C_block_item(mode, 0)) - 1 != strlen(fmode))10146 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", mode);10147 fbuf = C_OS_FILENAME(bv, 0);10148 fp = C_fopen(fbuf, C_OS_FILENAME(fbv, 1));10149 }1015010151 C_set_block_item(port, 0, (C_word)fp);10152 C_kontinue(k, C_mk_bool(fp != NULL));10153}101541015510156void C_ccall C_allocate_vector(C_word c, C_word *av)10157{10158 C_word10159 /* closure = av[ 0 ] */10160 k = av[ 1 ],10161 size, init, bytes, n, *p;1016210163 if(c != 4) C_bad_argc(c, 4);1016410165 size = av[ 2 ];10166 init = av[ 3 ];10167 n = C_unfix(size);1016810169 if(n > C_HEADER_SIZE_MASK || n < 0)10170 barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1017110172 bytes = C_wordstobytes(n) + sizeof(C_word);1017310174 C_save(k);10175 C_save(size);10176 C_save(init);10177 C_save(C_fix(bytes));1017810179 if(!C_demand(C_bytestowords(bytes))) {10180 /* Allocate on heap: */10181 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10182 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1018310184 C_save(C_SCHEME_TRUE);10185 /* We explicitly pass 5 here, that's the number of things saved.10186 * That's the arguments, plus one additional thing: the mode.10187 */10188 C_reclaim((void *)allocate_vector_2, 5);10189 }1019010191 C_save(C_SCHEME_FALSE);10192 p = C_temporary_stack;10193 C_temporary_stack = C_temporary_stack_bottom;10194 allocate_vector_2(0, p);10195}101961019710198void C_ccall allocate_vector_2(C_word c, C_word *av)10199{10200 C_word10201 mode = av[ 0 ],10202 bytes = C_unfix(av[ 1 ]),10203 init = av[ 2 ],10204 size = C_unfix(av[ 3 ]),10205 k = av[ 4 ],10206 *v0, v;1020710208 if(C_truep(mode)) {10209 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10210 if(C_heap_size_is_fixed)10211 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1021210213 C_save(init);10214 C_save(k);10215 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10216 k = C_restore;10217 init = C_restore;10218 }1021910220 v0 = (C_word *)C_align((C_word)C_fromspace_top);10221 C_fromspace_top += C_align(bytes);10222 }10223 else v0 = C_alloc(C_bytestowords(bytes));1022410225 v = (C_word)v0;10226 *(v0++) = C_VECTOR_TYPE | size;10227 while(size--) *(v0++) = init;10228 C_kontinue(k, v);10229}1023010231void C_ccall C_allocate_bytevector(C_word c, C_word *av)10232{10233 C_word10234 /* closure = av[ 0 ] */10235 k = av[ 1 ],10236 size, init, align8, bytes, str, n, *p;1023710238 if(c != 4) C_bad_argc(c, 4);1023910240 size = av[ 2 ];10241 init = av[ 3 ];10242 n = C_unfix(size);1024310244 if(n > C_HEADER_SIZE_MASK || n < 0)10245 barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1024610247 bytes = n + sizeof(C_word) * 2;1024810249 C_save(k);10250 C_save(size);10251 C_save(init);10252 C_save(C_fix(bytes));1025310254 if(!C_demand(C_bytestowords(bytes))) {10255 /* Allocate on heap: */10256 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10257 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1025810259 C_save(C_SCHEME_TRUE);10260 /* We explicitly pass 5 here, that's the number of things saved.10261 * That's the arguments, plus one additional thing: the mode.10262 */10263 C_reclaim((void *)allocate_bytevector_2, 5);10264 }1026510266 C_save(C_SCHEME_FALSE);10267 p = C_temporary_stack;10268 C_temporary_stack = C_temporary_stack_bottom;10269 allocate_bytevector_2(0, p);10270}102711027210273void C_ccall allocate_bytevector_2(C_word c, C_word *av)10274{10275 C_word10276 mode = av[ 0 ],10277 bytes = C_unfix(av[ 1 ]),10278 init = av[ 2 ],10279 size = C_unfix(av[ 3 ]),10280 k = av[ 4 ],10281 *v0, v;10282 char buf[ 4 ];1028310284 if(C_truep(mode)) {10285 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10286 if(C_heap_size_is_fixed)10287 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1028810289 C_save(init);10290 C_save(k);10291 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10292 k = C_restore;10293 init = C_restore;10294 }1029510296 v0 = (C_word *)C_align((C_word)C_fromspace_top);10297 C_fromspace_top += C_align(bytes);10298 }10299 else v0 = C_alloc(C_bytestowords(bytes));1030010301#ifndef C_SIXTY_FOUR10302 if(C_aligned8(v0)) ++v0;10303#endif1030410305 v = (C_word)v0;10306 *(v0++) = C_BYTEVECTOR_TYPE | size;1030710308 if(C_truep(init)) C_memset(v0, C_unfix(init), size);1030910310 C_kontinue(k, v);10311}1031210313static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)10314{10315 C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),10316 bigvec = (C_word)(mem + C_SIZEOF_BIGNUM_WRAPPER);10317 if (mem == NULL) abort(); /* TODO: panic */1031810319 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));10320 C_set_block_item(bigvec, 0, C_truep(negp));1032110322 if (C_truep(initp)) {10323 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10324 0, C_wordstobytes(C_unfix(size)));10325 }1032610327 return C_a_i_bignum_wrapper(&mem, bigvec);10328}1032910330C_regparm C_word10331C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)10332{10333 C_word big, bigvec = C_scratch_alloc(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));1033410335 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));10336 C_set_block_item(bigvec, 0, C_truep(negp));1033710338 if (C_truep(initp)) {10339 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10340 0, C_wordstobytes(C_unfix(size)));10341 }1034210343 big = C_a_i_bignum_wrapper(ptr, bigvec);10344 C_mutate_scratch_slot(&C_internal_bignum_vector(big), bigvec);10345 return big;10346}1034710348/* Simplification: scan trailing zeroes, then return a fixnum if the10349 * value fits, or trim the bignum's length. If the bignum was stored10350 * in scratch space, we mark it as reclaimable. This means any10351 * references to the original bignum are invalid after simplification!10352 */10353C_regparm C_word C_bignum_simplify(C_word big)10354{10355 C_uword *start = C_bignum_digits(big),10356 *last_digit = start + C_bignum_size(big) - 1,10357 *scan = last_digit, tmp;10358 int length;1035910360 while (scan >= start && *scan == 0)10361 scan--;10362 length = scan - start + 1;1036310364 switch(length) {10365 case 0:10366 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10367 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10368 return C_fix(0);10369 case 1:10370 tmp = *start;10371 if (C_bignum_negativep(big) ?10372 !(tmp & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)tmp) :10373 C_ufitsinfixnump(tmp)) {10374 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10375 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10376 return C_bignum_negativep(big) ? C_fix(-(C_word)tmp) : C_fix(tmp);10377 }10378 /* FALLTHROUGH */10379 default:10380 if (scan < last_digit) C_bignum_mutate_size(big, length);10381 return big;10382 }10383}1038410385static void bignum_digits_destructive_negate(C_word result)10386{10387 C_uword *scan, *end, digit, sum;1038810389 scan = C_bignum_digits(result);10390 end = scan + C_bignum_size(result);1039110392 do {10393 digit = ~*scan;10394 sum = digit + 1;10395 *scan++ = sum;10396 } while (sum == 0 && scan < end);1039710398 for (; scan < end; scan++) {10399 *scan = ~*scan;10400 }10401}1040210403static C_uword10404bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)10405{10406 C_uword digit, p;1040710408 assert(C_fitsinbignumhalfdigitp(carry));10409 assert(C_fitsinbignumhalfdigitp(factor));1041010411 /* See fixnum_times. Substitute xlo = factor, xhi = 0, y = digit10412 * and simplify the result to reduce variable usage.10413 */10414 while (start < end) {10415 digit = (*start);1041610417 p = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;10418 carry = C_BIGNUM_DIGIT_LO_HALF(p);1041910420 p = factor * C_BIGNUM_DIGIT_HI_HALF(digit) + C_BIGNUM_DIGIT_HI_HALF(p);10421 (*start++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), carry);10422 carry = C_BIGNUM_DIGIT_HI_HALF(p);10423 }10424 return carry;10425}1042610427static C_uword10428bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator)10429{10430 C_uword digit, k = 0;10431 C_uhword q_j_hi, q_j_lo;1043210433 /* Single digit divisor case from Hacker's Delight, Figure 9-1,10434 * adapted to modify u[] in-place instead of writing to q[].10435 */10436 while (start < end) {10437 digit = (*--end);1043810439 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_HI_HALF(digit)); /* j */10440 q_j_hi = k / denominator;10441 k -= q_j_hi * denominator;1044210443 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */10444 q_j_lo = k / denominator;10445 k -= q_j_lo * denominator;1044610447 *end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);10448 }10449 return k;10450}1045110452static C_uword10453bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp)10454{10455 int shift_left = C_BIGNUM_DIGIT_LENGTH - shift_right;10456 C_uword digit, carry = negp ? ((~(C_uword)0) << shift_left) : 0;1045710458 assert(shift_right < C_BIGNUM_DIGIT_LENGTH);1045910460 while (start < end) {10461 digit = *(--end);10462 *end = (digit >> shift_right) | carry;10463 carry = digit << shift_left;10464 }10465 return carry >> shift_left; /* The bits that were shifted out to the right */10466}1046710468static C_uword10469bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left)10470{10471 C_uword carry = 0, digit;10472 int shift_right = C_BIGNUM_DIGIT_LENGTH - shift_left;1047310474 assert(shift_left < C_BIGNUM_DIGIT_LENGTH);1047510476 while (start < end) {10477 digit = *start;10478 (*start++) = (digit << shift_left) | carry;10479 carry = digit >> shift_right;10480 }10481 return carry; /* This would end up as most significant digit if it fit */10482}1048310484static C_regparm void10485bignum_digits_multiply(C_word x, C_word y, C_word result)10486{10487 C_uword product,10488 *xd = C_bignum_digits(x),10489 *yd = C_bignum_digits(y),10490 *rd = C_bignum_digits(result);10491 C_uhword carry, yj;10492 /* Lengths in halfwords */10493 int i, j, length_x = C_bignum_size(x) * 2, length_y = C_bignum_size(y) * 2;1049410495 /* From Hacker's Delight, Figure 8-1 (top part) */10496 for (j = 0; j < length_y; ++j) {10497 yj = C_uhword_ref(yd, j);10498 if (yj == 0) continue;10499 carry = 0;10500 for (i = 0; i < length_x; ++i) {10501 product = (C_uword)C_uhword_ref(xd, i) * yj +10502 (C_uword)C_uhword_ref(rd, i + j) + carry;10503 C_uhword_set(rd, i + j, product);10504 carry = C_BIGNUM_DIGIT_HI_HALF(product);10505 }10506 C_uhword_set(rd, j + length_x, carry);10507 }10508}105091051010511/* "small" is either a number that fits a halfdigit, or a power of two */10512static C_regparm void10513bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)10514{10515 C_word size, quotient, q_negp = C_mk_bool((y & C_INT_SIGN_BIT) ?10516 !(C_bignum_negativep(x)) :10517 C_bignum_negativep(x)),10518 r_negp = C_mk_bool(C_bignum_negativep(x));10519 C_uword *start, *end, remainder;10520 int shift_amount;1052110522 size = C_fix(C_bignum_size(x));10523 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);10524 bignum_digits_destructive_copy(quotient, x);1052510526 start = C_bignum_digits(quotient);10527 end = start + C_bignum_size(quotient);1052810529 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);1053010531 shift_amount = C_ilen(y) - 1;10532 if (((C_uword)1 << shift_amount) == y) { /* Power of two? Shift! */10533 remainder = bignum_digits_destructive_shift_right(start,end,shift_amount,0);10534 assert(C_ufitsinfixnump(remainder));10535 } else {10536 remainder = bignum_digits_destructive_scale_down(start, end, y);10537 assert(C_fitsinbignumhalfdigitp(remainder));10538 }1053910540 if (r != NULL) *r = C_truep(r_negp) ? C_fix(-remainder) : C_fix(remainder);10541 /* Calling this function only makes sense if quotient is needed */10542 *q = C_bignum_simplify(quotient);10543}1054410545static C_regparm void10546bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder)10547{10548 C_word length = C_bignum_size(denominator);10549 C_uword d1 = *(C_bignum_digits(denominator) + length - 1),10550 *startr = C_bignum_digits(remainder),10551 *endr = startr + C_bignum_size(remainder);10552 int shift;1055310554 shift = C_BIGNUM_DIGIT_LENGTH - C_ilen(d1); /* nlz */1055510556 /* We have to work on halfdigits, so we shift out only the necessary10557 * amount in order fill out that halfdigit (base is halved).10558 * This trick is shamelessly stolen from Gauche :)10559 * See below for part 2 of the trick.10560 */10561 if (shift >= C_BIGNUM_HALF_DIGIT_LENGTH)10562 shift -= C_BIGNUM_HALF_DIGIT_LENGTH;1056310564 /* Code below won't always set high halfdigit of quotient, so do it here. */10565 if (quotient != C_SCHEME_UNDEFINED)10566 C_bignum_digits(quotient)[C_bignum_size(quotient)-1] = 0;1056710568 bignum_digits_destructive_copy(remainder, numerator);10569 *(endr-1) = 0; /* Ensure most significant digit is initialised */10570 if (shift == 0) { /* Already normalized */10571 bignum_destructive_divide_normalized(remainder, denominator, quotient);10572 } else { /* Requires normalisation; allocate scratch denominator for this */10573 C_uword *startnd;10574 C_word ndenom;1057510576 bignum_digits_destructive_shift_left(startr, endr, shift);1057710578 ndenom = allocate_tmp_bignum(C_fix(length), C_SCHEME_FALSE, C_SCHEME_FALSE);10579 startnd = C_bignum_digits(ndenom);10580 bignum_digits_destructive_copy(ndenom, denominator);10581 bignum_digits_destructive_shift_left(startnd, startnd+length, shift);1058210583 bignum_destructive_divide_normalized(remainder, ndenom, quotient);10584 if (C_truep(return_remainder)) /* Otherwise, don't bother shifting back */10585 bignum_digits_destructive_shift_right(startr, endr, shift, 0);1058610587 free_tmp_bignum(ndenom);10588 }10589}1059010591static C_regparm void10592bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)10593{10594 C_uword *v = C_bignum_digits(big_v),10595 *u = C_bignum_digits(big_u),10596 *q = big_q == C_SCHEME_UNDEFINED ? NULL : C_bignum_digits(big_q),10597 p, /* product of estimated quotient & "denominator" */10598 hat, qhat, rhat, /* estimated quotient and remainder digit */10599 vn_1, vn_2; /* "cached" values v[n-1], v[n-2] */10600 C_word t, k; /* Two helpers: temp/final remainder and "borrow" */10601 /* We use plain ints here, which theoretically may not be enough on10602 * 64-bit for an insanely huge number, but it is a _lot_ faster.10603 */10604 int n = C_bignum_size(big_v) * 2, /* in halfwords */10605 m = (C_bignum_size(big_u) * 2) - 2; /* Correct for extra digit */10606 int i, j; /* loop vars */1060710608 /* Part 2 of Gauche's aforementioned trick: */10609 if (C_uhword_ref(v, n-1) == 0) n--;1061010611 /* These won't change during the loop, but are used in every step. */10612 vn_1 = C_uhword_ref(v, n-1);10613 vn_2 = C_uhword_ref(v, n-2);1061410615 /* See also Hacker's Delight, Figure 9-1. This is almost exactly that. */10616 for (j = m - n; j >= 0; j--) {10617 hat = C_BIGNUM_DIGIT_COMBINE(C_uhword_ref(u, j+n), C_uhword_ref(u, j+n-1));10618 if (hat == 0) {10619 if (q != NULL) C_uhword_set(q, j, 0);10620 continue;10621 }10622 qhat = hat / vn_1;10623 rhat = hat % vn_1;1062410625 /* Two whiles is faster than one big check with an OR. Thanks, Gauche! */10626 while(qhat >= ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) { qhat--; rhat += vn_1; }10627 while(qhat * vn_2 > C_BIGNUM_DIGIT_COMBINE(rhat, C_uhword_ref(u, j+n-2))10628 && rhat < ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) {10629 qhat--;10630 rhat += vn_1;10631 }1063210633 /* Multiply and subtract */10634 k = 0;10635 for (i = 0; i < n; i++) {10636 p = qhat * C_uhword_ref(v, i);10637 t = C_uhword_ref(u, i+j) - k - C_BIGNUM_DIGIT_LO_HALF(p);10638 C_uhword_set(u, i+j, t);10639 k = C_BIGNUM_DIGIT_HI_HALF(p) - (t >> C_BIGNUM_HALF_DIGIT_LENGTH);10640 }10641 t = C_uhword_ref(u,j+n) - k;10642 C_uhword_set(u, j+n, t);1064310644 if (t < 0) { /* Subtracted too much? */10645 qhat--;10646 k = 0;10647 for (i = 0; i < n; i++) {10648 t = (C_uword)C_uhword_ref(u, i+j) + C_uhword_ref(v, i) + k;10649 C_uhword_set(u, i+j, t);10650 k = t >> C_BIGNUM_HALF_DIGIT_LENGTH;10651 }10652 C_uhword_set(u, j+n, (C_uhword_ref(u, j+n) + k));10653 }10654 if (q != NULL) C_uhword_set(q, j, qhat);10655 } /* end j */10656}106571065810659/* XXX this should be an inline_allocate routine */10660void C_ccall C_string_to_symbol(C_word c, C_word *av)10661{10662 C_word10663 /* closure = av[ 0 ] */10664 k = av[ 1 ];10665 int len, key;10666 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;10667 C_char *name;1066810669 b = av[ 2 ];10670 len = C_header_size(b) - 1;10671 name = C_c_string(b);1067210673 key = hash_string(len, name, symbol_table->size, symbol_table->rand);10674 if(!C_truep(s = lookup(key, len, name, symbol_table)))10675 s = add_symbol(&a, key, b, symbol_table);1067610677 C_kontinue(k, s);10678}1067910680/* XXX this should be an inline_allocate routine */10681void C_ccall C_string_to_keyword(C_word c, C_word *av)10682{10683 C_word10684 /* closure = av[ 0 ] */10685 k = av[ 1 ];10686 int len, key;10687 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;10688 C_char *name;1068910690 b = av[ 2 ];10691 len = C_header_size(b) - 1;10692 name = C_c_string(b);10693 key = hash_string(len, name, keyword_table->size, keyword_table->rand);1069410695 if(!C_truep(s = lookup(key, len, name, keyword_table))) {10696 s = add_symbol(&a, key, b, keyword_table);10697 C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */10698 C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */10699 }10700 C_kontinue(k, s);10701}1070210703/* This will usually return a flonum, but it may also return a cplxnum10704 * consisting of two flonums, making for a total of 11 words.10705 */10706C_regparm C_word10707C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)10708{10709 if (n & C_FIXNUM_BIT) {10710 return C_flonum(ptr, (double)C_unfix(n));10711 } else if (C_immediatep(n)) {10712 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10713 } else if (C_block_header(n) == C_FLONUM_TAG) {10714 return n;10715 } else if (C_truep(C_bignump(n))) {10716 return C_a_u_i_big_to_flo(ptr, c, n);10717 } else if (C_block_header(n) == C_CPLXNUM_TAG) {10718 return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)),10719 C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n)));10720 /* The horribly painful case: ratnums */10721 } else if (C_block_header(n) == C_RATNUM_TAG) {10722 /* This tries to keep the numbers within representable ranges and10723 * tries to drop as few significant digits as possible by bringing10724 * the two numbers to within the same powers of two. See10725 * algorithms M & N in Knuth, 4.2.1.10726 */10727 C_word num = C_u_i_ratnum_num(n), denom = C_u_i_ratnum_denom(n),10728 /* e = approx. distance between the numbers in powers of 2.10729 * ie, 2^e-1 < n/d < 2^e+1 (e is the *un*biased value of10730 * e_w in M2. TODO: What if b!=2 (ie, flonum-radix isn't 2)?10731 */10732 e = integer_length_abs(num) - integer_length_abs(denom),10733 ab[C_SIZEOF_FIX_BIGNUM*5+C_SIZEOF_FLONUM], *a = ab, tmp, q, r, len,10734 shift_amount, negp = C_i_integer_negativep(num);10735 C_uword *d;10736 double res, fraction;1073710738 /* Align by shifting the smaller to the size of the larger */10739 if (e < 0) num = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(-e));10740 else if (e > 0) denom = C_s_a_i_arithmetic_shift(&a, 2, denom, C_fix(e));1074110742 /* Here, 1/2 <= n/d < 2 [N3] */10743 if (C_truep(C_i_integer_lessp(num, denom))) { /* n/d < 1? */10744 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(1));10745 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10746 num = tmp;10747 e--;10748 }1074910750 /* Here, 1 <= n/d < 2 (normalized) [N5] */10751 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));1075210753 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));10754 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10755 num = tmp;1075610757 /* Now, calculate round(num/denom). We start with a quotient&remainder */10758 integer_divrem(&a, num, denom, &q, &r);1075910760 /* We multiply the remainder by two to simulate adding 1/2 for10761 * round. However, we don't do it if num = denom (q=1,r=0) */10762 if (!((q == C_fix(1) || q == C_fix(-1)) && r == C_fix(0))) {10763 tmp = C_s_a_i_arithmetic_shift(&a, 2, r, C_fix(1));10764 clear_buffer_object(ab, r); /* "knows" shift creates fresh numbers */10765 r = tmp;10766 }1076710768 /* Now q is the quotient, but to "round" result we need to10769 * adjust. This follows the semantics of the "round" procedure:10770 * Round away from zero on positive numbers (ignoring sign). In10771 * case of exactly halfway, we round up if odd.10772 */10773 tmp = C_a_i_exact_to_inexact(&a, 1, q);10774 fraction = fabs(C_flonum_magnitude(tmp));10775 switch (basic_cmp(r, denom, "", 0)) {10776 case C_fix(0):10777 if (C_truep(C_i_oddp(q))) fraction += 1.0;10778 break;10779 case C_fix(1):10780 fraction += 1.0;10781 break;10782 default: /* if r <= denom, we're done */ break;10783 }1078410785 clear_buffer_object(ab, num);10786 clear_buffer_object(ab, denom);10787 clear_buffer_object(ab, q);10788 clear_buffer_object(ab, r);1078910790 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));10791 res = ldexp(fraction, e - shift_amount);10792 return C_flonum(ptr, C_truep(negp) ? -res : res);10793 } else {10794 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10795 }10796}107971079810799/* this is different from C_a_i_flonum_round, for R5RS compatibility */10800C_regparm C_word C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)10801{10802 double fn, i, f, i2, r;1080310804 fn = C_flonum_magnitude(n);10805 if(fn < 0.0) {10806 f = modf(-fn, &i);10807 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10808 r = -i;10809 else10810 r = -(i + 1.0);10811 }10812 else if(fn == 0.0/* || fn == -0.0*/)10813 r = fn;10814 else {10815 f = modf(fn, &i);10816 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10817 r = i;10818 else10819 r = i + 1.0;10820 }1082110822 return C_flonum(ptr, r);10823}1082410825C_regparm C_word10826C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)10827{10828 double xub, yub, r;1082910830 if (!C_truep(C_u_i_fpintegerp(x)))10831 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);10832 if (!C_truep(C_u_i_fpintegerp(y)))10833 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);1083410835 xub = C_flonum_magnitude(x);10836 yub = C_flonum_magnitude(y);1083710838 if (xub < 0.0) xub = -xub;10839 if (yub < 0.0) yub = -yub;1084010841 while(yub != 0.0) {10842 r = fmod(xub, yub);10843 xub = yub;10844 yub = r;10845 }10846 return C_flonum(p, xub);10847}1084810849/* This is Lehmer's GCD algorithm with Jebelean's quotient test, as10850 * it is presented in the paper "An Analysis of Lehmer’s Euclidean10851 * GCD Algorithm", by J. Sorenson. Fuck the ACM and their goddamn10852 * paywall; you can currently find the paper here:10853 * http://www.csie.nuk.edu.tw/~cychen/gcd/An%20analysis%20of%20Lehmer%27s%20Euclidean%20GCD%20algorithm.pdf10854 * If that URI fails, it's also explained in [MpNT, 5.2]10855 *10856 * The basic idea is to avoid divisions which yield only small10857 * quotients, in which the remainder won't reduce the numbers by10858 * much. This can be detected by dividing only the leading k bits.10859 * In our case, k = C_WORD_SIZE - 2.10860 */10861inline static void lehmer_gcd(C_word **ptr, C_word u, C_word v, C_word *x, C_word *y)10862{10863 int i_even = 1, done = 0;10864 C_word shift_amount = integer_length_abs(u) - (C_WORD_SIZE - 2),10865 ab[C_SIZEOF_BIGNUM(2)*2+C_SIZEOF_FIX_BIGNUM*2], *a = ab,10866 uhat, vhat, qhat, xnext, ynext,10867 xprev = 1, yprev = 0, xcurr = 0, ycurr = 1;1086810869 uhat = C_s_a_i_arithmetic_shift(&a, 2, u, C_fix(-shift_amount));10870 vhat = C_s_a_i_arithmetic_shift(&a, 2, v, C_fix(-shift_amount));10871 assert(uhat & C_FIXNUM_BIT); uhat = C_unfix(uhat);10872 assert(vhat & C_FIXNUM_BIT); vhat = C_unfix(vhat);1087310874 do {10875 qhat = uhat / vhat; /* Estimated quotient for this step */10876 xnext = xprev - qhat * xcurr;10877 ynext = yprev - qhat * ycurr;1087810879 /* Euclidean GCD swap on uhat and vhat (shift_amount is not needed): */10880 shift_amount = vhat;10881 vhat = uhat - qhat * vhat;10882 uhat = shift_amount;1088310884 i_even = !i_even;10885 if (i_even)10886 done = (vhat < -xnext) || ((uhat - vhat) < (ynext - ycurr));10887 else10888 done = (vhat < -ynext) || ((uhat - vhat) < (xnext - xcurr));1088910890 if (!done) {10891 xprev = xcurr; yprev = ycurr;10892 xcurr = xnext; ycurr = ynext;10893 }10894 } while (!done);1089510896 /* x = xprev * u + yprev * v */10897 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xprev), u);10898 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(yprev), v);10899 *x = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10900 *x = move_buffer_object(ptr, ab, *x);10901 clear_buffer_object(ab, uhat);10902 clear_buffer_object(ab, vhat);1090310904 /* y = xcurr * u + ycurr * v */10905 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xcurr), u);10906 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(ycurr), v);10907 *y = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10908 *y = move_buffer_object(ptr, ab, *y);10909 clear_buffer_object(ab, uhat);10910 clear_buffer_object(ab, vhat);10911}1091210913/* Because this must be inlineable (due to + and - using this for10914 * ratnums), we can't use burnikel-ziegler division here, until we10915 * have a C implementation that doesn't consume stack. However,10916 * we *can* use Lehmer's GCD.10917 */10918C_regparm C_word10919C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)10920{10921 C_word ab[2][C_SIZEOF_BIGNUM(2) * 2], *a, newx, newy, size, i = 0;1092210923 if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1092410925 a = ab[i++];10926 x = C_s_a_u_i_integer_abs(&a, 1, x);10927 y = C_s_a_u_i_integer_abs(&a, 1, y);1092810929 if (!C_truep(C_i_integer_greaterp(x, y))) {10930 newx = y; y = x; x = newx; /* Ensure loop invariant: abs(x) >= abs(y) */10931 }1093210933 while(y != C_fix(0)) {10934 assert(integer_length_abs(x) >= integer_length_abs(y));10935 /* x and y are stored in the same buffer, as well as a result */10936 a = ab[i++];10937 if (i == 2) i = 0;1093810939 if (x & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1094010941 /* First, see if we should run a Lehmer step */10942 if ((integer_length_abs(x) - integer_length_abs(y)) < C_HALF_WORD_SIZE) {10943 lehmer_gcd(&a, x, y, &newx, &newy);10944 newx = move_buffer_object(&a, ab[i], newx);10945 newy = move_buffer_object(&a, ab[i], newy);10946 clear_buffer_object(ab[i], x);10947 clear_buffer_object(ab[i], y);10948 x = newx;10949 y = newy;10950 a = ab[i++]; /* Ensure x and y get cleared correctly below */10951 if (i == 2) i = 0;10952 }1095310954 newy = C_s_a_u_i_integer_remainder(&a, 2, x, y);10955 newy = move_buffer_object(&a, ab[i], newy);10956 newx = move_buffer_object(&a, ab[i], y);10957 clear_buffer_object(ab[i], x);10958 clear_buffer_object(ab[i], y);10959 x = newx;10960 y = newy;10961 }1096210963 newx = C_s_a_u_i_integer_abs(ptr, 1, x);10964 newx = move_buffer_object(ptr, ab, newx);10965 clear_buffer_object(ab, x);10966 clear_buffer_object(ab, y);10967 return newx;10968}109691097010971C_regparm C_word10972C_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)10973{10974 if (start == end) {10975 return C_SCHEME_FALSE;10976 } else {10977 size_t nbits;10978 char *s = C_c_string(C_block_item(str, 0));10979 C_word result, size;10980 end = C_unfix(end);10981 start = C_unfix(start);10982 radix = C_unfix(radix);1098310984 assert((radix > 1) && C_fitsinbignumhalfdigitp(radix));1098510986 nbits = (end - start) * C_ilen(radix - 1);10987 size = C_BIGNUM_BITS_TO_DIGITS(nbits);10988 if (size == 1) {10989 result = C_bignum1(ptr, C_truep(negp), 0);10990 } else if (size == 2) {10991 result = C_bignum2(ptr, C_truep(negp), 0, 0);10992 } else {10993 size = C_fix(size);10994 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);10995 }1099610997 return str_to_bignum(result, s + start, s + end, radix);10998 }10999}1100011001inline static int hex_char_to_digit(int ch)11002{11003 if (ch == (int)'#') return 0; /* Hash characters in numbers are mapped to 0 */11004 else if (ch >= (int)'a') return ch - (int)'a' + 10; /* lower hex */11005 else if (ch >= (int)'A') return ch - (int)'A' + 10; /* upper hex */11006 else return ch - (int)'0'; /* decimal (OR INVALID; handled elsewhere) */11007}1100811009/* Write from digit character stream to bignum. Bignum does not need11010 * to be initialised. Returns the bignum, or a fixnum. Assumes the11011 * string contains only digits that fit within radix (checked by11012 * string->number).11013 */11014static C_regparm C_word11015str_to_bignum(C_word bignum, char *str, char *str_end, int radix)11016{11017 int radix_shift, str_digit;11018 C_uword *digits = C_bignum_digits(bignum),11019 *end_digits = digits + C_bignum_size(bignum), big_digit = 0;1102011021 /* Below, we try to save up as much as possible in big_digit, and11022 * only when it exceeds what we would be able to multiply easily, we11023 * scale up the bignum and add what we saved up.11024 */11025 radix_shift = C_ilen(radix) - 1;11026 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11027 int n = 0; /* Number of bits read so far into current big digit */1102811029 /* Read from least to most significant digit to avoid shifting or scaling */11030 while (str_end > str) {11031 str_digit = hex_char_to_digit((int)*--str_end);1103211033 big_digit |= (C_uword)str_digit << n;11034 n += radix_shift;1103511036 if (n >= C_BIGNUM_DIGIT_LENGTH) {11037 n -= C_BIGNUM_DIGIT_LENGTH;11038 *digits++ = big_digit;11039 big_digit = str_digit >> (radix_shift - n);11040 }11041 }11042 assert(n < C_BIGNUM_DIGIT_LENGTH);11043 /* If radix isn't an exact divisor of digit length, write final digit */11044 if (n > 0) *digits++ = big_digit;11045 assert(digits == end_digits);11046 } else { /* Not a power of two */11047 C_uword *last_digit = digits, factor; /* bignum starts as zero */1104811049 do {11050 factor = radix;11051 while (str < str_end && C_fitsinbignumhalfdigitp(factor)) {11052 str_digit = hex_char_to_digit((int)*str++);11053 factor *= radix;11054 big_digit = radix * big_digit + str_digit;11055 }1105611057 big_digit = bignum_digits_destructive_scale_up_with_carry(11058 digits, last_digit, factor / radix, big_digit);1105911060 if (big_digit) {11061 (*last_digit++) = big_digit; /* Move end */11062 big_digit = 0;11063 }11064 } while (str < str_end);1106511066 /* Set remaining digits to zero so bignum_simplify can do its work */11067 assert(last_digit <= end_digits);11068 while (last_digit < end_digits) *last_digit++ = 0;11069 }1107011071 return C_bignum_simplify(bignum);11072}110731107411075static C_regparm double decode_flonum_literal(C_char *str)11076{11077 C_char *eptr;11078 double flo;11079 int len = C_strlen(str);1108011081 /* We only need to be able to parse what C_flonum_to_string() emits,11082 * so we avoid too much error checking.11083 */11084 if (len == 6) { /* Only perform comparisons when necessary */11085 if (!C_strcmp(str, "-inf.0")) return -1.0 / 0.0;11086 if (!C_strcmp(str, "+inf.0")) return 1.0 / 0.0;11087 if (!C_strcmp(str, "+nan.0")) return 0.0 / 0.0;11088 }1108911090 errno = 0;11091 flo = C_strtod(str, &eptr);1109211093 if((flo == HUGE_VAL && errno != 0) ||11094 (flo == -HUGE_VAL && errno != 0) ||11095 (*eptr != '\0' && C_strcmp(eptr, ".0") != 0)) {11096 panic(C_text("could not decode flonum literal"));11097 }1109811099 return flo;11100}111011110211103static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum)11104{11105 static char *digits = "0123456789abcdefghijklmnopqrstuvwxyz";11106 char *p;11107 C_uword shift = C_ilen(base) - 1;11108 int mask = (1 << shift) - 1;11109 if (as_flonum) {11110 buffer[68] = '\0';11111 buffer[67] = '0';11112 buffer[66] = '.';11113 } else {11114 buffer[66] = '\0';11115 }11116 p = buffer + 66;11117 if (mask == base - 1) {11118 do {11119 *(--p) = digits [ num & mask ];11120 num >>= shift;11121 } while (num);11122 } else {11123 do {11124 *(--p) = digits [ num % base ];11125 num /= base;11126 } while (num);11127 }11128 if (negp) *(--p) = '-';11129 return p;11130}111311113211133void C_ccall C_number_to_string(C_word c, C_word *av)11134{11135 C_word radix, num;1113611137 if(c == 3) {11138 radix = C_fix(10);11139 } else if(c == 4) {11140 radix = av[ 3 ];11141 if(!(radix & C_FIXNUM_BIT))11142 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);11143 } else {11144 C_bad_argc(c, 3);11145 }1114611147 num = av[ 2 ];1114811149 if(num & C_FIXNUM_BIT) {11150 C_fixnum_to_string(c, av); /* reuse av */11151 } else if (C_immediatep(num)) {11152 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);11153 } else if(C_block_header(num) == C_FLONUM_TAG) {11154 C_flonum_to_string(c, av); /* reuse av */11155 } else if (C_truep(C_bignump(num))) {11156 C_integer_to_string(c, av); /* reuse av */11157 } else {11158 C_word k = av[ 1 ];11159 try_extended_number("##sys#extended-number->string", 3, k, num, radix);11160 }11161}1116211163void C_ccall C_fixnum_to_string(C_word c, C_word *av)11164{11165 C_char *p;11166 C_word *a,11167 /* self = av[ 0 ] */11168 k = av[ 1 ],11169 num = av[ 2 ],11170 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ])),11171 neg = ((num & C_INT_SIGN_BIT) ? 1 : 0);1117211173 if (radix < 2 || radix > 36) {11174 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11175 }1117611177 num = neg ? -C_unfix(num) : C_unfix(num);11178 p = to_n_nary(num, radix, neg, 0);1117911180 num = C_strlen(p);11181 a = C_alloc(C_SIZEOF_STRING(num));11182 C_kontinue(k, C_string(&a, num, p));11183}1118411185void C_ccall C_flonum_to_string(C_word c, C_word *av)11186{11187 C_char *p;11188 double f, fa, m;11189 C_word *a,11190 /* self = av[ 0 ] */11191 k = av[ 1 ],11192 num = av[ 2 ],11193 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1119411195 f = C_flonum_magnitude(num);11196 fa = fabs(f);1119711198 /* XXX TODO: Should inexacts be printable in other bases than 10?11199 * Perhaps output a string starting with #i?11200 * Right now something like (number->string 1e40 16) results in11201 * a string that can't be read back using string->number.11202 */11203 if((radix < 2) || (radix > 16)){11204 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11205 }1120611207 if(f == 0.0 || (C_modf(f, &m) == 0.0 && log2(fa) < C_WORD_SIZE)) { /* Use fast int code */11208 if(signbit(f)) {11209 p = to_n_nary((C_uword)-f, radix, 1, 1);11210 } else {11211 p = to_n_nary((C_uword)f, radix, 0, 1);11212 }11213 } else if(C_isnan(f)) {11214 p = "+nan.0";11215 } else if(C_isinf(f)) {11216 p = f > 0 ? "+inf.0" : "-inf.0";11217 } else { /* Doesn't fit an unsigned int and not "special"; use system libc */11218 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),11219 /* XXX: flonum_print_precision */11220 (int)C_unfix(C_get_print_precision()), f);11221 buffer[STRING_BUFFER_SIZE-1] = '\0';1122211223 if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {11224 /* Already checked for these, so shouldn't happen */11225 assert(*buffer != 'i'); /* "inf" */11226 assert(*buffer != 'n'); /* "nan" */11227 /* Ensure integral flonums w/o expt are always terminated by .0 */11228#if defined(HAVE_STRLCAT) || !defined(C_strcat)11229 C_strlcat(buffer, C_text(".0"), sizeof(buffer));11230#else11231 C_strcat(buffer, C_text(".0"));11232#endif11233 }11234 p = buffer;11235 }1123611237 radix = C_strlen(p);11238 a = C_alloc(C_SIZEOF_STRING(radix));11239 radix = C_string(&a, radix, p);11240 C_kontinue(k, radix);11241}1124211243void C_ccall C_integer_to_string(C_word c, C_word *av)11244{11245 C_word11246 /* self = av[ 0 ] */11247 k = av[ 1 ],11248 num = av[ 2 ],11249 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1125011251 if (num & C_FIXNUM_BIT) {11252 C_fixnum_to_string(4, av); /* reuse av */11253 } else {11254 int len, radix_shift;11255 size_t nbits;1125611257 if ((radix < 2) || (radix > 36)) {11258 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11259 }1126011261 /* Approximation of the number of radix digits we'll need. We try11262 * to be as precise as possible to avoid memmove overhead at the end11263 * of the non-powers of two part of the conversion procedure, which11264 * we may need to do because we write strings back-to-front, and11265 * pointers must be aligned (even for byte blocks).11266 */11267 len = C_bignum_size(num)-1;1126811269 nbits = (size_t)len * C_BIGNUM_DIGIT_LENGTH;11270 nbits += C_ilen(C_bignum_digits(num)[len]);1127111272 len = C_ilen(radix)-1;11273 len = (nbits + len - 1) / len;11274 len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */1127511276 radix_shift = C_ilen(radix) - 1;11277 if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&11278 /* The power of two fast path is much faster than recursion */11279 ((C_uword)1 << radix_shift) != radix) {11280 try_extended_number("##sys#integer->string/recursive",11281 4, k, num, C_fix(radix), C_fix(len));11282 } else {11283 C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[4];1128411285 kav[ 0 ] = (C_word)NULL; /* No "self" closure */11286 kav[ 1 ] = C_closure(&ka, 4, (C_word)bignum_to_str_2,11287 k, num, C_fix(radix));11288 kav[ 2 ] = C_fix(len + 1);11289 kav[ 3 ] = C_SCHEME_FALSE; /* No initialization */11290 C_allocate_bytevector(4, kav);11291 }11292 }11293}1129411295static void bignum_to_str_2(C_word c, C_word *av)11296{11297 static char *characters = "0123456789abcdefghijklmnopqrstuvwxyz";11298 C_word11299 self = av[ 0 ],11300 string = av[ 1 ],11301 k = C_block_item(self, 1),11302 bignum = C_block_item(self, 2),11303 radix = C_unfix(C_block_item(self, 3));11304 char11305 *buf = C_c_string(string),11306 *index = buf + C_header_size(string) - 2;11307 int radix_shift,11308 negp = (C_bignum_negativep(bignum) ? 1 : 0);11309 C_word us[ 5 ], *a = us;1131011311 *(index + 1) = '\0';11312 radix_shift = C_ilen(radix) - 1;11313 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11314 int radix_mask = radix - 1, big_digit_len = 0, radix_digit;11315 C_uword *scan, *end, big_digit = 0;1131611317 scan = C_bignum_digits(bignum);11318 end = scan + C_bignum_size(bignum);1131911320 while (scan < end) {11321 /* If radix isn't an exact divisor of digit length, handle overlap */11322 if (big_digit_len == 0) {11323 big_digit = *scan++;11324 big_digit_len = C_BIGNUM_DIGIT_LENGTH;11325 } else {11326 assert(index >= buf);11327 radix_digit = big_digit;11328 big_digit = *scan++;11329 radix_digit |= ((unsigned int)big_digit << big_digit_len) & radix_mask;11330 *index-- = characters[radix_digit];11331 big_digit >>= (radix_shift - big_digit_len);11332 big_digit_len = C_BIGNUM_DIGIT_LENGTH - (radix_shift - big_digit_len);11333 }1133411335 while(big_digit_len >= radix_shift && index >= buf) {11336 radix_digit = big_digit & radix_mask;11337 *index-- = characters[radix_digit];11338 big_digit >>= radix_shift;11339 big_digit_len -= radix_shift;11340 }11341 }1134211343 assert(big_digit < radix);1134411345 /* Final digit (like overlap at start of while loop) */11346 if (big_digit) *index-- = characters[big_digit];1134711348 if (negp) {11349 /* Loop above might've overwritten sign position with a zero */11350 if (*(index+1) == '0') *(index+1) = '-';11351 else *index-- = '-';11352 }1135311354 /* Length calculation is always precise for radix powers of two. */11355 assert(index == buf-1);11356 } else {11357 C_uword base, *start, *scan, big_digit;11358 C_word working_copy;11359 int steps, i;1136011361 working_copy = allocate_tmp_bignum(C_fix(C_bignum_size(bignum)),11362 C_mk_bool(negp), C_SCHEME_FALSE);11363 bignum_digits_destructive_copy(working_copy, bignum);1136411365 start = C_bignum_digits(working_copy);1136611367 scan = start + C_bignum_size(bignum);11368 /* Calculate the largest power of radix that fits a halfdigit:11369 * steps = log10(2^halfdigit_bits), base = 10^steps11370 */11371 for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)11372 steps++;1137311374 base /= radix; /* Back down: we overshot in the loop */1137511376 while (scan > start) {11377 big_digit = bignum_digits_destructive_scale_down(start, scan, base);1137811379 if (*(scan-1) == 0) scan--; /* Adjust if we exhausted the highest digit */1138011381 for(i = 0; i < steps && index >= buf; ++i) {11382 C_word tmp = big_digit / radix;11383 *index-- = characters[big_digit - (tmp*radix)]; /* big_digit % radix */11384 big_digit = tmp;11385 }11386 }11387 assert(index >= buf-1);11388 free_tmp_bignum(working_copy);1138911390 /* Move index onto first nonzero digit. We're writing a bignum11391 here: it can't consist of only zeroes. */11392 while(*++index == '0');1139311394 if (negp) *--index = '-';1139511396 /* Shorten with distance between start and index. */11397 if (buf != index) {11398 i = C_header_size(string) - (index - buf);11399 C_memmove(buf, index, i); /* Move start of number to beginning. */11400 buf[ i ] = '\0'; /* terminating 0 */11401 C_block_header(string) = C_BYTEVECTOR_TYPE | i; /* Mutate strlength. */11402 }11403 }1140411405 C_kontinue(k, C_a_ustring(&a, 0, string, C_fix(C_header_size(string) - 1)));11406}114071140811409/* XXX replace with inline routine */11410void C_ccall C_make_structure(C_word c, C_word *av)11411{11412 C_word11413 /* closure = av[ 0 ] */11414 k = av[ 1 ],11415 type = av[ 2 ],11416 size = c - 3,11417 *s, s0;1141811419 if(!C_demand(size + 2))11420 C_save_and_reclaim((void *)C_make_structure, c, av);1142111422 s = C_alloc(C_SIZEOF_STRUCTURE(size + 1)),11423 s0 = (C_word)s;11424 *(s++) = C_STRUCTURE_TYPE | (size + 1);11425 *(s++) = type;11426 av += 3;1142711428 while(size--)11429 *(s++) = *(av++);1143011431 C_kontinue(k, s0);11432}114331143411435/* XXX replace with inline routine */11436void C_ccall C_make_symbol(C_word c, C_word *av)11437{11438 C_word11439 /* closure = av[ 0 ] */11440 k = av[ 1 ],11441 name = av[ 2 ],11442 ab[ C_SIZEOF_SYMBOL ],11443 *a = ab,11444 s0 = (C_word)a;1144511446 *(a++) = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);11447 *(a++) = C_SCHEME_UNBOUND;11448 *(a++) = name;11449 *a = C_SCHEME_END_OF_LIST;11450 C_kontinue(k, s0);11451}114521145311454/* XXX replace with inline routine */11455void C_ccall C_make_pointer(C_word c, C_word *av)11456{11457 C_word11458 /* closure = av[ 0 ] */11459 k = av[ 1 ],11460 ab[ 2 ],11461 *a = ab,11462 p;1146311464 p = C_mpointer(&a, NULL);11465 C_kontinue(k, p);11466}114671146811469/* XXX replace with inline routine */11470void C_ccall C_make_tagged_pointer(C_word c, C_word *av)11471{11472 C_word11473 /* closure = av[ 0 ] */11474 k = av[ 1 ],11475 tag = av[ 2 ],11476 ab[ 3 ],11477 *a = ab,11478 p;1147911480 p = C_taggedmpointer(&a, tag, NULL);11481 C_kontinue(k, p);11482}114831148411485void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)11486{11487 C_word11488 /* closure = av[ 0 ] */11489 k = av[ 1 ],11490 n = av[ 2 ],11491 *p;1149211493 C_save(k);1149411495 if(!C_demand(C_bytestowords(C_unfix(n))))11496 C_reclaim((void *)generic_trampoline, 1);1149711498 p = C_temporary_stack;11499 C_temporary_stack = C_temporary_stack_bottom;11500 generic_trampoline(0, p);11501}115021150311504void C_ccall generic_trampoline(C_word c, C_word *av)11505{11506 C_word k = av[ 0 ];1150711508 C_kontinue(k, C_SCHEME_UNDEFINED);11509}115101151111512void C_ccall C_return_to_host(C_word c, C_word *av)11513{11514 C_word11515 /* closure = av[ 0 ] */11516 k = av[ 1 ];1151711518 return_to_host = 1;11519 C_save(k);11520 C_reclaim((void *)generic_trampoline, 1);11521}115221152311524void C_ccall C_get_symbol_table_info(C_word c, C_word *av)11525{11526 C_word11527 /* closure = av[ 0 ] */11528 k = av[ 1 ];11529 double d1, d2;11530 int n = 0, total;11531 C_SYMBOL_TABLE *stp;11532 C_word11533 x, y,11534 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_VECTOR(4) ],11535 *a = ab;1153611537 for(stp = symbol_table_list; stp != NULL; stp = stp->next)11538 ++n;1153911540 d1 = compute_symbol_table_load(&d2, &total);11541 x = C_flonum(&a, d1); /* load */11542 y = C_flonum(&a, d2); /* avg bucket length */11543 C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));11544}115451154611547void C_ccall C_get_memory_info(C_word c, C_word *av)11548{11549 C_word11550 /* closure = av[ 0 ] */11551 k = av[ 1 ],11552 ab[ C_SIZEOF_VECTOR(2) ],11553 *a = ab;1155411555 C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));11556}115571155811559void C_ccall C_context_switch(C_word c, C_word *av)11560{11561 C_word11562 /* closure = av[ 0 ] */11563 state = av[ 2 ],11564 n = C_header_size(state) - 1,11565 adrs = C_block_item(state, 0),11566 *av2;11567 C_proc tp = (C_proc)C_block_item(adrs,0);1156811569 /* Copy argvector because it may be mutated in-place. The state11570 * vector should not be re-invoked(?), but it can be kept alive11571 * during GC, so the mutated argvector/state slots may turn stale.11572 */11573 av2 = C_alloc(n);11574 C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word));11575 tp(n, av2);11576}115771157811579void C_ccall C_peek_signed_integer(C_word c, C_word *av)11580{11581 C_word11582 /* closure = av[ 0 ] */11583 k = av[ 1 ],11584 v = av[ 2 ],11585 index = av[ 3 ],11586 x = C_block_item(v, C_unfix(index)),11587 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1158811589 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1159011591 C_kontinue(k, C_int_to_num(&a, num));11592}115931159411595void C_ccall C_peek_unsigned_integer(C_word c, C_word *av)11596{11597 C_word11598 /* closure = av[ 0 ] */11599 k = av[ 1 ],11600 v = av[ 2 ],11601 index = av[ 3 ],11602 x = C_block_item(v, C_unfix(index)),11603 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1160411605 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1160611607 C_kontinue(k, C_unsigned_int_to_num(&a, num));11608}1160911610void C_ccall C_peek_int64(C_word c, C_word *av)11611{11612 C_word11613 /* closure = av[ 0 ] */11614 k = av[ 1 ],11615 v = av[ 2 ],11616 index = av[ 3 ],11617 x = C_block_item(v, C_unfix(index)),11618 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1161911620 C_s64 num = ((C_s64 *)C_data_pointer(v))[ C_unfix(index) ];1162111622 C_kontinue(k, C_int64_to_num(&a, num));11623}116241162511626void C_ccall C_peek_uint64(C_word c, C_word *av)11627{11628 C_word11629 /* closure = av[ 0 ] */11630 k = av[ 1 ],11631 v = av[ 2 ],11632 index = av[ 3 ],11633 x = C_block_item(v, C_unfix(index)),11634 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1163511636 C_u64 num = ((C_u64 *)C_data_pointer(v))[ C_unfix(index) ];1163711638 C_kontinue(k, C_uint64_to_num(&a, num));11639}116401164111642void C_ccall C_decode_seconds(C_word c, C_word *av)11643{11644 C_word11645 /* closure = av[ 0 ] */11646 k = av[ 1 ],11647 secs = av[ 2 ],11648 mode = av[ 3 ];11649 time_t tsecs;11650 struct tm *tmt;11651 C_word11652 ab[ C_SIZEOF_VECTOR(10) ],11653 *a = ab,11654 info;1165511656 tsecs = (time_t)C_num_to_int64(secs);1165711658 if(mode == C_SCHEME_FALSE) tmt = C_localtime(&tsecs);11659 else tmt = C_gmtime(&tsecs);1166011661 if(tmt == NULL)11662 C_kontinue(k, C_SCHEME_FALSE);1166311664 info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),11665 C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),11666 C_fix(tmt->tm_wday), C_fix(tmt->tm_yday),11667 tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,11668#ifdef C_GNU_ENV11669 /* negative for west of UTC, but we want positive */11670 C_fix(-tmt->tm_gmtoff)11671#elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)11672 C_fix(mode == C_SCHEME_FALSE ? _timezone : 0) /* does not account for DST */11673#else11674 C_fix(mode == C_SCHEME_FALSE ? timezone : 0) /* does not account for DST */11675#endif11676 );11677 C_kontinue(k, info);11678}116791168011681void C_ccall C_machine_byte_order(C_word c, C_word *av)11682{11683 C_word11684 /* closure = av[ 0 ] */11685 k = av[ 1 ];11686 char *str;11687 C_word *a, s;1168811689 if(c != 2) C_bad_argc(c, 2);1169011691#if defined(C_MACHINE_BYTE_ORDER)11692 str = C_MACHINE_BYTE_ORDER;11693#else11694 C_cblock11695 static C_word one_two_three = 123;11696 str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";11697 C_cblockend;11698#endif1169911700 a = C_alloc(C_SIZEOF_STRING(strlen(str)));11701 s = C_string2(&a, str);1170211703 C_kontinue(k, s);11704}117051170611707void C_ccall C_machine_type(C_word c, C_word *av)11708{11709 C_word11710 /* closure = av[ 0 ] */11711 k = av[ 1 ],11712 *a, s;1171311714 if(c != 2) C_bad_argc(c, 2);1171511716 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_MACHINE_TYPE)));11717 s = C_string2(&a, C_MACHINE_TYPE);1171811719 C_kontinue(k, s);11720}117211172211723void C_ccall C_software_type(C_word c, C_word *av)11724{11725 C_word11726 /* closure = av[ 0 ] */11727 k = av[ 1 ],11728 *a, s;1172911730 if(c != 2) C_bad_argc(c, 2);1173111732 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_TYPE)));11733 s = C_string2(&a, C_SOFTWARE_TYPE);1173411735 C_kontinue(k, s);11736}117371173811739void C_ccall C_build_platform(C_word c, C_word *av)11740{11741 C_word11742 /* closure = av[ 0 ] */11743 k = av[ 1 ],11744 *a, s;1174511746 if(c != 2) C_bad_argc(c, 2);1174711748 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_BUILD_PLATFORM)));11749 s = C_string2(&a, C_BUILD_PLATFORM);1175011751 C_kontinue(k, s);11752}117531175411755void C_ccall C_software_version(C_word c, C_word *av)11756{11757 C_word11758 /* closure = av[ 0 ] */11759 k = av[ 1 ],11760 *a, s;1176111762 if(c != 2) C_bad_argc(c, 2);1176311764 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_VERSION)));11765 s = C_string2(&a, C_SOFTWARE_VERSION);1176611767 C_kontinue(k, s);11768}117691177011771/* Register finalizer: */1177211773void C_ccall C_register_finalizer(C_word c, C_word *av)11774{11775 C_word11776 /* closure = av[ 0 ]) */11777 k = av[ 1 ],11778 x = av[ 2 ],11779 proc = av[ 3 ];1178011781 if(C_immediatep(x) ||11782 (!C_in_stackp(x) && !C_in_heapp(x) && !C_in_scratchspacep(x)))11783 C_kontinue(k, x); /* not GCable */1178411785 C_do_register_finalizer(x, proc);11786 C_kontinue(k, x);11787}117881178911790/*XXX could this be made static? is it used in eggs somewhere?11791 if not, declare as fcall/regparm (and static, remove from chicken.h)11792 */11793void C_ccall C_do_register_finalizer(C_word x, C_word proc)11794{11795 C_word *ptr;11796 int n, i;11797 FINALIZER_NODE *flist;1179811799 if(finalizer_free_list == NULL) {11800 if((flist = (FINALIZER_NODE *)C_malloc(sizeof(FINALIZER_NODE))) == NULL)11801 panic(C_text("out of memory - cannot allocate finalizer node"));1180211803 ++allocated_finalizer_count;11804 }11805 else {11806 flist = finalizer_free_list;11807 finalizer_free_list = flist->next;11808 }1180911810 if(finalizer_list != NULL) finalizer_list->previous = flist;1181111812 flist->previous = NULL;11813 flist->next = finalizer_list;11814 finalizer_list = flist;1181511816 if(C_in_stackp(x)) C_mutate_slot(&flist->item, x);11817 else flist->item = x;1181811819 if(C_in_stackp(proc)) C_mutate_slot(&flist->finalizer, proc);11820 else flist->finalizer = proc;1182111822 ++live_finalizer_count;11823}118241182511826/*XXX same here */11827int C_do_unregister_finalizer(C_word x)11828{11829 int n;11830 FINALIZER_NODE *flist;1183111832 for(flist = finalizer_list; flist != NULL; flist = flist->next) {11833 if(flist->item == x) {11834 if(flist->previous == NULL) finalizer_list = flist->next;11835 else flist->previous->next = flist->next;11836 if(flist->next != NULL) flist->next->previous = flist->previous;1183711838 flist->next = finalizer_free_list;11839 flist->previous = NULL;11840 finalizer_free_list = flist;11841 --live_finalizer_count;11842 return 1;11843 }11844 }1184511846 return 0;11847}118481184911850/* Dynamic loading of shared objects: */1185111852void C_ccall C_set_dlopen_flags(C_word c, C_word *av)11853{11854 C_word11855 /* closure = av[ 0 ] */11856 k = av[ 1 ],11857 now = av[ 2 ],11858 global = av[ 3 ];1185911860#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)11861 dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);11862#endif11863 C_kontinue(k, C_SCHEME_UNDEFINED);11864}118651186611867void C_ccall C_dload(C_word c, C_word *av)11868{11869 C_word11870 /* closure = av[ 0 ] */11871 k = av[ 1 ],11872 name = av[ 2 ],11873 entry = av[ 3 ];1187411875#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))11876 /* Force minor GC: otherwise the lf may contain pointers to stack-data11877 (stack allocated interned symbols, for example) */11878 C_save_and_reclaim_args((void *)dload_2, 3, k, name, entry);11879#endif1188011881 C_kontinue(k, C_SCHEME_FALSE);11882}118831188411885#ifdef DLOAD_2_DEFINED11886# undef DLOAD_2_DEFINED11887#endif1188811889#if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)11890# ifdef __hpux__11891# define DLOAD_2_DEFINED11892void C_ccall dload_2(C_word c, C_word *av0)11893{11894 void *handle, *p;11895 C_word11896 entry = av0[ 0 ],11897 name = av0[ 1 ],11898 k = av0[ 2 ],,11899 av[ 2 ];11900 C_char *mname = C_c_string(name);1190111902 /*11903 * C_fprintf(C_stderr,11904 * "shl_loading %s : %s\n",11905 * (char *) C_c_string(name),11906 * (char *) C_c_string(entry));11907 */1190811909 if ((handle = (void *) shl_load(mname,11910 BIND_IMMEDIATE | DYNAMIC_PATH,11911 0L)) != NULL) {11912 shl_t shl_handle = (shl_t) handle;1191311914 /*** This version does not check for C_dynamic_and_unsafe. Fix it. */11915 if (shl_findsym(&shl_handle, (char *) C_c_string(entry), TYPE_PROCEDURE, &p) == 0) {11916 current_module_name = C_strdup(mname);11917 current_module_handle = handle;1191811919 if(debug_mode) {11920 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11921 current_module_name, (C_uword)current_module_handle);11922 }1192311924 av[ 0 ] = C_SCHEME_UNDEFINED;11925 av[ 1 ] = k;11926 ((C_proc)p)(2, av); /* doesn't return */11927 } else {11928 C_dlerror = (char *) C_strerror(errno);11929 shl_unload(shl_handle);11930 }11931 } else {11932 C_dlerror = (char *) C_strerror(errno);11933 }1193411935 C_kontinue(k, C_SCHEME_FALSE);11936}11937# endif11938#endif119391194011941#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)11942# ifndef __hpux__11943# define DLOAD_2_DEFINED11944void C_ccall dload_2(C_word c, C_word *av0)11945{11946 void *handle, *p, *p2;11947 C_word11948 entry = av0[ 0 ],11949 name = av0[ 1 ],11950 k = av0[ 2 ],11951 av[ 2 ];11952 C_char *topname = (C_char *)C_c_string(entry);11953 C_char *mname = (C_char *)C_c_string(name);11954 C_char *tmp;11955 int tmp_len = 0;1195611957 if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {11958 if((p = C_dlsym(handle, topname)) == NULL) {11959 tmp_len = C_strlen(topname) + 2;11960 tmp = (C_char *)C_malloc(tmp_len);1196111962 if(tmp == NULL)11963 panic(C_text("out of memory - cannot allocate toplevel name string"));1196411965 C_strlcpy(tmp, C_text("_"), tmp_len);11966 C_strlcat(tmp, topname, tmp_len);11967 p = C_dlsym(handle, tmp);11968 C_free(tmp);11969 }1197011971 if(p != NULL) {11972 current_module_name = C_strdup(mname);11973 current_module_handle = handle;1197411975 if(debug_mode) {11976 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11977 current_module_name, (C_uword)current_module_handle);11978 }1197911980 av[ 0 ] = C_SCHEME_UNDEFINED;11981 av[ 1 ] = k;11982 ((C_proc)p)(2, av); /* doesn't return */11983 }1198411985 C_dlclose(handle);11986 }1198711988 C_dlerror = (char *)dlerror();11989 C_kontinue(k, C_SCHEME_FALSE);11990}11991# endif11992#endif119931199411995#if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)11996# define DLOAD_2_DEFINED11997void C_ccall dload_2(C_word c, C_word *av0)11998{11999 HINSTANCE handle;12000 FARPROC p = NULL, p2;12001 C_word12002 entry = av0[ 0 ],12003 name = av0[ 1 ],12004 k = av0[ 2 ],12005 av[ 2 ];12006 C_char *topname = (C_char *)C_c_string(entry);12007 C_char *mname = (C_char *)C_c_string(name);1200812009 /* cannot use LoadLibrary on non-DLLs, so we use extension checking */12010 if (C_strlen(mname) >= 5) {12011 C_char *n = mname;12012 int l = C_strlen(mname);12013 if (C_strncmp(".dll", n+l-4, 4) &&12014 C_strncmp(".DLL", n+l-4, 4) &&12015 C_strncmp(".so", n+l-3, 3) &&12016 C_strncmp(".SO", n+l-3, 3))12017 C_kontinue(k, C_SCHEME_FALSE);12018 }1201912020 if((handle = LoadLibrary(mname)) != NULL) {12021 if ((p = GetProcAddress(handle, topname)) != NULL) {12022 current_module_name = C_strdup(mname);12023 current_module_handle = handle;1202412025 if(debug_mode) {12026 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),12027 current_module_name, (C_uword)current_module_handle);12028 }1202912030 av[ 0 ] = C_SCHEME_UNDEFINED;12031 av[ 1 ] = k;12032 ((C_proc)p)(2, av); /* doesn't return */12033 }12034 else FreeLibrary(handle);12035 }1203612037 C_dlerror = (char *) C_strerror(errno);12038 C_kontinue(k, C_SCHEME_FALSE);12039}12040#endif120411204212043void C_ccall C_become(C_word c, C_word *av)12044{12045 C_word12046 /* closure = av[ 0 ] */12047 k = av[ 1 ],12048 table = av[ 2 ],12049 tp, x, old, neu, i, *p;1205012051 i = forwarding_table_size;12052 p = forwarding_table;1205312054 for(tp = table; tp != C_SCHEME_END_OF_LIST; tp = C_u_i_cdr(tp)) {12055 x = C_u_i_car(tp);12056 old = C_u_i_car(x);12057 neu = C_u_i_cdr(x);1205812059 if(i == 0) {12060 if((forwarding_table = (C_word *)realloc(forwarding_table, (forwarding_table_size + 1) * 4 * sizeof(C_word))) == NULL)12061 panic(C_text("out of memory - cannot re-allocate forwarding table"));1206212063 i = forwarding_table_size;12064 p = forwarding_table + forwarding_table_size * 2;12065 forwarding_table_size *= 2;12066 }1206712068 *(p++) = old;12069 *(p++) = neu;12070 --i;12071 }1207212073 *p = 0;12074 C_fromspace_top = C_fromspace_limit;12075 C_save_and_reclaim_args((void *)become_2, 1, k);12076}120771207812079void C_ccall become_2(C_word c, C_word *av)12080{12081 C_word k = av[ 0 ];1208212083 *forwarding_table = 0;12084 C_kontinue(k, C_SCHEME_UNDEFINED);12085}120861208712088C_regparm C_word12089C_a_i_cpu_time(C_word **a, int c, C_word buf)12090{12091 C_word u, s = C_fix(0);1209212093#if defined(C_NONUNIX) || defined(__CYGWIN__)12094 if(CLOCKS_PER_SEC == 1000) u = clock();12095 else u = C_uint64_to_num(a, ((C_u64)clock() / CLOCKS_PER_SEC) * 1000);12096#else12097 struct rusage ru;1209812099 if(C_getrusage(RUSAGE_SELF, &ru) == -1) u = 0;12100 else {12101 u = C_uint64_to_num(a, (C_u64)ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000);12102 s = C_uint64_to_num(a, (C_u64)ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000);12103 }12104#endif1210512106 /* buf must not be in nursery */12107 C_set_block_item(buf, 0, u);12108 C_set_block_item(buf, 1, s);12109 return buf;12110}121111211212113C_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)12114{12115 C_word *loc = *a;12116 int offset, i, in = C_unfix(index);12117 *a = loc + C_SIZEOF_LOCATIVE;1211812119 loc[ 0 ] = C_LOCATIVE_TAG;1212012121 switch(C_unfix(type)) {12122 case C_SLOT_LOCATIVE: in *= sizeof(C_word); break;12123 case C_U16_LOCATIVE:12124 case C_S16_LOCATIVE: in *= 2; break;12125 case C_U32_LOCATIVE:12126 case C_F32_LOCATIVE:12127 case C_S32_LOCATIVE: in *= 4; break;12128 case C_U64_LOCATIVE:12129 case C_S64_LOCATIVE:12130 case C_F64_LOCATIVE: in *= 8; break;12131 }1213212133 offset = in + sizeof(C_header);12134 loc[ 1 ] = object + offset;12135 loc[ 2 ] = C_fix(offset);12136 loc[ 3 ] = type;12137 loc[ 4 ] = C_truep(weak) ? C_SCHEME_FALSE : object;1213812139 return (C_word)loc;12140}1214112142C_regparm C_word C_a_i_locative_ref(C_word **a, int c, C_word loc)12143{12144 C_word *ptr;1214512146 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12147 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);1214812149 ptr = (C_word *)C_block_item(loc, 0);1215012151 if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);1215212153 switch(C_unfix(C_block_item(loc, 2))) {12154 case C_SLOT_LOCATIVE: return *ptr;12155 case C_CHAR_LOCATIVE: return C_utf_decode_ptr((C_char *)ptr);12156 case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));12157 case C_S8_LOCATIVE: return C_fix(*((char *)ptr));12158 case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));12159 case C_S16_LOCATIVE: return C_fix(*((short *)ptr));12160 case C_U32_LOCATIVE: return C_unsigned_int_to_num(a, *((C_u32 *)ptr));12161 case C_S32_LOCATIVE: return C_int_to_num(a, *((C_s32 *)ptr));12162 case C_U64_LOCATIVE: return C_uint64_to_num(a, *((C_u64 *)ptr));12163 case C_S64_LOCATIVE: return C_int64_to_num(a, *((C_s64 *)ptr));12164 case C_F32_LOCATIVE: return C_flonum(a, *((float *)ptr));12165 case C_F64_LOCATIVE: return C_flonum(a, *((double *)ptr));12166 default: panic(C_text("bad locative type"));12167 }12168}1216912170C_regparm C_word C_i_locative_set(C_word loc, C_word x)12171{12172 C_word *ptr, val;1217312174 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12175 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);1217612177 ptr = (C_word *)C_block_item(loc, 0);1217812179 if(ptr == NULL)12180 barf(C_LOST_LOCATIVE_ERROR, "locative-set!", loc);1218112182 switch(C_unfix(C_block_item(loc, 2))) {12183 case C_SLOT_LOCATIVE: C_mutate(ptr, x); break;1218412185 case C_CHAR_LOCATIVE:12186 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)12187 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1218812189 /* does not check for exceeded buffer length! */12190 C_utf_encode((C_char *)ptr, C_character_code(x));12191 break;1219212193 case C_U8_LOCATIVE:12194 if((x & C_FIXNUM_BIT) == 0)12195 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1219612197 *((unsigned char *)ptr) = C_unfix(x);12198 break;1219912200 case C_S8_LOCATIVE:12201 if((x & C_FIXNUM_BIT) == 0)12202 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1220312204 *((char *)ptr) = C_unfix(x);12205 break;1220612207 case C_U16_LOCATIVE:12208 if((x & C_FIXNUM_BIT) == 0)12209 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1221012211 *((unsigned short *)ptr) = C_unfix(x);12212 break;1221312214 case C_S16_LOCATIVE:12215 if((x & C_FIXNUM_BIT) == 0)12216 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1221712218 *((short *)ptr) = C_unfix(x);12219 break;1222012221 case C_U32_LOCATIVE:12222 if(!C_truep(C_i_exact_integerp(x)))12223 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1222412225 *((C_u32 *)ptr) = C_num_to_unsigned_int(x);12226 break;1222712228 case C_S32_LOCATIVE:12229 if(!C_truep(C_i_exact_integerp(x)))12230 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1223112232 *((C_s32 *)ptr) = C_num_to_int(x);12233 break;1223412235 case C_U64_LOCATIVE:12236 if(!C_truep(C_i_exact_integerp(x)))12237 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1223812239 *((C_u64 *)ptr) = C_num_to_uint64(x);12240 break;1224112242 case C_S64_LOCATIVE:12243 if(!C_truep(C_i_exact_integerp(x)))12244 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1224512246 *((C_s64 *)ptr) = C_num_to_int64(x);12247 break;1224812249 case C_F32_LOCATIVE:12250 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12251 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1225212253 *((float *)ptr) = C_flonum_magnitude(x);12254 break;1225512256 case C_F64_LOCATIVE:12257 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12258 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1225912260 *((double *)ptr) = C_flonum_magnitude(x);12261 break;1226212263 default: panic(C_text("bad locative type"));12264 }1226512266 return C_SCHEME_UNDEFINED;12267}122681226912270C_regparm C_word C_i_locative_to_object(C_word loc)12271{12272 C_word *ptr;1227312274 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12275 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative->object", loc);1227612277 ptr = (C_word *)C_block_item(loc, 0);1227812279 if(ptr == NULL) return C_SCHEME_FALSE;12280 else return (C_word)ptr - C_unfix(C_block_item(loc, 1));12281}122821228312284C_regparm C_word C_i_locative_index(C_word loc)12285{12286 int bytes;1228712288 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12289 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-index", loc);1229012291 bytes = C_unfix(C_block_item(loc, 1)) - sizeof(C_header);1229212293 switch(C_unfix(C_block_item(loc, 2))) {12294 case C_SLOT_LOCATIVE: return C_fix(bytes/sizeof(C_word)); break;1229512296 case C_CHAR_LOCATIVE:12297 { C_word x = C_i_locative_to_object(loc);12298 if(x == C_SCHEME_FALSE)12299 barf(C_LOST_LOCATIVE_ERROR, "locative-index", loc);12300 return C_fix(C_utf_char_position(x, bytes)); }1230112302 case C_U8_LOCATIVE:12303 case C_S8_LOCATIVE: return C_fix(bytes); break;1230412305 case C_U16_LOCATIVE:12306 case C_S16_LOCATIVE: return C_fix(bytes/2); break;1230712308 case C_U32_LOCATIVE:12309 case C_S32_LOCATIVE:12310 case C_F32_LOCATIVE: return C_fix(bytes/4); break;1231112312 case C_U64_LOCATIVE:12313 case C_S64_LOCATIVE:12314 case C_F64_LOCATIVE: return C_fix(bytes/8); break;1231512316 default: panic(C_text("bad locative type"));12317 }12318}123191232012321/* GC protection of user-variables: */1232212323C_regparm void C_gc_protect(C_word **addr, int n)12324{12325 int k;1232612327 if(collectibles_top + n >= collectibles_limit) {12328 k = collectibles_limit - collectibles;12329 collectibles = (C_word **)C_realloc(collectibles, sizeof(C_word *) * k * 2);1233012331 if(collectibles == NULL)12332 panic(C_text("out of memory - cannot allocate GC protection vector"));1233312334 collectibles_top = collectibles + k;12335 collectibles_limit = collectibles + k * 2;12336 }1233712338 C_memcpy(collectibles_top, addr, n * sizeof(C_word *));12339 collectibles_top += n;12340}123411234212343C_regparm void C_gc_unprotect(int n)12344{12345 collectibles_top -= n;12346}123471234812349/* Map procedure-ptr to id or id to ptr: */1235012351C_char *C_lookup_procedure_id(void *ptr)12352{12353 LF_LIST *lfl;12354 C_PTABLE_ENTRY *pt;1235512356 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12357 pt = lfl->ptable;1235812359 if(pt != NULL) {12360 while(pt->id != NULL) {12361 if(pt->ptr == ptr) return pt->id;12362 else ++pt;12363 }12364 }12365 }1236612367 return NULL;12368}123691237012371void *C_lookup_procedure_ptr(C_char *id)12372{12373 LF_LIST *lfl;12374 C_PTABLE_ENTRY *pt;1237512376 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12377 pt = lfl->ptable;1237812379 if(pt != NULL) {12380 while(pt->id != NULL) {12381 if(!C_strcmp(id, pt->id)) return pt->ptr;12382 else ++pt;12383 }12384 }12385 }1238612387 return NULL;12388}123891239012391void C_ccall C_copy_closure(C_word c, C_word *av)12392{12393 C_word12394 /* closure = av[ 0 ] */12395 k = av[ 1 ],12396 proc = av[ 2 ],12397 *p;12398 int n = C_header_size(proc);1239912400 if(!C_demand(n + 1))12401 C_save_and_reclaim_args((void *)copy_closure_2, 2, proc, k);12402 else {12403 C_save(proc);12404 C_save(k);12405 p = C_temporary_stack;12406 C_temporary_stack = C_temporary_stack_bottom;12407 copy_closure_2(0, p);12408 }12409}124101241112412static void C_ccall copy_closure_2(C_word c, C_word *av)12413{12414 C_word12415 k = av[ 0 ],12416 proc = av[ 1 ];12417 int cells = C_header_size(proc);12418 C_word12419 *ptr = C_alloc(C_SIZEOF_CLOSURE(cells)),12420 *p = ptr;1242112422 *(p++) = C_CLOSURE_TYPE | cells;12423 /* this is only allowed because the storage is freshly allocated: */12424 C_memcpy_slots(p, C_data_pointer(proc), cells);12425 C_kontinue(k, (C_word)ptr);12426}124271242812429/* Ph'nglui mglw'nafh Cthulhu R'lyeh wgah'nagl fhtagn */1243012431void C_ccall C_call_with_cthulhu(C_word c, C_word *av)12432{12433 C_word12434 proc = av[ 2 ],12435 *a = C_alloc(C_SIZEOF_CLOSURE(1)),12436 av2[ 2 ];1243712438 av2[ 0 ] = proc;12439 av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */12440 C_do_apply(2, av2);12441}124421244312444/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)12445 These routines return #f if the operation failed due to overflow.12446 */1244712448C_regparm C_word C_i_o_fixnum_plus(C_word n1, C_word n2)12449{12450 C_word x1, x2, s;1245112452 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1245312454 x1 = C_unfix(n1);12455 x2 = C_unfix(n2);12456 s = x1 + x2;1245712458#ifdef C_SIXTY_FOUR12459 if((((s ^ x1) & (s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12460#else12461 if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12462#endif12463 else return C_fix(s);12464}124651246612467C_regparm C_word C_i_o_fixnum_difference(C_word n1, C_word n2)12468{12469 C_word x1, x2, s;1247012471 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1247212473 x1 = C_unfix(n1);12474 x2 = C_unfix(n2);12475 s = x1 - x2;1247612477#ifdef C_SIXTY_FOUR12478 if((((s ^ x1) & ~(s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12479#else12480 if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12481#endif12482 else return C_fix(s);12483}124841248512486C_regparm C_word C_i_o_fixnum_times(C_word n1, C_word n2)12487{12488 C_word x1, x2;12489 C_uword x1u, x2u;12490#ifdef C_SIXTY_FOUR12491# ifdef C_LLP12492 C_uword c = 1ULL<<63ULL;12493# else12494 C_uword c = 1UL<<63UL;12495# endif12496#else12497 C_uword c = 1UL<<31UL;12498#endif1249912500 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1250112502 if((n1 & C_INT_SIGN_BIT) == (n2 & C_INT_SIGN_BIT)) --c;1250312504 x1 = C_unfix(n1);12505 x2 = C_unfix(n2);12506 x1u = x1 < 0 ? -x1 : x1;12507 x2u = x2 < 0 ? -x2 : x2;1250812509 if(x2u != 0 && x1u > (c / x2u)) return C_SCHEME_FALSE;1251012511 x1 = x1 * x2;1251212513 if(C_fitsinfixnump(x1)) return C_fix(x1);12514 else return C_SCHEME_FALSE;12515}125161251712518C_regparm C_word C_i_o_fixnum_quotient(C_word n1, C_word n2)12519{12520 C_word x1, x2;1252112522 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1252312524 x1 = C_unfix(n1);12525 x2 = C_unfix(n2);1252612527 if(x2 == 0)12528 barf(C_DIVISION_BY_ZERO_ERROR, "fx/?");1252912530#ifdef C_SIXTY_FOUR12531 if(x1 == 0x8000000000000000L && x2 == -1) return C_SCHEME_FALSE;12532#else12533 if(x1 == 0x80000000L && x2 == -1) return C_SCHEME_FALSE;12534#endif1253512536 x1 = x1 / x2;1253712538 if(C_fitsinfixnump(x1)) return C_fix(x1);12539 else return C_SCHEME_FALSE;12540}125411254212543C_regparm C_word C_i_o_fixnum_and(C_word n1, C_word n2)12544{12545 C_uword x1, x2, r;1254612547 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1254812549 x1 = C_unfix(n1);12550 x2 = C_unfix(n2);12551 r = x1 & x2;1255212553 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12554 else return C_fix(r);12555}125561255712558C_regparm C_word C_i_o_fixnum_ior(C_word n1, C_word n2)12559{12560 C_uword x1, x2, r;1256112562 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1256312564 x1 = C_unfix(n1);12565 x2 = C_unfix(n2);12566 r = x1 | x2;1256712568 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12569 else return C_fix(r);12570}125711257212573C_regparm C_word C_i_o_fixnum_xor(C_word n1, C_word n2)12574{12575 C_uword x1, x2, r;1257612577 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1257812579 x1 = C_unfix(n1);12580 x2 = C_unfix(n2);12581 r = x1 ^ x2;1258212583 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12584 else return C_fix(r);12585}125861258712588/* decoding of literals in compressed format */1258912590static C_regparm C_uword decode_size(C_char **str)12591{12592 C_uchar **ustr = (C_uchar **)str;12593 C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */1259412595 size |= (*((*ustr)++) & 0xff) << 8;12596 size |= (*((*ustr)++) & 0xff);12597 return size;12598}125991260012601static C_regparm C_word decode_literal2(C_word **ptr, C_char **str,12602 C_word *dest)12603{12604 C_ulong bits = *((*str)++) & 0xff;12605 C_word *data, *dptr, val;12606 C_uword size;1260712608 /* vvv this can be taken out at a later stage (once it works reliably) vvv */12609 if(bits != 0xfe)12610 panic(C_text("invalid encoded literal format"));1261112612 bits = *((*str)++) & 0xff;12613 /* ^^^ */1261412615#ifdef C_SIXTY_FOUR12616 bits <<= 24 + 32;12617#else12618 bits <<= 24;12619#endif1262012621 if(bits == C_HEADER_BITS_MASK) { /* special/immediate */12622 switch(0xff & *((*str)++)) {12623 case C_BOOLEAN_BITS:12624 return C_mk_bool(*((*str)++));1262512626 case C_CHARACTER_BITS:12627 return C_make_character(decode_size(str));1262812629 case C_SCHEME_END_OF_LIST:12630 case C_SCHEME_UNDEFINED:12631 case C_SCHEME_END_OF_FILE:12632 case C_SCHEME_BROKEN_WEAK_PTR:12633 return (C_word)(*(*str - 1));1263412635 case C_FIXNUM_BIT:12636 val = (C_uword)(signed char)*((*str)++) << 24; /* always big endian */12637 val |= ((C_uword)*((*str)++) & 0xff) << 16;12638 val |= ((C_uword)*((*str)++) & 0xff) << 8;12639 val |= ((C_uword)*((*str)++) & 0xff);12640 return C_fix(val);1264112642/* XXX Handle legacy bignum encoding */12643#ifdef C_SIXTY_FOUR12644 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12645#else12646 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12647#endif12648 bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);12649 break;12650/* XXX */1265112652#ifdef C_SIXTY_FOUR12653 case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12654#else12655 case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12656#endif12657 bits = (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT);12658 break;1265912660 default:12661 panic(C_text("invalid encoded special literal"));12662 }12663 }1266412665#ifndef C_SIXTY_FOUR12666 if((bits & C_8ALIGN_BIT) != 0) {12667 /* Align _data_ on 8-byte boundary: */12668 if(C_aligned8(*ptr)) ++(*ptr);12669 }12670#endif1267112672 val = (C_word)(*ptr);1267312674 if((bits & C_SPECIALBLOCK_BIT) != 0)12675 panic(C_text("literals with special bit cannot be decoded"));1267612677 if(bits == C_FLONUM_TYPE) {12678 val = C_flonum(ptr, decode_flonum_literal(*str));12679 while(*((*str)++) != '\0'); /* skip terminating '\0' */12680 return val;12681 }1268212683 size = decode_size(str);1268412685 switch(bits) {12686 /* This cannot be encoded as a bytevector due to endianness differences */1268712688 /* XXX legacy bignum encoding: */12689 case (C_STRING_TYPE | C_BYTEBLOCK_BIT | C_GC_FORWARDING_BIT): /* This represents "exact int" */12690 /* XXX */12691 case (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */12692 /* bignums are also allocated statically */12693 val = C_static_bignum(ptr, size, *str);12694 *str += size;12695 break;1269612697 /* XXX legacy encoding: */12698 case (C_STRING_TYPE | C_BYTEBLOCK_BIT):12699 /* strings are always allocated statically */12700 val = C_static_string(ptr, size, *str);12701 *str += size;12702 break;12703 /* XXX */1270412705 case C_STRING_TYPE:12706 /* strings are always allocated statically */12707 val = C_static_string(ptr, size - 1, *str);12708 *str += size;12709 break;1271012711 case C_BYTEVECTOR_TYPE:12712 /* ... as are bytevectors */12713 val = C_static_bytevector(ptr, size, *str);12714 *str += size;12715 break;1271612717 case C_SYMBOL_TYPE:12718 if(dest == NULL)12719 panic(C_text("invalid literal symbol destination"));1272012721 if (**str == '\1') {12722 val = C_h_intern(dest, size, ++*str);12723 } else if (**str == '\2') {12724 val = C_h_intern_kw(dest, size, ++*str);12725 } else {12726 C_snprintf(buffer, sizeof(buffer), C_text("Unknown symbol subtype: %d"), (int)**str);12727 panic(buffer);12728 }12729 *str += size;12730 break;1273112732 case C_LAMBDA_INFO_TYPE:12733 /* lambda infos are always allocated statically */12734 val = C_static_lambda_info(ptr, size, *str);12735 *str += size;12736 break;1273712738 default:12739 *((*ptr)++) = C_make_header(bits, size);12740 data = *ptr;1274112742 if((bits & C_BYTEBLOCK_BIT) != 0) {12743 C_memcpy(data, *str, size);12744 size = C_align(size);12745 *str += size;12746 *ptr = (C_word *)C_align((C_word)(*ptr) + size);12747 }12748 else {12749 C_word *dptr = *ptr;12750 *ptr += size;1275112752 while(size--) {12753 *dptr = decode_literal2(ptr, str, dptr);12754 ++dptr;12755 }12756 }12757 }1275812759 return val;12760}127611276212763C_regparm C_word12764C_decode_literal(C_word **ptr, C_char *str)12765{12766 return decode_literal2(ptr, &str, NULL);12767}127681276912770void12771C_use_private_repository(C_char *path)12772{12773 private_repository = path;12774}127751277612777C_char *12778C_private_repository_path()12779{12780 return private_repository;12781}1278212783C_char *12784C_executable_pathname() {12785#ifdef SEARCH_EXE_PATH12786 return C_main_exe == NULL ? NULL : C_strdup(C_main_exe);12787#else12788 return C_resolve_executable_pathname(NULL);12789#endif12790}1279112792C_char *12793C_executable_dirname() {12794 int len;12795 C_char *path;1279612797 if((path = C_executable_pathname()) == NULL)12798 return NULL;1279912800 for(len = C_strlen(path); len >= 0 && path[len] != '/' && path[len] != '\\'; len--);1280112802 path[len] = '\0';12803 return path;12804}1280512806C_char *12807C_resolve_executable_pathname(C_char *fname)12808{12809 int n;12810 C_WCHAR *buffer = (C_WCHAR *) C_malloc(C_MAX_PATH * sizeof(C_WCHAR));1281112812 if(buffer == NULL) return NULL;1281312814#if defined(__linux__) || defined(__sun)12815 C_char linkname[64]; /* /proc/<pid>/exe */12816 pid_t pid = C_getpid();1281712818# ifdef __linux__12819 C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);12820# else12821 C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */12822# endif1282312824 n = C_readlink(linkname, buffer, C_MAX_PATH);12825 if(n < 0 || n >= C_MAX_PATH)12826 goto error;1282712828 buffer[n] = '\0';12829 return buffer;12830#elif defined(_WIN32) && !defined(__CYGWIN__)12831 n = GetModuleFileNameW(NULL, buffer, C_MAX_PATH);12832 if(n == 0 || n >= C_MAX_PATH)12833 goto error;1283412835 C_char *buf2 = C_strdup(C_utf8(buffer));12836 C_free(buffer);12837 C_char *p = buf2;12838 while(*p) {12839 *p = *p == '\\' ? '/' : *p;12840 ++p;12841 }12842 return buf2;12843#elif defined(C_MACOSX)12844 C_char buf[C_MAX_PATH];12845 C_u32 size = C_MAX_PATH;1284612847 if(_NSGetExecutablePath(buf, &size) != 0)12848 goto error;1284912850 if(C_realpath(buf, buffer) == NULL)12851 goto error;1285212853 return buffer;12854#elif defined(__HAIKU__)12855{12856 image_info info;12857 int32 cookie = 0;1285812859 while (get_next_image_info(0, &cookie, &info) == B_OK) {12860 if (info.type == B_APP_IMAGE) {12861 C_strlcpy(buffer, info.name, C_MAX_PATH);12862 return buffer;12863 }12864 }12865}12866#elif defined(SEARCH_EXE_PATH)12867 int len;12868 C_char *path, buf[C_MAX_PATH];1286912870 /* no name given (execve) */12871 if(fname == NULL)12872 goto error;1287312874 /* absolute pathname */12875 if(fname[0] == '/') {12876 if(C_realpath(fname, buffer) == NULL)12877 goto error;12878 else12879 return buffer;12880 }1288112882 /* current directory */12883 if(C_strchr(fname, '/') != NULL) {12884 if(C_getcwd(buffer, C_MAX_PATH) == NULL)12885 goto error;1288612887 n = C_snprintf(buf, C_MAX_PATH, "%s/%s", buffer, fname);12888 if(n < 0 || n >= C_MAX_PATH)12889 goto error;1289012891 if(C_access(buf, X_OK) == 0) {12892 if(C_realpath(buf, buffer) == NULL)12893 goto error;12894 else12895 return buffer;12896 }12897 }1289812899 /* walk PATH */12900 if((path = getenv("PATH")) == NULL)12901 goto error;1290212903 do {12904 /* check PATH entry length */12905 len = C_strcspn(path, ":");12906 if(len == 0 || len >= C_MAX_PATH)12907 continue;1290812909 /* "<path>/<fname>" to buf */12910 C_strncpy(buf, path, len);12911 n = C_snprintf(buf + len, C_MAX_PATH - len, "/%s", fname);12912 if(n < 0 || n + len >= C_MAX_PATH)12913 continue;1291412915 if(C_access(buf, X_OK) != 0)12916 continue;1291712918 /* fname found, resolve links */12919 if(C_realpath(buf, buffer) != NULL)12920 return buffer;1292112922 /* seek next entry, skip colon */12923 } while (path += len, *path++);12924#else12925# error "Please either define SEARCH_EXE_PATH in Makefile.<platform> or implement C_resolve_executable_pathname for your platform!"12926#endif1292712928error:12929 C_free(buffer);12930 return NULL;12931}1293212933C_regparm C_word12934C_i_getprop(C_word sym, C_word prop, C_word def)12935{12936 C_word pl = C_symbol_plist(sym);1293712938 while(pl != C_SCHEME_END_OF_LIST) {12939 if(C_block_item(pl, 0) == prop)12940 return C_u_i_car(C_u_i_cdr(pl));12941 else pl = C_u_i_cdr(C_u_i_cdr(pl));12942 }1294312944 return def;12945}129461294712948C_regparm C_word12949C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)12950{12951 C_word pl = C_symbol_plist(sym);1295212953 /* Newly added plist? Ensure the symbol stays! */12954 if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym);1295512956 while(pl != C_SCHEME_END_OF_LIST) {12957 if(C_block_item(pl, 0) == prop) {12958 C_mutate(&C_u_i_car(C_u_i_cdr(pl)), val);12959 return val;12960 }12961 else pl = C_u_i_cdr(C_u_i_cdr(pl));12962 }1296312964 pl = C_a_pair(ptr, val, C_symbol_plist(sym));12965 pl = C_a_pair(ptr, prop, pl);12966 C_mutate_slot(&C_symbol_plist(sym), pl);12967 return val;12968}129691297012971C_regparm C_word12972C_i_get_keyword(C_word kw, C_word args, C_word def)12973{12974 while(!C_immediatep(args)) {12975 if(C_header_type(args) == C_PAIR_TYPE) {12976 if(kw == C_u_i_car(args)) {12977 args = C_u_i_cdr(args);1297812979 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)12980 return def;12981 else return C_u_i_car(args);12982 }12983 else {12984 args = C_u_i_cdr(args);1298512986 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)12987 return def;12988 else args = C_u_i_cdr(args);12989 }12990 }12991 }1299212993 return def;12994}1299512996C_word C_i_dump_statistical_profile()12997{12998 PROFILE_BUCKET *b, *b2, **bp;12999 FILE *fp;13000 C_char *k1, *k2 = NULL;13001 int n;13002 double ms;1300313004 assert(profiling);13005 assert(profile_table != NULL);1300613007 set_profile_timer(0);1300813009 profiling = 0; /* In case a SIGPROF is delivered late */13010 bp = profile_table;1301113012 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("PROFILE.%d"), C_getpid());1301313014 if(debug_mode)13015 C_dbg(C_text("debug"), C_text("dumping statistical profile to `%s'...\n"), buffer);13016 fp = fopen(buffer, "w");13017 if (fp == NULL)13018 panic(C_text("could not write profile!"));1301913020 C_fputs(C_text("statistical\n"), fp);13021 for(n = 0; n < PROFILE_TABLE_SIZE; ++n) {13022 for(b = bp[ n ]; b != NULL; b = b2) {13023 b2 = b->next;1302413025 k1 = b->key;13026 C_fputs(C_text("(|"), fp);13027 /* Dump raw C string as if it were a symbol */13028 while((k2 = C_strpbrk(k1, C_text("\\|"))) != NULL) {13029 C_fwrite(k1, 1, k2-k1, fp);13030 C_fputc('\\', fp);13031 C_fputc(*k2, fp);13032 k1 = k2+1;13033 }13034 C_fputs(k1, fp);13035 ms = (double)b->sample_count * (double)profile_frequency / 1000.0;13036 C_fprintf(fp, C_text("| " UWORD_COUNT_FORMAT_STRING " %lf)\n"),13037 b->call_count, ms);13038 C_free(b);13039 }13040 }1304113042 C_fclose(fp);13043 C_free(profile_table);13044 profile_table = NULL;1304513046 return C_SCHEME_UNDEFINED;13047}1304813049void C_ccall C_dump_heap_state(C_word c, C_word *av)13050{13051 C_word13052 /* closure = av[ 0 ] */13053 k = av[ 1 ];1305413055 /* make sure heap is compacted */13056 C_save(k);13057 C_fromspace_top = C_fromspace_limit; /* force major GC */13058 C_reclaim((void *)dump_heap_state_2, 1);13059}130601306113062static C_ulong13063hdump_hash(C_word key)13064{13065 return (C_ulong)key % HDUMP_TABLE_SIZE;13066}130671306813069static void13070hdump_count(C_word key, int n, int t)13071{13072 HDUMP_BUCKET **bp = hdump_table + hdump_hash(key);13073 HDUMP_BUCKET *b = *bp;1307413075 while(b != NULL) {13076 if(b->key == key) {13077 b->count += n;13078 b->total += t;13079 return;13080 }13081 else b = b->next;13082 }1308313084 b = (HDUMP_BUCKET *)C_malloc(sizeof(HDUMP_BUCKET));1308513086 if(b == 0)13087 panic(C_text("out of memory - can not allocate heap-dump table-bucket"));1308813089 b->next = *bp;13090 b->key = key;13091 *bp = b;13092 b->count = n;13093 b->total = t;13094}130951309613097static void C_ccall dump_heap_state_2(C_word c, C_word *av)13098{13099 C_word k = av[ 0 ];13100 HDUMP_BUCKET *b, *b2, **bp;13101 int n, bytes;13102 C_byte *scan;13103 C_SCHEME_BLOCK *sbp;13104 C_header h;13105 C_word x, key, *p;13106 int imm = 0, blk = 0;1310713108 hdump_table = (HDUMP_BUCKET **)C_malloc(HDUMP_TABLE_SIZE * sizeof(HDUMP_BUCKET *));1310913110 if(hdump_table == NULL)13111 panic(C_text("out of memory - can not allocate heap-dump table"));1311213113 C_memset(hdump_table, 0, sizeof(HDUMP_BUCKET *) * HDUMP_TABLE_SIZE);1311413115 scan = fromspace_start;1311613117 while(scan < C_fromspace_top) {13118 ++blk;13119 sbp = (C_SCHEME_BLOCK *)scan;1312013121 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13122 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1312313124 n = C_header_size(sbp);13125 h = sbp->header;13126 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13127 key = (C_word)(h & C_HEADER_BITS_MASK);13128 p = sbp->data;1312913130 if(key == C_STRUCTURE_TYPE && !C_immediatep(*p) && C_block_header(*p) == C_SYMBOL_TYPE)13131 key = *p;1313213133 hdump_count(key, 1, bytes);1313413135 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {13136 if((h & C_SPECIALBLOCK_BIT) != 0) {13137 --n;13138 ++p;13139 }1314013141 while(n--) {13142 x = *(p++);13143 if(C_immediatep(x)) {13144 ++imm;1314513146 if((x & C_FIXNUM_BIT) != 0) key = C_fix(1);13147 else {13148 switch(x & C_IMMEDIATE_TYPE_BITS) {13149 case C_BOOLEAN_BITS: key = C_SCHEME_TRUE; break;13150 case C_CHARACTER_BITS: key = C_make_character('A'); break;13151 default: key = x;13152 }13153 }1315413155 hdump_count(key, 1, 0);13156 }13157 }13158 }1315913160 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13161 }1316213163 bp = hdump_table;13164 /* HACK */13165#define C_WEAK_PAIR_TYPE (C_PAIR_TYPE | C_SPECIALBLOCK_BIT)1316613167 for(n = 0; n < HDUMP_TABLE_SIZE; ++n) {13168 for(b = bp[ n ]; b != NULL; b = b2) {13169 b2 = b->next;1317013171 switch(b->key) {13172 case C_fix(1): C_fprintf(C_stderr, C_text("fixnum")); break;13173 case C_SCHEME_TRUE: C_fprintf(C_stderr, C_text("boolean\t")); break;13174 case C_SCHEME_END_OF_LIST: C_fprintf(C_stderr, C_text("null\t")); break;13175 case C_SCHEME_UNDEFINED : C_fprintf(C_stderr, C_text("void\t")); break;13176 case C_SCHEME_BROKEN_WEAK_PTR: C_fprintf(C_stderr, C_text("broken weak ptr")); break;13177 case C_make_character('A'): C_fprintf(C_stderr, C_text("character\t")); break;13178 case C_SCHEME_END_OF_FILE: C_fprintf(C_stderr, C_text("eof\t")); break;13179 case C_SCHEME_UNBOUND: C_fprintf(C_stderr, C_text("unbound\t")); break;13180 case C_SYMBOL_TYPE: C_fprintf(C_stderr, C_text("symbol\t")); break;13181 case C_STRING_TYPE: C_fprintf(C_stderr, C_text("string\t")); break;13182 case C_PAIR_TYPE: C_fprintf(C_stderr, C_text("pair\t")); break;13183 case C_CLOSURE_TYPE: C_fprintf(C_stderr, C_text("closure\t")); break;13184 case C_FLONUM_TYPE: C_fprintf(C_stderr, C_text("flonum\t")); break;13185 case C_PORT_TYPE: C_fprintf(C_stderr, C_text("port\t")); break;13186 case C_POINTER_TYPE: C_fprintf(C_stderr, C_text("pointer\t")); break;13187 case C_LOCATIVE_TYPE: C_fprintf(C_stderr, C_text("locative\t")); break;13188 case C_TAGGED_POINTER_TYPE: C_fprintf(C_stderr, C_text("tagged pointer\t")); break;13189 case C_LAMBDA_INFO_TYPE: C_fprintf(C_stderr, C_text("lambda info\t")); break;13190 case C_WEAK_PAIR_TYPE: C_fprintf(C_stderr, C_text("weak pair\t")); break;13191 case C_VECTOR_TYPE: C_fprintf(C_stderr, C_text("vector\t")); break;13192 case C_BYTEVECTOR_TYPE: C_fprintf(C_stderr, C_text("bytevector\t")); break;13193 case C_BIGNUM_TYPE: C_fprintf(C_stderr, C_text("bignum\t")); break;13194 case C_CPLXNUM_TYPE: C_fprintf(C_stderr, C_text("cplxnum\t")); break;13195 case C_RATNUM_TYPE: C_fprintf(C_stderr, C_text("ratnum\t")); break;13196 case C_STRUCTURE_TYPE: C_fprintf(C_stderr, C_text("generated structure type\t")); break;13197 /* XXX this is sort of funny: */13198 case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("bytevector\t")); break;13199 default:13200 x = b->key;1320113202 if(!C_immediatep(x) && C_header_bits(x) == C_SYMBOL_TYPE) {13203 x = C_block_item(x, 1);13204 C_fprintf(C_stderr, C_text("`%.*s'"), (int)C_header_size(x), C_c_string(x));13205 }13206 else13207 C_fprintf(C_stderr, C_text("unknown key " UWORD_FORMAT_STRING), (C_uword)b->key);13208 }1320913210 C_fprintf(C_stderr, C_text("\t%d"), b->count);1321113212 if(b->total > 0)13213 C_fprintf(C_stderr, C_text("\t%d bytes"), b->total);1321413215 C_fputc('\n', C_stderr);13216 C_free(b);13217 }13218 }1321913220 C_fprintf(C_stderr, C_text("\ntotal number of blocks: %d, immediates: %d\n"),13221 blk, imm);13222 C_free(hdump_table);13223 C_kontinue(k, C_SCHEME_UNDEFINED);13224}132251322613227static void C_ccall filter_heap_objects_2(C_word c, C_word *av)13228{13229 void *func = C_pointer_address(av[ 0 ]);13230 C_word13231 userarg = av[ 1 ],13232 vector = av[ 2 ],13233 k = av[ 3 ];13234 int n, bytes;13235 C_byte *scan;13236 C_SCHEME_BLOCK *sbp;13237 C_header h;13238 C_word *p;13239 int vecsize = C_header_size(vector);13240 typedef int (*filterfunc)(C_word x, C_word userarg);13241 filterfunc ff = (filterfunc)func;13242 int vcount = 0;1324313244 scan = fromspace_start;1324513246 while(scan < C_fromspace_top) {13247 sbp = (C_SCHEME_BLOCK *)scan;1324813249 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13250 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1325113252 n = C_header_size(sbp);13253 h = sbp->header;13254 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13255 p = sbp->data;1325613257 if(ff((C_word)sbp, userarg)) {13258 if(vcount < vecsize) {13259 C_set_block_item(vector, vcount, (C_word)sbp);13260 ++vcount;13261 }13262 else {13263 C_kontinue(k, C_fix(-1));13264 }13265 }1326613267 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13268 }1326913270 C_kontinue(k, C_fix(vcount));13271}132721327313274void C_ccall C_filter_heap_objects(C_word c, C_word *av)13275{13276 C_word13277 /* closure = av[ 0 ] */13278 k = av[ 1 ],13279 func = av[ 2 ],13280 vector = av[ 3 ],13281 userarg = av[ 4 ];1328213283 /* make sure heap is compacted */13284 C_save(k);13285 C_save(vector);13286 C_save(userarg);13287 C_save(func);13288 C_fromspace_top = C_fromspace_limit; /* force major GC */13289 C_reclaim((void *)filter_heap_objects_2, 4);13290}1329113292C_regparm C_word C_i_process_sleep(C_word n)13293{13294#if defined(_WIN32) && !defined(__CYGWIN__)13295 Sleep(C_unfix(n) * 1000);13296 return C_fix(0);13297#else13298 return C_fix(sleep(C_unfix(n)));13299#endif13300}1330113302C_regparm C_word13303C_i_file_exists_p(C_word name, C_word file, C_word dir)13304{13305#if defined(_WIN32) && !defined(__CYGWIN__)13306 struct _stat64i32 buf;13307#else13308 struct stat buf;13309#endif13310 int res;1331113312 res = C_stat(C_OS_FILENAME(name, 0), &buf);1331313314 if(res != 0) {13315 switch(errno) {13316 case ENOENT: return C_SCHEME_FALSE;13317 case EOVERFLOW: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13318 case ENOTDIR: return C_SCHEME_FALSE;13319 default: return C_fix(res);13320 }13321 }1332213323 switch(buf.st_mode & S_IFMT) {13324 case S_IFDIR: return C_truep(file) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13325 default: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13326 }13327}133281332913330C_regparm C_word13331C_i_pending_interrupt(C_word dummy)13332{13333 if(pending_interrupts_count > 0) {13334 handling_interrupts = 1; /* Lock out further forced GCs until we're done */13335 return C_fix(pending_interrupts[ --pending_interrupts_count ]);13336 } else {13337 handling_interrupts = 0; /* OK, can go on */13338 return C_SCHEME_FALSE;13339 }13340}133411334213343/* random numbers, mostly lifted from13344 https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c13345*/1334613347#ifdef __linux__13348# include <sys/syscall.h>13349#endif133501335113352#if !defined(_WIN32)13353static C_word random_urandom(C_word buf, int count)13354{13355 static int fd = -1;13356 int off = 0, r;1335713358 if(fd == -1) {13359 fd = open("/dev/urandom", O_RDONLY);1336013361 if(fd == -1) return C_SCHEME_FALSE;13362 }1336313364 while(count > 0) {13365 r = read(fd, C_data_pointer(buf) + off, count);1336613367 if(r == -1) {13368 if(errno != EINTR && errno != EAGAIN) return C_SCHEME_FALSE;13369 else r = 0;13370 }1337113372 count -= r;13373 off += r;13374 }1337513376 return C_SCHEME_TRUE;13377}13378#endif133791338013381C_word C_random_bytes(C_word buf, C_word size)13382{13383 int count = C_unfix(size);13384 int r = 0;13385 int off = 0;1338613387#if defined(__OpenBSD__) || defined(__FreeBSD__)13388 arc4random_buf(C_data_pointer(buf), count);13389#elif defined(SYS_getrandom) && defined(__NR_getrandom)13390 static int use_urandom = 0;1339113392 if(use_urandom) return random_urandom(buf, count);1339313394 while(count > 0) {13395 /* GRND_NONBLOCK = 0x0001 */13396 r = syscall(SYS_getrandom, C_data_pointer(buf) + off, count, 1);1339713398 if(r == -1) {13399 if(errno == ENOSYS) {13400 use_urandom = 1;13401 return random_urandom(buf, count);13402 }13403 else if(errno != EINTR) return C_SCHEME_FALSE;13404 else r = 0;13405 }1340613407 count -= r;13408 off += r;13409 }13410#elif defined(_WIN32) && !defined(__CYGWIN__)13411 typedef BOOLEAN (*func)(PVOID, ULONG);13412 static func RtlGenRandom = NULL;1341313414 if(RtlGenRandom == NULL) {13415 HMODULE mod = LoadLibrary("advapi32.dll");1341613417 if(mod == NULL) return C_SCHEME_FALSE;1341813419 if((RtlGenRandom = (func)GetProcAddress(mod, "SystemFunction036")) == NULL)13420 return C_SCHEME_FALSE;13421 }1342213423 if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))13424 return C_SCHEME_FALSE;13425#else13426 return random_urandom(buf, count);13427#endif1342813429 return C_SCHEME_TRUE;13430}134311343213433/* WELL512 pseudo random number generator, see also:13434 https://en.wikipedia.org/wiki/Well_equidistributed_long-period_linear13435 http://lomont.org/Math/Papers/2008/Lomont_PRNG_2008.pdf13436*/1343713438static C_uword random_word(void)13439{13440 C_uword a, b, c, d, r;13441 a = random_state[random_state_index];13442 c = random_state[(random_state_index+13)&15];13443 b = a^c^(a<<16)^(c<<15);13444 c = random_state[(random_state_index+9)&15];13445 c ^= (c>>11);13446 a = random_state[random_state_index] = b^c;13447 d = a^((a<<5)&0xDA442D24UL);13448 random_state_index = (random_state_index + 15)&15;13449 a = random_state[random_state_index];13450 random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);13451 r = random_state[random_state_index];13452 return r;13453}134541345513456static C_uword random_uniform(C_uword bound)13457{13458 C_uword r, min;1345913460 if (bound < 2) return 0;1346113462 min = (1U + ~bound) % bound; /* = 2**<wordsize> mod bound */1346313464 do r = random_word(); while (r < min);1346513466 /* r is now clamped to a set whose size mod upper_bound == 013467 * the worst case (2**<wordsize-1>+1) requires ~ 2 attempts */1346813469 return r % bound;13470}134711347213473C_regparm C_word C_random_fixnum(C_word n)13474{13475 C_word nf;1347613477 if (!(n & C_FIXNUM_BIT))13478 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "pseudo-random-integer", n);1347913480 nf = C_unfix(n);1348113482 if(nf < 0)13483 barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", n, C_fix(0));1348413485 return C_fix(random_uniform(nf));13486}134871348813489C_regparm C_word13490C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)13491{13492 C_uword *start, *end;1349313494 if(C_bignum_negativep(rn))13495 barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", rn, C_fix(0));1349613497 int len = integer_length_abs(rn);13498 C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));13499 C_word result = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);13500 C_uword *p;13501 C_uword highest_word = C_bignum_digits(rn)[C_bignum_size(rn)-1];13502 start = C_bignum_digits(result);13503 end = start + C_bignum_size(result);1350413505 for(p = start; p < (end - 1); ++p) {13506 *p = random_word();13507 len -= sizeof(C_uword);13508 }1350913510 *p = random_uniform(highest_word);13511 return C_bignum_simplify(result);13512}1351313514/*13515 * C_a_i_random_real: Generate a stream of bits uniformly at random and13516 * interpret it as the fractional part of the binary expansion of a13517 * number in [0, 1], 0.00001010011111010100...; then round it.13518 * More information on https://mumble.net/~campbell/2014/04/28/uniform-random-float13519 */1352013521static inline C_u64 random64() {13522#ifdef C_SIXTY_FOUR13523 return random_word();13524#else13525 C_u64 v = 0;13526 v |= ((C_u64) random_word()) << 32;13527 v |= (C_u64) random_word();13528 return v;13529#endif13530}1353113532#if defined(__GNUC__) && !defined(__TINYC__)13533# define clz64 __builtin_clzll13534#else13535/* https://en.wikipedia.org/wiki/Find_first_set#CLZ */13536static const C_uchar clz_table_4bit[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 };1353713538int clz32(C_u32 x)13539{13540 int n;13541 if ((x & 0xFFFF0000) == 0) {n = 16; x <<= 16;} else {n = 0;}13542 if ((x & 0xFF000000) == 0) {n += 8; x <<= 8;}13543 if ((x & 0xF0000000) == 0) {n += 4; x <<= 4;}13544 n += (int)clz_table_4bit[x >> (32-4)];13545 return n;13546}1354713548int clz64(C_u64 x)13549{13550 int y = clz32(x >> 32);1355113552 if(y == 32) return y + clz32(x);1355313554 return y;13555}13556#endif1355713558C_regparm C_word13559C_a_i_random_real(C_word **ptr, C_word n) {13560 int exponent = -64;13561 uint64_t significand;13562 unsigned shift;1356313564 while (C_unlikely((significand = random64()) == 0)) {13565 exponent -= 64;13566 if (C_unlikely(exponent < -1074))13567 return C_flonum(ptr, 0.0);13568 }1356913570 shift = clz64(significand);13571 if (shift != 0) {13572 exponent -= shift;13573 significand <<= shift;13574 significand |= (random64() >> (64 - shift));13575 }1357613577 significand |= 1;13578 return C_flonum(ptr, ldexp((double)significand, exponent));13579}1358013581C_word C_set_random_seed(C_word buf, C_word n)13582{13583 int i, nsu = C_unfix(n) / sizeof(C_uword);13584 int off = 0;1358513586 for(i = 0; i < (C_RANDOM_STATE_SIZE / sizeof(C_uword)); ++i) {13587 if(off >= nsu) off = 0;1358813589 random_state[ i ] = *((C_uword *)C_data_pointer(buf) + off);13590 ++off;13591 }1359213593 random_state_index = 0;13594 return C_SCHEME_FALSE;13595}1359613597C_word C_a_extract_struct_2(C_word **ptr, size_t sz, void *sp)13598{13599 C_word bv = C_scratch_alloc(C_SIZEOF_BYTEVECTOR(sz));13600 C_word w;13601 C_block_header_init(bv, C_make_header(C_BYTEVECTOR_TYPE, sz));13602 C_memcpy(C_data_pointer(bv), sp, sz);13603 w = C_a_i_record2(ptr, 2, C_SCHEME_FALSE, bv);13604 return w;13605}1360613607C_regparm C_word C_i_setenv(C_word var, C_word val)13608{13609#if defined(_WIN32) && !defined(__CYGWIN__)13610 C_WCHAR *wvar = C_utf16(var,0);13611 C_WCHAR *wval = val == C_SCHEME_FALSE ? NULL : C_utf16(val, 1);13612 SetEnvironmentVariableW(wvar, wval);13613 return C_fix(0);13614#elif defined(HAVE_SETENV)13615 C_char *cvar = C_c_string(var);13616 if(val == C_SCHEME_FALSE) unsetenv(C_c_string(var));13617 else setenv(C_c_string(var), C_c_string(val), 1);13618 return(C_fix(0));13619#else13620 char *sx = C_c_string(C_var),13621 *sy = (val == C_SCHEME_FALSE ? "" : C_c_string(val));13622 int n1 = C_strlen(sx), n2 = C_strlen(sy);13623 int buf_len = n1 + n2 + 2;13624 char *buf = (char *)C_malloc(buf_len);13625 if(buf == NULL) return(C_fix(0));13626 else {13627 C_strlcpy(buf, sx, buf_len);13628 C_strlcat(buf, "=", buf_len);13629 C_strlcat(buf, sy, buf_len);13630 return(C_fix(putenv(buf)));13631 }13632#endif13633}1363413635C_char *C_getenv(C_word var)13636{13637#if defined(_WIN32) && !defined(__CYGWIN__)13638 C_WCHAR *wvar = C_utf16(var, 0);13639 if(GetEnvironmentVariableW(wvar, (C_WCHAR *)buffer, STRING_BUFFER_SIZE) ==13640 0) return NULL;13641 return C_utf8((C_WCHAR *)buffer);13642#else13643 return getenv(C_c_string(var));13644#endif13645}1364613647#ifdef HAVE_CRT_EXTERNS_H13648# include <crt_externs.h>13649# define environ (*_NSGetEnviron())13650#elif !defined(_WIN32) || defined(__CYGWIN__)13651extern char **environ;13652#endif1365313654C_char *C_getenventry(int i)13655{13656#if defined(_WIN32) && !defined(__CYGWIN__)13657 C_WCHAR *env = GetEnvironmentStringsW();13658 C_WCHAR *p = env;13659 while(i--) {13660 while(*p != 0) ++p;13661 if(*(++p) == 0) return NULL;13662 }13663 C_char *s = C_strdup(C_utf8(p));13664 FreeEnvironmentStringsW(env);13665 return s;13666#else13667 return environ[ i ] == NULL ? NULL : C_strdup(environ[ i ]);13668#endif13669}1367013671C_regparm C_long C_current_jiffy(void) {13672#if defined(_WIN32) && !defined(__CYGWIN__)13673 LARGE_INTEGER ticks;13674 QueryPerformanceCounter(&ticks);13675 return ticks.QuadPart;13676#else13677 struct timespec tm;13678 clock_gettime(CLOCK_MONOTONIC, &tm);13679 return tm.tv_nsec / 1000 + tm.tv_sec * 1000000;13680#endif13681}1368213683C_regparm C_long C_jiffies_per_second(void) {13684#if defined(_WIN32) && !defined(__CYGWIN__)13685 LARGE_INTEGER ticks;13686 QueryPerformanceFrequency(&ticks);13687 return ticks.QuadPart;13688#else13689 return 1000000;13690#endif13691}