~ 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;359char360 **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, C_WCHAR *argv[], void *toplevel)608{609 C_word h, s, n;610611 if(C_gui_mode) {612#ifdef _WIN32613 parse_argv(C_utf8(GetCommandLineW()));614 argc = C_main_argc;615 argv = C_main_argv;616#else617 /* ??? */618#endif619 }620#if defined(_WIN32) && !defined(__CYGWIN__)621 else {622 int i, n;623 C_char *aptr, *arg;624 C_main_argv = (C_char **)malloc((MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS + 1) * sizeof(C_char *));625626 if(C_main_argv == NULL)627 panic(C_text("cannot allocate argument-list buffer"));628629 for(i = 0; i < argc; ++i) {630 arg = C_utf8(argv[ i ]);631 n = strlen(arg);632 aptr = (C_char *)malloc(n + 1);633634 if(!aptr) panic(C_text("cannot allocate argument buffer"));635636 C_strlcpy(aptr, arg, n + 1);637 C_main_argv[ i ] = aptr;638 }639640 C_main_argc = argc;641 C_main_argv[ argc ] = NULL;642 argv = C_main_argv;643 }644#endif645646 pass_serious_signals = 0;647 CHICKEN_parse_command_line(argc, argv, &h, &s, &n);648649 if(!CHICKEN_initialize(h, s, n, toplevel))650 panic(C_text("cannot initialize - out of memory"));651652 CHICKEN_run(NULL);653 return 0;654}655656657/* Custom argv parser for Windowz: */658659void parse_argv(C_char *cmds)660{661 C_char *ptr = cmds, *bptr0, *bptr, *aptr;662 int n = 0;663 C_main_argv = (C_char **)malloc((MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS + 1) * sizeof(C_char *));664665 if(C_main_argv == NULL)666 panic(C_text("cannot allocate argument-list buffer"));667668 C_main_argc = 0;669670 while(C_main_argc < MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS) {671 while(C_utf_isspace((int)(*ptr))) ++ptr;672673 if(*ptr == '\0') break;674675 for(bptr0 = bptr = buffer; !C_utf_isspace((int)(*ptr)) && *ptr != '\0'; *(bptr++) = *(ptr++))676 ++n;677678 *bptr = '\0';679 aptr = (C_char*)malloc(n + 1);680681 if(!aptr) panic(C_text("cannot allocate argument buffer"));682683 C_strlcpy(aptr, bptr0, n + 1);684 C_main_argv[ C_main_argc++ ] = aptr;685 }686687 C_main_argv[ C_main_argc ] = NULL;688}689690/* simple linear congruential PRNG, to avoid OpenBSD warnings.691 https://stackoverflow.com/questions/26237419/faster-than-rand692*/693694static int g_seed;695696void C_fast_srand(int seed) { g_seed = seed; }697698/* Output value in range [0, 32767] */699int C_fast_rand(void)700{701 g_seed = (214013*g_seed+2531011);702 return (g_seed>>16)&0x7FFF;703}704705706/* Initialize runtime system: */707708int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)709{710 C_SCHEME_BLOCK *k0;711 int i;712#ifdef HAVE_SIGACTION713 struct sigaction sa;714#endif715716 /* FIXME Should have C_tzset in chicken.h? */717#if defined(__MINGW32__)718# if defined(__MINGW64_VERSION_MAJOR)719 ULONGLONG tick_count = GetTickCount64();720# else721 /* mingw doesn't yet have GetTickCount64 support */722 ULONGLONG tick_count = GetTickCount();723# endif724 C_startup_time_sec = tick_count / 1000;725 C_startup_time_msec = tick_count % 1000;726 /* Make sure _tzname, _timezone, and _daylight are set */727 _tzset();728#else729 struct timeval tv;730 C_gettimeofday(&tv, NULL);731 C_startup_time_sec = tv.tv_sec;732 C_startup_time_msec = tv.tv_usec / 1000;733 /* Make sure tzname, timezone, and daylight are set */734 tzset();735#endif736737 if(chicken_is_initialized) return 1;738 else chicken_is_initialized = 1;739740#if defined(__ANDROID__) && defined(DEBUGBUILD)741 debug_mode = 2;742#endif743744 if(debug_mode)745 C_dbg(C_text("debug"), C_text("application startup...\n"));746747 C_panic_hook = usual_panic;748 symbol_table_list = NULL;749750 symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE);751752 if(symbol_table == NULL)753 return 0;754755 keyword_table = C_new_symbol_table("kw", symbols ? symbols / 4 : DEFAULT_KEYWORD_TABLE_SIZE);756757 if(keyword_table == NULL)758 return 0;759760 page_size = 0;761 stack_size = stack ? stack : DEFAULT_STACK_SIZE;762 C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);763764 /* Allocate temporary stack: */765 temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;766 if((C_temporary_stack_limit = (C_word *)C_malloc(temporary_stack_size * sizeof(C_word))) == NULL)767 return 0;768769 C_temporary_stack_bottom = C_temporary_stack_limit + temporary_stack_size;770 C_temporary_stack = C_temporary_stack_bottom;771772 /* Allocate mutation stack: */773 mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));774775 if(mutation_stack_bottom == NULL) return 0;776777 mutation_stack_top = mutation_stack_bottom;778 mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;779 C_gc_mutation_hook = NULL;780 C_gc_trace_hook = NULL;781782 /* Initialize finalizer lists: */783 finalizer_list = NULL;784 finalizer_free_list = NULL;785 pending_finalizer_indices =786 (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));787788 if(pending_finalizer_indices == NULL) return 0;789790 /* Initialize forwarding table: */791 forwarding_table =792 (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));793794 if(forwarding_table == NULL) return 0;795796 *forwarding_table = 0;797 forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;798799 /* Setup collectibles: */800 collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);801802 if(collectibles == NULL) return 0;803804 collectibles_top = collectibles;805 collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;806 gc_root_list = NULL;807808#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)809 dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;810#else811 dlopen_flags = 0;812#endif813814#ifdef HAVE_SIGACTION815 sa.sa_flags = 0;816 sigfillset(&sa.sa_mask); /* See note in C_establish_signal_handler() */817 sa.sa_handler = global_signal_handler;818#endif819820 /* setup signal handlers */821 if(!pass_serious_signals) {822#ifdef HAVE_SIGACTION823 C_sigaction(SIGBUS, &sa, NULL);824 C_sigaction(SIGFPE, &sa, NULL);825 C_sigaction(SIGILL, &sa, NULL);826 C_sigaction(SIGSEGV, &sa, NULL);827#else828 C_signal(SIGBUS, global_signal_handler);829 C_signal(SIGILL, global_signal_handler);830 C_signal(SIGFPE, global_signal_handler);831 C_signal(SIGSEGV, global_signal_handler);832#endif833 }834835 tracked_mutation_count = mutation_count = gc_count_1 = gc_count_1_total = gc_count_2 = maximum_heap_usage = 0;836 lf_list = NULL;837 C_register_lf2(NULL, 0, create_initial_ptable());838 C_restart_trampoline = (void *)toplevel;839 trace_buffer = NULL;840 C_clear_trace_buffer();841 chicken_is_running = chicken_ran_once = 0;842 pending_interrupts_count = 0;843 handling_interrupts = 0;844 last_interrupt_latency = 0;845 C_interrupts_enabled = 1;846 C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;847 C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;848 memset(signal_mapping_table, 0, sizeof(int) * NSIG);849 C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";850 error_location = C_SCHEME_FALSE;851 C_pre_gc_hook = NULL;852 C_post_gc_hook = NULL;853 C_scratchspace_start = NULL;854 C_scratchspace_top = NULL;855 C_scratchspace_limit = NULL;856 C_scratch_usage = 0;857 scratchspace_size = 0;858 live_finalizer_count = 0;859 allocated_finalizer_count = 0;860 current_module_name = NULL;861 current_module_handle = NULL;862 callback_continuation_level = 0;863 weak_pair_chain = (C_word)NULL;864 locative_chain = (C_word)NULL;865 gc_ms = 0;866 if (!random_state_initialized) {867 C_fast_srand(time(NULL));868 random_state_initialized = 1;869 }870871 for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_uword); ++i)872 random_state[ i ] = C_fast_rand();873874 initialize_symbol_table();875876 if (profiling) {877#ifndef C_NONUNIX878# ifdef HAVE_SIGACTION879 C_sigaction(C_PROFILE_SIGNAL, &sa, NULL);880# else881 C_signal(C_PROFILE_SIGNAL, global_signal_handler);882# endif883#endif884885 profile_table = (PROFILE_BUCKET **)C_malloc(PROFILE_TABLE_SIZE * sizeof(PROFILE_BUCKET *));886887 if(profile_table == NULL)888 panic(C_text("out of memory - can not allocate profile table"));889890 C_memset(profile_table, 0, sizeof(PROFILE_BUCKET *) * PROFILE_TABLE_SIZE);891 }892893 /* create k to invoke code for system-startup: */894 k0 = (C_SCHEME_BLOCK *)C_align((C_word)C_fromspace_top);895 C_fromspace_top += C_align(2 * sizeof(C_word));896 k0->header = C_CLOSURE_TYPE | 1;897 C_set_block_item(k0, 0, (C_word)termination_continuation);898 C_save(k0);899 C_save(C_SCHEME_UNDEFINED);900 C_restart_c = 2;901 return 1;902}903904905void *C_get_statistics(void) {906 static void *stats[ 8 ];907908 stats[ 0 ] = fromspace_start;909 stats[ 1 ] = C_fromspace_limit;910 stats[ 2 ] = C_scratchspace_start;911 stats[ 3 ] = C_scratchspace_limit;912 stats[ 4 ] = C_stack_limit;913 stats[ 5 ] = stack_bottom;914 stats[ 6 ] = C_fromspace_top;915 stats[ 7 ] = C_scratchspace_top;916 return stats;917}918919920static C_PTABLE_ENTRY *create_initial_ptable()921{922 /* IMPORTANT: hardcoded table size -923 this must match the number of C_pte calls + 1 (NULL terminator)! */924 C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 64);925 int i = 0;926927 if(pt == NULL)928 panic(C_text("out of memory - cannot create initial ptable"));929930 C_pte(termination_continuation);931 C_pte(callback_return_continuation);932 C_pte(values_continuation);933 C_pte(call_cc_values_wrapper);934 C_pte(call_cc_wrapper);935 C_pte(C_gc);936 C_pte(C_allocate_vector);937 C_pte(C_allocate_bytevector);938 C_pte(C_make_structure);939 C_pte(C_ensure_heap_reserve);940 C_pte(C_return_to_host);941 C_pte(C_get_symbol_table_info);942 C_pte(C_get_memory_info);943 C_pte(C_decode_seconds);944 C_pte(C_stop_timer);945 C_pte(C_dload);946 C_pte(C_set_dlopen_flags);947 C_pte(C_become);948 C_pte(C_apply_values);949 C_pte(C_times);950 C_pte(C_minus);951 C_pte(C_plus);952 C_pte(C_nequalp);953 C_pte(C_greaterp);954 /* IMPORTANT: have you read the comments at the start and the end of this function? */955 C_pte(C_lessp);956 C_pte(C_greater_or_equal_p);957 C_pte(C_less_or_equal_p);958 C_pte(C_number_to_string);959 C_pte(C_make_symbol);960 C_pte(C_string_to_symbol);961 C_pte(C_string_to_keyword);962 C_pte(C_apply);963 C_pte(C_call_cc);964 C_pte(C_values);965 C_pte(C_call_with_values);966 C_pte(C_continuation_graft);967 C_pte(C_open_file_port);968 C_pte(C_software_type);969 C_pte(C_machine_type);970 C_pte(C_machine_byte_order);971 C_pte(C_software_version);972 C_pte(C_build_platform);973 C_pte(C_make_pointer);974 /* IMPORTANT: have you read the comments at the start and the end of this function? */975 C_pte(C_make_tagged_pointer);976 C_pte(C_peek_signed_integer);977 C_pte(C_peek_unsigned_integer);978 C_pte(C_peek_int64);979 C_pte(C_peek_uint64);980 C_pte(C_context_switch);981 C_pte(C_register_finalizer);982 C_pte(C_copy_closure);983 C_pte(C_dump_heap_state);984 C_pte(C_filter_heap_objects);985 C_pte(C_fixnum_to_string);986 C_pte(C_integer_to_string);987 C_pte(C_flonum_to_string);988 C_pte(C_signum);989 C_pte(C_quotient_and_remainder);990 C_pte(C_u_integer_quotient_and_remainder);991 C_pte(C_bitwise_and);992 C_pte(C_bitwise_ior);993 C_pte(C_bitwise_xor);994995 /* IMPORTANT: did you remember the hardcoded pte table size? */996 pt[ i ].id = NULL;997 return pt;998}99910001001void *CHICKEN_new_gc_root_2(int finalizable)1002{1003 C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));10041005 if(r == NULL)1006 panic(C_text("out of memory - cannot allocate GC root"));10071008 r->value = C_SCHEME_UNDEFINED;1009 r->next = gc_root_list;1010 r->prev = NULL;1011 r->finalizable = finalizable;10121013 if(gc_root_list != NULL) gc_root_list->prev = r;10141015 gc_root_list = r;1016 return (void *)r;1017}101810191020void *CHICKEN_new_gc_root()1021{1022 return CHICKEN_new_gc_root_2(0);1023}102410251026void *CHICKEN_new_finalizable_gc_root()1027{1028 return CHICKEN_new_gc_root_2(1);1029}103010311032void CHICKEN_delete_gc_root(void *root)1033{1034 C_GC_ROOT *r = (C_GC_ROOT *)root;10351036 if(r->prev == NULL) gc_root_list = r->next;1037 else r->prev->next = r->next;10381039 if(r->next != NULL) r->next->prev = r->prev;10401041 C_free(root);1042}104310441045void *CHICKEN_global_lookup(char *name)1046{1047 int1048 len = C_strlen(name),1049 key = hash_string(len, name, symbol_table->size, symbol_table->rand);1050 C_word s;1051 void *root = CHICKEN_new_gc_root();10521053 if(C_truep(s = lookup(key, len, name, symbol_table))) {1054 if(C_block_item(s, 0) != C_SCHEME_UNBOUND) {1055 CHICKEN_gc_root_set(root, s);1056 return root;1057 }1058 }10591060 return NULL;1061}106210631064int CHICKEN_is_running()1065{1066 return chicken_is_running;1067}106810691070void CHICKEN_interrupt()1071{1072 C_timer_interrupt_counter = 0;1073}107410751076C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)1077{1078 C_SYMBOL_TABLE *stp;1079 int i;10801081 if((stp = C_find_symbol_table(name)) != NULL) return stp;10821083 if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)1084 return NULL;10851086 stp->name = name;1087 stp->size = size;1088 stp->next = symbol_table_list;1089 stp->rand = C_fast_rand();10901091 if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)1092 return NULL;10931094 for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);10951096 symbol_table_list = stp;1097 return stp;1098}109911001101C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)1102{1103 C_SYMBOL_TABLE *stp;11041105 for(stp = symbol_table_list; stp != NULL; stp = stp->next)1106 if(!C_strcmp(name, stp->name)) return stp;11071108 return NULL;1109}111011111112C_regparm C_word C_find_symbol(C_word bv, C_SYMBOL_TABLE *stable)1113{1114 C_char *sptr = C_c_string(bv);1115 int len = C_header_size(bv) - 1;1116 int key;1117 C_word s;11181119 if(stable == NULL) stable = symbol_table;11201121 key = hash_string(len, sptr, stable->size, stable->rand);11221123 if(C_truep(s = lookup(key, len, sptr, stable))) return s;1124 else return C_SCHEME_FALSE;1125}112611271128/* Setup symbol-table with internally used symbols; */11291130void initialize_symbol_table(void)1131{1132 int i;11331134 for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);11351136 /* Obtain reference to hooks for later: */1137 core_provided_symbol = C_intern2(C_heaptop, C_text("##core#provided"));1138 interrupt_hook_symbol = C_intern2(C_heaptop, C_text("##sys#interrupt-hook"));1139 error_hook_symbol = C_intern2(C_heaptop, C_text("##sys#error-hook"));1140 callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);1141 pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));1142 current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);11431144 /* SRFI-4 tags */1145 s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));1146 u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));1147 s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));1148 u32vector_symbol = C_intern2(C_heaptop, C_text("u32vector"));1149 s32vector_symbol = C_intern2(C_heaptop, C_text("s32vector"));1150 u64vector_symbol = C_intern2(C_heaptop, C_text("u64vector"));1151 s64vector_symbol = C_intern2(C_heaptop, C_text("s64vector"));1152 f32vector_symbol = C_intern2(C_heaptop, C_text("f32vector"));1153 f64vector_symbol = C_intern2(C_heaptop, C_text("f64vector"));1154}115511561157C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)1158{1159 C_char *sptr = C_c_string(str);1160 int len = C_header_size(str) - 1;1161 int key;1162 C_word s;11631164 if(kwtable == NULL) kwtable = keyword_table;11651166 key = hash_string(len, sptr, kwtable->size, kwtable->rand);11671168 if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;1169 else return C_SCHEME_FALSE;1170}117111721173void C_ccall sigsegv_trampoline(C_word c, C_word *av)1174{1175 barf(C_MEMORY_VIOLATION_ERROR, NULL);1176}117711781179void C_ccall sigbus_trampoline(C_word c, C_word *av)1180{1181 barf(C_BUS_ERROR, NULL);1182}118311841185void C_ccall sigfpe_trampoline(C_word c, C_word *av)1186{1187 barf(C_FLOATING_POINT_EXCEPTION_ERROR, NULL);1188}118911901191void C_ccall sigill_trampoline(C_word c, C_word *av)1192{1193 barf(C_ILLEGAL_INSTRUCTION_ERROR, NULL);1194}119511961197/* This is called from POSIX signals: */11981199void global_signal_handler(int signum)1200{1201#if defined(HAVE_SIGPROCMASK)1202 if(signum == SIGSEGV || signum == SIGFPE || signum == SIGILL || signum == SIGBUS) {1203 sigset_t sset;12041205 if(serious_signal_occurred || !chicken_is_running) {1206 switch(signum) {1207 case SIGSEGV: panic(C_text("unrecoverable segmentation violation"));1208 case SIGFPE: panic(C_text("unrecoverable floating-point exception"));1209 case SIGILL: panic(C_text("unrecoverable illegal instruction error"));1210 case SIGBUS: panic(C_text("unrecoverable bus error"));1211 default: panic(C_text("unrecoverable serious condition"));1212 }1213 }1214 else serious_signal_occurred = 1;12151216 /* unblock signal to avoid nested invocation of the handler */1217 sigemptyset(&sset);1218 sigaddset(&sset, signum);1219 C_sigprocmask(SIG_UNBLOCK, &sset, NULL);12201221 switch(signum) {1222 case SIGSEGV: C_reclaim(sigsegv_trampoline, 0);1223 case SIGFPE: C_reclaim(sigfpe_trampoline, 0);1224 case SIGILL: C_reclaim(sigill_trampoline, 0);1225 case SIGBUS: C_reclaim(sigbus_trampoline, 0);1226 default: panic(C_text("invalid serious signal"));1227 }1228 }1229#endif12301231 /* TODO: Make full use of sigaction: check that /our/ timer expired */1232 if (signum == C_PROFILE_SIGNAL && profiling) take_profile_sample();1233 else C_raise_interrupt(signal_mapping_table[ signum ]);12341235#ifndef HAVE_SIGACTION1236 /* not necessarily needed, but older UNIXen may not leave the handler installed: */1237 C_signal(signum, global_signal_handler);1238#endif1239}124012411242/* Align memory to page boundary */12431244static void *align_to_page(void *mem)1245{1246 return (void *)C_align((C_uword)mem);1247}124812491250static C_byte *1251heap_alloc (size_t size, C_byte **page_aligned)1252{1253 C_byte *p;1254 p = (C_byte *)C_malloc (size + page_size);12551256 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12571258 return p;1259}126012611262static void1263heap_free (C_byte *ptr, size_t size)1264{1265 C_free (ptr);1266}126712681269static C_byte *1270heap_realloc (C_byte *ptr, size_t old_size,1271 size_t new_size, C_byte **page_aligned)1272{1273 C_byte *p;1274 p = (C_byte *)C_realloc (ptr, new_size + page_size);12751276 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12771278 return p;1279}128012811282/* Modify heap size at runtime: */12831284void C_set_or_change_heap_size(C_word heap, int reintern)1285{1286 C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;1287 C_word size = heap / 2;12881289 if(heap_size_changed && fromspace_start) return;12901291 if(fromspace_start && heap_size >= heap) return;12921293 if(debug_mode)1294 C_dbg(C_text("debug"), C_text("heap resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), heap);12951296 heap_size = heap;12971298 if((ptr1 = heap_realloc (fromspace_start,1299 C_fromspace_limit - fromspace_start,1300 size, &ptr1a)) == NULL ||1301 (ptr2 = heap_realloc (tospace_start,1302 tospace_limit - tospace_start,1303 size, &ptr2a)) == NULL)1304 panic(C_text("out of memory - cannot allocate heap"));13051306 heapspace1 = ptr1;1307 heapspace1_size = size;1308 heapspace2 = ptr2;1309 heapspace2_size = size;1310 fromspace_start = ptr1a;1311 C_fromspace_top = fromspace_start;1312 C_fromspace_limit = fromspace_start + size;1313 tospace_start = ptr2a;1314 tospace_top = tospace_start;1315 tospace_limit = tospace_start + size;1316 mutation_stack_top = mutation_stack_bottom;13171318 if(reintern) initialize_symbol_table();1319}132013211322/* Modify stack-size at runtime: */13231324void C_do_resize_stack(C_word stack)1325{1326 C_uword old = stack_size,1327 diff = stack - old;13281329 if(diff != 0 && !stack_size_changed) {1330 if(debug_mode)1331 C_dbg(C_text("debug"), C_text("stack resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), stack);13321333 stack_size = stack;13341335#if C_STACK_GROWS_DOWNWARD1336 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit - diff);1337#else1338 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit + diff);1339#endif1340 C_stack_limit = C_stack_hard_limit;1341 }1342}134313441345/* Check whether nursery is sufficiently big: */13461347void C_check_nursery_minimum(C_word words)1348{1349 if(words >= C_bytestowords(stack_size))1350 panic(C_text("nursery is too small - try higher setting using the `-:s' option"));1351}13521353C_word C_resize_pending_finalizers(C_word size) {1354 int sz = C_num_to_int(size);13551356 FINALIZER_NODE **newmem =1357 (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));13581359 if (newmem == NULL)1360 return C_SCHEME_FALSE;13611362 pending_finalizer_indices = newmem;1363 C_max_pending_finalizers = sz;1364 return C_SCHEME_TRUE;1365}136613671368/* Parse runtime options from command-line: */13691370void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols)1371{1372 int i;1373 char *ptr;1374 C_word x;13751376 C_main_argc = argc;1377 C_main_argv = argv;13781379 *heap = DEFAULT_HEAP_SIZE;1380 *stack = DEFAULT_STACK_SIZE;1381 *symbols = DEFAULT_SYMBOL_TABLE_SIZE;13821383 for(i = 1; i < C_main_argc; ++i) {1384 if (strncmp(C_main_argv[ i ], C_text("-:"), 2))1385 break; /* Stop parsing on first non-runtime option */13861387 ptr = &C_main_argv[ i ][ 2 ];1388 if (*ptr == '\0')1389 break; /* Also stop parsing on first "empty" option (i.e. "-:") */13901391 do {1392 switch(*(ptr++)) {1393 case '?':1394 C_dbg("Runtime options", "\n\n"1395 " -:? display this text\n"1396 " -:c always treat stdin as console\n"1397 " -:d enable debug output\n"1398 " -:D enable more debug output\n"1399 " -:g show GC information\n"1400 " -:o disable stack overflow checks\n"1401 " -:hiSIZE set initial heap size\n"1402 " -:hmSIZE set maximal heap size\n"1403 " -:hfSIZE set minimum unused heap size\n"1404 " -:hgPERCENTAGE set heap growth percentage\n"1405 " -:hsPERCENTAGE set heap shrink percentage\n"1406 " -:huPERCENTAGE set percentage of memory used at which heap will be shrunk\n"1407 " -:hSIZE set fixed heap size\n"1408 " -:r write trace output to stderr\n"1409 " -:RSEED initialize rand() seed with SEED (helpful for benchmark stability)\n"1410 " -:p collect statistical profile and write to file at exit\n"1411 " -:PFREQUENCY like -:p, specifying sampling frequency in us (default: 10000)\n"1412 " -:sSIZE set nursery (stack) size\n"1413 " -:tSIZE set symbol-table size\n"1414 " -:fSIZE set maximal number of pending finalizers\n"1415 " -:x deliver uncaught exceptions of other threads to primordial one\n"1416 " -:B sound bell on major GC\n"1417 " -:G force GUI mode\n"1418 " -:aSIZE set trace-buffer/call-chain size\n"1419 " -:ASIZE set fixed temporary stack size\n"1420 " -:H dump heap state on exit\n"1421 " -:S do not handle segfaults or other serious conditions\n"1422 "\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"1423 " times 1024, 1048576, and 1073741824, respectively.\n\n");1424 C_exit_runtime(C_fix(0));14251426 case 'h':1427 switch(*ptr) {1428 case 'i':1429 *heap = arg_val(ptr + 1);1430 heap_size_changed = 1;1431 goto next;1432 case 'f':1433 C_heap_half_min_free = arg_val(ptr + 1);1434 goto next;1435 case 'g':1436 C_heap_growth = arg_val(ptr + 1);1437 goto next;1438 case 'm':1439 C_maximal_heap_size = arg_val(ptr + 1);1440 goto next;1441 case 's':1442 C_heap_shrinkage = arg_val(ptr + 1);1443 goto next;1444 case 'u':1445 C_heap_shrinkage_used = arg_val(ptr + 1);1446 goto next;1447 default:1448 *heap = arg_val(ptr);1449 heap_size_changed = 1;1450 C_heap_size_is_fixed = 1;1451 goto next;1452 }14531454 case 'o':1455 C_disable_overflow_check = 1;1456 break;14571458 case 'B':1459 gc_bell = 1;1460 break;14611462 case 'G':1463 C_gui_mode = 1;1464 break;14651466 case 'H':1467 dump_heap_on_exit = 1;1468 break;14691470 case 'S':1471 pass_serious_signals = 1;1472 break;14731474 case 's':1475 *stack = arg_val(ptr);1476 stack_size_changed = 1;1477 goto next;14781479 case 'f':1480 C_max_pending_finalizers = arg_val(ptr);1481 goto next;14821483 case 'a':1484 C_trace_buffer_size = arg_val(ptr);1485 goto next;14861487 case 'A':1488 fixed_temporary_stack_size = arg_val(ptr);1489 goto next;14901491 case 't':1492 *symbols = arg_val(ptr);1493 goto next;14941495 case 'c':1496 fake_tty_flag = 1;1497 break;14981499 case 'd':1500 debug_mode = 1;1501 break;15021503 case 'D':1504 debug_mode = 2;1505 break;15061507 case 'g':1508 gc_report_flag = 2;1509 break;15101511 case 'P':1512 profiling = 1;1513 profile_frequency = arg_val(ptr);1514 goto next;15151516 case 'p':1517 profiling = 1;1518 break;15191520 case 'r':1521 show_trace = 1;1522 break;15231524 case 'R':1525 C_fast_srand((unsigned int)arg_val(ptr));1526 random_state_initialized = 1;1527 goto next;15281529 case 'x':1530 C_abort_on_thread_exceptions = 1;1531 break;15321533 default: panic(C_text("illegal runtime option"));1534 }1535 } while(*ptr != '\0');15361537 next:;1538 }1539}154015411542C_word arg_val(C_char *arg)1543{1544 int len;1545 C_char *end;1546 C_long val, mul = 1;15471548 if (arg == NULL) panic(C_text("illegal runtime-option argument"));15491550 len = C_strlen(arg);15511552 if(len < 1) panic(C_text("illegal runtime-option argument"));15531554 switch(arg[ len - 1 ]) {1555 case 'k':1556 case 'K': mul = 1024; break;15571558 case 'm':1559 case 'M': mul = 1024 * 1024; break;15601561 case 'g':1562 case 'G': mul = 1024 * 1024 * 1024; break;15631564 default: mul = 1;1565 }15661567 val = C_strtow(arg, &end, 10);15681569 if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))1570 panic(C_text("invalid runtime-option argument suffix"));15711572 return val * mul;1573}157415751576/* Run embedded code with arguments: */15771578C_word CHICKEN_run(void *toplevel)1579{1580 if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))1581 panic(C_text("could not initialize"));15821583 if(chicken_is_running)1584 panic(C_text("re-invocation of Scheme world while process is already running"));15851586 chicken_is_running = chicken_ran_once = 1;1587 return_to_host = 0;15881589 if(profiling) set_profile_timer(profile_frequency);15901591#if C_STACK_GROWS_DOWNWARD1592 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);1593#else1594 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);1595#endif1596 C_stack_limit = C_stack_hard_limit;15971598 stack_bottom = C_stack_pointer;15991600 if(debug_mode)1601 C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx\n"), (C_word)stack_bottom);16021603 /* The point of (usually) no return... */1604#ifdef HAVE_SIGSETJMP1605 C_sigsetjmp(C_restart, 0);1606#else1607 C_setjmp(C_restart);1608#endif16091610 serious_signal_occurred = 0;16111612 if(!return_to_host) {1613 /* We must copy the argvector onto the stack, because1614 * any subsequent save() will otherwise clobber it.1615 */1616 C_word *p = C_alloc(C_restart_c);1617 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));1618 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));1619 C_temporary_stack = C_temporary_stack_bottom;1620 ((C_proc)C_restart_trampoline)(C_restart_c, p);1621 }16221623 if(profiling) set_profile_timer(0);16241625 chicken_is_running = 0;1626 return C_restore;1627}162816291630C_word CHICKEN_continue(C_word k)1631{1632 if(C_temporary_stack_bottom != C_temporary_stack)1633 panic(C_text("invalid temporary stack level"));16341635 if(!chicken_is_initialized)1636 panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));16371638 C_save(k);1639 return CHICKEN_run(NULL);1640}164116421643/* The final continuation: */16441645void C_ccall termination_continuation(C_word c, C_word *av)1646{1647 if(debug_mode) {1648 C_dbg(C_text("debug"), C_text("application terminated normally\n"));1649 }16501651 C_exit_runtime(C_fix(0));1652}165316541655/* Signal unrecoverable runtime error: */16561657void panic(C_char *msg)1658{1659 if(C_panic_hook != NULL) C_panic_hook(msg);16601661 usual_panic(msg);1662}166316641665void usual_panic(C_char *msg)1666{1667 C_char *dmp = C_dump_trace(0);16681669 C_dbg_hook(C_SCHEME_UNDEFINED);16701671 if(C_gui_mode) {1672 C_snprintf(buffer, sizeof(buffer), C_text("%s\n\n%s"), msg, dmp);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 if not WIN32 GUI app */16781679 C_dbg("panic", C_text("%s - execution terminated\n\n%s"), msg, dmp);1680 C_exit_runtime(C_fix(1));1681}168216831684void horror(C_char *msg)1685{1686 C_dbg_hook(C_SCHEME_UNDEFINED);16871688 if(C_gui_mode) {1689 C_snprintf(buffer, sizeof(buffer), C_text("%s"), msg);1690#if defined(_WIN32) && !defined(__CYGWIN__)1691 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1692 ExitProcess(1);1693#endif1694 } /* fall through */16951696 C_dbg("horror", C_text("\n%s - execution terminated"), msg);1697 C_exit_runtime(C_fix(1));1698}169917001701/* Error-hook, called from C-level runtime routines: */17021703void barf(int code, char *loc, ...)1704{1705 C_char *msg;1706 C_word err = error_hook_symbol;1707 int c, i;1708 va_list v;1709 C_word *av;17101711 C_dbg_hook(C_SCHEME_UNDEFINED);17121713 C_temporary_stack = C_temporary_stack_bottom;1714 err = C_block_item(err, 0);17151716 switch(code) {1717 case C_BAD_ARGUMENT_COUNT_ERROR:1718 msg = C_text("bad argument count");1719 c = 3;1720 break;17211722 case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:1723 msg = C_text("too few arguments");1724 c = 3;1725 break;17261727 case C_BAD_ARGUMENT_TYPE_ERROR:1728 msg = C_text("bad argument type");1729 c = 1;1730 break;17311732 case C_UNBOUND_VARIABLE_ERROR:1733 msg = C_text("unbound variable");1734 c = 1;1735 break;17361737 case C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR:1738 msg = C_text("bad argument type - not a keyword");1739 c = 1;1740 break;17411742 case C_OUT_OF_MEMORY_ERROR:1743 msg = C_text("not enough memory");1744 c = 0;1745 break;17461747 case C_DIVISION_BY_ZERO_ERROR:1748 msg = C_text("division by zero");1749 c = 0;1750 break;17511752 case C_OUT_OF_BOUNDS_ERROR:1753 msg = C_text("out of range");1754 c = 2;1755 break;17561757 case C_NOT_A_CLOSURE_ERROR:1758 msg = C_text("call of non-procedure");1759 c = 1;1760 break;17611762 case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:1763 msg = C_text("continuation cannot receive multiple values");1764 c = 1;1765 break;17661767 case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:1768 msg = C_text("bad argument type - not a non-cyclic list");1769 c = 1;1770 break;17711772 case C_TOO_DEEP_RECURSION_ERROR:1773 msg = C_text("recursion too deep");1774 c = 0;1775 break;17761777 case C_CANT_REPRESENT_INEXACT_ERROR:1778 msg = C_text("inexact number cannot be represented as an exact number");1779 c = 1;1780 break;17811782 case C_NOT_A_PROPER_LIST_ERROR:1783 msg = C_text("bad argument type - not a proper list");1784 c = 1;1785 break;17861787 case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:1788 msg = C_text("bad argument type - not a fixnum");1789 c = 1;1790 break;17911792 case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:1793 msg = C_text("bad argument type - not a string");1794 c = 1;1795 break;17961797 case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:1798 msg = C_text("bad argument type - not a pair");1799 c = 1;1800 break;18011802 case C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR:1803 msg = C_text("bad argument type - not a boolean");1804 c = 1;1805 break;18061807 case C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR:1808 msg = C_text("bad argument type - not a locative");1809 c = 1;1810 break;18111812 case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:1813 msg = C_text("bad argument type - not a list");1814 c = 1;1815 break;18161817 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:1818 msg = C_text("bad argument type - not a number");1819 c = 1;1820 break;18211822 case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:1823 msg = C_text("bad argument type - not a symbol");1824 c = 1;1825 break;18261827 case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:1828 msg = C_text("bad argument type - not a vector");1829 c = 1;1830 break;18311832 case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:1833 msg = C_text("bad argument type - not a character");1834 c = 1;1835 break;18361837 case C_STACK_OVERFLOW_ERROR:1838 msg = C_text("stack overflow");1839 c = 0;1840 break;18411842 case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:1843 msg = C_text("bad argument type - not a structure of the required type");1844 c = 2;1845 break;18461847 case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:1848 msg = C_text("bad argument type - not a bytevector");1849 c = 1;1850 break;18511852 case C_LOST_LOCATIVE_ERROR:1853 msg = C_text("locative refers to reclaimed object");1854 c = 1;1855 break;18561857 case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:1858 msg = C_text("bad argument type - not a object");1859 c = 1;1860 break;18611862 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:1863 msg = C_text("bad argument type - not a number vector");1864 c = 2;1865 break;18661867 case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:1868 msg = C_text("bad argument type - not an integer");1869 c = 1;1870 break;18711872 case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:1873 msg = C_text("bad argument type - not an unsigned integer");1874 c = 1;1875 break;18761877 case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:1878 msg = C_text("bad argument type - not a pointer");1879 c = 1;1880 break;18811882 case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:1883 msg = C_text("bad argument type - not a tagged pointer");1884 c = 2;1885 break;18861887 case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:1888 msg = C_text("bad argument type - not a flonum");1889 c = 1;1890 break;18911892 case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:1893 msg = C_text("bad argument type - not a procedure");1894 c = 1;1895 break;18961897 case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:1898 msg = C_text("bad argument type - invalid base");1899 c = 1;1900 break;19011902 case C_CIRCULAR_DATA_ERROR:1903 msg = C_text("recursion too deep or circular data encountered");1904 c = 0;1905 break;19061907 case C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR:1908 msg = C_text("bad argument type - not a port");1909 c = 1;1910 break;19111912 case C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR:1913 msg = C_text("bad argument type - not a port of the correct type");1914 c = 1;1915 break;19161917 case C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR:1918 msg = C_text("bad argument type - not an input-port");1919 c = 1;1920 break;19211922 case C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR:1923 msg = C_text("bad argument type - not an output-port");1924 c = 1;1925 break;19261927 case C_PORT_CLOSED_ERROR:1928 msg = C_text("port already closed");1929 c = 1;1930 break;19311932 case C_ASCIIZ_REPRESENTATION_ERROR:1933 msg = C_text("cannot represent string with NUL bytes as C string");1934 c = 1;1935 break;19361937 case C_MEMORY_VIOLATION_ERROR:1938 msg = C_text("segmentation violation");1939 c = 0;1940 break;19411942 case C_FLOATING_POINT_EXCEPTION_ERROR:1943 msg = C_text("floating point exception");1944 c = 0;1945 break;19461947 case C_ILLEGAL_INSTRUCTION_ERROR:1948 msg = C_text("illegal instruction");1949 c = 0;1950 break;19511952 case C_BUS_ERROR:1953 msg = C_text("bus error");1954 c = 0;1955 break;19561957 case C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR:1958 msg = C_text("bad argument type - not an exact number");1959 c = 1;1960 break;19611962 case C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR:1963 msg = C_text("bad argument type - not an inexact number");1964 c = 1;1965 break;19661967 case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:1968 msg = C_text("bad argument type - not an real");1969 c = 1;1970 break;19711972 case C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR:1973 msg = C_text("bad argument type - complex number has no ordering");1974 c = 1;1975 break;19761977 case C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR:1978 msg = C_text("bad argument type - not an exact integer");1979 c = 1;1980 break;19811982 case C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION:1983 msg = C_text("number does not fit in foreign type");1984 c = 1;1985 break;19861987 case C_BAD_ARGUMENT_TYPE_COMPLEX_ABS:1988 msg = C_text("cannot compute absolute value of complex number");1989 c = 1;1990 break;19911992 case C_REST_ARG_OUT_OF_BOUNDS_ERROR:1993 msg = C_text("attempted rest argument access beyond end of list");1994 c = 3;1995 break;19961997 case C_DECODING_ERROR:1998 msg = C_text("string contains invalid UTF-8 sequence");1999 c = 2;2000 break;20012002 case C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR:2003 msg = C_text("bad argument type - value exceeds numeric range");2004 c = 1;2005 break;20062007 default: panic(C_text("illegal internal error code"));2008 }20092010 if(C_immediatep(err)) {2011 C_dbg(C_text("error"), C_text("%s\n"), msg);2012 panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));2013 } else {2014 av = C_alloc(c + 4);2015 va_start(v, loc);2016 av[ 0 ] = err;2017 /* No continuation is passed: '##sys#error-hook' may not return: */2018 av[ 1 ] = C_SCHEME_UNDEFINED;2019 av[ 2 ] = C_fix(code);20202021 if(loc != NULL)2022 av[ 3 ] = intern0(loc);2023 else {2024 av[ 3 ] = error_location;2025 error_location = C_SCHEME_FALSE;2026 }20272028 for(i = 0; i < c; ++i)2029 av[ i + 4 ] = va_arg(v, C_word);20302031 va_end(v);2032 C_do_apply(c + 4, av);2033 }2034}203520362037/* Never use extended number hook procedure names longer than this! */2038/* Current longest name: ##sys#integer->string/recursive */2039#define MAX_EXTNUM_HOOK_NAME 3220402041/* This exists so that we don't have to create any extra closures */2042static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)2043{2044 static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];2045 int i;2046 va_list v;2047 C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;20482049 ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));20502051 if(!C_immediatep(ext_proc_sym))2052 ext_proc = C_block_item(ext_proc_sym, 0);20532054 if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {2055 C_word *av = C_alloc(c + 1);2056 av[ 0 ] = ext_proc;2057 av[ 1 ] = k;2058 va_start(v, k);20592060 for(i = 0; i < c - 1; ++i)2061 av[ i + 2 ] = va_arg(v, C_word);20622063 va_end(v);2064 C_do_apply(c + 1, av);2065 } else {2066 barf(C_UNBOUND_VARIABLE_ERROR, NULL, ext_proc_sym);2067 }2068}206920702071/* Hook for setting breakpoints */20722073C_word C_dbg_hook(C_word dummy)2074{2075 return dummy;2076}207720782079/* Timing routines: */20802081/* DEPRECATED */2082C_regparm C_u64 C_milliseconds(void)2083{2084 return C_current_process_milliseconds();2085}20862087C_regparm C_u64 C_current_process_milliseconds(void)2088{2089#if defined(__MINGW32__)2090# if defined(__MINGW64_VERSION_MAJOR)2091 ULONGLONG tick_count = GetTickCount64();2092# else2093 ULONGLONG tick_count = GetTickCount();2094# endif2095 return tick_count - (C_startup_time_sec * 1000) - C_startup_time_msec;2096#else2097 struct timeval tv;20982099 if(C_gettimeofday(&tv, NULL) == -1) return 0;2100 else return (tv.tv_sec - C_startup_time_sec) * 1000 + tv.tv_usec / 1000 - C_startup_time_msec;2101#endif2102}210321042105C_regparm time_t C_seconds(C_long *ms)2106{2107#ifdef C_NONUNIX2108 if(ms != NULL) *ms = 0;21092110 return (time_t)(clock() / CLOCKS_PER_SEC);2111#else2112 struct timeval tv;21132114 if(C_gettimeofday(&tv, NULL) == -1) {2115 if(ms != NULL) *ms = 0;21162117 return (time_t)0;2118 }2119 else {2120 if(ms != NULL) *ms = tv.tv_usec / 1000;21212122 return tv.tv_sec;2123 }2124#endif2125}212621272128C_regparm C_u64 C_cpu_milliseconds(void)2129{2130#if defined(C_NONUNIX) || defined(__CYGWIN__)2131 if(CLOCKS_PER_SEC == 1000) return clock();2132 else return ((C_u64)clock() / CLOCKS_PER_SEC) * 1000;2133#else2134 struct rusage ru;21352136 if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;2137 else return (((C_u64)ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 10002138 + ((C_u64)ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000);2139#endif2140}214121422143/* Support code for callbacks: */21442145int C_save_callback_continuation(C_word **ptr, C_word k)2146{2147 C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));21482149 C_mutate_slot(&C_block_item(callback_continuation_stack_symbol, 0), p);2150 return ++callback_continuation_level;2151}215221532154C_word C_restore_callback_continuation(void)2155{2156 /* obsolete, but retained for keeping old code working */2157 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2158 k;21592160 assert(!C_immediatep(p) && C_header_type(p) == C_PAIR_TYPE);2161 k = C_u_i_car(p);21622163 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2164 --callback_continuation_level;2165 return k;2166}216721682169C_word C_restore_callback_continuation2(int level)2170{2171 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2172 k;21732174 if(level != callback_continuation_level || C_immediatep(p) || C_header_type(p) != C_PAIR_TYPE)2175 panic(C_text("unbalanced callback continuation stack"));21762177 k = C_u_i_car(p);21782179 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2180 --callback_continuation_level;2181 return k;2182}218321842185C_word C_callback(C_word closure, int argc)2186{2187#ifdef HAVE_SIGSETJMP2188 sigjmp_buf prev;2189#else2190 jmp_buf prev;2191#endif2192 C_word2193 *a = C_alloc(C_SIZEOF_CLOSURE(2)),2194 k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE),2195 *av;2196 int old = chicken_is_running;21972198 if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)2199 panic(C_text("callback invoked in non-safe context"));22002201 C_memcpy(&prev, &C_restart, sizeof(C_restart));2202 callback_returned_flag = 0;2203 chicken_is_running = 1;2204 av = C_alloc(argc + 2);2205 av[ 0 ] = closure;2206 av[ 1 ] = k;2207 /*XXX is the order of arguments an issue? */2208 C_memcpy(av + 2, C_temporary_stack, argc * sizeof(C_word));2209 C_temporary_stack = C_temporary_stack_bottom;22102211#ifdef HAVE_SIGSETJMP2212 if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc + 2, av);2213#else2214 if(!C_setjmp(C_restart)) C_do_apply(argc + 2, av);2215#endif22162217 serious_signal_occurred = 0;22182219 if(!callback_returned_flag) {2220 /* We must copy the argvector onto the stack, because2221 * any subsequent save() will otherwise clobber it.2222 */2223 C_word *p = C_alloc(C_restart_c);2224 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));2225 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));2226 C_temporary_stack = C_temporary_stack_bottom;2227 ((C_proc)C_restart_trampoline)(C_restart_c, p);2228 }2229 else {2230 C_memcpy(&C_restart, &prev, sizeof(C_restart));2231 callback_returned_flag = 0;2232 }22332234 chicken_is_running = old;2235 return C_restore;2236}223722382239void C_callback_adjust_stack(C_word *a, int size)2240{2241 if(!chicken_is_running && !C_in_stackp((C_word)a)) {2242 if(debug_mode)2243 C_dbg(C_text("debug"),2244 C_text("callback invoked in lower stack region - adjusting limits:\n"2245 "[debug] current: \t%p\n"2246 "[debug] previous: \t%p (bottom) - %p (limit)\n"),2247 a, stack_bottom, C_stack_limit);22482249#if C_STACK_GROWS_DOWNWARD2250 C_stack_hard_limit = (C_word *)((C_byte *)a - stack_size);2251 stack_bottom = a + size;2252#else2253 C_stack_hard_limit = (C_word *)((C_byte *)a + stack_size);2254 stack_bottom = a;2255#endif2256 C_stack_limit = C_stack_hard_limit;22572258 if(debug_mode)2259 C_dbg(C_text("debug"), C_text("new: \t%p (bottom) - %p (limit)\n"),2260 stack_bottom, C_stack_limit);2261 }2262}226322642265C_word C_callback_wrapper(void *proc, int argc)2266{2267 C_word2268 *a = C_alloc(C_SIZEOF_CLOSURE(1)),2269 closure = C_closure(&a, 1, (C_word)proc),2270 result;22712272 result = C_callback(closure, argc);2273 assert(C_temporary_stack == C_temporary_stack_bottom);2274 return result;2275}227622772278void C_ccall callback_return_continuation(C_word c, C_word *av)2279{2280 C_word self = av[0];2281 C_word r = av[1];22822283 if(C_block_item(self, 1) == C_SCHEME_TRUE)2284 panic(C_text("callback returned twice"));22852286 assert(callback_returned_flag == 0);2287 callback_returned_flag = 1;2288 C_set_block_item(self, 1, C_SCHEME_TRUE);2289 C_save(r);2290 C_reclaim(NULL, 0);2291}229222932294/* Register/unregister literal frame: */22952296void C_initialize_lf(C_word *lf, int count)2297{2298 while(count-- > 0)2299 *(lf++) = C_SCHEME_UNBOUND;2300}230123022303void *C_register_lf(C_word *lf, int count)2304{2305 return C_register_lf2(lf, count, NULL);2306}230723082309void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)2310{2311 LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));2312 LF_LIST *np;2313 int status = 0;23142315 node->lf = lf;2316 node->count = count;2317 node->ptable = ptable;2318 node->module_name = current_module_name;2319 node->module_handle = current_module_handle;2320 current_module_handle = NULL;23212322 if(lf_list) lf_list->prev = node;23232324 node->next = lf_list;2325 node->prev = NULL;2326 lf_list = node;2327 return (void *)node;2328}232923302331LF_LIST *find_module_handle(char *name)2332{2333 LF_LIST *np;23342335 for(np = lf_list; np != NULL; np = np->next) {2336 if(np->module_name != NULL && !C_strcmp(np->module_name, name))2337 return np;2338 }23392340 return NULL;2341}234223432344void C_unregister_lf(void *handle)2345{2346 LF_LIST *node = (LF_LIST *) handle;23472348 if (node->next) node->next->prev = node->prev;23492350 if (node->prev) node->prev->next = node->next;23512352 if (lf_list == node) lf_list = node->next;23532354 C_free(node->module_name);2355 C_free(node);2356}235723582359/* Intern symbol into symbol-table: */23602361C_regparm C_word C_intern(C_word **ptr, int len, C_char *str)2362{2363 return C_intern_in(ptr, len, str, symbol_table);2364}236523662367C_regparm C_word C_h_intern(C_word *slot, int len, C_char *str)2368{2369 return C_h_intern_in(slot, len, str, symbol_table);2370}237123722373C_regparm C_word C_intern_kw(C_word **ptr, int len, C_char *str)2374{2375 C_word kw = C_intern_in(ptr, len, str, keyword_table);2376 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2377 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2378 return kw;2379}238023812382C_regparm C_word C_h_intern_kw(C_word *slot, int len, C_char *str)2383{2384 C_word kw = C_h_intern_in(slot, len, str, keyword_table);2385 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2386 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2387 return kw;2388}23892390C_regparm C_word C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)2391{2392 int key;2393 C_word s;23942395 if(stable == NULL) stable = symbol_table;23962397 key = hash_string(len, str, stable->size, stable->rand);23982399 if(C_truep(s = lookup(key, len, str, stable))) return s;24002401 s = C_bytevector(ptr, len + 1, str);2402 return add_symbol(ptr, key, s, stable);2403}240424052406C_regparm C_word C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)2407{2408 /* Intern as usual, but remember slot, and allocate in static2409 * memory. If symbol already exists, replace its string by a fresh2410 * statically allocated string to ensure it never gets collected, as2411 * lf[] entries are not tracked by the GC.2412 */2413 int key;2414 C_word s, bv;24152416 if(stable == NULL) stable = symbol_table;24172418 key = hash_string(len, str, stable->size, stable->rand);24192420 if(C_truep(s = lookup(key, len, str, stable))) {2421 if(C_in_stackp(s)) C_mutate_slot(slot, s);24222423 if(!C_truep(C_permanentp(C_symbol_name(s)))) {2424 /* Replace by statically allocated string, and persist it */2425 bv = C_static_bytevector(C_heaptop, len + 1, str);2426 C_c_bytevector(bv)[ len ] = 0;2427 C_set_block_item(s, 1, bv);2428 C_i_persist_symbol(s);2429 }2430 return s;2431 }24322433 bv = C_static_bytevector(C_heaptop, len + 1, str);2434 C_c_bytevector(bv)[ len ] = 0;2435 return add_symbol(C_heaptop, key, bv, stable);2436}243724382439C_regparm C_word intern0(C_char *str)2440{2441 int len = C_strlen(str);2442 int key = hash_string(len, str, symbol_table->size, symbol_table->rand);2443 C_word s;24442445 if(C_truep(s = lookup(key, len, str, symbol_table))) return s;2446 else return C_SCHEME_FALSE;2447}244824492450C_regparm C_word C_lookup_symbol(C_word sym)2451{2452 int key;2453 C_word bv = C_block_item(sym, 1);2454 int len = C_header_size(bv) - 1;24552456 key = hash_string(len, C_c_string(bv), symbol_table->size, symbol_table->rand);24572458 return lookup(key, len, C_c_string(bv), symbol_table);2459}246024612462C_regparm C_word C_intern2(C_word **ptr, C_char *str)2463{2464 return C_intern_in(ptr, C_strlen(str), str, symbol_table);2465}246624672468C_regparm C_word C_intern3(C_word **ptr, C_char *str, C_word value)2469{2470 C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);24712472 C_mutate(&C_block_item(s,0), value);2473 C_i_persist_symbol(s); /* Symbol has a value now; persist it */2474 return s;2475}247624772478C_regparm C_word hash_string(int len, C_char *str, C_word m, C_word r)2479{2480 C_uword key = r;24812482 while(len--)2483 key ^= (key << 6) + (key >> 2) + *(str++);24842485 return (C_word)(key % (C_uword)m);2486}248724882489C_regparm C_word lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)2490{2491 C_word bucket, last = 0, sym, s;24922493 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2494 bucket = C_block_item(bucket,1)) {2495 sym = C_block_item(bucket,0);24962497 /* If the symbol is unreferenced, drop it: */2498 if (sym == C_SCHEME_BROKEN_WEAK_PTR) {2499 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2500 else stable->table[ key ] = C_block_item(bucket,1);2501 } else {2502 last = bucket;2503 s = C_block_item(sym, 1);25042505 if(C_header_size(s) - 1 == (C_word)len2506 && !C_memcmp(str, (C_char *)C_data_pointer(s), len))2507 return sym;2508 }2509 }25102511 return C_SCHEME_FALSE;2512}25132514/* Mark a symbol as "persistent", to prevent it from being GC'ed */2515C_regparm C_word C_i_persist_symbol(C_word sym)2516{2517 C_word bucket;2518 C_SYMBOL_TABLE *stp;25192520 /* Normally, this will get called with a symbol, but in2521 * C_h_intern_kw we may call it with keywords too.2522 */2523 if(!C_truep(C_i_symbolp(sym)) && !C_truep(C_i_keywordp(sym))) {2524 error_location = C_SCHEME_FALSE;2525 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, sym);2526 }25272528 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2529 bucket = lookup_bucket(sym, stp);25302531 if (C_truep(bucket)) {2532 /* Change weak to strong ref to ensure long-term survival */2533 C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;2534 /* Ensure survival on next minor GC */2535 if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);2536 }2537 }2538 return C_SCHEME_UNDEFINED;2539}25402541/* Possibly remove "persistence" of symbol, to allowed it to be GC'ed.2542 * This is only done if the symbol is unbound, has an empty plist and2543 * is allocated in managed memory.2544 */2545C_regparm C_word C_i_unpersist_symbol(C_word sym)2546{2547 C_word bucket;2548 C_SYMBOL_TABLE *stp;25492550 C_i_check_symbol(sym);25512552 if (C_persistable_symbol(sym) ||2553 C_truep(C_permanentp(C_symbol_name(sym)))) {2554 return C_SCHEME_FALSE;2555 }25562557 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2558 bucket = lookup_bucket(sym, NULL);25592560 if (C_truep(bucket)) {2561 /* Turn it into a weak ref */2562 C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;2563 return C_SCHEME_TRUE;2564 }2565 }2566 return C_SCHEME_FALSE;2567}25682569C_regparm C_word lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)2570{2571 C_word bucket, str = C_block_item(sym, 1);2572 int key, len = C_header_size(str) - 1;25732574 if (stable == NULL) stable = symbol_table;25752576 key = hash_string(len, C_c_string(str), stable->size, stable->rand);25772578 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2579 bucket = C_block_item(bucket,1)) {2580 if (C_block_item(bucket,0) == sym) return bucket;2581 }2582 return C_SCHEME_FALSE;2583}258425852586double compute_symbol_table_load(double *avg_bucket_len, int *total_n)2587{2588 C_word bucket, last;2589 int i, j, alen = 0, bcount = 0, total = 0;25902591 for(i = 0; i < symbol_table->size; ++i) {2592 last = 0;2593 j = 0;2594 for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST;2595 bucket = C_block_item(bucket,1)) {2596 /* If the symbol is unreferenced, drop it: */2597 if (C_block_item(bucket,0) == C_SCHEME_BROKEN_WEAK_PTR) {2598 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2599 else symbol_table->table[ i ] = C_block_item(bucket,1);2600 } else {2601 last = bucket;2602 ++j;2603 }2604 }26052606 if(j > 0) {2607 alen += j;2608 ++bcount;2609 }26102611 total += j;2612 }26132614 if(avg_bucket_len != NULL)2615 *avg_bucket_len = (double)alen / (double)bcount;26162617 *total_n = total;26182619 /* return load: */2620 return (double)total / (double)symbol_table->size;2621}262226232624C_word add_symbol(C_word **ptr, C_word key, C_word bv, C_SYMBOL_TABLE *stable)2625{2626 C_word bucket, sym, b2, *p;26272628 p = *ptr;2629 sym = (C_word)p;2630 p += C_SIZEOF_SYMBOL;2631 C_block_header_init(sym, C_SYMBOL_TAG);2632 C_set_block_item(sym, 0, C_SCHEME_UNBOUND);2633 C_set_block_item(sym, 1, bv);2634 C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);2635 *ptr = p;2636 b2 = stable->table[ key ]; /* previous bucket */26372638 /* Create new weak or strong bucket depending on persistability */2639 if (C_truep(C_permanentp(bv))) {2640 bucket = C_a_pair(ptr, sym, b2);2641 } else {2642 bucket = C_a_weak_pair(ptr, sym, b2);2643 }26442645 if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);2646 else {2647 /* If a stack-allocated bucket was here, and we allocate from2648 heap-top (say, in a toplevel literal frame allocation) then we have2649 to inform the memory manager that a 2nd gen. block points to a2650 1st gen. block, hence the mutation: */2651 C_mutate(&C_block_item(bucket,1), b2);2652 stable->table[ key ] = bucket;2653 }26542655 return sym;2656}265726582659C_regparm int C_in_stackp(C_word x)2660{2661 C_word *ptr = (C_word *)(C_uword)x;26622663#if C_STACK_GROWS_DOWNWARD2664 return ptr >= C_stack_pointer_test && ptr <= stack_bottom;2665#else2666 return ptr < C_stack_pointer_test && ptr >= stack_bottom;2667#endif2668}266926702671C_regparm int C_in_heapp(C_word x)2672{2673 C_byte *ptr = (C_byte *)(C_uword)x;2674 return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||2675 (ptr >= tospace_start && ptr < tospace_limit);2676}26772678/* Only used during major GC (heap realloc) */2679static C_regparm int C_in_new_heapp(C_word x)2680{2681 C_byte *ptr = (C_byte *)(C_uword)x;2682 return (ptr >= new_tospace_start && ptr < new_tospace_limit);2683}26842685C_regparm int C_in_fromspacep(C_word x)2686{2687 C_byte *ptr = (C_byte *)(C_uword)x;2688 return (ptr >= fromspace_start && ptr < C_fromspace_limit);2689}26902691C_regparm int C_in_scratchspacep(C_word x)2692{2693 C_word *ptr = (C_word *)(C_uword)x;2694 return (ptr >= C_scratchspace_start && ptr < C_scratchspace_limit);2695}26962697/* Cons the rest-aguments together: */26982699C_regparm C_word C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)2700{2701 C_word2702 x = C_SCHEME_END_OF_LIST,2703 *p = *ptr;2704 C_SCHEME_BLOCK *node;27052706 av += c;27072708 while(--c >= n) {2709 node = (C_SCHEME_BLOCK *)p;2710 p += 3;2711 node->header = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2712 node->data[ 0 ] = *(--av);2713 node->data[ 1 ] = x;2714 x = (C_word)node;2715 }27162717 *ptr = p;2718 return x;2719}272027212722/* Print error messages and exit: */27232724void C_bad_memory(void)2725{2726 panic(C_text("there is not enough stack-space to run this executable"));2727}272827292730void C_bad_memory_2(void)2731{2732 panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));2733}273427352736/* The following two can be thrown out in the next release... */27372738void C_bad_argc(int c, int n)2739{2740 C_bad_argc_2(c, n, C_SCHEME_FALSE);2741}274227432744void C_bad_min_argc(int c, int n)2745{2746 C_bad_min_argc_2(c, n, C_SCHEME_FALSE);2747}274827492750void C_bad_argc_2(int c, int n, C_word closure)2751{2752 barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2753}275427552756void C_bad_min_argc_2(int c, int n, C_word closure)2757{2758 barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2759}276027612762void C_stack_overflow(C_char *loc)2763{2764 barf(C_STACK_OVERFLOW_ERROR, loc);2765}276627672768void C_no_closure_error(C_word x)2769{2770 barf(C_NOT_A_CLOSURE_ERROR, NULL, x);2771}277227732774void C_div_by_zero_error(C_char *loc)2775{2776 barf(C_DIVISION_BY_ZERO_ERROR, loc);2777}27782779void C_unimplemented(C_char *msg)2780{2781 C_fprintf(C_stderr, C_text("Error: unimplemented feature: %s\n"), msg);2782 C_exit_runtime(C_fix(EX_SOFTWARE));2783}27842785void C_not_an_integer_error(C_char *loc, C_word x)2786{2787 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);2788}27892790void C_not_an_uinteger_error(C_char *loc, C_word x)2791{2792 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x);2793}27942795void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka)2796{2797 C_rest_arg_out_of_bounds_error_2(c, n, ka, C_SCHEME_FALSE);2798}27992800void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure)2801{2802 barf(C_REST_ARG_OUT_OF_BOUNDS_ERROR, NULL, C_u_fixnum_difference(c, ka), C_u_fixnum_difference(n, ka), closure);2803}28042805/* Allocate and initialize record: */28062807C_regparm C_word C_string(C_word **ptr, int len, C_char *str)2808{2809 C_word buf = C_bytevector(ptr, len + 1, str);2810 C_word s = (C_word)(*ptr);2811 int n;2812 *ptr += 5; /* C_SIZEOF_STRING */2813 C_c_bytevector(buf)[ len ] = 0;2814 C_block_header_init(s, C_STRING_TAG);2815 C_set_block_item(s, 0, buf);2816 n = C_utf_count(str, len);2817 C_set_block_item(s, 1, C_fix(n));2818 C_set_block_item(s, 2, C_fix(0));2819 C_set_block_item(s, 3, C_fix(0));2820 return s;2821}28222823C_regparm C_word C_static_string(C_word **ptr, int len, C_char *str)2824{2825 C_word buf = C_static_bytevector(ptr, len + 1, str);2826 C_word s = (C_word)(*ptr);2827 int n;2828 *ptr += 5; /* C_SIZEOF_STRING */2829 C_c_bytevector(buf)[ len ] = 0;2830 C_block_header_init(s, C_STRING_TAG);2831 C_set_block_item(s, 0, buf);2832 n = C_utf_count(str, len);2833 C_set_block_item(s, 1, C_fix(n));2834 C_set_block_item(s, 2, C_fix(0));2835 C_set_block_item(s, 3, C_fix(0));2836 return s;2837}28382839C_regparm C_word C_static_bignum(C_word **ptr, int len, C_char *str)2840{2841 C_word *dptr, bignum, bigvec, retval, size, negp = 0;28422843 if (*str == '+' || *str == '-') {2844 negp = ((*str++) == '-') ? 1 : 0;2845 --len;2846 }2847 size = C_BIGNUM_BITS_TO_DIGITS((unsigned int)len << 2);28482849 dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(size)));2850 if(dptr == NULL)2851 panic(C_text("out of memory - cannot allocate static bignum"));28522853 bigvec = (C_word)dptr;2854 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(size + 1));2855 C_set_block_item(bigvec, 0, negp);2856 /* This needs to be allocated at ptr, not dptr, because GC moves type tag */2857 bignum = C_a_i_bignum_wrapper(ptr, bigvec);28582859 retval = str_to_bignum(bignum, str, str + len, 16);2860 if (retval & C_FIXNUM_BIT)2861 C_free(dptr); /* Might have been simplified */2862 return retval;2863}28642865C_regparm C_word C_static_lambda_info(C_word **ptr, int len, C_char *str)2866{2867 int dlen = sizeof(C_header) + C_align(len);2868 void *dptr = C_malloc(dlen);2869 C_word strblock;28702871 if(dptr == NULL)2872 panic(C_text("out of memory - cannot allocate static lambda info"));28732874 strblock = (C_word)dptr;2875 C_block_header_init(strblock, C_LAMBDA_INFO_TYPE | len);2876 C_memcpy(C_data_pointer(strblock), str, len);2877 return strblock;2878}287928802881C_regparm C_word C_bytevector(C_word **ptr, int len, C_char *str)2882{2883 C_word block = (C_word)(*ptr);2884 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));2885 C_block_header_init(block, C_BYTEVECTOR_TYPE | len);2886 C_memcpy(C_data_pointer(block), str, len);2887 return block;2888}288928902891C_regparm C_word C_static_bytevector(C_word **ptr, int len, C_char *str)2892{2893 /* we need to add 4 here, as utf8_decode does 3-byte lookahead */2894 C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len + 4));2895 C_word block;28962897 if(dptr == NULL)2898 panic(C_text("out of memory - cannot allocate static bytevector"));28992900 block = (C_word)dptr;2901 C_block_header_init(block, C_BYTEVECTOR_TYPE | len);2902 C_memcpy(C_data_pointer(block), str, len);2903 return block;2904}290529062907C_regparm C_word C_pbytevector(int len, C_char *str)2908{2909 C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));29102911 if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent bytevector"));29122913 pbv->header = C_BYTEVECTOR_TYPE | len;2914 C_memcpy(pbv->data, str, len);2915 return (C_word)pbv;2916}291729182919C_regparm C_word C_string2(C_word **ptr, C_char *str)2920{2921 C_word strblock = (C_word)(*ptr);2922 int len;29232924 if(str == NULL) return C_SCHEME_FALSE;29252926 len = C_strlen(str);2927 return C_string(ptr, len, str);2928}292929302931C_regparm C_word C_string2_safe(C_word **ptr, int max, C_char *str)2932{2933 C_word strblock = (C_word)(*ptr);2934 int len;29352936 if(str == NULL) return C_SCHEME_FALSE;29372938 len = C_strlen(str);29392940 if(len >= max) {2941 C_snprintf(buffer, sizeof(buffer), C_text("foreign string result exceeded maximum of %d bytes"), max);2942 panic(buffer);2943 }29442945 return C_string(ptr, len, str);2946}294729482949C_word C_closure(C_word **ptr, int cells, C_word proc, ...)2950{2951 va_list va;2952 C_word *p = *ptr,2953 *p0 = p;29542955 *p = C_CLOSURE_TYPE | cells;2956 *(++p) = proc;29572958 for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));29592960 va_end(va);2961 *ptr = p + 1;2962 return (C_word)p0;2963}296429652966/* obsolete: replaced by C_a_pair in chicken.h */2967C_regparm C_word C_pair(C_word **ptr, C_word car, C_word cdr)2968{2969 C_word *p = *ptr,2970 *p0 = p;29712972 *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2973 *(p++) = car;2974 *(p++) = cdr;2975 *ptr = p;2976 return (C_word)p0;2977}297829792980C_regparm C_word C_number(C_word **ptr, double n)2981{2982 C_word2983 *p = *ptr,2984 *p0;2985 double m;29862987 if(n <= (double)C_MOST_POSITIVE_FIXNUM2988 && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0) {2989 return C_fix(n);2990 }29912992#ifndef C_SIXTY_FOUR2993#ifndef C_DOUBLE_IS_32_BITS2994 /* Align double on 8-byte boundary: */2995 if(C_aligned8(p)) ++p;2996#endif2997#endif29982999 p0 = p;3000 *(p++) = C_FLONUM_TAG;3001 *((double *)p) = n;3002 *ptr = p + sizeof(double) / sizeof(C_word);3003 return (C_word)p0;3004}300530063007C_regparm C_word C_mpointer(C_word **ptr, void *mp)3008{3009 C_word3010 *p = *ptr,3011 *p0 = p;30123013 *(p++) = C_POINTER_TYPE | 1;3014 *((void **)p) = mp;3015 *ptr = p + 1;3016 return (C_word)p0;3017}301830193020C_regparm C_word C_mpointer_or_false(C_word **ptr, void *mp)3021{3022 C_word3023 *p = *ptr,3024 *p0 = p;30253026 if(mp == NULL) return C_SCHEME_FALSE;30273028 *(p++) = C_POINTER_TYPE | 1;3029 *((void **)p) = mp;3030 *ptr = p + 1;3031 return (C_word)p0;3032}303330343035C_regparm C_word C_taggedmpointer(C_word **ptr, C_word tag, void *mp)3036{3037 C_word3038 *p = *ptr,3039 *p0 = p;30403041 *(p++) = C_TAGGED_POINTER_TAG;3042 *((void **)p) = mp;3043 *(++p) = tag;3044 *ptr = p + 1;3045 return (C_word)p0;3046}304730483049C_regparm C_word C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)3050{3051 C_word3052 *p = *ptr,3053 *p0 = p;30543055 if(mp == NULL) return C_SCHEME_FALSE;30563057 *(p++) = C_TAGGED_POINTER_TAG;3058 *((void **)p) = mp;3059 *(++p) = tag;3060 *ptr = p + 1;3061 return (C_word)p0;3062}306330643065C_word C_vector(C_word **ptr, int n, ...)3066{3067 va_list v;3068 C_word3069 *p = *ptr,3070 *p0 = p;30713072 *(p++) = C_VECTOR_TYPE | n;3073 va_start(v, n);30743075 while(n--)3076 *(p++) = va_arg(v, C_word);30773078 *ptr = p;3079 va_end(v);3080 return (C_word)p0;3081}308230833084C_word C_structure(C_word **ptr, int n, ...)3085{3086 va_list v;3087 C_word *p = *ptr,3088 *p0 = p;30893090 *(p++) = C_STRUCTURE_TYPE | n;3091 va_start(v, n);30923093 while(n--)3094 *(p++) = va_arg(v, C_word);30953096 *ptr = p;3097 va_end(v);3098 return (C_word)p0;3099}310031013102C_regparm C_word3103C_mutate_slot(C_word *slot, C_word val)3104{3105 unsigned int mssize, newmssize, bytes;31063107 ++mutation_count;3108 /* Mutation stack exists to track mutations pointing from elsewhere3109 * into nursery. Stuff pointing anywhere else can be skipped, as3110 * well as mutations on nursery objects.3111 */3112 if(C_in_stackp((C_word)slot) || (!C_in_stackp(val) && !C_in_scratchspacep(val)))3113 return *slot = val;31143115#ifdef C_GC_HOOKS3116 if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;3117#endif31183119 if(mutation_stack_top >= mutation_stack_limit) {3120 assert(mutation_stack_top == mutation_stack_limit);3121 mssize = mutation_stack_top - mutation_stack_bottom;3122 newmssize = mssize * 2;3123 bytes = newmssize * sizeof(C_word *);31243125 if(debug_mode)3126 C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),3127 (mssize * sizeof(C_word *)) / 1024, bytes / 1024);31283129 mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, bytes);31303131 if(mutation_stack_bottom == NULL)3132 panic(C_text("out of memory - cannot re-allocate mutation stack"));31333134 mutation_stack_limit = mutation_stack_bottom + newmssize;3135 mutation_stack_top = mutation_stack_bottom + mssize;3136 }31373138 *(mutation_stack_top++) = slot;3139 ++tracked_mutation_count;3140 return *slot = val;3141}31423143/* Allocate memory in scratch space, "size" is in words, like C_alloc.3144 * The memory in the scratch space is laid out as follows: First,3145 * there's a count that indicates how big the object originally was,3146 * followed by a pointer to the slot in the object which points to the3147 * object in scratch space, finally followed by the object itself.3148 * The reason we store the slot pointer is so that we can figure out3149 * whether the object is still "live" when reallocating; that's3150 * because we don't have a saved continuation from where we can trace3151 * the live data. The reason we store the total length of the object3152 * is because we may be mutating in-place the lengths of the stored3153 * objects, and we need to know how much to skip over while scanning.3154 *3155 * If the allocating function returns, it *must* first mark all the3156 * values in scratch space as reclaimable. This is needed because3157 * there is no way to distinguish between a stale pointer into scratch3158 * space that's still somewhere on the stack in "uninitialized" memory3159 * versus a word that's been recycled by the next called function,3160 * which now holds a value that happens to have the same bit pattern3161 * but represents another thing entirely.3162 */3163C_regparm C_word C_scratch_alloc(C_uword size)3164{3165 C_word result;31663167 if (C_scratchspace_top + size + 2 >= C_scratchspace_limit) {3168 C_word *new_scratch_start, *new_scratch_top, *new_scratch_limit;3169 C_uword needed = C_scratch_usage + size + 2,3170 new_size = nmax(scratchspace_size << 1, 2UL << C_ilen(needed));31713172 /* Shrink if the needed size is much smaller, but not below minimum */3173 if (needed < (new_size >> 4)) new_size >>= 1;3174 new_size = nmax(new_size, DEFAULT_SCRATCH_SPACE_SIZE);31753176 /* TODO: Maybe we should work with two semispaces to reduce mallocs? */3177 new_scratch_start = (C_word *)C_malloc(C_wordstobytes(new_size));3178 if (new_scratch_start == NULL)3179 panic(C_text("out of memory - cannot (re-)allocate scratch space"));3180 new_scratch_top = new_scratch_start;3181 new_scratch_limit = new_scratch_start + new_size;31823183 if(debug_mode) {3184 C_dbg(C_text("debug"), C_text("resizing scratchspace dynamically from "3185 UWORD_COUNT_FORMAT_STRING "k to "3186 UWORD_COUNT_FORMAT_STRING "k ...\n"),3187 C_wordstobytes(scratchspace_size) / 1024,3188 C_wordstobytes(new_size) / 1024);3189 }31903191 if(gc_report_flag) {3192 C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING3193 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3194 (C_word)C_scratchspace_start, (C_word)C_scratchspace_limit);3195 C_dbg(C_text("GC"), C_text("(new) scratchspace: \tstart=" UWORD_FORMAT_STRING3196 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3197 (C_word)new_scratch_start, (C_word)new_scratch_limit);3198 }31993200 /* Move scratch data into new space and mutate slots pointing there.3201 * This is basically a much-simplified version of really_mark.3202 */3203 if (C_scratchspace_start != NULL) {3204 C_word val, *sscan, *slot;3205 C_uword n, words;3206 C_header h;3207 C_SCHEME_BLOCK *p, *p2;32083209 sscan = C_scratchspace_start;32103211 while (sscan < C_scratchspace_top) {3212 words = *sscan;3213 slot = (C_word *)*(sscan+1);32143215 if (*(sscan+2) == ALIGNMENT_HOLE_MARKER) val = (C_word)(sscan+3);3216 else val = (C_word)(sscan+2);32173218 sscan += words + 2;32193220 p = (C_SCHEME_BLOCK *)val;3221 h = p->header;3222 if (is_fptr(h)) /* TODO: Support scratch->scratch pointers? */3223 panic(C_text("Unexpected forwarding pointer in scratch space"));32243225 p2 = (C_SCHEME_BLOCK *)(new_scratch_top+2);32263227#ifndef C_SIXTY_FOUR3228 if ((h & C_8ALIGN_BIT) && C_aligned8(p2) &&3229 (C_word *)p2 < new_scratch_limit) {3230 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3231 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3232 }3233#endif32343235 /* If orig slot still points here, copy data and update it */3236 if (slot != NULL) {3237 assert(*slot == val);3238 n = C_header_size(p);3239 n = (h & C_BYTEBLOCK_BIT) ? C_bytestowords(n) : n;32403241 *slot = (C_word)p2;3242 /* size = header plus block size plus optional alignment hole */3243 *new_scratch_top = ((C_word *)p2-(C_word *)new_scratch_top-2) + n + 1;3244 *(new_scratch_top+1) = (C_word)slot;32453246 new_scratch_top = (C_word *)p2 + n + 1;3247 if(new_scratch_top > new_scratch_limit)3248 panic(C_text("out of memory - scratch space full while resizing"));32493250 p2->header = h;3251 p->header = ptr_to_fptr((C_uword)p2);3252 C_memcpy(p2->data, p->data, C_wordstobytes(n));3253 }3254 }3255 free(C_scratchspace_start);3256 }3257 C_scratchspace_start = new_scratch_start;3258 C_scratchspace_top = new_scratch_top;3259 C_scratchspace_limit = new_scratch_limit;3260 /* Scratch space is now tightly packed */3261 C_scratch_usage = (new_scratch_top - new_scratch_start);3262 scratchspace_size = new_size;3263 }3264 assert(C_scratchspace_top + size + 2 <= C_scratchspace_limit);32653266 *C_scratchspace_top = size;3267 *(C_scratchspace_top+1) = (C_word)NULL; /* Nothing points here 'til mutated */3268 result = (C_word)(C_scratchspace_top+2);3269 C_scratchspace_top += size + 2;3270 /* This will only be marked as "used" when it's claimed by a pointer */3271 /* C_scratch_usage += size + 2; */3272 return result;3273}32743275/* Given a root object, scan its slots recursively (the objects3276 * themselves should be shallow and non-recursive), and migrate every3277 * object stored between the memory boundaries to the supplied3278 * pointer. Scratch data pointed to by objects between the memory3279 * boundaries is updated to point to the new memory region. If the3280 * supplied pointer is NULL, the scratch memory is marked reclaimable.3281 */3282C_regparm C_word3283C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)3284{3285 C_word size, header, *data, *p = NULL, obj_in_buffer;32863287 if (C_immediatep(obj)) return obj;32883289 size = C_header_size(obj);3290 header = C_block_header(obj);3291 data = C_data_pointer(obj);3292 obj_in_buffer = (obj >= (C_word)start && obj < (C_word)end);32933294 /* Only copy object if we have a target pointer and it's in the buffer */3295 if (ptr != NULL && obj_in_buffer) {3296 p = *ptr;3297 obj = (C_word)p; /* Return the object's new location at the end */3298 }32993300 if (p != NULL) *p++ = header;33013302 if (header & C_BYTEBLOCK_BIT) {3303 if (p != NULL) {3304 *ptr = (C_word *)((C_byte *)(*ptr) + sizeof(C_header) + C_align(size));3305 C_memcpy(p, data, size);3306 }3307 } else {3308 if (p != NULL) *ptr += size + 1;33093310 if(header & C_SPECIALBLOCK_BIT) {3311 if (p != NULL) *(p++) = *data;3312 size--;3313 data++;3314 }33153316 /* TODO: See if we can somehow make this use Cheney's algorithm */3317 while(size--) {3318 C_word slot = *data;33193320 if(!C_immediatep(slot)) {3321 if (C_in_scratchspacep(slot)) {3322 if (obj_in_buffer) { /* Otherwise, don't touch scratch backpointer */3323 /* TODO: Support recursing into objects in scratch space? */3324 C_word *sp = (C_word *)slot;33253326 if (*(sp-1) == ALIGNMENT_HOLE_MARKER) --sp;3327 if (*(sp-1) != (C_word)NULL && p == NULL)3328 C_scratch_usage -= *(sp-2) + 2;3329 *(sp-1) = (C_word)p; /* This is why we traverse even if p = NULL */33303331 *data = C_SCHEME_UNBOUND; /* Ensure old reference is killed dead */3332 }3333 } else { /* Slot is not a scratchspace object: check sub-objects */3334 slot = C_migrate_buffer_object(ptr, start, end, slot);3335 }3336 }3337 if (p != NULL) *(p++) = slot;3338 else *data = slot; /* Sub-object may have moved! */3339 data++;3340 }3341 }3342 return obj; /* Should be NULL if ptr was NULL */3343}33443345/* Register an object's slot as holding data to scratch space. Only3346 * one slot can point to a scratch space object; the object in scratch3347 * space is preceded by a pointer that points to this slot (or NULL).3348 */3349C_regparm C_word C_mutate_scratch_slot(C_word *slot, C_word val)3350{3351 C_word *ptr = (C_word *)val;3352 assert(C_in_scratchspacep(val));3353/* XXX assert(slot == NULL || C_in_stackp((C_word)slot));3354*/3355 if (*(ptr-1) == ALIGNMENT_HOLE_MARKER) --ptr;3356 if (*(ptr-1) == (C_word)NULL && slot != NULL)3357 C_scratch_usage += *(ptr-2) + 2;3358 if (*(ptr-1) != (C_word)NULL && slot == NULL)3359 C_scratch_usage -= *(ptr-2) + 2;3360 *(ptr-1) = (C_word)slot; /* Remember the slot pointing here, for realloc */3361 if (slot != NULL) *slot = val;3362 return val;3363}33643365/* Initiate garbage collection: */336633673368void C_save_and_reclaim(void *trampoline, int n, C_word *av)3369{3370 C_word new_size = nmax((C_word)1 << C_ilen(n), DEFAULT_TEMPORARY_STACK_SIZE);33713372 assert(av > C_temporary_stack_bottom || av < C_temporary_stack_limit);3373 assert(C_temporary_stack == C_temporary_stack_bottom);33743375 /* Don't *immediately* slam back to default size */3376 if (new_size < temporary_stack_size / 4)3377 new_size = temporary_stack_size >> 1;33783379 if (new_size != temporary_stack_size) {33803381 if(fixed_temporary_stack_size)3382 panic(C_text("fixed temporary stack overflow (\"apply\" called with too many arguments?)"));33833384 if(gc_report_flag) {3385 C_dbg(C_text("GC"), C_text("resizing temporary stack dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),3386 C_wordstobytes(temporary_stack_size) / 1024,3387 C_wordstobytes(new_size) / 1024);3388 }33893390 C_free(C_temporary_stack_limit);33913392 if((C_temporary_stack_limit = (C_word *)C_malloc(new_size * sizeof(C_word))) == NULL)3393 panic(C_text("out of memory - could not resize temporary stack"));33943395 C_temporary_stack_bottom = C_temporary_stack_limit + new_size;3396 C_temporary_stack = C_temporary_stack_bottom;3397 temporary_stack_size = new_size;3398 }33993400 C_temporary_stack = C_temporary_stack_bottom - n;34013402 assert(C_temporary_stack >= C_temporary_stack_limit);34033404 C_memmove(C_temporary_stack, av, n * sizeof(C_word));3405 C_reclaim(trampoline, n);3406}340734083409void C_save_and_reclaim_args(void *trampoline, int n, ...)3410{3411 va_list v;3412 int i;34133414 va_start(v, n);34153416 for(i = 0; i < n; ++i)3417 C_save(va_arg(v, C_word));34183419 va_end(v);3420 C_reclaim(trampoline, n);3421}342234233424#ifdef __SUNPRO_C3425static void _mark(C_word *x, C_byte *s, C_byte **t, C_byte *l) { \3426 C_word *_x = (x), _val = *_x; \3427 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3428}3429#else3430# define _mark(x,s,t,l) \3431 C_cblock \3432 C_word *_x = (x), _val = *_x; \3433 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3434 C_cblockend3435#endif34363437/* NOTE: This macro is particularly unhygienic! */3438#define mark(x) _mark(x, tgt_space_start, tgt_space_top, tgt_space_limit)34393440C_regparm void C_reclaim(void *trampoline, C_word c)3441{3442 int i, j, fcount;3443 C_uword count;3444 C_word **msp, last;3445 C_byte *tmp, *start;3446 C_GC_ROOT *gcrp;3447 double tgc = 0;3448 volatile int finalizers_checked;3449 FINALIZER_NODE *flist;3450 C_DEBUG_INFO cell;3451 C_byte *tgt_space_start, **tgt_space_top, *tgt_space_limit;34523453 /* assert(C_timer_interrupt_counter >= 0); */34543455 if(pending_interrupts_count > 0 && C_interrupts_enabled) {3456 stack_check_demand = 0; /* forget demand: we're not going to gc yet */3457 handle_interrupt(trampoline);3458 }34593460 cell.enabled = 0;3461 cell.event = C_DEBUG_GC;3462 cell.loc = "<runtime>";3463 cell.val = "GC_MINOR";3464 C_debugger(&cell, 0, NULL);34653466 /* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */3467 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);34683469 finalizers_checked = 0;3470 C_restart_trampoline = trampoline;3471 C_restart_c = c;3472 gc_mode = GC_MINOR;3473 tgt_space_start = fromspace_start;3474 tgt_space_top = &C_fromspace_top;3475 tgt_space_limit = C_fromspace_limit;3476 weak_pair_chain = (C_word)NULL;3477 locative_chain = (C_word)NULL;34783479 start = C_fromspace_top;34803481 /* Entry point for second-level GC (on explicit request or because of full fromspace): */3482#ifdef HAVE_SIGSETJMP3483 if(C_sigsetjmp(gc_restart, 0) || start >= C_fromspace_limit) {3484#else3485 if(C_setjmp(gc_restart) || start >= C_fromspace_limit) {3486#endif3487 if(gc_bell) {3488 C_putchar(7);3489 C_fflush(stdout);3490 }34913492 tgc = C_cpu_milliseconds();34933494 if(gc_mode == GC_REALLOC) {3495 cell.val = "GC_REALLOC";3496 C_debugger(&cell, 0, NULL);3497 C_rereclaim2(percentage(heap_size, C_heap_growth), 0);3498 gc_mode = GC_MAJOR;34993500 tgt_space_start = tospace_start;3501 tgt_space_top = &tospace_top;3502 tgt_space_limit= tospace_limit;35033504 count = (C_uword)tospace_top - (C_uword)tospace_start;3505 goto never_mind_edsger;3506 }35073508 start = (C_byte *)C_align((C_uword)tospace_top);3509 gc_mode = GC_MAJOR;3510 tgt_space_start = tospace_start;3511 tgt_space_top = &tospace_top;3512 tgt_space_limit= tospace_limit;3513 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into tospace */3514 locative_chain = (C_word)NULL; /* same for locatives */35153516 cell.val = "GC_MAJOR";3517 C_debugger(&cell, 0, NULL);35183519 mark_live_heap_only_objects(tgt_space_start, tgt_space_top, tgt_space_limit);35203521 /* mark normal GC roots (see below for finalizer handling): */3522 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3523 if(!gcrp->finalizable) mark(&gcrp->value);3524 }3525 }3526 else {3527 /* Mark mutated slots: */3528 for(msp = mutation_stack_bottom; msp < mutation_stack_top; ++msp)3529 mark(*msp);3530 }35313532 mark_live_objects(tgt_space_start, tgt_space_top, tgt_space_limit);35333534 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);3535 start = *tgt_space_top;35363537 if(gc_mode == GC_MINOR) {3538 count = (C_uword)C_fromspace_top - (C_uword)start;3539 ++gc_count_1;3540 ++gc_count_1_total;3541 update_locatives(GC_MINOR, start, *tgt_space_top);3542 update_weak_pairs(GC_MINOR, start, *tgt_space_top);3543 }3544 else {3545 /* Mark finalizer list and remember pointers to non-forwarded items: */3546 last = C_block_item(pending_finalizers_symbol, 0);35473548 if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {3549 /* still finalizers pending: just mark table items... */3550 if(gc_report_flag)3551 C_dbg(C_text("GC"), C_text("%d finalized item(s) still pending\n"), j);35523553 j = fcount = 0;35543555 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3556 mark(&flist->item);3557 mark(&flist->finalizer);3558 ++fcount;3559 }35603561 /* mark finalizable GC roots: */3562 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3563 if(gcrp->finalizable) mark(&gcrp->value);3564 }35653566 if(gc_report_flag && fcount > 0)3567 C_dbg(C_text("GC"), C_text("%d finalizer value(s) marked\n"), fcount);3568 }3569 else {3570 j = fcount = 0;35713572 /* move into pending */3573 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3574 if(j < C_max_pending_finalizers) {3575 if(!is_fptr(C_block_header(flist->item)))3576 pending_finalizer_indices[ j++ ] = flist;3577 }3578 }35793580 /* mark */3581 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3582 mark(&flist->item);3583 mark(&flist->finalizer);3584 }35853586 /* mark finalizable GC roots: */3587 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3588 if(gcrp->finalizable) mark(&gcrp->value);3589 }3590 }35913592 pending_finalizer_count = j;3593 finalizers_checked = 1;35943595 if(pending_finalizer_count > 0 && gc_report_flag)3596 C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),3597 pending_finalizer_count, live_finalizer_count);35983599 /* Once more mark nested objects after (maybe) copying finalizer objects: */3600 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);36013602 /* Copy finalized items with remembered indices into `##sys#pending-finalizers'3603 (and release finalizer node): */3604 if(pending_finalizer_count > 0) {3605 if(gc_report_flag)3606 C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count);36073608 last = C_block_item(pending_finalizers_symbol, 0);3609 assert(C_block_item(last, 0) == C_fix(0));3610 C_set_block_item(last, 0, C_fix(pending_finalizer_count));36113612 for(i = 0; i < pending_finalizer_count; ++i) {3613 flist = pending_finalizer_indices[ i ];3614 C_set_block_item(last, 1 + i * 2, flist->item);3615 C_set_block_item(last, 2 + i * 2, flist->finalizer);36163617 if(flist->previous != NULL) flist->previous->next = flist->next;3618 else finalizer_list = flist->next;36193620 if(flist->next != NULL) flist->next->previous = flist->previous;36213622 flist->next = finalizer_free_list;3623 flist->previous = NULL;3624 finalizer_free_list = flist;3625 --live_finalizer_count;3626 }3627 }36283629 update_locatives(gc_mode, start, *tgt_space_top);3630 update_weak_pairs(gc_mode, start, *tgt_space_top);36313632 count = (C_uword)tospace_top - (C_uword)tospace_start; // Actual used, < heap_size/236333634 {3635 C_uword min_half = count + C_heap_half_min_free;3636 C_uword low_half = percentage(heap_size/2, C_heap_shrinkage_used);3637 C_uword grown = percentage(heap_size, C_heap_growth);3638 C_uword shrunk = percentage(heap_size, C_heap_shrinkage);36393640 if (count < low_half) {3641 heap_shrink_counter++;3642 } else {3643 heap_shrink_counter = 0;3644 }36453646 /*** isn't gc_mode always GC_MAJOR here? */3647 if(gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3648 C_heap_shrinkage > 0 &&3649 // This prevents grow, shrink, grow, shrink... spam3650 HEAP_SHRINK_COUNTS < heap_shrink_counter &&3651 (min_half * 2) <= shrunk && // Min. size trumps shrinkage3652 heap_size > MINIMAL_HEAP_SIZE) {3653 if(gc_report_flag) {3654 C_dbg(C_text("GC"), C_text("Heap low water mark hit (%d%%), shrinking...\n"),3655 C_heap_shrinkage_used);3656 }3657 heap_shrink_counter = 0;3658 C_rereclaim2(shrunk, 0);3659 } else if (gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3660 (heap_size / 2) < min_half) {3661 if(gc_report_flag) {3662 C_dbg(C_text("GC"), C_text("Heap high water mark hit, growing...\n"));3663 }3664 heap_shrink_counter = 0;3665 C_rereclaim2(grown, 0);3666 } else {3667 C_fromspace_top = tospace_top;3668 tmp = fromspace_start;3669 fromspace_start = tospace_start;3670 tospace_start = tospace_top = tmp;3671 tmp = C_fromspace_limit;3672 C_fromspace_limit = tospace_limit;3673 tospace_limit = tmp;3674 }3675 }36763677 never_mind_edsger:3678 ++gc_count_2;3679 }36803681 if(gc_mode == GC_MAJOR) {3682 tgc = C_cpu_milliseconds() - tgc;3683 gc_ms += tgc;3684 timer_accumulated_gc_ms += tgc;3685 }36863687 /* Display GC report:3688 Note: stubbornly writes to stderr - there is no provision for other output-ports */3689 if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {3690 C_dbg(C_text("GC"), C_text("level %d\tgcs(minor) %d\tgcs(major) %d\n"),3691 gc_mode, gc_count_1, gc_count_2);3692 i = (C_uword)C_stack_pointer;36933694#if C_STACK_GROWS_DOWNWARD3695 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3696 (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);3697#else3698 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3699 (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);3700#endif37013702 if(gc_mode == GC_MINOR)3703 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);37043705 C_fputc('\n', C_stderr);3706 C_dbg("GC", C_text(" from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3707 (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);37083709 if(gc_mode == GC_MAJOR)3710 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);37113712 C_fputc('\n', C_stderr);3713 C_dbg("GC", C_text(" to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),3714 (C_uword)tospace_start, (C_uword)tospace_top,3715 (C_uword)tospace_limit);3716 }37173718 /* GC will have copied any live objects out of scratch space: clear it */3719 if (C_scratchspace_start != C_scratchspace_top) {3720 /* And drop the scratchspace in case of a major or reallocating collection */3721 if (gc_mode != GC_MINOR) {3722 C_free(C_scratchspace_start);3723 C_scratchspace_start = NULL;3724 C_scratchspace_limit = NULL;3725 scratchspace_size = 0;3726 }3727 C_scratchspace_top = C_scratchspace_start;3728 C_scratch_usage = 0;3729 }37303731 if(gc_mode == GC_MAJOR) {3732 gc_count_1 = 0;3733 maximum_heap_usage = count > maximum_heap_usage ? count : maximum_heap_usage;3734 }37353736 if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);37373738 /* Unwind stack completely */3739#ifdef HAVE_SIGSETJMP3740 C_siglongjmp(C_restart, 1);3741#else3742 C_longjmp(C_restart, 1);3743#endif3744}374537463747/* Mark live objects which can exist in the nursery and/or the heap */3748static C_regparm void mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3749{3750 C_word *p;3751 TRACE_INFO *tinfo;37523753 assert(C_temporary_stack >= C_temporary_stack_limit);37543755 /* Mark live values from the currently running closure: */3756 for(p = C_temporary_stack; p < C_temporary_stack_bottom; ++p)3757 mark(p);37583759 /* Clear the mutated slot stack: */3760 mutation_stack_top = mutation_stack_bottom;37613762 /* Mark trace-buffer: */3763 for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {3764 mark(&tinfo->cooked_location);3765 mark(&tinfo->cooked1);3766 mark(&tinfo->cooked2);3767 mark(&tinfo->thread);3768 }3769}377037713772/*3773 * Mark all live *heap* objects that don't need GC mode-specific3774 * treatment. Thus, no finalizers or other GC roots.3775 *3776 * Finalizers are excluded because these need special handling:3777 * finalizers referring to dead objects must be marked and queued.3778 * However, *pending* finalizers (for objects previously determined3779 * to be collectable) are marked so that these objects stick around3780 * until after the finalizer has been run.3781 *3782 * This function does not need to be called on a minor GC, since these3783 * objects won't ever exist in the nursery.3784 */3785static C_regparm void mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3786{3787 LF_LIST *lfn;3788 C_word *p, **msp, last;3789 unsigned int i;3790 C_SYMBOL_TABLE *stp;37913792 /* Mark items in forwarding table: */3793 for(p = forwarding_table; *p != 0; p += 2) {3794 last = p[ 1 ];3795 mark(&p[ 1 ]);3796 C_block_header(p[ 0 ]) = C_block_header(last);3797 }37983799 /* Mark literal frames: */3800 for(lfn = lf_list; lfn != NULL; lfn = lfn->next)3801 for(i = 0; i < (unsigned int)lfn->count; ++i)3802 mark(&lfn->lf[i]);38033804 /* Mark symbol tables: */3805 for(stp = symbol_table_list; stp != NULL; stp = stp->next)3806 for(i = 0; i < stp->size; ++i)3807 mark(&stp->table[i]);38083809 /* Mark collectibles: */3810 for(msp = collectibles; msp < collectibles_top; ++msp)3811 if(*msp != NULL) mark(*msp);38123813 /* Mark system globals */3814 mark(&core_provided_symbol);3815 mark(&interrupt_hook_symbol);3816 mark(&error_hook_symbol);3817 mark(&callback_continuation_stack_symbol);3818 mark(&pending_finalizers_symbol);3819 mark(¤t_thread_symbol);38203821 mark(&s8vector_symbol);3822 mark(&u16vector_symbol);3823 mark(&s16vector_symbol);3824 mark(&u32vector_symbol);3825 mark(&s32vector_symbol);3826 mark(&u64vector_symbol);3827 mark(&s64vector_symbol);3828 mark(&f32vector_symbol);3829 mark(&f64vector_symbol);3830}383138323833/*3834 * Mark nested values in already moved (i.e., marked) blocks in3835 * breadth-first manner (Cheney's algorithm).3836 */3837static 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)3838{3839 int n;3840 C_word bytes;3841 C_word *p;3842 C_header h;3843 C_SCHEME_BLOCK *bp;38443845 while(heap_scan_top < *tgt_space_top) {3846 bp = (C_SCHEME_BLOCK *)heap_scan_top;38473848 if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)3849 bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);38503851 n = C_header_size(bp);3852 h = bp->header;3853 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);3854 p = bp->data;38553856 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {3857 if(h & C_SPECIALBLOCK_BIT) {3858 --n;3859 ++p;3860 }38613862 while(n--) mark(p++);3863 }38643865 heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);3866 }3867}386838693870static C_regparm void really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3871{3872 C_word val;3873 C_uword n, bytes;3874 C_header h;3875 C_SCHEME_BLOCK *p, *p2;38763877 val = *x;38783879 if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_scratchspacep(val)) {3880#ifdef C_GC_HOOKS3881 if(C_gc_trace_hook != NULL)3882 C_gc_trace_hook(x, gc_mode);3883#endif3884 return;3885 }38863887 p = (C_SCHEME_BLOCK *)val;3888 h = p->header;38893890 while(is_fptr(h)) { /* TODO: Pass in fptr chain limit? */3891 val = fptr_to_ptr(h);3892 p = (C_SCHEME_BLOCK *)val;3893 h = p->header;3894 }38953896 /* Already in target space, probably as result of chasing fptrs */3897 if ((C_uword)val >= (C_uword)tgt_space_start && (C_uword)val < (C_uword)*tgt_space_top) {3898 *x = val;3899 return;3900 }39013902 p2 = (C_SCHEME_BLOCK *)C_align((C_uword)*tgt_space_top);39033904#ifndef C_SIXTY_FOUR3905 if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tgt_space_limit) {3906 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3907 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3908 }3909#endif39103911 n = C_header_size(p);3912 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);39133914 if(C_unlikely(((C_byte *)p2 + bytes + sizeof(C_word)) > tgt_space_limit)) {3915 if (gc_mode == GC_MAJOR) {3916 /* Detect impossibilities before GC_REALLOC to preserve state: */3917 if (C_in_stackp((C_word)p) && bytes > stack_size)3918 panic(C_text("Detected corrupted data in stack"));3919 if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))3920 panic(C_text("Detected corrupted data in heap"));3921 if(C_heap_size_is_fixed)3922 panic(C_text("out of memory - heap full"));39233924 gc_mode = GC_REALLOC;3925 } else if (gc_mode == GC_REALLOC) {3926 if (new_tospace_top > new_tospace_limit) {3927 panic(C_text("out of memory - heap full while resizing"));3928 }3929 }3930#ifdef HAVE_SIGSETJMP3931 C_siglongjmp(gc_restart, 1);3932#else3933 C_longjmp(gc_restart, 1);3934#endif3935 }39363937 *tgt_space_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);39383939 *x = (C_word)p2;3940 p2->header = h;3941 p->header = ptr_to_fptr((C_uword)p2);3942 C_memcpy(p2->data, p->data, bytes);3943 if (h == C_WEAK_PAIR_TAG && !C_immediatep(p2->data[0])) {3944 p->data[0] = weak_pair_chain; /* "Recycle" the weak pair's CAR to point to prev head */3945 weak_pair_chain = (C_word)p; /* Make this fwd ptr the new head of the weak pair chain */3946 } else if (h == C_LOCATIVE_TAG) {3947 p->data[0] = locative_chain; /* "Recycle" the locative pointer field to point to prev head */3948 locative_chain = (C_word)p; /* Make this fwd ptr the new head of the locative chain */3949 }3950}395139523953/* Do a major GC into a freshly allocated heap: */39543955#define remark(x) _mark(x, new_tospace_start, &new_tospace_top, new_tospace_limit)39563957C_regparm void C_rereclaim2(C_uword size, int relative_resize)3958{3959 int i;3960 C_GC_ROOT *gcrp;3961 FINALIZER_NODE *flist;3962 C_byte *new_heapspace, *start;3963 size_t new_heapspace_size;39643965 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);39663967 /*3968 * Normally, size is "absolute": it indicates the desired size of3969 * the entire new heap. With relative_resize, size is a demanded3970 * increase of the heap, so we'll have to add it. This calculation3971 * doubles the current heap size because heap_size is already both3972 * halves. We add size*2 because we'll eventually divide the size3973 * by 2 for both halves. We also add stack_size*2 because all the3974 * nursery data is also copied to the heap on GC, and the requested3975 * memory "size" must be available after the GC.3976 */3977 if(relative_resize) size = (heap_size + size + stack_size) * 2;39783979 if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;39803981 /*3982 * When heap grows, ensure it's enough to accommodate first3983 * generation (nursery). Because we're calculating the total heap3984 * size here (fromspace *AND* tospace), we have to double the stack3985 * size, otherwise we'd accommodate only half the stack in the tospace.3986 */3987 if(size > heap_size && size - heap_size < stack_size * 2)3988 size = heap_size + stack_size * 2;39893990 /*3991 * The heap has grown but we've already hit the maximal size with the current3992 * heap, we can't do anything else but panic.3993 */3994 if(size > heap_size && heap_size >= C_maximal_heap_size)3995 panic(C_text("out of memory - heap has reached its maximum size"));39963997 if(size > C_maximal_heap_size) size = C_maximal_heap_size;39983999 if(debug_mode) {4000 C_dbg(C_text("debug"), C_text("resizing heap dynamically from "4001 UWORD_COUNT_FORMAT_STRING "k to "4002 UWORD_COUNT_FORMAT_STRING "k ...\n"),4003 heap_size / 1024, size / 1024);4004 }40054006 if(gc_report_flag) {4007 C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING4008 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4009 (C_word)fromspace_start, (C_word)C_fromspace_limit);4010 C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING4011 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4012 (C_word)tospace_start, (C_word)tospace_limit);4013 }40144015 heap_size = size; /* Total heap size of the two halves... */4016 size /= 2; /* ...each half is this big */40174018 /*4019 * Start by allocating the new heap's fromspace. After remarking,4020 * allocate the other half of the new heap (its tospace).4021 *4022 * To clarify: what we call "new_space" here is what will eventually4023 * be cycled over to "fromspace" when re-reclamation has finished4024 * (that is, after the old one has been freed).4025 */4026 if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)4027 panic(C_text("out of memory - cannot allocate heap segment"));4028 new_heapspace_size = size;40294030 new_tospace_top = new_tospace_start;4031 new_tospace_limit = new_tospace_start + size;4032 start = new_tospace_top;4033 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into new heap */4034 locative_chain = (C_word)NULL; /* same for locatives */40354036 /* Mark standard live objects in nursery and heap */4037 mark_live_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);4038 mark_live_heap_only_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);40394040 /* Mark finalizer table: */4041 for(flist = finalizer_list; flist != NULL; flist = flist->next) {4042 remark(&flist->item);4043 remark(&flist->finalizer);4044 }40454046 /* Mark *all* GC roots */4047 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {4048 remark(&gcrp->value);4049 }40504051 /* Mark nested values in already moved (marked) blocks in breadth-first manner: */4052 mark_nested_objects(start, new_tospace_start, &new_tospace_top, new_tospace_limit);4053 update_locatives(GC_REALLOC, new_tospace_top, new_tospace_top);4054 update_weak_pairs(GC_REALLOC, new_tospace_top, new_tospace_top);40554056 heap_free (heapspace1, heapspace1_size);4057 heap_free (heapspace2, heapspace2_size);40584059 if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)4060 panic(C_text("out of memory - cannot allocate next heap segment"));4061 heapspace2_size = size;40624063 heapspace1 = new_heapspace;4064 heapspace1_size = new_heapspace_size;4065 tospace_limit = tospace_start + size;4066 tospace_top = tospace_start;4067 fromspace_start = new_tospace_start;4068 C_fromspace_top = new_tospace_top;4069 C_fromspace_limit = new_tospace_limit;40704071 if(gc_report_flag) {4072 C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);4073 C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING4074 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4075 (C_word)fromspace_start, (C_word)C_fromspace_limit);4076 C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING4077 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4078 (C_word)tospace_start, (C_word)tospace_limit);4079 }40804081 if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);4082}408340844085/* When a weak pair is encountered by GC, it turns it into a4086 * forwarding reference as usual, but then it re-uses the now-defunct4087 * pair's CAR field. It clobbers that field with a plain C pointer to4088 * the current "weak pair chain". Then, the weak pair chain is4089 * updated to point to this new forwarding pointer, creating a crude4090 * linked list of sorts.4091 *4092 * We can get away with this because the slots of an object are4093 * unused/dead when it is turned into a forwarding pointer - the4094 * forwarding pointer itself is just a header, but those data fields4095 * remain allocated. Since the weak pair chain is a linked list that4096 * can *only* contain weak-pairs-turned-forwarding-pointer, we may4097 * freely access the first slot of such forwarding pointers.4098 */4099static C_regparm void update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end)4100{4101 int weakn = 0;4102 C_word p, pair, car, h;4103 C_byte *car_ptr;41044105 /* NOTE: Don't use C_block_item() because it asserts the block is4106 * big enough in DEBUGBUILD, but forwarding pointers have size 0.4107 */4108 for (p = weak_pair_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4109 /* NOTE: We only chain up the weak pairs' forwarding pointers into4110 * the new space. This is safe because already forwarded weak4111 * pairs in nursery/fromspace will be forwarded *again* into4112 * tospace/new heap. That forwarding pointer is chained up.4113 * Still-unforwarded weak pairs will be forwarded straight to the4114 * new space, and also chained up.4115 */4116 h = C_block_header(p);4117 assert(is_fptr(h));4118 pair = fptr_to_ptr(h);4119 assert(!is_fptr(C_block_header(pair)));41204121 /* The pair itself should be live */4122 assert((mode == GC_MINOR && !C_in_stackp(pair)) ||4123 (mode == GC_MAJOR && !C_in_stackp(pair) && !C_in_fromspacep(pair)) ||4124 (mode == GC_REALLOC && !C_in_stackp(pair) && !C_in_heapp(pair))); /* NB: *old* heap! */41254126 car = C_block_item(pair, 0);4127 assert(!C_immediatep(car)); /* should be ensured when adding it to the chain */4128 h = C_block_header(car);4129 while (is_fptr(h)) {4130 car = fptr_to_ptr(h);4131 h = C_block_header(car);4132 }41334134 car_ptr = (C_byte *)(C_uword)car;4135 /* If the car is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4136 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4137 if((mode == GC_MINOR && C_in_stackp(car)) ||4138 (mode == GC_MAJOR && (C_in_stackp(car) || C_in_fromspacep(car) || (car_ptr >= undead_start && car_ptr < undead_end))) ||4139 (mode == GC_REALLOC && (C_in_stackp(car) || C_in_heapp(car) || (car_ptr >= undead_start && car_ptr < undead_end)))) { /* NB: *old* heap! */41404141 C_set_block_item(pair, 0, C_SCHEME_BROKEN_WEAK_PTR);4142 ++weakn;4143 } else {4144 /* Might have moved, re-set the car to the target value */4145 C_set_block_item(pair, 0, car);4146 }4147 }4148 weak_pair_chain = (C_word)NULL;4149 if(gc_report_flag && weakn)4150 C_dbg("GC", C_text("%d recoverable weak pairs found\n"), weakn);4151}41524153/* Same as weak pairs (see above), but for locatives. Note that this4154 * also includes non-weak locatives, as these point *into* an object,4155 * so the updating of that pointer is not handled by the GC proper4156 * (which only deals with full objects).4157 */4158static C_regparm void update_locatives(int mode, C_byte *undead_start, C_byte *undead_end)4159{4160 int weakn = 0;4161 C_word p, loc, ptr, obj, h, offset;4162 C_byte *obj_ptr;41634164 for (p = locative_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4165 h = C_block_header(p);4166 assert(is_fptr(h));4167 loc = fptr_to_ptr(h);4168 assert(!is_fptr(C_block_header(loc)));41694170 /* The locative object itself should be live */4171 assert((mode == GC_MINOR && !C_in_stackp(loc)) ||4172 (mode == GC_MAJOR && !C_in_stackp(loc) && !C_in_fromspacep(loc)) ||4173 (mode == GC_REALLOC && !C_in_stackp(loc) && !C_in_heapp(loc))); /* NB: *old* heap! */41744175 ptr = C_block_item(loc, 0); /* fix up ptr */4176 if (ptr == 0) continue; /* Skip already dropped weak locatives */4177 offset = C_unfix(C_block_item(loc, 1));4178 obj = ptr - offset;41794180 h = C_block_header(obj);4181 while (is_fptr(h)) {4182 obj = fptr_to_ptr(h);4183 h = C_block_header(obj);4184 }41854186 obj_ptr = (C_byte *)(C_uword)obj;4187 /* If the object is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4188 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4189 if((mode == GC_MINOR && C_in_stackp(obj)) ||4190 (mode == GC_MAJOR && (C_in_stackp(obj) || C_in_fromspacep(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end))) ||4191 (mode == GC_REALLOC && (C_in_stackp(obj) || C_in_heapp(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end)))) { /* NB: *old* heap! */41924193 /* NOTE: This does *not* use BROKEN_WEAK_POINTER. This slot4194 * holds an unaligned raw C pointer, not a Scheme object */4195 C_set_block_item(loc, 0, 0);4196 ++weakn;4197 } else {4198 /* Might have moved, re-set the object to the target value */4199 C_set_block_item(loc, 0, obj + offset);4200 }4201 }4202 locative_chain = (C_word)NULL;4203 if(gc_report_flag && weakn)4204 C_dbg("GC", C_text("%d recoverable weak locatives found\n"), weakn);4205}420642074208void handle_interrupt(void *trampoline)4209{4210 C_word *p, h, reason, state, proc, n;4211 double c;4212 C_word av[ 4 ];42134214 /* Build vector with context information: */4215 n = C_temporary_stack_bottom - C_temporary_stack;4216 p = C_alloc(C_SIZEOF_VECTOR(2) + C_SIZEOF_VECTOR(n));4217 proc = (C_word)p;4218 *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | sizeof(C_word);4219 *(p++) = (C_word)trampoline;4220 state = (C_word)p;4221 *(p++) = C_VECTOR_TYPE | (n + 1);4222 *(p++) = proc;4223 C_memcpy(p, C_temporary_stack, n * sizeof(C_word));42244225 /* Restore state to the one at the time of the interrupt: */4226 C_temporary_stack = C_temporary_stack_bottom;4227 C_stack_limit = C_stack_hard_limit;42284229 /* Invoke high-level interrupt handler: */4230 reason = C_fix(pending_interrupts[ --pending_interrupts_count ]);4231 proc = C_block_item(interrupt_hook_symbol, 0);42324233 if(C_immediatep(proc))4234 panic(C_text("`##sys#interrupt-hook' is not defined"));42354236 c = C_cpu_milliseconds() - interrupt_time;4237 last_interrupt_latency = c;4238 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4239 /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */4240 av[ 0 ] = proc;4241 av[ 1 ] = C_SCHEME_UNDEFINED;4242 av[ 2 ] = reason;4243 av[ 3 ] = state;4244 C_do_apply(4, av);4245}424642474248void4249C_unbound_variable(C_word sym)4250{4251 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);4252}425342544255void4256C_decoding_error(C_word str, C_word index)4257{4258 barf(C_DECODING_ERROR, NULL, str, index);4259}426042614262/* XXX: This needs to be given a better name.4263 C_retrieve used to exist but it just called C_fast_retrieve */4264C_regparm C_word C_retrieve2(C_word val, char *name)4265{4266 C_word *p;4267 int len;42684269 if(val == C_SCHEME_UNBOUND) {4270 len = C_strlen(name);4271 /* this is ok: we won't return from `C_retrieve2'4272 * (or the value isn't needed). */4273 p = C_alloc(C_SIZEOF_STRING(len));4274 C_unbound_variable(C_string2(&p, name));4275 }42764277 return val;4278}427942804281void C_ccall C_invalid_procedure(C_word c, C_word *av)4282{4283 C_word self = av[0];4284 barf(C_NOT_A_CLOSURE_ERROR, NULL, self);4285}428642874288C_regparm void *C_retrieve2_symbol_proc(C_word val, char *name)4289{4290 C_word *p;4291 int len;42924293 if(val == C_SCHEME_UNBOUND) {4294 len = C_strlen(name);4295 /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */4296 p = C_alloc(C_SIZEOF_STRING(len));4297 barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));4298 }42994300 return C_fast_retrieve_proc(val);4301}43024303#ifdef C_NONUNIX4304VOID CALLBACK win_timer(PVOID data_ignored, BOOLEAN wait_or_fired)4305{4306 if (profiling) take_profile_sample();4307}4308#endif43094310static void set_profile_timer(C_uword freq)4311{4312#ifdef C_NONUNIX4313 static HANDLE timer = NULL;43144315 if (freq == 0) {4316 assert(timer != NULL);4317 if (!DeleteTimerQueueTimer(NULL, timer, NULL)) goto error;4318 timer = NULL;4319 } else if (freq < 1000) {4320 panic(C_text("On Windows, sampling can only be done in milliseconds"));4321 } else {4322 if (!CreateTimerQueueTimer(&timer, NULL, win_timer, NULL, 0, freq/1000, 0))4323 goto error;4324 }4325#else4326 struct itimerval itv;43274328 itv.it_value.tv_sec = freq / 1000000;4329 itv.it_value.tv_usec = freq % 1000000;4330 itv.it_interval.tv_sec = itv.it_value.tv_sec;4331 itv.it_interval.tv_usec = itv.it_value.tv_usec;43324333 if (setitimer(C_PROFILE_TIMER, &itv, NULL) == -1) goto error;4334#endif43354336 return;43374338error:4339 if (freq == 0) panic(C_text("error clearing timer for profiling"));4340 else panic(C_text("error setting timer for profiling"));4341}43424343/* Bump profile count for current top of trace buffer */4344static void take_profile_sample()4345{4346 PROFILE_BUCKET **bp, *b;4347 C_char *key;4348 TRACE_INFO *tb;4349 /* To count distinct calls of a procedure, remember last call */4350 static C_char *prev_key = NULL;4351 static TRACE_INFO *prev_tb = NULL;43524353 /* trace_buffer_top points *beyond* the topmost entry: Go back one */4354 if (trace_buffer_top == trace_buffer) {4355 if (!trace_buffer_full) return; /* No data yet */4356 tb = trace_buffer_limit - 1;4357 } else {4358 tb = trace_buffer_top - 1;4359 }43604361 if (tb->raw_location != NULL) {4362 key = tb->raw_location;4363 } else {4364 key = "<eval>"; /* Location string is GCable, can't use it */4365 }43664367 /* We could also just hash the pointer but that's a bit trickier */4368 bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0);4369 b = *bp;43704371 /* First try to find pre-existing item in hash table */4372 while(b != NULL) {4373 if(b->key == key) {4374 b->sample_count++;4375 if (prev_key != key && prev_tb != tb)4376 b->call_count++;4377 goto done;4378 }4379 else b = b->next;4380 }43814382 /* Not found, allocate a new item and use it as bucket's new head */4383 b = next_profile_bucket;4384 next_profile_bucket = NULL;43854386 assert(b != NULL);43874388 b->next = *bp;4389 b->key = key;4390 *bp = b;4391 b->sample_count = 1;4392 b->call_count = 1;43934394done:4395 prev_tb = tb;4396 prev_key = key;4397}439843994400C_regparm void C_trace(C_char *name)4401{4402 C_word thread;44034404 if(show_trace) {4405 C_fputs(name, C_stderr);4406 C_fputc('\n', C_stderr);4407 }44084409 /*4410 * When profiling, pre-allocate profile bucket if necessary. This4411 * is used in the signal handler, because it may not malloc.4412 */4413 if(profiling && next_profile_bucket == NULL) {4414 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4415 if (next_profile_bucket == NULL) {4416 panic(C_text("out of memory - cannot allocate profile table-bucket"));4417 }4418 }44194420 if(trace_buffer_top >= trace_buffer_limit) {4421 trace_buffer_top = trace_buffer;4422 trace_buffer_full = 1;4423 }44244425 trace_buffer_top->raw_location = name;4426 trace_buffer_top->cooked_location = C_SCHEME_FALSE;4427 trace_buffer_top->cooked1 = C_SCHEME_FALSE;4428 trace_buffer_top->cooked2 = C_SCHEME_FALSE;4429 thread = C_block_item(current_thread_symbol, 0);4430 trace_buffer_top->thread = C_and(C_blockp(thread), C_thread_id(thread));4431 ++trace_buffer_top;4432}443344344435C_regparm C_word C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)4436{4437 /* See above */4438 if(profiling && next_profile_bucket == NULL) {4439 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4440 if (next_profile_bucket == NULL) {4441 panic(C_text("out of memory - cannot allocate profile table-bucket"));4442 }4443 }44444445 if(trace_buffer_top >= trace_buffer_limit) {4446 trace_buffer_top = trace_buffer;4447 trace_buffer_full = 1;4448 }44494450 trace_buffer_top->raw_location = raw;4451 trace_buffer_top->cooked_location = l;4452 trace_buffer_top->cooked1 = x;4453 trace_buffer_top->cooked2 = y;4454 trace_buffer_top->thread = t;4455 ++trace_buffer_top;4456 return x;4457}445844594460C_char *C_dump_trace(int start)4461{4462 TRACE_INFO *ptr;4463 C_char *result;4464 int i, result_len;44654466 result_len = STRING_BUFFER_SIZE;4467 if((result = (char *)C_malloc(result_len)) == NULL)4468 horror(C_text("out of memory - cannot allocate trace-dump buffer"));44694470 *result = '\0';44714472 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4473 if(trace_buffer_full) {4474 i = C_trace_buffer_size;4475 C_strlcat(result, C_text("...more...\n"), result_len);4476 }4477 else i = trace_buffer_top - trace_buffer;44784479 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4480 ptr += start;4481 i -= start;44824483 for(;i--; ++ptr) {4484 if(ptr >= trace_buffer_limit) ptr = trace_buffer;44854486 if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {4487 result_len = C_strlen(result) * 2;4488 result = C_realloc(result, result_len);4489 if(result == NULL)4490 horror(C_text("out of memory - cannot reallocate trace-dump buffer"));4491 }44924493 if (ptr->raw_location != NULL) {4494 C_strlcat(result, ptr->raw_location, result_len);4495 } else if (ptr->cooked_location != C_SCHEME_FALSE) {4496 C_word bv = C_block_item(ptr->cooked_location, 0);4497 C_strlcat(result, C_c_string(bv), nmin(C_header_size(bv) - 1, result_len));4498 } else {4499 C_strlcat(result, "<unknown>", result_len);4500 }45014502 if(i > 0) C_strlcat(result, "\n", result_len);4503 else C_strlcat(result, " \t<--\n", result_len);4504 }4505 }45064507 return result;4508}450945104511C_regparm void C_clear_trace_buffer(void)4512{4513 int i, old_profiling = profiling;45144515 profiling = 0;45164517 if(trace_buffer == NULL) {4518 if(C_trace_buffer_size < MIN_TRACE_BUFFER_SIZE)4519 C_trace_buffer_size = MIN_TRACE_BUFFER_SIZE;45204521 trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);45224523 if(trace_buffer == NULL)4524 panic(C_text("out of memory - cannot allocate trace-buffer"));4525 }45264527 trace_buffer_top = trace_buffer;4528 trace_buffer_limit = trace_buffer + C_trace_buffer_size;4529 trace_buffer_full = 0;45304531 for(i = 0; i < C_trace_buffer_size; ++i) {4532 trace_buffer[ i ].raw_location = NULL;4533 trace_buffer[ i ].cooked_location = C_SCHEME_FALSE;4534 trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;4535 trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;4536 trace_buffer[ i ].thread = C_SCHEME_FALSE;4537 }45384539 profiling = old_profiling;4540}45414542C_word C_resize_trace_buffer(C_word size) {4543 int old_size = C_trace_buffer_size, old_profiling = profiling;4544 assert(trace_buffer);4545 profiling = 0;4546 free(trace_buffer);4547 trace_buffer = NULL;4548 C_trace_buffer_size = C_unfix(size);4549 C_clear_trace_buffer();4550 profiling = old_profiling;4551 return(C_fix(old_size));4552}45534554C_word C_fetch_trace(C_word starti, C_word buffer)4555{4556 TRACE_INFO *ptr;4557 int i, p = 0, start = C_unfix(starti);45584559 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4560 if(trace_buffer_full) i = C_trace_buffer_size;4561 else i = trace_buffer_top - trace_buffer;45624563 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4564 ptr += start;4565 i -= start;45664567 if(C_header_size(buffer) < i * 5)4568 panic(C_text("destination buffer too small for call-chain"));45694570 for(;i--; ++ptr) {4571 if(ptr >= trace_buffer_limit) ptr = trace_buffer;45724573 /* outside-pointer, will be ignored by GC */4574 C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw_location);45754576 /* subject to GC */4577 C_mutate(&C_block_item(buffer, p++), ptr->cooked_location);4578 C_mutate(&C_block_item(buffer, p++), ptr->cooked1);4579 C_mutate(&C_block_item(buffer, p++), ptr->cooked2);4580 C_mutate(&C_block_item(buffer, p++), ptr->thread);4581 }4582 }45834584 return C_fix(p);4585}45864587C_regparm C_word C_u_i_bytevector_hash(C_word str, C_word start, C_word end, C_word rnd)4588{4589 int len = C_header_size(str);4590 C_char *ptr = C_c_string(str);4591 return C_fix(hash_string(C_unfix(end) - C_unfix(start), ptr + C_unfix(start), C_MOST_POSITIVE_FIXNUM, C_unfix(rnd)));4592}45934594C_regparm void C_toplevel_entry(C_char *name)4595{4596 if(debug_mode)4597 C_dbg(C_text("debug"), C_text("entering %s...\n"), name);4598}45994600C_regparm C_word C_a_i_provide(C_word **a, int c, C_word id)4601{4602 if (debug_mode == 2) {4603 C_word str = C_block_item(id, 1);4604 C_dbg(C_text("debug"), C_text("providing %s...\n"), C_c_string(str));4605 }4606 return C_a_i_putprop(a, 3, core_provided_symbol, id, C_SCHEME_TRUE);4607}46084609C_regparm C_word C_i_providedp(C_word id)4610{4611 return C_i_getprop(core_provided_symbol, id, C_SCHEME_FALSE);4612}46134614C_word C_halt(C_word msg)4615{4616 C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;46174618 if(C_gui_mode) {4619 if(msg != C_SCHEME_FALSE) {4620 int n = C_header_size(msg);46214622 if (n >= sizeof(buffer))4623 n = sizeof(buffer) - 1;4624 C_strlcpy(buffer, (C_char *)C_data_pointer(msg), n);4625 /* XXX msg isn't checked for NUL bytes, but we can't barf here either! */4626 }4627 else C_strlcpy(buffer, C_text("(aborted)"), sizeof(buffer));46284629 C_strlcat(buffer, C_text("\n\n"), sizeof(buffer));46304631 if(dmp != NULL) C_strlcat(buffer, dmp, sizeof(buffer));46324633#if defined(_WIN32) && !defined(__CYGWIN__)4634 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);4635 ExitProcess(1);4636#endif4637 } /* otherwise fall through */46384639 if(msg != C_SCHEME_FALSE) {4640 C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);4641 C_fputc('\n', C_stderr);4642 }46434644 if(dmp != NULL)4645 C_dbg("", C_text("\n%s"), dmp);46464647 C_exit_runtime(C_fix(EX_SOFTWARE));4648 return 0;4649}465046514652C_word C_message(C_word msg)4653{4654 C_word m = C_block_item(msg, 0);4655 unsigned int n = C_header_size(m);4656 /*4657 * Strictly speaking this isn't necessary for the non-gui-mode,4658 * but let's try and keep this consistent across modes.4659 */4660 if (C_memchr(C_c_string(m), '\0', n - 1) != NULL)4661 barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);46624663 if(C_gui_mode) {4664 if (n >= sizeof(buffer))4665 n = sizeof(buffer) - 1;4666 C_strncpy(buffer, C_c_string(m), n);4667 buffer[ n ] = '\0';4668#if defined(_WIN32) && !defined(__CYGWIN__)4669 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONEXCLAMATION);4670 return C_SCHEME_UNDEFINED;4671#endif4672 } /* fall through */46734674 C_fwrite(C_c_string(m), n, sizeof(C_char), stdout);4675 C_putchar('\n');4676 return C_SCHEME_UNDEFINED;4677}467846794680C_regparm C_word C_equalp(C_word x, C_word y)4681{4682 C_header header;4683 C_word bits, n, i;46844685 C_stack_check1(barf(C_CIRCULAR_DATA_ERROR, "equal?"));46864687 loop:4688 if(x == y) return 1;46894690 if(C_immediatep(x) || C_immediatep(y)) return 0;46914692 /* NOTE: Extra check at the end is special consideration for pairs being equal to weak pairs */4693 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;4694 else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {4695 if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)4696 return C_ub_i_flonum_eqvp(C_flonum_magnitude(x),4697 C_flonum_magnitude(y));4698 else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);4699 }4700 else if(C_header_bits(x) == C_STRING_TYPE)4701 return C_equalp(C_block_item(x, 0), C_block_item(y, 0));4702 else if(header == C_SYMBOL_TAG) return 0;4703 else {4704 i = 0;4705 n = header & C_HEADER_SIZE_MASK;47064707 if(bits & C_SPECIALBLOCK_BIT) {4708 /* do not recurse into closures */4709 if(C_header_bits(x) == C_CLOSURE_TYPE)4710 return !C_memcmp(C_data_pointer(x), C_data_pointer(y), n * sizeof(C_word));4711 else if(C_block_item(x, 0) != C_block_item(y, 0)) return 0;4712 else ++i;47134714 if(n == 1) return 1;4715 }47164717 if(--n < 0) return 1;47184719 while(i < n)4720 if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;4721 else ++i;47224723 x = C_block_item(x, i);4724 y = C_block_item(y, i);4725 goto loop;4726 }4727}472847294730C_regparm C_word C_set_gc_report(C_word flag)4731{4732 if(flag == C_SCHEME_FALSE) gc_report_flag = 0;4733 else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;4734 else gc_report_flag = 1;47354736 return C_SCHEME_UNDEFINED;4737}47384739C_regparm C_word C_i_accumulated_gc_time(void)4740{4741 double tgc;47424743 tgc = timer_accumulated_gc_ms;4744 timer_accumulated_gc_ms = 0;4745 return C_fix(tgc);4746}47474748C_regparm C_word C_start_timer(void)4749{4750 tracked_mutation_count = 0;4751 mutation_count = 0;4752 gc_count_1_total = 0;4753 gc_count_2 = 0;4754 timer_start_ms = C_cpu_milliseconds();4755 gc_ms = 0;4756 maximum_heap_usage = 0;4757 return C_SCHEME_UNDEFINED;4758}475947604761void C_ccall C_stop_timer(C_word c, C_word *av)4762{4763 C_word4764 closure = av[ 0 ],4765 k = av[ 1 ];4766 double t0 = C_cpu_milliseconds() - timer_start_ms;4767 C_word4768 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_BIGNUM(1) + C_SIZEOF_VECTOR(7) ],4769 *a = ab,4770 elapsed = C_flonum(&a, t0 / 1000.0),4771 gc_time = C_flonum(&a, gc_ms / 1000.0),4772 heap_usage = C_unsigned_int_to_num(&a, maximum_heap_usage),4773 info;47744775 info = C_vector(&a, 7, elapsed, gc_time, C_fix(mutation_count),4776 C_fix(tracked_mutation_count), C_fix(gc_count_1_total),4777 C_fix(gc_count_2), heap_usage);4778 C_kontinue(k, info);4779}478047814782C_word C_exit_runtime(C_word code)4783{4784 C_fflush(NULL);4785 C__exit(C_unfix(code));4786}478747884789C_regparm C_word C_set_print_precision(C_word n)4790{4791 flonum_print_precision = C_unfix(n);4792 return C_SCHEME_UNDEFINED;4793}479447954796C_regparm C_word C_get_print_precision(void)4797{4798 return C_fix(flonum_print_precision);4799}480048014802C_regparm C_word C_read_char(C_word port)4803{4804 C_FILEPTR fp = C_port_file(port);4805 C_char buf[ 5 ];4806 int n = 0, r, c;48074808 do {4809 c = C_getc(fp);48104811 if(c == EOF) {4812 if(ferror(fp)) {4813 clearerr(fp);4814 if(n == 0) return C_fix(-1);4815 }4816 /* Found here:4817 http://mail.python.org/pipermail/python-bugs-list/2002-July/012579.html */4818#if defined(_WIN32) && !defined(__CYGWIN__)4819 else if(GetLastError() == ERROR_OPERATION_ABORTED) {4820 if(n == 0) return C_fix(-1);4821 }4822#endif4823 else if(n == 0) return C_SCHEME_END_OF_FILE;4824 }48254826 if(n == 0) r = C_utf_expect(c);4827 buf[ n++ ] = c;4828 } while(n < r);48294830 return C_utf_decode_ptr(buf);4831}483248334834C_regparm C_word C_execute_shell_command(C_word string)4835{4836 C_word bv = C_block_item(string, 0);4837 int n = C_header_size(bv);4838 char *buf = buffer;48394840 /* Windows doc says to flush all output streams before calling system.4841 Probably a good idea for all platforms. */4842 (void)fflush(NULL);48434844 if(n >= STRING_BUFFER_SIZE) {4845 if((buf = (char *)C_malloc(n + 1)) == NULL)4846 barf(C_OUT_OF_MEMORY_ERROR, "system");4847 }48484849 C_memcpy(buf, C_data_pointer(bv), n); /* includes 0 */4850 if (n - 1 != strlen(buf))4851 barf(C_ASCIIZ_REPRESENTATION_ERROR, "system", string);48524853 n = C_system(C_OS_FILENAME(bv, 0));48544855 if(buf != buffer) C_free(buf);48564857 return C_fix(n);4858}48594860/*4861 * TODO: Implement something for Windows that supports selecting on4862 * arbitrary fds (there, select() only works on network sockets and4863 * poll() is not available at all).4864 */4865C_regparm int C_check_fd_ready(int fd)4866{4867#ifdef NO_POSIX_POLL4868 fd_set in;4869 struct timeval tm;4870 int rv;4871 FD_ZERO(&in);4872 FD_SET(fd, &in);4873 tm.tv_sec = tm.tv_usec = 0;4874 rv = select(fd + 1, &in, NULL, NULL, &tm);4875 if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }4876 return rv;4877#else4878 struct pollfd ps;4879 ps.fd = fd;4880 ps.events = POLLIN;4881 return poll(&ps, 1, 0);4882#endif4883}48844885C_regparm C_word C_char_ready_p(C_word port)4886{4887#if defined(C_NONUNIX)4888 /* The best we can currently do on Windows... */4889 return C_SCHEME_TRUE;4890#else4891 int fd = C_fileno(C_port_file(port));4892 return C_mk_bool(C_check_fd_ready(fd) == 1);4893#endif4894}48954896C_regparm C_word C_i_tty_forcedp(void)4897{4898 return C_mk_bool(fake_tty_flag);4899}49004901C_regparm C_word C_i_debug_modep(void)4902{4903 return C_mk_bool(debug_mode);4904}49054906C_regparm C_word C_i_dump_heap_on_exitp(void)4907{4908 return C_mk_bool(dump_heap_on_exit);4909}49104911C_regparm C_word C_i_profilingp(void)4912{4913 return C_mk_bool(profiling);4914}49154916C_regparm C_word C_i_live_finalizer_count(void)4917{4918 return C_fix(live_finalizer_count);4919}49204921C_regparm C_word C_i_allocated_finalizer_count(void)4922{4923 return C_fix(allocated_finalizer_count);4924}492549264927C_regparm void C_raise_interrupt(int reason)4928{4929 if(C_interrupts_enabled) {4930 if(pending_interrupts_count == 0 && !handling_interrupts) {4931 pending_interrupts[ pending_interrupts_count++ ] = reason;4932 /*4933 * Force the next "soft" stack check to fail by faking a "full"4934 * stack. This causes save_and_reclaim() to be called, which4935 * invokes handle_interrupt(), which restores the stack limit.4936 */4937 C_stack_limit = stack_bottom;4938 interrupt_time = C_cpu_milliseconds();4939 } else if(pending_interrupts_count < MAX_PENDING_INTERRUPTS) {4940 int i;4941 /*4942 * Drop signals if too many, but don't queue up multiple entries4943 * for the same signal.4944 */4945 for (i = 0; i < pending_interrupts_count; ++i) {4946 if (pending_interrupts[i] == reason)4947 return;4948 }4949 pending_interrupts[ pending_interrupts_count++ ] = reason;4950 }4951 }4952}495349544955C_regparm C_word C_enable_interrupts(void)4956{4957 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4958 /* assert(C_timer_interrupt_counter > 0); */4959 C_interrupts_enabled = 1;4960 return C_SCHEME_UNDEFINED;4961}496249634964C_regparm C_word C_disable_interrupts(void)4965{4966 C_interrupts_enabled = 0;4967 return C_SCHEME_UNDEFINED;4968}496949704971C_regparm C_word C_establish_signal_handler(C_word signum, C_word reason)4972{4973 int sig = C_unfix(signum);4974#if defined(HAVE_SIGACTION)4975 struct sigaction newsig;4976#endif49774978 if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);4979 else if(reason == C_SCHEME_TRUE) C_signal(sig, SIG_DFL);4980 else {4981 signal_mapping_table[ sig ] = C_unfix(reason);4982#if defined(HAVE_SIGACTION)4983 newsig.sa_flags = 0;4984 /* The global signal handler is used for all signals, and4985 manipulates a single queue. Don't allow other signals to4986 concurrently arrive while it's doing this, to avoid races. */4987 sigfillset(&newsig.sa_mask);4988 newsig.sa_handler = global_signal_handler;4989 C_sigaction(sig, &newsig, NULL);4990#else4991 C_signal(sig, global_signal_handler);4992#endif4993 }49944995 return C_SCHEME_UNDEFINED;4996}499749984999/* Copy blocks into collected or static memory: */50005001C_regparm C_word C_copy_block(C_word from, C_word to)5002{5003 int n = C_header_size(from);5004 C_long bytes;50055006 if(C_header_bits(from) & C_BYTEBLOCK_BIT) {5007 bytes = n;5008 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));5009 }5010 else {5011 bytes = C_wordstobytes(n);5012 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));5013 }50145015 return to;5016}501750185019C_regparm C_word C_evict_block(C_word from, C_word ptr)5020{5021 int n = C_header_size(from);5022 C_long bytes;5023 C_word *p = (C_word *)C_pointer_address(ptr);50245025 if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;5026 else bytes = C_wordstobytes(n);50275028 C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));5029 return (C_word)p;5030}503150325033/* Inline versions of some standard procedures: */50345035C_regparm C_word C_i_listp(C_word x)5036{5037 C_word fast = x, slow = x;50385039 while(fast != C_SCHEME_END_OF_LIST)5040 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5041 fast = C_u_i_cdr(fast);50425043 if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;5044 else if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5045 fast = C_u_i_cdr(fast);5046 slow = C_u_i_cdr(slow);50475048 if(fast == slow) return C_SCHEME_FALSE;5049 }5050 else return C_SCHEME_FALSE;5051 }5052 else return C_SCHEME_FALSE;50535054 return C_SCHEME_TRUE;5055}50565057C_regparm C_word C_i_s8vectorp(C_word x)5058{5059 return C_i_structurep(x, s8vector_symbol);5060}50615062C_regparm C_word C_i_u16vectorp(C_word x)5063{5064 return C_i_structurep(x, u16vector_symbol);5065}50665067C_regparm C_word C_i_s16vectorp(C_word x)5068{5069 return C_i_structurep(x, s16vector_symbol);5070}50715072C_regparm C_word C_i_u32vectorp(C_word x)5073{5074 return C_i_structurep(x, u32vector_symbol);5075}50765077C_regparm C_word C_i_s32vectorp(C_word x)5078{5079 return C_i_structurep(x, s32vector_symbol);5080}50815082C_regparm C_word C_i_u64vectorp(C_word x)5083{5084 return C_i_structurep(x, u64vector_symbol);5085}50865087C_regparm C_word C_i_s64vectorp(C_word x)5088{5089 return C_i_structurep(x, s64vector_symbol);5090}50915092C_regparm C_word C_i_f32vectorp(C_word x)5093{5094 return C_i_structurep(x, f32vector_symbol);5095}50965097C_regparm C_word C_i_f64vectorp(C_word x)5098{5099 return C_i_structurep(x, f64vector_symbol);5100}510151025103C_regparm C_word C_i_string_equal_p(C_word x, C_word y)5104{5105 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5106 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);51075108 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5109 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);51105111 return C_utf_equal(x, y);5112}511351145115C_regparm C_word C_i_string_ci_equal_p(C_word x, C_word y)5116{5117 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5118 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);51195120 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5121 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);51225123 return C_utf_equal_ci(x, y);5124}512551265127C_word C_a_i_list(C_word **a, int c, ...)5128{5129 va_list v;5130 C_word x, last, current,5131 first = C_SCHEME_END_OF_LIST;51325133 va_start(v, c);51345135 for(last = C_SCHEME_UNDEFINED; c--; last = current) {5136 x = va_arg(v, C_word);5137 current = C_a_pair(a, x, C_SCHEME_END_OF_LIST);51385139 if(last != C_SCHEME_UNDEFINED)5140 C_set_block_item(last, 1, current);5141 else first = current;5142 }51435144 va_end(v);5145 return first;5146}514751485149C_word C_a_i_string(C_word **a, int c, ...)5150{5151 va_list v;5152 C_word x, s, b;5153 char *p;5154 int len;51555156 s = (C_word)(*a);5157 *a = (C_word *)((C_word)(*a) + sizeof(C_word) * 5); /* C_SIZEOF_STRING */5158 b = (C_word)(*a);51595160 C_block_header_init(s, C_STRING_TAG);5161 C_set_block_item(s, 0, b);5162 C_set_block_item(s, 1, C_fix(c));5163 C_set_block_item(s, 2, C_fix(0));5164 C_set_block_item(s, 3, C_fix(0));5165 p = (char *)C_data_pointer(b);5166 va_start(v, c);51675168 for(; c; c--) {5169 x = va_arg(v, C_word);51705171 if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)5172 p = C_utf_encode(p, C_character_code(x));5173 else break;5174 }51755176 len = p - (char *)C_data_pointer(b) + 1;5177 *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(len));5178 *p = '\0';5179 C_block_header_init(b, C_BYTEVECTOR_TYPE | len);5180 va_end(v);5181 if (c) barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);5182 return s;5183}518451855186C_word C_a_i_record(C_word **ptr, int n, ...)5187{5188 va_list v;5189 C_word *p = *ptr,5190 *p0 = p;51915192 *(p++) = C_STRUCTURE_TYPE | n;5193 va_start(v, n);51945195 while(n--)5196 *(p++) = va_arg(v, C_word);51975198 *ptr = p;5199 va_end(v);5200 return (C_word)p0;5201}520252035204C_word C_a_i_port(C_word **ptr, int n)5205{5206 C_word5207 *p = *ptr,5208 *p0 = p;5209 int i;52105211 *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);5212 *(p++) = (C_word)NULL;52135214 for(i = 0; i < C_SIZEOF_PORT - 2; ++i)5215 *(p++) = C_SCHEME_FALSE;52165217 *ptr = p;5218 return (C_word)p0;5219}522052215222C_regparm C_word C_a_i_bytevector(C_word **ptr, int c, C_word num)5223{5224 C_word *p = *ptr,5225 *p0;5226 int n = C_unfix(num);52275228#ifndef C_SIXTY_FOUR5229 /* Align on 8-byte boundary: */5230 if(C_aligned8(p)) ++p;5231#endif52325233 p0 = p;5234 *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);5235 *ptr = p + n;5236 return (C_word)p0;5237}523852395240C_word C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)5241{5242 C_word5243 *p = *ptr,5244 *p0 = p;5245 void *mp;52465247 if(C_immediatep(x)) mp = NULL;5248 else if((C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);5249 else mp = C_data_pointer(x);52505251 *(p++) = C_POINTER_TYPE | 1;5252 *((void **)p) = mp;5253 *ptr = p + 1;5254 return (C_word)p0;5255}52565257C_regparm C_word C_i_nanp(C_word x)5258{5259 if (x & C_FIXNUM_BIT) {5260 return C_SCHEME_FALSE;5261 } else if (C_immediatep(x)) {5262 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5263 } else if (C_block_header(x) == C_FLONUM_TAG) {5264 return C_u_i_flonum_nanp(x);5265 } else if (C_truep(C_bignump(x))) {5266 return C_SCHEME_FALSE;5267 } else if (C_block_header(x) == C_RATNUM_TAG) {5268 return C_SCHEME_FALSE;5269 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5270 return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) ||5271 C_truep(C_i_nanp(C_u_i_cplxnum_imag(x))));5272 } else {5273 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5274 }5275}52765277C_regparm C_word C_i_finitep(C_word x)5278{5279 if (x & C_FIXNUM_BIT) {5280 return C_SCHEME_TRUE;5281 } else if (C_immediatep(x)) {5282 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5283 } else if (C_block_header(x) == C_FLONUM_TAG) {5284 return C_u_i_flonum_finitep(x);5285 } else if (C_truep(C_bignump(x))) {5286 return C_SCHEME_TRUE;5287 } else if (C_block_header(x) == C_RATNUM_TAG) {5288 return C_SCHEME_TRUE;5289 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5290 return C_and(C_i_finitep(C_u_i_cplxnum_real(x)),5291 C_i_finitep(C_u_i_cplxnum_imag(x)));5292 } else {5293 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5294 }5295}52965297C_regparm C_word C_i_infinitep(C_word x)5298{5299 if (x & C_FIXNUM_BIT) {5300 return C_SCHEME_FALSE;5301 } else if (C_immediatep(x)) {5302 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5303 } else if (C_block_header(x) == C_FLONUM_TAG) {5304 return C_u_i_flonum_infinitep(x);5305 } else if (C_truep(C_bignump(x))) {5306 return C_SCHEME_FALSE;5307 } else if (C_block_header(x) == C_RATNUM_TAG) {5308 return C_SCHEME_FALSE;5309 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5310 return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) ||5311 C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x))));5312 } else {5313 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5314 }5315}53165317C_regparm C_word C_i_exactp(C_word x)5318{5319 if (x & C_FIXNUM_BIT) {5320 return C_SCHEME_TRUE;5321 } else if (C_immediatep(x)) {5322 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5323 } else if (C_block_header(x) == C_FLONUM_TAG) {5324 return C_SCHEME_FALSE;5325 } else if (C_truep(C_bignump(x))) {5326 return C_SCHEME_TRUE;5327 } else if (C_block_header(x) == C_RATNUM_TAG) {5328 return C_SCHEME_TRUE;5329 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5330 return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5331 } else {5332 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5333 }5334}533553365337C_regparm C_word C_i_inexactp(C_word x)5338{5339 if (x & C_FIXNUM_BIT) {5340 return C_SCHEME_FALSE;5341 } else if (C_immediatep(x)) {5342 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5343 } else if (C_block_header(x) == C_FLONUM_TAG) {5344 return C_SCHEME_TRUE;5345 } else if (C_truep(C_bignump(x))) {5346 return C_SCHEME_FALSE;5347 } else if (C_block_header(x) == C_RATNUM_TAG) {5348 return C_SCHEME_FALSE;5349 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5350 return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5351 } else {5352 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5353 }5354}535553565357C_regparm C_word C_i_zerop(C_word x)5358{5359 if (x & C_FIXNUM_BIT) {5360 return C_mk_bool(x == C_fix(0));5361 } else if (C_immediatep(x)) {5362 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5363 } else if (C_block_header(x) == C_FLONUM_TAG) {5364 return C_mk_bool(C_flonum_magnitude(x) == 0.0);5365 } else if (C_block_header(x) == C_BIGNUM_TAG ||5366 C_block_header(x) == C_RATNUM_TAG ||5367 C_block_header(x) == C_CPLXNUM_TAG) {5368 return C_SCHEME_FALSE;5369 } else {5370 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5371 }5372}53735374/* DEPRECATED */5375C_regparm C_word C_u_i_zerop(C_word x)5376{5377 return C_mk_bool(x == C_fix(0) ||5378 (!C_immediatep(x) &&5379 C_block_header(x) == C_FLONUM_TAG &&5380 C_flonum_magnitude(x) == 0.0));5381}538253835384C_regparm C_word C_i_positivep(C_word x)5385{5386 if (x & C_FIXNUM_BIT)5387 return C_i_fixnum_positivep(x);5388 else if (C_immediatep(x))5389 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5390 else if (C_block_header(x) == C_FLONUM_TAG)5391 return C_mk_bool(C_flonum_magnitude(x) > 0.0);5392 else if (C_truep(C_bignump(x)))5393 return C_mk_nbool(C_bignum_negativep(x));5394 else if (C_block_header(x) == C_RATNUM_TAG)5395 return C_i_integer_positivep(C_u_i_ratnum_num(x));5396 else if (C_block_header(x) == C_CPLXNUM_TAG)5397 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x);5398 else5399 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5400}54015402C_regparm C_word C_i_integer_positivep(C_word x)5403{5404 if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);5405 else return C_mk_nbool(C_bignum_negativep(x));5406}54075408C_regparm C_word C_i_negativep(C_word x)5409{5410 if (x & C_FIXNUM_BIT)5411 return C_i_fixnum_negativep(x);5412 else if (C_immediatep(x))5413 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5414 else if (C_block_header(x) == C_FLONUM_TAG)5415 return C_mk_bool(C_flonum_magnitude(x) < 0.0);5416 else if (C_truep(C_bignump(x)))5417 return C_mk_bool(C_bignum_negativep(x));5418 else if (C_block_header(x) == C_RATNUM_TAG)5419 return C_i_integer_negativep(C_u_i_ratnum_num(x));5420 else if (C_block_header(x) == C_CPLXNUM_TAG)5421 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x);5422 else5423 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5424}542554265427C_regparm C_word C_i_integer_negativep(C_word x)5428{5429 if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);5430 else return C_mk_bool(C_bignum_negativep(x));5431}543254335434C_regparm C_word C_i_evenp(C_word x)5435{5436 if(x & C_FIXNUM_BIT) {5437 return C_i_fixnumevenp(x);5438 } else if(C_immediatep(x)) {5439 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5440 } else if (C_block_header(x) == C_FLONUM_TAG) {5441 double val, dummy;5442 val = C_flonum_magnitude(x);5443 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5444 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5445 else5446 return C_mk_bool(fmod(val, 2.0) == 0.0);5447 } else if (C_truep(C_bignump(x))) {5448 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5449 } else { /* No need to try extended number */5450 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5451 }5452}54535454C_regparm C_word C_i_integer_evenp(C_word x)5455{5456 if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);5457 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5458}545954605461C_regparm C_word C_i_oddp(C_word x)5462{5463 if(x & C_FIXNUM_BIT) {5464 return C_i_fixnumoddp(x);5465 } else if(C_immediatep(x)) {5466 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5467 } else if(C_block_header(x) == C_FLONUM_TAG) {5468 double val, dummy;5469 val = C_flonum_magnitude(x);5470 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5471 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5472 else5473 return C_mk_bool(fmod(val, 2.0) != 0.0);5474 } else if (C_truep(C_bignump(x))) {5475 return C_mk_bool(C_bignum_digits(x)[0] & 1);5476 } else {5477 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5478 }5479}548054815482C_regparm C_word C_i_integer_oddp(C_word x)5483{5484 if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);5485 return C_mk_bool(C_bignum_digits(x)[0] & 1);5486}548754885489C_regparm C_word C_i_car(C_word x)5490{5491 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5492 barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);54935494 return C_u_i_car(x);5495}549654975498C_regparm C_word C_i_cdr(C_word x)5499{5500 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5501 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);55025503 return C_u_i_cdr(x);5504}550555065507C_regparm C_word C_i_caar(C_word x)5508{5509 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5510 bad:5511 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x);5512 }55135514 x = C_u_i_car(x);55155516 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55175518 return C_u_i_car(x);5519}552055215522C_regparm C_word C_i_cadr(C_word x)5523{5524 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5525 bad:5526 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);5527 }55285529 x = C_u_i_cdr(x);55305531 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55325533 return C_u_i_car(x);5534}553555365537C_regparm C_word C_i_cdar(C_word x)5538{5539 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5540 bad:5541 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x);5542 }55435544 x = C_u_i_car(x);55455546 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55475548 return C_u_i_cdr(x);5549}555055515552C_regparm C_word C_i_cddr(C_word x)5553{5554 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5555 bad:5556 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);5557 }55585559 x = C_u_i_cdr(x);5560 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55615562 return C_u_i_cdr(x);5563}556455655566C_regparm C_word C_i_caddr(C_word x)5567{5568 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5569 bad:5570 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);5571 }55725573 x = C_u_i_cdr(x);5574 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5575 x = C_u_i_cdr(x);5576 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55775578 return C_u_i_car(x);5579}558055815582C_regparm C_word C_i_cdddr(C_word x)5583{5584 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5585 bad:5586 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);5587 }55885589 x = C_u_i_cdr(x);5590 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5591 x = C_u_i_cdr(x);5592 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55935594 return C_u_i_cdr(x);5595}559655975598C_regparm C_word C_i_cadddr(C_word x)5599{5600 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5601 bad:5602 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);5603 }56045605 x = C_u_i_cdr(x);5606 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5607 x = C_u_i_cdr(x);5608 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5609 x = C_u_i_cdr(x);5610 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;56115612 return C_u_i_car(x);5613}561456155616C_regparm C_word C_i_cddddr(C_word x)5617{5618 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5619 bad:5620 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);5621 }56225623 x = C_u_i_cdr(x);5624 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5625 x = C_u_i_cdr(x);5626 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5627 x = C_u_i_cdr(x);5628 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;56295630 return C_u_i_cdr(x);5631}563256335634C_regparm C_word C_i_list_tail(C_word lst, C_word i)5635{5636 C_word lst0 = lst;5637 int n;56385639 if(lst != C_SCHEME_END_OF_LIST &&5640 (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))5641 barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst);56425643 if(i & C_FIXNUM_BIT) n = C_unfix(i);5644 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);56455646 while(n--) {5647 if(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)5648 barf(C_OUT_OF_BOUNDS_ERROR, "list-tail", lst0, i);56495650 lst = C_u_i_cdr(lst);5651 }56525653 return lst;5654}565556565657C_regparm C_word C_i_vector_ref(C_word v, C_word i)5658{5659 int j;56605661 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5662 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);56635664 if(i & C_FIXNUM_BIT) {5665 j = C_unfix(i);56665667 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_BOUNDS_ERROR, "vector-ref", v, i);56685669 return C_block_item(v, j);5670 }56715672 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);5673 return C_SCHEME_UNDEFINED;5674}56755676C_regparm C_word C_i_bytevector_ref(C_word v, C_word i)5677{5678 int j;56795680 if(!C_truep(C_bytevectorp(v)))5681 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", v);56825683 if(i & C_FIXNUM_BIT) {5684 j = C_unfix(i);56855686 if(j < 0 || j >= C_header_size(v))5687 barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-ref", v, i);56885689 return C_fix(((unsigned char *)C_data_pointer(v))[j]);5690 }56915692 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", i);5693 return C_SCHEME_UNDEFINED;5694}56955696C_regparm C_word C_i_s8vector_ref(C_word v, C_word i)5697{5698 int j;56995700 if(!C_truep(C_i_s8vectorp(v)))5701 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", v);57025703 if(i & C_FIXNUM_BIT) {5704 j = C_unfix(i);57055706 if(j < 0 || j >= C_header_size(C_block_item(v, 1)))5707 barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-ref", v, i);57085709 return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);5710 }57115712 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);5713 return C_SCHEME_UNDEFINED;5714}57155716C_regparm C_word C_i_u16vector_ref(C_word v, C_word i)5717{5718 int j;57195720 if(!C_truep(C_i_u16vectorp(v)))5721 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", v);57225723 if(i & C_FIXNUM_BIT) {5724 j = C_unfix(i);57255726 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))5727 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);57285729 return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);5730 }57315732 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);5733 return C_SCHEME_UNDEFINED;5734}57355736C_regparm C_word C_i_s16vector_ref(C_word v, C_word i)5737{5738 C_word size;5739 int j;57405741 if(C_immediatep(v) || C_header_bits(v) != C_STRUCTURE_TYPE ||5742 C_header_size(v) != 2 || C_block_item(v, 0) != s16vector_symbol)5743 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", v);57445745 if(i & C_FIXNUM_BIT) {5746 j = C_unfix(i);57475748 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))5749 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);57505751 return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);5752 }57535754 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);5755 return C_SCHEME_UNDEFINED;5756}57575758C_regparm C_word C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5759{5760 int j;57615762 if(!C_truep(C_i_u32vectorp(v)))5763 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", v);57645765 if(i & C_FIXNUM_BIT) {5766 j = C_unfix(i);57675768 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5769 barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-ref", v, i);57705771 return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);5772 }57735774 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);5775 return C_SCHEME_UNDEFINED;5776}57775778C_regparm C_word C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5779{5780 int j;57815782 if(!C_truep(C_i_s32vectorp(v)))5783 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", v);57845785 if(i & C_FIXNUM_BIT) {5786 j = C_unfix(i);57875788 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5789 barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-ref", v, i);57905791 return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);5792 }57935794 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);5795 return C_SCHEME_UNDEFINED;5796}57975798C_regparm C_word C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5799{5800 int j;58015802 if(!C_truep(C_i_u64vectorp(v)))5803 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", v);58045805 if(i & C_FIXNUM_BIT) {5806 j = C_unfix(i);58075808 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5809 barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-ref", v, i);58105811 return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);5812 }58135814 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);5815 return C_SCHEME_UNDEFINED;5816}58175818C_regparm C_word C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5819{5820 int j;58215822 if(!C_truep(C_i_s64vectorp(v)))5823 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", v);58245825 if(i & C_FIXNUM_BIT) {5826 j = C_unfix(i);58275828 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5829 barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-ref", v, i);58305831 return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);5832 }58335834 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);5835 return C_SCHEME_UNDEFINED;5836}58375838C_regparm C_word C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5839{5840 int j;58415842 if(!C_truep(C_i_f32vectorp(v)))5843 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", v);58445845 if(i & C_FIXNUM_BIT) {5846 j = C_unfix(i);58475848 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))5849 barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-ref", v, i);58505851 return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);5852 }58535854 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);5855 return C_SCHEME_UNDEFINED;5856}58575858C_regparm C_word C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5859{5860 C_word size;5861 int j;58625863 if(!C_truep(C_i_f64vectorp(v)))5864 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", v);58655866 if(i & C_FIXNUM_BIT) {5867 j = C_unfix(i);58685869 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))5870 barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-ref", v, i);58715872 return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);5873 }58745875 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);5876 return C_SCHEME_UNDEFINED;5877}587858795880C_regparm C_word C_i_block_ref(C_word x, C_word i)5881{5882 int j;58835884 if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)5885 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);58865887 if(i & C_FIXNUM_BIT) {5888 j = C_unfix(i);58895890 if(j < 0 || j >= C_header_size(x))5891 barf(C_OUT_OF_BOUNDS_ERROR, "##sys#block-ref", x, i);58925893 return C_block_item(x, j);5894 }58955896 barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);5897 return C_SCHEME_UNDEFINED;5898}589959005901C_regparm C_word C_i_string_set(C_word s, C_word i, C_word c)5902{5903 int j;59045905 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5906 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);59075908 if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)5909 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);59105911 if(i & C_FIXNUM_BIT) {5912 j = C_unfix(i);59135914 if(j < 0 || j >= C_unfix(C_block_item(s, 1)))5915 barf(C_OUT_OF_BOUNDS_ERROR, "string-set!", s, i);59165917 return C_utf_setsubchar(s, i, c);5918 }59195920 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);5921 return C_SCHEME_UNDEFINED;5922}592359245925C_regparm C_word C_i_string_ref(C_word s, C_word i)5926{5927 int j;59285929 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5930 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);59315932 if(i & C_FIXNUM_BIT) {5933 j = C_unfix(i);59345935 if(j < 0 || j >= C_unfix(C_block_item(s, 1)))5936 barf(C_OUT_OF_BOUNDS_ERROR, "string-ref", s, i);59375938 return C_utf_subchar(s, i);5939 }59405941 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);5942 return C_SCHEME_UNDEFINED;5943}594459455946C_regparm C_word C_i_vector_length(C_word v)5947{5948 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5949 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);59505951 return C_fix(C_header_size(v));5952}59535954C_regparm C_word C_i_bytevector_length(C_word v)5955{5956 if(C_immediatep(v) || !C_truep(C_bytevectorp(v)))5957 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-length", v);59585959 return C_fix(C_header_size(v));5960}59615962C_regparm C_word C_i_s8vector_length(C_word v)5963{5964 if(!C_truep(C_i_s8vectorp(v)))5965 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);59665967 return C_fix(C_header_size(C_block_item(v, 1)));5968}59695970C_regparm C_word C_i_u16vector_length(C_word v)5971{5972 if(!C_truep(C_i_u16vectorp(v)))5973 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);59745975 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5976}59775978C_regparm C_word C_i_s16vector_length(C_word v)5979{5980 if(!C_truep(C_i_s16vectorp(v)))5981 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);59825983 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5984}59855986C_regparm C_word C_i_u32vector_length(C_word v)5987{5988 if(!C_truep(C_i_u32vectorp(v)))5989 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);59905991 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5992}59935994C_regparm C_word C_i_s32vector_length(C_word v)5995{5996 if(!C_truep(C_i_s32vectorp(v)))5997 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);59985999 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);6000}60016002C_regparm C_word C_i_u64vector_length(C_word v)6003{6004 if(!C_truep(C_i_u64vectorp(v)))6005 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);60066007 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);6008}60096010C_regparm C_word C_i_s64vector_length(C_word v)6011{6012 if(!C_truep(C_i_s64vectorp(v)))6013 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);60146015 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);6016}601760186019C_regparm C_word C_i_f32vector_length(C_word v)6020{6021 if(!C_truep(C_i_f32vectorp(v)))6022 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);60236024 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);6025}60266027C_regparm C_word C_i_f64vector_length(C_word v)6028{6029 if(!C_truep(C_i_f64vectorp(v)))6030 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);60316032 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);6033}603460356036C_regparm C_word C_i_string_length(C_word s)6037{6038 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)6039 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);60406041 return C_block_item(s, 1);6042}604360446045C_regparm C_word C_i_length(C_word lst)6046{6047 C_word fast = lst, slow = lst;6048 int n = 0;60496050 while(slow != C_SCHEME_END_OF_LIST) {6051 if(fast != C_SCHEME_END_OF_LIST) {6052 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6053 fast = C_u_i_cdr(fast);60546055 if(fast != C_SCHEME_END_OF_LIST) {6056 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6057 fast = C_u_i_cdr(fast);6058 }6059 else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);6060 }60616062 if(fast == slow)6063 barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);6064 }6065 }60666067 if(C_immediatep(slow) || C_header_type(slow) != C_PAIR_TYPE)6068 barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);60696070 slow = C_u_i_cdr(slow);6071 ++n;6072 }60736074 return C_fix(n);6075}607660776078C_regparm C_word C_u_i_length(C_word lst)6079{6080 int n = 0;60816082 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {6083 lst = C_u_i_cdr(lst);6084 ++n;6085 }60866087 return C_fix(n);6088}60896090C_regparm C_word C_i_set_car(C_word x, C_word val)6091{6092 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6093 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);60946095 C_mutate(&C_u_i_car(x), val);6096 return C_SCHEME_UNDEFINED;6097}609860996100C_regparm C_word C_i_set_cdr(C_word x, C_word val)6101{6102 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6103 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);61046105 C_mutate(&C_u_i_cdr(x), val);6106 return C_SCHEME_UNDEFINED;6107}610861096110C_regparm C_word C_i_vector_set(C_word v, C_word i, C_word x)6111{6112 int j;61136114 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)6115 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);61166117 if(i & C_FIXNUM_BIT) {6118 j = C_unfix(i);61196120 if(j < 0 || j >= C_header_size(v))6121 barf(C_OUT_OF_BOUNDS_ERROR, "vector-set!", v, i);61226123 C_mutate(&C_block_item(v, j), x);6124 }6125 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);61266127 return C_SCHEME_UNDEFINED;6128}61296130C_regparm C_word C_i_bytevector_set(C_word v, C_word i, C_word x)6131{6132 int j;6133 C_word n;61346135 if(!C_truep(C_bytevectorp(v)))6136 barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-set!", v);61376138 if(i & C_FIXNUM_BIT) {6139 j = C_unfix(i);61406141 if(j < 0 || j >= C_header_size(v))6142 barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-set!", v, i);61436144 if(x & C_FIXNUM_BIT) {6145 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6146 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "bytevector-u8-set!", x);6147 }6148 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", x);6149 }6150 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", i);61516152 ((signed char *)C_data_pointer(v))[j] = n;6153 return C_SCHEME_UNDEFINED;6154}61556156C_regparm C_word C_i_s8vector_set(C_word v, C_word i, C_word x)6157{6158 int j;6159 C_word n;61606161 if(!C_truep(C_i_s8vectorp(v)))6162 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", v);61636164 if(i & C_FIXNUM_BIT) {6165 j = C_unfix(i);61666167 if(j < 0 || j >= C_header_size(C_block_item(v, 1)))6168 barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-set!", v, i);61696170 if(x & C_FIXNUM_BIT) {6171 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6172 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s8vector-set!", x);6173 }6174 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);6175 }6176 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", i);61776178 ((signed char *)C_data_pointer(C_block_item(v, 1)))[j] = n;6179 return C_SCHEME_UNDEFINED;6180}61816182C_regparm C_word C_i_u16vector_set(C_word v, C_word i, C_word x)6183{6184 int j;6185 C_word n;61866187 if(!C_truep(C_i_u16vectorp(v)))6188 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", v);61896190 if(i & C_FIXNUM_BIT) {6191 j = C_unfix(i);61926193 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))6194 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);61956196 if(x & C_FIXNUM_BIT) {6197 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);6198 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u16vector-set!", x);6199 }6200 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);6201 }6202 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", i);62036204 ((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6205 return C_SCHEME_UNDEFINED;6206}62076208C_regparm C_word C_i_s16vector_set(C_word v, C_word i, C_word x)6209{6210 int j;6211 C_word n;62126213 if(!C_truep(C_i_s16vectorp(v)))6214 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", v);62156216 if(i & C_FIXNUM_BIT) {6217 j = C_unfix(i);62186219 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))6220 barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);62216222 if(x & C_FIXNUM_BIT) {6223 if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);6224 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s16vector-set!", x);6225 }6226 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);6227 }6228 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", i);62296230 ((short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6231 return C_SCHEME_UNDEFINED;6232}62336234C_regparm C_word C_i_u32vector_set(C_word v, C_word i, C_word x)6235{6236 int j;6237 C_u32 n;62386239 if(!C_truep(C_i_u32vectorp(v)))6240 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", v);62416242 if(i & C_FIXNUM_BIT) {6243 j = C_unfix(i);62446245 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6246 barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-set!", v, i);62476248 if(C_truep(C_i_exact_integerp(x))) {6249 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);6250 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u32vector-set!", x);6251 }6252 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);6253 }6254 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", i);62556256 ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6257 return C_SCHEME_UNDEFINED;6258}62596260C_regparm C_word C_i_s32vector_set(C_word v, C_word i, C_word x)6261{6262 int j;6263 C_s32 n;62646265 if(!C_truep(C_i_s32vectorp(v)))6266 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", v);62676268 if(i & C_FIXNUM_BIT) {6269 j = C_unfix(i);62706271 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6272 barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-set!", v, i);62736274 if(C_truep(C_i_exact_integerp(x))) {6275 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);6276 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s32vector-set!", x);6277 }6278 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);6279 }6280 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", i);62816282 ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6283 return C_SCHEME_UNDEFINED;6284}62856286C_regparm C_word C_i_u64vector_set(C_word v, C_word i, C_word x)6287{6288 int j;6289 C_u64 n;62906291 if(!C_truep(C_i_u64vectorp(v)))6292 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", v);62936294 if(i & C_FIXNUM_BIT) {6295 j = C_unfix(i);62966297 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6298 barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-set!", v, i);62996300 if(C_truep(C_i_exact_integerp(x))) {6301 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);6302 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u64vector-set!", x);6303 }6304 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);6305 }6306 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", i);63076308 ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6309 return C_SCHEME_UNDEFINED;6310}63116312C_regparm C_word C_i_s64vector_set(C_word v, C_word i, C_word x)6313{6314 int j;6315 C_s64 n;63166317 if(!C_truep(C_i_s64vectorp(v)))6318 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", v);63196320 if(i & C_FIXNUM_BIT) {6321 j = C_unfix(i);63226323 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6324 barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-set!", v, i);63256326 if(C_truep(C_i_exact_integerp(x))) {6327 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);6328 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s64vector-set!", x);6329 }6330 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);6331 }6332 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", i);63336334 ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6335 return C_SCHEME_UNDEFINED;6336}63376338C_regparm C_word C_i_f32vector_set(C_word v, C_word i, C_word x)6339{6340 int j;6341 double f;63426343 if(!C_truep(C_i_f32vectorp(v)))6344 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", v);63456346 if(i & C_FIXNUM_BIT) {6347 j = C_unfix(i);63486349 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))6350 barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-set!", v, i);63516352 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6353 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6354 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6355 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f32vector-set!", x);6356 }6357 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);63586359 ((float *)C_data_pointer(C_block_item(v, 1)))[j] = (float)f;6360 return C_SCHEME_UNDEFINED;6361}63626363C_regparm C_word C_i_f64vector_set(C_word v, C_word i, C_word x)6364{6365 int j;6366 double f;63676368 if(!C_truep(C_i_f64vectorp(v)))6369 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", v);63706371 if(i & C_FIXNUM_BIT) {6372 j = C_unfix(i);63736374 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))6375 barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-set!", v, i);63766377 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6378 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6379 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6380 else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f64vector-set!", x);63816382 }6383 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);63846385 ((double *)C_data_pointer(C_block_item(v, 1)))[j] = f;6386 return C_SCHEME_UNDEFINED;6387}638863896390/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */6391C_regparm C_word6392C_s_a_i_abs(C_word **ptr, C_word n, C_word x)6393{6394 if (x & C_FIXNUM_BIT) {6395 return C_a_i_fixnum_abs(ptr, 1, x);6396 } else if (C_immediatep(x)) {6397 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6398 } else if (C_block_header(x) == C_FLONUM_TAG) {6399 return C_a_i_flonum_abs(ptr, 1, x);6400 } else if (C_truep(C_bignump(x))) {6401 return C_s_a_u_i_integer_abs(ptr, 1, x);6402 } else if (C_block_header(x) == C_RATNUM_TAG) {6403 return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)),6404 C_u_i_ratnum_denom(x));6405 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6406 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x);6407 } else {6408 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6409 }6410}64116412void C_ccall C_signum(C_word c, C_word *av)6413{6414 C_word k = av[ 1 ], x, y;64156416 if (c != 3) C_bad_argc_2(c, 3, av[ 0 ]);64176418 x = av[ 2 ];6419 y = av[ 3 ];64206421 if (x & C_FIXNUM_BIT) {6422 C_kontinue(k, C_i_fixnum_signum(x));6423 } else if (C_immediatep(x)) {6424 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);6425 } else if (C_block_header(x) == C_FLONUM_TAG) {6426 C_word *a = C_alloc(C_SIZEOF_FLONUM);6427 C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));6428 } else if (C_truep(C_bignump(x))) {6429 C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));6430 } else {6431 try_extended_number("##sys#extended-signum", 2, k, x);6432 }6433}643464356436/* The maximum this can allocate is a cplxnum which consists of two6437 * ratnums that consist of 2 fix bignums each. So that's6438 * C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!6439 */6440C_regparm C_word6441C_s_a_i_negate(C_word **ptr, C_word n, C_word x)6442{6443 if (x & C_FIXNUM_BIT) {6444 return C_a_i_fixnum_negate(ptr, 1, x);6445 } else if (C_immediatep(x)) {6446 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6447 } else if (C_block_header(x) == C_FLONUM_TAG) {6448 return C_a_i_flonum_negate(ptr, 1, x);6449 } else if (C_truep(C_bignump(x))) {6450 return C_s_a_u_i_integer_negate(ptr, 1, x);6451 } else if (C_block_header(x) == C_RATNUM_TAG) {6452 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)),6453 C_u_i_ratnum_denom(x));6454 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6455 return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)),6456 C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x)));6457 } else {6458 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6459 }6460}64616462/* Copy all the digits from source to target, obliterating what was6463 * there. If target is larger than source, the most significant6464 * digits will remain untouched.6465 */6466inline static void bignum_digits_destructive_copy(C_word target, C_word source)6467{6468 C_memcpy(C_bignum_digits(target), C_bignum_digits(source),6469 C_wordstobytes(C_bignum_size(source)));6470}64716472C_regparm C_word6473C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)6474{6475 if (x & C_FIXNUM_BIT) {6476 return C_a_i_fixnum_negate(ptr, 1, x);6477 } else {6478 if (C_bignum_negated_fitsinfixnump(x)) {6479 return C_fix(C_MOST_NEGATIVE_FIXNUM);6480 } else {6481 C_word res, negp = C_mk_nbool(C_bignum_negativep(x)),6482 size = C_fix(C_bignum_size(x));6483 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);6484 bignum_digits_destructive_copy(res, x);6485 return C_bignum_simplify(res);6486 }6487 }6488}648964906491/* Faster version that ignores sign */6492inline static int integer_length_abs(C_word x)6493{6494 if (x & C_FIXNUM_BIT) {6495 return C_ilen(C_wabs(C_unfix(x)));6496 } else {6497 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6498 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6499 last_digit_length = C_ilen(*last_digit);6500 return result + last_digit_length;6501 }6502}65036504C_regparm C_word C_i_integer_length(C_word x)6505{6506 if (x & C_FIXNUM_BIT) {6507 return C_i_fixnum_length(x);6508 } else if (C_truep(C_i_bignump(x))) {6509 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6510 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6511 last_digit_length = C_ilen(*last_digit);65126513 /* If *only* the highest bit is set, negating will give one less bit */6514 if (C_bignum_negativep(x) &&6515 *last_digit == ((C_uword)1 << (last_digit_length-1))) {6516 C_uword *startx = C_bignum_digits(x);6517 while (startx < last_digit && *startx == 0) ++startx;6518 if (startx == last_digit) result--;6519 }6520 return C_fix(result + last_digit_length);6521 } else {6522 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "integer-length", x);6523 }6524}65256526/* This is currently only used by Karatsuba multiplication and6527 * Burnikel-Ziegler division. */6528static C_regparm C_word6529bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end)6530{6531 if (x & C_FIXNUM_BIT) { /* Needed? */6532 if (C_unfix(start) == 0 && (end == C_SCHEME_FALSE || C_unfix(end) > 0))6533 return x;6534 else6535 return C_fix(0);6536 } else {6537 C_word negp, size;65386539 negp = C_mk_bool(C_bignum_negativep(x)); /* Always false */65406541 start = C_unfix(start);6542 /* We might get passed larger values than actually fits; pad w/ zeroes */6543 if (end == C_SCHEME_FALSE) end = C_bignum_size(x);6544 else end = nmin(C_unfix(end), C_bignum_size(x));6545 assert(start >= 0);65466547 size = end - start;65486549 if (size == 0 || start >= C_bignum_size(x)) {6550 return C_fix(0);6551 } else {6552 C_uword res, *res_digits, *x_digits;6553 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6554 res_digits = C_bignum_digits(res);6555 x_digits = C_bignum_digits(x);6556 /* Can't use bignum_digits_destructive_copy because that assumes6557 * target is at least as big as source.6558 */6559 C_memcpy(res_digits, x_digits + start, C_wordstobytes(end - start));6560 return C_bignum_simplify(res);6561 }6562 }6563}65646565/* This returns a tmp bignum negated copy of X (must be freed!) when6566 * the number is negative, or #f if it doesn't need to be negated.6567 * The size can be larger or smaller than X (it may be 1-padded).6568 */6569inline static C_word maybe_negate_bignum_for_bitwise_op(C_word x, C_word size)6570{6571 C_word nx = C_SCHEME_FALSE, xsize;6572 if (C_bignum_negativep(x)) {6573 nx = allocate_tmp_bignum(C_fix(size), C_SCHEME_FALSE, C_SCHEME_FALSE);6574 xsize = C_bignum_size(x);6575 /* Copy up until requested size, and init any remaining upper digits */6576 C_memcpy(C_bignum_digits(nx), C_bignum_digits(x),6577 C_wordstobytes(nmin(size, xsize)));6578 if (size > xsize)6579 C_memset(C_bignum_digits(nx)+xsize, 0, C_wordstobytes(size-xsize));6580 bignum_digits_destructive_negate(nx);6581 }6582 return nx;6583}65846585/* DEPRECATED */6586C_regparm C_word C_i_bit_to_bool(C_word n, C_word i)6587{6588 if (!C_truep(C_i_exact_integerp(n))) {6589 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit->boolean", n);6590 } else if (!(i & C_FIXNUM_BIT)) {6591 if (!C_immediatep(i) && C_truep(C_bignump(i)) && !C_bignum_negativep(i)) {6592 return C_i_integer_negativep(n); /* A bit silly, but strictly correct */6593 } else {6594 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6595 }6596 } else if (i & C_INT_SIGN_BIT) {6597 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6598 } else {6599 i = C_unfix(i);6600 if (n & C_FIXNUM_BIT) {6601 if (i >= C_WORD_SIZE) return C_mk_bool(n & C_INT_SIGN_BIT);6602 else return C_mk_bool((C_unfix(n) & ((C_word)1 << i)) != 0);6603 } else {6604 C_word nn, d;6605 d = i / C_BIGNUM_DIGIT_LENGTH;6606 if (d >= C_bignum_size(n)) return C_mk_bool(C_bignum_negativep(n));66076608 /* TODO: this isn't necessary, is it? */6609 if (C_truep(nn = maybe_negate_bignum_for_bitwise_op(n, d))) n = nn;66106611 i %= C_BIGNUM_DIGIT_LENGTH;6612 d = C_mk_bool((C_bignum_digits(n)[d] & (C_uword)1 << i) != 0);6613 if (C_truep(nn)) free_tmp_bignum(nn);6614 return d;6615 }6616 }6617}66186619C_regparm C_word6620C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)6621{6622 if ((x & y) & C_FIXNUM_BIT) {6623 return C_u_fixnum_and(x, y);6624 } else if (!C_truep(C_i_exact_integerp(x))) {6625 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", x);6626 } else if (!C_truep(C_i_exact_integerp(y))) {6627 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", y);6628 } else {6629 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6630 C_uword *scanr, *endr, *scans1, *ends1, *scans2;66316632 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6633 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);66346635 negp = C_mk_bool(C_bignum_negativep(x) && C_bignum_negativep(y));6636 /* Allow negative 1-bits to propagate */6637 if (C_bignum_negativep(x) || C_bignum_negativep(y))6638 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6639 else6640 size = nmin(C_bignum_size(x), C_bignum_size(y));66416642 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6643 scanr = C_bignum_digits(res);6644 endr = scanr + C_bignum_size(res);66456646 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6647 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;66486649 if (C_bignum_size(x) < C_bignum_size(y)) {6650 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6651 scans2 = C_bignum_digits(y);6652 } else {6653 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6654 scans2 = C_bignum_digits(x);6655 }66566657 while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;6658 C_memset(scanr, 0, C_wordstobytes(endr - scanr));66596660 if (C_truep(nx)) free_tmp_bignum(nx);6661 if (C_truep(ny)) free_tmp_bignum(ny);6662 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);66636664 return C_bignum_simplify(res);6665 }6666}66676668void C_ccall C_bitwise_and(C_word c, C_word *av)6669{6670 /* C_word closure = av[ 0 ]; */6671 C_word k = av[ 1 ];6672 C_word next_val, result, prev_result;6673 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;66746675 c -= 2;6676 av += 2;66776678 if (c == 0) C_kontinue(k, C_fix(-1));66796680 prev_result = result = *(av++);66816682 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6683 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", result);66846685 while (c--) {6686 next_val = *(av++);6687 a = ab[c&1]; /* One may hold last iteration result, the other is unused */6688 result = C_s_a_i_bitwise_and(&a, 2, result, next_val);6689 result = move_buffer_object(&a, ab[(c+1)&1], result);6690 clear_buffer_object(ab[(c+1)&1], prev_result);6691 prev_result = result;6692 }66936694 C_kontinue(k, result);6695}66966697C_regparm C_word6698C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)6699{6700 if ((x & y) & C_FIXNUM_BIT) {6701 return C_u_fixnum_or(x, y);6702 } else if (!C_truep(C_i_exact_integerp(x))) {6703 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", x);6704 } else if (!C_truep(C_i_exact_integerp(y))) {6705 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", y);6706 } else {6707 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6708 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;67096710 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6711 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);67126713 negp = C_mk_bool(C_bignum_negativep(x) || C_bignum_negativep(y));6714 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6715 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6716 scanr = C_bignum_digits(res);6717 endr = scanr + C_bignum_size(res);67186719 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6720 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;67216722 if (C_bignum_size(x) < C_bignum_size(y)) {6723 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6724 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6725 } else {6726 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6727 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6728 }67296730 while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;6731 while (scans2 < ends2) *scanr++ = *scans2++;6732 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6733 assert(scanr == endr);67346735 if (C_truep(nx)) free_tmp_bignum(nx);6736 if (C_truep(ny)) free_tmp_bignum(ny);6737 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);67386739 return C_bignum_simplify(res);6740 }6741}67426743void C_ccall C_bitwise_ior(C_word c, C_word *av)6744{6745 /* C_word closure = av[ 0 ]; */6746 C_word k = av[ 1 ];6747 C_word next_val, result, prev_result;6748 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;67496750 c -= 2;6751 av += 2;67526753 if (c == 0) C_kontinue(k, C_fix(0));67546755 prev_result = result = *(av++);67566757 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6758 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", result);67596760 while (c--) {6761 next_val = *(av++);6762 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6763 result = C_s_a_i_bitwise_ior(&a, 2, result, next_val);6764 result = move_buffer_object(&a, ab[(c+1)&1], result);6765 clear_buffer_object(ab[(c+1)&1], prev_result);6766 prev_result = result;6767 }67686769 C_kontinue(k, result);6770}67716772C_regparm C_word6773C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)6774{6775 if ((x & y) & C_FIXNUM_BIT) {6776 return C_fixnum_xor(x, y);6777 } else if (!C_truep(C_i_exact_integerp(x))) {6778 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", x);6779 } else if (!C_truep(C_i_exact_integerp(y))) {6780 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", y);6781 } else {6782 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6783 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;67846785 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6786 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);67876788 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6789 negp = C_mk_bool(C_bignum_negativep(x) != C_bignum_negativep(y));6790 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6791 scanr = C_bignum_digits(res);6792 endr = scanr + C_bignum_size(res);67936794 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6795 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;67966797 if (C_bignum_size(x) < C_bignum_size(y)) {6798 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6799 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6800 } else {6801 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6802 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6803 }68046805 while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;6806 while (scans2 < ends2) *scanr++ = *scans2++;6807 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6808 assert(scanr == endr);68096810 if (C_truep(nx)) free_tmp_bignum(nx);6811 if (C_truep(ny)) free_tmp_bignum(ny);6812 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);68136814 return C_bignum_simplify(res);6815 }6816}68176818void C_ccall C_bitwise_xor(C_word c, C_word *av)6819{6820 /* C_word closure = av[ 0 ]; */6821 C_word k = av[ 1 ];6822 C_word next_val, result, prev_result;6823 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;68246825 c -= 2;6826 av += 2;68276828 if (c == 0) C_kontinue(k, C_fix(0));68296830 prev_result = result = *(av++);68316832 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6833 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", result);68346835 while (c--) {6836 next_val = *(av++);6837 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6838 result = C_s_a_i_bitwise_xor(&a, 2, result, next_val);6839 result = move_buffer_object(&a, ab[(c+1)&1], result);6840 clear_buffer_object(ab[(c+1)&1], prev_result);6841 prev_result = result;6842 }68436844 C_kontinue(k, result);6845}68466847C_regparm C_word6848C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)6849{6850 if (!C_truep(C_i_exact_integerp(x))) {6851 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-not", x);6852 } else {6853 return C_s_a_u_i_integer_minus(ptr, 2, C_fix(-1), x);6854 }6855}68566857C_regparm C_word6858C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)6859{6860 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, size, negp, res,6861 digit_offset, bit_offset;68626863 if (!(y & C_FIXNUM_BIT))6864 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", y);68656866 y = C_unfix(y);6867 if (y == 0 || x == C_fix(0)) { /* Done (no shift) */6868 return x;6869 } else if (x & C_FIXNUM_BIT) {6870 if (y < 0) {6871 /* Don't shift more than a word's length (that's undefined in C!) */6872 if (-y < C_WORD_SIZE) {6873 return C_fix(C_unfix(x) >> -y);6874 } else {6875 return (x < 0) ? C_fix(-1) : C_fix(0);6876 }6877 } else if (y > 0 && y < C_WORD_SIZE-2 &&6878 /* After shifting, the length still fits a fixnum */6879 (C_ilen(C_unfix(x)) + y) < C_WORD_SIZE-2) {6880 return C_fix((C_uword)C_unfix(x) << y);6881 } else {6882 x = C_a_u_i_fix_to_big(&a, x);6883 }6884 } else if (!C_truep(C_i_bignump(x))) {6885 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "arithmetic-shift", x);6886 }68876888 negp = C_mk_bool(C_bignum_negativep(x));68896890 if (y > 0) { /* Shift left */6891 C_uword *startr, *startx, *endx, *endr;68926893 digit_offset = y / C_BIGNUM_DIGIT_LENGTH;6894 bit_offset = y % C_BIGNUM_DIGIT_LENGTH;68956896 size = C_fix(C_bignum_size(x) + digit_offset + 1);6897 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);68986899 startr = C_bignum_digits(res);6900 endr = startr + C_bignum_size(res);69016902 startx = C_bignum_digits(x);6903 endx = startx + C_bignum_size(x);69046905 /* Initialize only the lower digits we're skipping and the MSD */6906 C_memset(startr, 0, C_wordstobytes(digit_offset));6907 *(endr-1) = 0;6908 startr += digit_offset;6909 /* Can't use bignum_digits_destructive_copy because it assumes6910 * we want to copy from the start.6911 */6912 C_memcpy(startr, startx, C_wordstobytes(endx-startx));6913 if(bit_offset > 0)6914 bignum_digits_destructive_shift_left(startr, endr, bit_offset);69156916 return C_bignum_simplify(res);6917 } else if (-y >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) {6918 /* All bits are shifted out, just return 0 or -1 */6919 return C_truep(negp) ? C_fix(-1) : C_fix(0);6920 } else { /* Shift right */6921 C_uword *startr, *startx, *endr;6922 C_word nx;69236924 digit_offset = -y / C_BIGNUM_DIGIT_LENGTH;6925 bit_offset = -y % C_BIGNUM_DIGIT_LENGTH;69266927 size = C_fix(C_bignum_size(x) - digit_offset);6928 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);69296930 startr = C_bignum_digits(res);6931 endr = startr + C_bignum_size(res);69326933 size = C_bignum_size(x) + 1;6934 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) {6935 startx = C_bignum_digits(nx) + digit_offset;6936 } else {6937 startx = C_bignum_digits(x) + digit_offset;6938 }6939 /* Can't use bignum_digits_destructive_copy because that assumes6940 * target is at least as big as source.6941 */6942 C_memcpy(startr, startx, C_wordstobytes(endr-startr));6943 if(bit_offset > 0)6944 bignum_digits_destructive_shift_right(startr,endr,bit_offset,C_truep(nx));69456946 if (C_truep(nx)) {6947 free_tmp_bignum(nx);6948 bignum_digits_destructive_negate(res);6949 }6950 return C_bignum_simplify(res);6951 }6952}695369546955C_regparm C_word C_a_i_exp(C_word **a, int c, C_word n)6956{6957 double f;69586959 C_check_real(n, "exp", f);6960 return C_flonum(a, C_exp(f));6961}696269636964C_regparm C_word C_a_i_log(C_word **a, int c, C_word n)6965{6966 double f;69676968 C_check_real(n, "log", f);6969 return C_flonum(a, C_log(f));6970}697169726973C_regparm C_word C_a_i_sin(C_word **a, int c, C_word n)6974{6975 double f;69766977 C_check_real(n, "sin", f);6978 return C_flonum(a, C_sin(f));6979}698069816982C_regparm C_word C_a_i_cos(C_word **a, int c, C_word n)6983{6984 double f;69856986 C_check_real(n, "cos", f);6987 return C_flonum(a, C_cos(f));6988}698969906991C_regparm C_word C_a_i_tan(C_word **a, int c, C_word n)6992{6993 double f;69946995 C_check_real(n, "tan", f);6996 return C_flonum(a, C_tan(f));6997}699869997000C_regparm C_word C_a_i_asin(C_word **a, int c, C_word n)7001{7002 double f;70037004 C_check_real(n, "asin", f);7005 return C_flonum(a, C_asin(f));7006}700770087009C_regparm C_word C_a_i_acos(C_word **a, int c, C_word n)7010{7011 double f;70127013 C_check_real(n, "acos", f);7014 return C_flonum(a, C_acos(f));7015}701670177018C_regparm C_word C_a_i_atan(C_word **a, int c, C_word n)7019{7020 double f;70217022 C_check_real(n, "atan", f);7023 return C_flonum(a, C_atan(f));7024}702570267027C_regparm C_word C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)7028{7029 double f1, f2;70307031 C_check_real(n1, "atan", f1);7032 C_check_real(n2, "atan", f2);7033 return C_flonum(a, C_atan2(f1, f2));7034}703570367037C_regparm C_word C_a_i_sinh(C_word **a, int c, C_word n)7038{7039 double f;70407041 C_check_real(n, "sinh", f);7042 return C_flonum(a, C_sinh(f));7043}704470457046C_regparm C_word C_a_i_cosh(C_word **a, int c, C_word n)7047{7048 double f;70497050 C_check_real(n, "cosh", f);7051 return C_flonum(a, C_cosh(f));7052}705370547055C_regparm C_word C_a_i_tanh(C_word **a, int c, C_word n)7056{7057 double f;70587059 C_check_real(n, "tanh", f);7060 return C_flonum(a, C_tanh(f));7061}706270637064C_regparm C_word C_a_i_asinh(C_word **a, int c, C_word n)7065{7066 double f;70677068 C_check_real(n, "asinh", f);7069 return C_flonum(a, C_asinh(f));7070}707170727073C_regparm C_word C_a_i_acosh(C_word **a, int c, C_word n)7074{7075 double f;70767077 C_check_real(n, "acosh", f);7078 return C_flonum(a, C_acosh(f));7079}708070817082C_regparm C_word C_a_i_atanh(C_word **a, int c, C_word n)7083{7084 double f;70857086 C_check_real(n, "atanh", f);7087 return C_flonum(a, C_atanh(f));7088}708970907091C_regparm C_word C_a_i_sqrt(C_word **a, int c, C_word n)7092{7093 double f;70947095 C_check_real(n, "sqrt", f);7096 return C_flonum(a, C_sqrt(f));7097}709870997100C_regparm C_word C_i_assq(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_u_i_car(a) == x) return a;7109 }7110 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);71117112 lst = C_u_i_cdr(lst);7113 }71147115 if(lst!=C_SCHEME_END_OF_LIST)7116 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", lst);71177118 return C_SCHEME_FALSE;7119}712071217122C_regparm C_word C_i_assv(C_word x, C_word lst)7123{7124 C_word a;71257126 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7127 a = C_u_i_car(lst);71287129 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7130 if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;7131 }7132 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);71337134 lst = C_u_i_cdr(lst);7135 }71367137 if(lst!=C_SCHEME_END_OF_LIST)7138 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", lst);71397140 return C_SCHEME_FALSE;7141}714271437144C_regparm C_word C_i_assoc(C_word x, C_word lst)7145{7146 C_word a;71477148 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7149 a = C_u_i_car(lst);71507151 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7152 if(C_equalp(C_u_i_car(a), x)) return a;7153 }7154 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);71557156 lst = C_u_i_cdr(lst);7157 }71587159 if(lst!=C_SCHEME_END_OF_LIST)7160 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", lst);71617162 return C_SCHEME_FALSE;7163}716471657166C_regparm C_word C_i_memq(C_word x, C_word lst)7167{7168 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7169 if(C_u_i_car(lst) == x) return lst;7170 else lst = C_u_i_cdr(lst);7171 }71727173 if(lst!=C_SCHEME_END_OF_LIST)7174 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memq", lst);71757176 return C_SCHEME_FALSE;7177}717871797180C_regparm C_word C_u_i_memq(C_word x, C_word lst)7181{7182 while(!C_immediatep(lst)) {7183 if(C_u_i_car(lst) == x) return lst;7184 else lst = C_u_i_cdr(lst);7185 }71867187 return C_SCHEME_FALSE;7188}718971907191C_regparm C_word C_i_memv(C_word x, C_word lst)7192{7193 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7194 if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;7195 else lst = C_u_i_cdr(lst);7196 }71977198 if(lst!=C_SCHEME_END_OF_LIST)7199 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);72007201 return C_SCHEME_FALSE;7202}720372047205C_regparm C_word C_i_member(C_word x, C_word lst)7206{7207 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7208 if(C_equalp(C_u_i_car(lst), x)) return lst;7209 else lst = C_u_i_cdr(lst);7210 }72117212 if(lst!=C_SCHEME_END_OF_LIST)7213 barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", lst);72147215 return C_SCHEME_FALSE;7216}721772187219/* Inline routines for extended bindings: */72207221C_regparm C_word C_i_check_closure_2(C_word x, C_word loc)7222{7223 if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {7224 error_location = loc;7225 barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);7226 }72277228 return C_SCHEME_UNDEFINED;7229}72307231C_regparm C_word C_i_check_fixnum_2(C_word x, C_word loc)7232{7233 if(!(x & C_FIXNUM_BIT)) {7234 error_location = loc;7235 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);7236 }72377238 return C_SCHEME_UNDEFINED;7239}72407241/* DEPRECATED */7242C_regparm C_word C_i_check_exact_2(C_word x, C_word loc)7243{7244 if(C_u_i_exactp(x) == C_SCHEME_FALSE) {7245 error_location = loc;7246 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR, NULL, x);7247 }72487249 return C_SCHEME_UNDEFINED;7250}725172527253C_regparm C_word C_i_check_inexact_2(C_word x, C_word loc)7254{7255 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {7256 error_location = loc;7257 barf(C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR, NULL, x);7258 }72597260 return C_SCHEME_UNDEFINED;7261}726272637264C_regparm C_word C_i_check_char_2(C_word x, C_word loc)7265{7266 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7267 error_location = loc;7268 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7269 }72707271 return C_SCHEME_UNDEFINED;7272}727372747275C_regparm C_word C_i_check_number_2(C_word x, C_word loc)7276{7277 if (C_i_numberp(x) == C_SCHEME_FALSE) {7278 error_location = loc;7279 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);7280 }72817282 return C_SCHEME_UNDEFINED;7283}728472857286C_regparm C_word C_i_check_string_2(C_word x, C_word loc)7287{7288 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {7289 error_location = loc;7290 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);7291 }72927293 return C_SCHEME_UNDEFINED;7294}729572967297C_regparm C_word C_i_check_bytevector_2(C_word x, C_word loc)7298{7299 if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {7300 error_location = loc;7301 barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);7302 }73037304 return C_SCHEME_UNDEFINED;7305}730673077308C_regparm C_word C_i_check_vector_2(C_word x, C_word loc)7309{7310 if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {7311 error_location = loc;7312 barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);7313 }73147315 return C_SCHEME_UNDEFINED;7316}731773187319C_regparm C_word C_i_check_structure_2(C_word x, C_word st, C_word loc)7320{7321 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) {7322 error_location = loc;7323 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);7324 }73257326 return C_SCHEME_UNDEFINED;7327}732873297330C_regparm C_word C_i_check_pair_2(C_word x, C_word loc)7331{7332 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {7333 error_location = loc;7334 barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);7335 }73367337 return C_SCHEME_UNDEFINED;7338}733973407341C_regparm C_word C_i_check_boolean_2(C_word x, C_word loc)7342{7343 if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {7344 error_location = loc;7345 barf(C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR, NULL, x);7346 }73477348 return C_SCHEME_UNDEFINED;7349}735073517352C_regparm C_word C_i_check_locative_2(C_word x, C_word loc)7353{7354 if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {7355 error_location = loc;7356 barf(C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR, NULL, x);7357 }73587359 return C_SCHEME_UNDEFINED;7360}736173627363C_regparm C_word C_i_check_symbol_2(C_word x, C_word loc)7364{7365 if(!C_truep(C_i_symbolp(x))) {7366 error_location = loc;7367 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);7368 }73697370 return C_SCHEME_UNDEFINED;7371}737273737374C_regparm C_word C_i_check_keyword_2(C_word x, C_word loc)7375{7376 if(!C_truep(C_i_keywordp(x))) {7377 error_location = loc;7378 barf(C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR, NULL, x);7379 }73807381 return C_SCHEME_UNDEFINED;7382}73837384C_regparm C_word C_i_check_list_2(C_word x, C_word loc)7385{7386 if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)) {7387 error_location = loc;7388 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);7389 }73907391 return C_SCHEME_UNDEFINED;7392}739373947395C_regparm C_word C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)7396{73977398 if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {7399 error_location = loc;7400 barf(C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR, NULL, x);7401 }74027403 if((C_block_item(x, 1) & dir) != dir) { /* slot #1: I/O direction mask */7404 error_location = loc;7405 switch (dir) {7406 case C_fix(1):7407 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR, NULL, x);7408 case C_fix(2):7409 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR, NULL, x);7410 default:7411 barf(C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR, NULL, x);7412 }7413 }74147415 if(open == C_SCHEME_TRUE) {7416 if(C_block_item(x, 8) == C_FIXNUM_BIT) { /* slot #8: closed mask */7417 error_location = loc;7418 barf(C_PORT_CLOSED_ERROR, NULL, x);7419 }7420 }74217422 return C_SCHEME_UNDEFINED;7423}742474257426C_regparm C_word C_i_check_range_2(C_word i, C_word f, C_word t, C_word loc)7427{7428 if(!(i & C_FIXNUM_BIT)) {7429 error_location = loc;7430 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);7431 }74327433 int index = C_unfix(i);74347435 if(index < C_unfix(f)) {7436 error_location = loc;7437 barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);7438 }74397440 if(index >= C_unfix(t)) {7441 error_location = loc;7442 barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);7443 }74447445 return C_SCHEME_UNDEFINED;7446}744774487449C_regparm C_word C_i_check_range_including_2(C_word i, C_word f, C_word t, C_word loc)7450{7451 if(!(i & C_FIXNUM_BIT)) {7452 error_location = loc;7453 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);7454 }74557456 int index = C_unfix(i);74577458 if(index < C_unfix(f)) {7459 error_location = loc;7460 barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);7461 }74627463 if(index > C_unfix(t)) {7464 error_location = loc;7465 barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);7466 }74677468 return C_SCHEME_UNDEFINED;7469}747074717472/*XXX these are not correctly named */7473C_regparm C_word C_i_foreign_char_argumentp(C_word x)7474{7475 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)7476 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);74777478 return x;7479}748074817482C_regparm C_word C_i_foreign_fixnum_argumentp(C_word x)7483{7484 if((x & C_FIXNUM_BIT) == 0)7485 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);74867487 return x;7488}748974907491C_regparm C_word C_i_foreign_flonum_argumentp(C_word x)7492{7493 if((x & C_FIXNUM_BIT) != 0) return x;74947495 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7496 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);74977498 return x;7499}750075017502C_regparm C_word C_i_foreign_cplxnum_argumentp(C_word x)7503{7504 if((x & C_FIXNUM_BIT) != 0) return x;75057506 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7507 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);75087509 return x;7510}751175127513C_regparm C_word C_i_foreign_block_argumentp(C_word x)7514{7515 if(C_immediatep(x))7516 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);75177518 return x;7519}752075217522C_regparm C_word C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)7523{7524 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)7525 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, t, x);75267527 return x;7528}752975307531C_regparm C_word C_i_foreign_string_argumentp(C_word x)7532{7533 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)7534 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);75357536 return x;7537}753875397540C_regparm C_word C_i_foreign_symbol_argumentp(C_word x)7541{7542 if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)7543 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);75447545 return x;7546}754775487549C_regparm C_word C_i_foreign_pointer_argumentp(C_word x)7550{7551 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7552 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);75537554 return x;7555}755675577558/* TODO: Is this used? */7559C_regparm C_word C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)7560{7561 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7562 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);75637564 return x;7565}756675677568C_regparm C_word C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)7569{7570 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 07571 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))7572 barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);75737574 return x;7575}75767577C_regparm C_word C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)7578{7579 if((x & C_FIXNUM_BIT) != 0) {7580 if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;7581 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7582 } else if (C_truep(C_i_bignump(x))) {7583 if (C_truep(C_fixnum_lessp(C_i_integer_length(x), bits))) return x;7584 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7585 } else {7586 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);7587 }7588}75897590C_regparm C_word C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)7591{7592 if((x & C_FIXNUM_BIT) != 0) {7593 if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7594 else if(C_ilen(C_unfix(x)) <= C_unfix(bits)) return x;7595 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7596 } else if(C_truep(C_i_bignump(x))) {7597 if(C_bignum_negativep(x)) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7598 else if(integer_length_abs(x) <= C_unfix(bits)) return x;7599 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7600 } else {7601 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7602 }7603}76047605/* I */7606C_regparm C_word C_i_not_pair_p_2(C_word x)7607{7608 return C_mk_bool(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE);7609}761076117612C_regparm C_word C_i_null_list_p(C_word x)7613{7614 if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;7615 else if(!C_immediatep(x) && C_header_type(x) == C_PAIR_TYPE) return C_SCHEME_FALSE;7616 else {7617 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);7618 return C_SCHEME_FALSE;7619 }7620}762176227623C_regparm C_word C_i_string_null_p(C_word x)7624{7625 if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)7626 return C_mk_bool(C_unfix(C_block_item(x, 1)) == 0);7627 else {7628 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);7629 return C_SCHEME_FALSE;7630 }7631}763276337634C_regparm C_word C_i_null_pointerp(C_word x)7635{7636 if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)7637 return C_null_pointerp(x);76387639 barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);7640 return C_SCHEME_FALSE;7641}76427643/* only used here for char comparators below: */7644static C_word check_char_internal(C_word x, C_char *loc)7645{7646 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7647 error_location = intern0(loc);7648 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7649 }76507651 return C_SCHEME_UNDEFINED;7652}76537654C_regparm C_word C_i_char_equalp(C_word x, C_word y)7655{7656 check_char_internal(x, "char=?");7657 check_char_internal(y, "char=?");7658 return C_u_i_char_equalp(x, y);7659}76607661C_regparm C_word C_i_char_greaterp(C_word x, C_word y)7662{7663 check_char_internal(x, "char>?");7664 check_char_internal(y, "char>?");7665 return C_u_i_char_greaterp(x, y);7666}76677668C_regparm C_word C_i_char_lessp(C_word x, C_word y)7669{7670 check_char_internal(x, "char<?");7671 check_char_internal(y, "char<?");7672 return C_u_i_char_lessp(x, y);7673}76747675C_regparm C_word C_i_char_greater_or_equal_p(C_word x, C_word y)7676{7677 check_char_internal(x, "char>=?");7678 check_char_internal(y, "char>=?");7679 return C_u_i_char_greater_or_equal_p(x, y);7680}76817682C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y)7683{7684 check_char_internal(x, "char<=?");7685 check_char_internal(y, "char<=?");7686 return C_u_i_char_less_or_equal_p(x, y);7687}768876897690/* Primitives: */76917692void C_ccall C_apply(C_word c, C_word *av)7693{7694 C_word7695 /* closure = av[ 0 ] */7696 k = av[ 1 ],7697 fn = av[ 2 ];7698 int av2_size, i, n = c - 3;7699 int non_list_args = n - 1;7700 C_word lst, len, *ptr, *av2;77017702 if(c < 4) C_bad_min_argc(c, 4);77037704 if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE)7705 barf(C_NOT_A_CLOSURE_ERROR, "apply", fn);77067707 lst = av[ c - 1 ];7708 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7709 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);77107711 len = C_unfix(C_u_i_length(lst));7712 av2_size = 2 + non_list_args + len;77137714 if(C_demand(av2_size))7715 stack_check_demand = 0;7716 else if(stack_check_demand)7717 C_stack_overflow("apply");7718 else {7719 stack_check_demand = av2_size;7720 C_save_and_reclaim((void *)C_apply, c, av);7721 }77227723 av2 = ptr = C_alloc(av2_size);7724 *(ptr++) = fn;7725 *(ptr++) = k;77267727 if(non_list_args > 0) {7728 C_memcpy(ptr, av + 3, non_list_args * sizeof(C_word));7729 ptr += non_list_args;7730 }77317732 while(len--) {7733 *(ptr++) = C_u_i_car(lst);7734 lst = C_u_i_cdr(lst);7735 }77367737 assert((ptr - av2) == av2_size);77387739 ((C_proc)(void *)C_block_item(fn, 0))(av2_size, av2);7740}774177427743void C_ccall C_call_cc(C_word c, C_word *av)7744{7745 C_word7746 /* closure = av[ 0 ] */7747 k = av[ 1 ],7748 cont = av[ 2 ],7749 *a = C_alloc(C_SIZEOF_CLOSURE(2)),7750 wrapper;7751 void *pr = (void *)C_block_item(cont,0);7752 C_word av2[ 3 ];77537754 if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)7755 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);77567757 /* Check for values-continuation: */7758 if(C_block_item(k, 0) == (C_word)values_continuation)7759 wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);7760 else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);77617762 av2[ 0 ] = cont;7763 av2[ 1 ] = k;7764 av2[ 2 ] = wrapper;7765 ((C_proc)pr)(3, av2);7766}776777687769void C_ccall call_cc_wrapper(C_word c, C_word *av)7770{7771 C_word7772 closure = av[ 0 ],7773 /* av[ 1 ] is current k and ignored */7774 result,7775 k = C_block_item(closure, 1);77767777 if(c != 3) C_bad_argc(c, 3);77787779 result = av[ 2 ];7780 C_kontinue(k, result);7781}778277837784void C_ccall call_cc_values_wrapper(C_word c, C_word *av)7785{7786 C_word7787 closure = av[ 0 ],7788 /* av[ 1 ] is current k and ignored */7789 k = C_block_item(closure, 1),7790 x1,7791 n = c;77927793 av[ 0 ] = k; /* reuse av */7794 C_memmove(av + 1, av + 2, (n - 1) * sizeof(C_word));7795 C_do_apply(n - 1, av);7796}779777987799void C_ccall C_continuation_graft(C_word c, C_word *av)7800{7801 C_word7802 /* self = av[ 0 ] */7803 /* k = av[ 1 ] */7804 kk = av[ 2 ],7805 proc = av[ 3 ];78067807 av[ 0 ] = proc; /* reuse av */7808 av[ 1 ] = C_block_item(kk, 1);7809 ((C_proc)C_fast_retrieve_proc(proc))(2, av);7810}781178127813void C_ccall C_values(C_word c, C_word *av)7814{7815 C_word7816 /* closure = av[ 0 ] */7817 k = av[ 1 ],7818 n = c;78197820 if(c < 2) C_bad_min_argc(c, 2);78217822 /* Check continuation whether it receives multiple values: */7823 if(C_block_item(k, 0) == (C_word)values_continuation) {7824 av[ 0 ] = k; /* reuse av */7825 C_memmove(av + 1, av + 2, (c - 2) * sizeof(C_word));7826 C_do_apply(c - 1, av);7827 }78287829 if(c != 3) {7830#ifdef RELAX_MULTIVAL_CHECK7831 if(c == 2) n = C_SCHEME_UNDEFINED;7832 else n = av[ 2 ];7833#else7834 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7835#endif7836 }7837 else n = av[ 2 ];78387839 C_kontinue(k, n);7840}784178427843void C_ccall C_apply_values(C_word c, C_word *av)7844{7845 C_word7846 /* closure = av[ 0 ] */7847 k = av[ 1 ],7848 lst, len, n;78497850 if(c != 3) C_bad_argc(c, 3);78517852 lst = av[ 2 ];78537854 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7855 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);78567857 /* Check whether continuation receives multiple values: */7858 if(C_block_item(k, 0) == (C_word)values_continuation) {7859 C_word *av2, *ptr;78607861 len = C_unfix(C_u_i_length(lst));7862 n = len + 1;78637864 if(C_demand(n))7865 stack_check_demand = 0;7866 else if(stack_check_demand)7867 C_stack_overflow("apply");7868 else {7869 stack_check_demand = n;7870 C_save_and_reclaim((void *)C_apply_values, c, av);7871 }78727873 av2 = C_alloc(n);7874 av2[ 0 ] = k;7875 ptr = av2 + 1;7876 while(len--) {7877 *(ptr++) = C_u_i_car(lst);7878 lst = C_u_i_cdr(lst);7879 }78807881 C_do_apply(n, av2);7882 }78837884 if(C_immediatep(lst)) {7885#ifdef RELAX_MULTIVAL_CHECK7886 n = C_SCHEME_UNDEFINED;7887#else7888 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7889#endif7890 }7891 else if(C_header_type(lst) == C_PAIR_TYPE) {7892 if(C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)7893 n = C_u_i_car(lst);7894 else {7895#ifdef RELAX_MULTIVAL_CHECK7896 n = C_u_i_car(lst);7897#else7898 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7899#endif7900 }7901 }7902 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);79037904 C_kontinue(k, n);7905}790679077908void C_ccall C_call_with_values(C_word c, C_word *av)7909{7910 C_word7911 /* closure = av[ 0 ] */7912 k = av[ 1 ],7913 thunk,7914 kont,7915 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7916 kk;79177918 if(c != 4) C_bad_argc(c, 4);79197920 thunk = av[ 2 ];7921 kont = av[ 3 ];79227923 if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)7924 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);79257926 if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)7927 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);79287929 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7930 av[ 0 ] = thunk; /* reuse av */7931 av[ 1 ] = kk;7932 C_do_apply(2, av);7933}793479357936void C_ccall C_u_call_with_values(C_word c, C_word *av)7937{7938 C_word7939 /* closure = av[ 0 ] */7940 k = av[ 1 ],7941 thunk = av[ 2 ],7942 kont = av[ 3 ],7943 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7944 kk;79457946 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7947 av[ 0 ] = thunk; /* reuse av */7948 av[ 1 ] = kk;7949 C_do_apply(2, av);7950}795179527953void C_ccall values_continuation(C_word c, C_word *av)7954{7955 C_word7956 closure = av[ 0 ],7957 kont = C_block_item(closure, 1),7958 k = C_block_item(closure, 2),7959 *av2 = C_alloc(c + 1);79607961 av2[ 0 ] = kont;7962 av2[ 1 ] = k;7963 C_memcpy(av2 + 2, av + 1, (c - 1) * sizeof(C_word));7964 C_do_apply(c + 1, av2);7965}79667967static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i)7968{7969 C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab, num, denom, gcd, a_div_g;79707971 switch (i) {7972 case C_fix(0): return C_fix(0);7973 case C_fix(1): return rat;7974 case C_fix(-1):7975 num = C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(rat));7976 return C_ratnum(ptr, num , C_u_i_ratnum_denom(rat));7977 /* default: CONTINUE BELOW */7978 }79797980 num = C_u_i_ratnum_num(rat);7981 denom = C_u_i_ratnum_denom(rat);79827983 /* a/b * c/d = a*c / b*d [with b = 1] */7984 /* = ((a / g) * c) / (d / g) */7985 /* With g = gcd(a, d) and a = x [Knuth, 4.5.1] */7986 gcd = C_s_a_u_i_integer_gcd(&a, 2, i, denom);79877988 /* Calculate a/g (= i/gcd), which will later be multiplied by y */7989 a_div_g = C_s_a_u_i_integer_quotient(&a, 2, i, gcd);7990 if (a_div_g == C_fix(0)) {7991 clear_buffer_object(ab, gcd);7992 return C_fix(0); /* Save some work */7993 }79947995 /* Final numerator = a/g * c (= a_div_g * num) */7996 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g, num);79977998 /* Final denominator = d/g (= denom/gcd) */7999 denom = C_s_a_u_i_integer_quotient(ptr, 2, denom, gcd);80008001 num = move_buffer_object(ptr, ab, num);8002 denom = move_buffer_object(ptr, ab, denom);80038004 clear_buffer_object(ab, gcd);8005 clear_buffer_object(ab, a_div_g);80068007 if (denom == C_fix(1)) return num;8008 else return C_ratnum(ptr, num, denom);8009}80108011static C_word rat_times_rat(C_word **ptr, C_word x, C_word y)8012{8013 C_word ab[C_SIZEOF_FIX_BIGNUM * 6], *a = ab,8014 num, denom, xnum, xdenom, ynum, ydenom,8015 g1, g2, a_div_g1, b_div_g2, c_div_g2, d_div_g1;80168017 xnum = C_u_i_ratnum_num(x);8018 xdenom = C_u_i_ratnum_denom(x);8019 ynum = C_u_i_ratnum_num(y);8020 ydenom = C_u_i_ratnum_denom(y);80218022 /* a/b * c/d = a*c / b*d [generic] */8023 /* = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1)) */8024 /* With g1 = gcd(a, d) and g2 = gcd(b, c) [Knuth, 4.5.1] */8025 g1 = C_s_a_u_i_integer_gcd(&a, 2, xnum, ydenom);8026 g2 = C_s_a_u_i_integer_gcd(&a, 2, ynum, xdenom);80278028 /* Calculate a/g1 (= xnum/g1), which will later be multiplied by c/g2 */8029 a_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, xnum, g1);80308031 /* Calculate c/g2 (= ynum/g2), which will later be multiplied by a/g1 */8032 c_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, ynum, g2);80338034 /* Final numerator = a/g1 * c/g2 */8035 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g1, c_div_g2);80368037 /* Now, do the same for the denominator.... */80388039 /* Calculate b/g2 (= xdenom/g2), which will later be multiplied by d/g1 */8040 b_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g2);80418042 /* Calculate d/g1 (= ydenom/g1), which will later be multiplied by b/g2 */8043 d_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);80448045 /* Final denominator = b/g2 * d/g1 */8046 denom = C_s_a_u_i_integer_times(ptr, 2, b_div_g2, d_div_g1);80478048 num = move_buffer_object(ptr, ab, num);8049 denom = move_buffer_object(ptr, ab, denom);80508051 clear_buffer_object(ab, g1);8052 clear_buffer_object(ab, g2);8053 clear_buffer_object(ab, a_div_g1);8054 clear_buffer_object(ab, b_div_g2);8055 clear_buffer_object(ab, c_div_g2);8056 clear_buffer_object(ab, d_div_g1);80578058 if (denom == C_fix(1)) return num;8059 else return C_ratnum(ptr, num, denom);8060}80618062static C_word8063cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)8064{8065 /* Allocation here is kind of tricky: Each intermediate result can8066 * be at most a ratnum consisting of two bignums (2 digits), so8067 * C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2) = 9 words8068 */8069 C_word ab[(C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2))*6], *a = ab,8070 r1, r2, i1, i2, r, i;80718072 /* a+bi * c+di = (a*c - b*d) + (a*d + b*c)i */8073 /* We call these: r1 = a*c, r2 = b*d, i1 = a*d, i2 = b*c */8074 r1 = C_s_a_i_times(&a, 2, rx, ry);8075 r2 = C_s_a_i_times(&a, 2, ix, iy);8076 i1 = C_s_a_i_times(&a, 2, rx, iy);8077 i2 = C_s_a_i_times(&a, 2, ix, ry);80788079 r = C_s_a_i_minus(ptr, 2, r1, r2);8080 i = C_s_a_i_plus(ptr, 2, i1, i2);80818082 r = move_buffer_object(ptr, ab, r);8083 i = move_buffer_object(ptr, ab, i);80848085 clear_buffer_object(ab, r1);8086 clear_buffer_object(ab, r2);8087 clear_buffer_object(ab, i1);8088 clear_buffer_object(ab, i2);80898090 if (C_truep(C_u_i_zerop2(i))) return r;8091 else return C_cplxnum(ptr, r, i);8092}80938094/* The maximum size this needs is that required to store a complex8095 * number result, where both real and imag parts consist of ratnums.8096 * The maximum size of those ratnums is if they consist of two bignums8097 * from a fixnum multiplication (2 digits each), so we're looking at8098 * C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words!8099 */8100C_regparm C_word8101C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)8102{8103 if (x & C_FIXNUM_BIT) {8104 if (y & C_FIXNUM_BIT) {8105 return C_a_i_fixnum_times(ptr, 2, x, y);8106 } else if (C_immediatep(y)) {8107 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8108 } else if (C_block_header(y) == C_FLONUM_TAG) {8109 return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y));8110 } else if (C_truep(C_bignump(y))) {8111 return C_s_a_u_i_integer_times(ptr, 2, x, y);8112 } else if (C_block_header(y) == C_RATNUM_TAG) {8113 return rat_times_integer(ptr, y, x);8114 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8115 return cplx_times(ptr, x, C_fix(0),8116 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8117 } else {8118 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8119 }8120 } else if (C_immediatep(x)) {8121 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8122 } else if (C_block_header(x) == C_FLONUM_TAG) {8123 if (y & C_FIXNUM_BIT) {8124 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y));8125 } else if (C_immediatep(y)) {8126 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8127 } else if (C_block_header(y) == C_FLONUM_TAG) {8128 return C_a_i_flonum_times(ptr, 2, x, y);8129 } else if (C_truep(C_bignump(y))) {8130 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y));8131 } else if (C_block_header(y) == C_RATNUM_TAG) {8132 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8133 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8134 C_word ab[C_SIZEOF_FLONUM], *a = ab;8135 return cplx_times(ptr, x, C_flonum(&a, 0.0),8136 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8137 } else {8138 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8139 }8140 } else if (C_truep(C_bignump(x))) {8141 if (y & C_FIXNUM_BIT) {8142 return C_s_a_u_i_integer_times(ptr, 2, x, y);8143 } else if (C_immediatep(y)) {8144 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8145 } else if (C_block_header(y) == C_FLONUM_TAG) {8146 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y));8147 } else if (C_truep(C_bignump(y))) {8148 return C_s_a_u_i_integer_times(ptr, 2, x, y);8149 } else if (C_block_header(y) == C_RATNUM_TAG) {8150 return rat_times_integer(ptr, y, x);8151 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8152 return cplx_times(ptr, x, C_fix(0),8153 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8154 } else {8155 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8156 }8157 } else if (C_block_header(x) == C_RATNUM_TAG) {8158 if (y & C_FIXNUM_BIT) {8159 return rat_times_integer(ptr, x, y);8160 } else if (C_immediatep(y)) {8161 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8162 } else if (C_block_header(y) == C_FLONUM_TAG) {8163 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8164 } else if (C_truep(C_bignump(y))) {8165 return rat_times_integer(ptr, x, y);8166 } else if (C_block_header(y) == C_RATNUM_TAG) {8167 return rat_times_rat(ptr, x, y);8168 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8169 return cplx_times(ptr, x, C_fix(0),8170 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8171 } else {8172 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8173 }8174 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8175 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8176 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x),8177 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8178 } else {8179 C_word ab[C_SIZEOF_FLONUM], *a = ab, yi;8180 yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0);8181 return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi);8182 }8183 } else {8184 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8185 }8186}818781888189C_regparm C_word8190C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)8191{8192 if (x & C_FIXNUM_BIT) {8193 if (y & C_FIXNUM_BIT) {8194 return C_a_i_fixnum_times(ptr, 2, x, y);8195 } else {8196 C_word tmp = x; /* swap to ensure x is a bignum and y a fixnum */8197 x = y;8198 y = tmp;8199 }8200 }8201 /* Here, we know for sure that X is a bignum */8202 if (y == C_fix(0)) {8203 return C_fix(0);8204 } else if (y == C_fix(1)) {8205 return x;8206 } else if (y == C_fix(-1)) {8207 return C_s_a_u_i_integer_negate(ptr, 1, x);8208 } else if (y & C_FIXNUM_BIT) { /* Any other fixnum */8209 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y),8210 negp = C_mk_bool((y & C_INT_SIGN_BIT) ?8211 !C_bignum_negativep(x) :8212 C_bignum_negativep(x));82138214 if (C_fitsinbignumhalfdigitp(absy) ||8215 (((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {8216 C_word size, res;8217 C_uword *startr, *endr;8218 int shift;8219 size = C_bignum_size(x) + 1; /* Needs _at most_ one more digit */8220 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);82218222 bignum_digits_destructive_copy(res, x);82238224 startr = C_bignum_digits(res);8225 endr = startr + size - 1;8226 /* Scale up, and sanitise the result. */8227 shift = C_ilen(absy) - 1;8228 if (((C_uword)1 << shift) == absy) { /* Power of two? */8229 *endr = bignum_digits_destructive_shift_left(startr, endr, shift);8230 } else {8231 *endr = bignum_digits_destructive_scale_up_with_carry(startr, endr,8232 absy, 0);8233 }8234 return C_bignum_simplify(res);8235 } else {8236 C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);8237 y = C_a_u_i_fix_to_big(&a, y);8238 return bignum_times_bignum_unsigned(ptr, x, y, negp);8239 }8240 } else {8241 C_word negp = C_bignum_negativep(x) ?8242 !C_bignum_negativep(y) :8243 C_bignum_negativep(y);8244 return bignum_times_bignum_unsigned(ptr, x, y, C_mk_bool(negp));8245 }8246}82478248static C_regparm C_word8249bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8250{8251 C_word size, res = C_SCHEME_FALSE;8252 if (C_bignum_size(y) < C_bignum_size(x)) { /* Ensure size(x) <= size(y) */8253 C_word z = x;8254 x = y;8255 y = z;8256 }82578258 if (C_bignum_size(x) >= C_KARATSUBA_THRESHOLD)8259 res = bignum_times_bignum_karatsuba(ptr, x, y, negp);82608261 if (!C_truep(res)) {8262 size = C_bignum_size(x) + C_bignum_size(y);8263 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_TRUE);8264 bignum_digits_multiply(x, y, res);8265 res = C_bignum_simplify(res);8266 }8267 return res;8268}82698270/* Karatsuba multiplication: invoked when the two numbers are large8271 * enough to make it worthwhile, and we still have enough stack left.8272 * Complexity is O(n^log2(3)), where n is max(len(x), len(y)). The8273 * description in [Knuth, 4.3.3] leaves a lot to be desired. [MCA,8274 * 1.3.2] and [MpNT, 3.2] are a bit easier to understand. We assume8275 * that length(x) <= length(y).8276 */8277static C_regparm C_word8278bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)8279{8280 C_word kab[C_SIZEOF_FIX_BIGNUM*15+C_SIZEOF_BIGNUM(2)*3], *ka = kab, o[18],8281 xhi, xlo, xmid, yhi, ylo, ymid, a, b, c, n, bits;8282 int i = 0;82838284 /* Ran out of stack? Fall back to non-recursive multiplication */8285 C_stack_check1(return C_SCHEME_FALSE);82868287 /* Split |x| in half: <xhi,xlo> and |y|: <yhi,ylo> with len(ylo)=len(xlo) */8288 x = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, x);8289 y = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, y);8290 n = C_fix(C_bignum_size(y) >> 1);8291 xhi = o[i++] = bignum_extract_digits(&ka, 3, x, n, C_SCHEME_FALSE);8292 xlo = o[i++] = bignum_extract_digits(&ka, 3, x, C_fix(0), n);8293 yhi = o[i++] = bignum_extract_digits(&ka, 3, y, n, C_SCHEME_FALSE);8294 ylo = o[i++] = bignum_extract_digits(&ka, 3, y, C_fix(0), n);82958296 /* a = xhi * yhi, b = xlo * ylo, c = (xhi - xlo) * (yhi - ylo) */8297 a = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xhi, yhi);8298 b = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xlo, ylo);8299 xmid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, xhi, xlo);8300 ymid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, yhi, ylo);8301 c = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xmid, ymid);83028303 /* top(x) = a << (bits - 1) and bottom(y) = ((b + (a - c)) << bits) + b */8304 bits = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;8305 x = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, a, C_fix((C_uword)bits << 1));8306 c = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, a, c);8307 c = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, b, c);8308 c = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, c, C_fix(bits));8309 y = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, c, b);8310 /* Finally, return top + bottom, and correct for negative */8311 n = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, x, y);8312 if (C_truep(negp)) n = o[i++] = C_s_a_u_i_integer_negate(&ka, 1, n);83138314 n = move_buffer_object(ptr, kab, n);8315 while(i--) clear_buffer_object(kab, o[i]);8316 return n;8317}83188319void C_ccall C_times(C_word c, C_word *av)8320{8321 /* C_word closure = av[ 0 ]; */8322 C_word k = av[ 1 ];8323 C_word next_val,8324 result = C_fix(1),8325 prev_result = result;8326 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a;83278328 c -= 2;8329 av += 2;83308331 while (c--) {8332 next_val = *(av++);8333 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */8334 result = C_s_a_i_times(&a, 2, result, next_val);8335 result = move_buffer_object(&a, ab[(c+1)&1], result);8336 clear_buffer_object(ab[(c+1)&1], prev_result);8337 prev_result = result;8338 }83398340 C_kontinue(k, result);8341}834283438344static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8345{8346 C_word size, result;8347 C_uword sum, digit, *scan_y, *end_y, *scan_r, *end_r;8348 int carry = 0;83498350 if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(y) <= size(x) */8351 C_word z = x;8352 x = y;8353 y = z;8354 }83558356 size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */8357 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);83588359 scan_y = C_bignum_digits(y);8360 end_y = scan_y + C_bignum_size(y);8361 scan_r = C_bignum_digits(result);8362 end_r = scan_r + C_bignum_size(result);83638364 /* Copy x into r so we can operate on two pointers, which is faster8365 * than three, and we can stop earlier after adding y. It's slower8366 * if x and y have equal length. On average it's slightly faster.8367 */8368 bignum_digits_destructive_copy(result, x);8369 *(end_r-1) = 0; /* Ensure most significant digit is initialised */83708371 /* Move over x and y simultaneously, destructively adding digits w/ carry. */8372 while (scan_y < end_y) {8373 digit = *scan_r;8374 if (carry) {8375 sum = digit + *scan_y++ + 1;8376 carry = sum <= digit;8377 } else {8378 sum = digit + *scan_y++;8379 carry = sum < digit;8380 }8381 (*scan_r++) = sum;8382 }83838384 /* The end of y, the smaller number. Propagate carry into the rest of x. */8385 while (carry) {8386 sum = (*scan_r) + 1;8387 carry = (sum == 0);8388 (*scan_r++) = sum;8389 }8390 assert(scan_r <= end_r);83918392 return C_bignum_simplify(result);8393}83948395static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op)8396{8397 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8398 num, denom, tmp, res;83998400 if (i == C_fix(0)) return rat;84018402 num = C_u_i_ratnum_num(rat);8403 denom = C_u_i_ratnum_denom(rat);84048405 /* a/b [+-] c/d = (a*d [+-] b*c)/(b*d) | d = 1: (num + denom * i) / denom */8406 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8407 res = plusmin_op(&a, 2, num, tmp);8408 res = move_buffer_object(ptr, ab, res);8409 clear_buffer_object(ab, tmp);8410 return C_ratnum(ptr, res, denom);8411}84128413/* This is needed only for minus: plus is commutative but minus isn't. */8414static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat)8415{8416 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8417 num, denom, tmp, res;84188419 num = C_u_i_ratnum_num(rat);8420 denom = C_u_i_ratnum_denom(rat);84218422 if (i == C_fix(0))8423 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, num), denom);84248425 /* a/b - c/d = (a*d - b*c)/(b*d) | b = 1: (denom * i - num) / denom */8426 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8427 res = C_s_a_u_i_integer_minus(&a, 2, tmp, num);8428 res = move_buffer_object(ptr, ab, res);8429 clear_buffer_object(ab, tmp);8430 return C_ratnum(ptr, res, denom);8431}84328433/* This is pretty braindead and ugly */8434static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op)8435{8436 C_word ab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)*2], *a = ab,8437 xnum = C_u_i_ratnum_num(x), ynum = C_u_i_ratnum_num(y),8438 xdenom = C_u_i_ratnum_denom(x), ydenom = C_u_i_ratnum_denom(y),8439 xnorm, ynorm, tmp_r, g1, ydenom_g1, xdenom_g1, norm_sum, g2, len,8440 res_num, res_denom;84418442 /* Knuth, 4.5.1. Start with g1 = gcd(xdenom, ydenom) */8443 g1 = C_s_a_u_i_integer_gcd(&a, 2, xdenom, ydenom);84448445 /* xnorm = xnum * (ydenom/g1) */8446 ydenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);8447 xnorm = C_s_a_u_i_integer_times(&a, 2, xnum, ydenom_g1);84488449 /* ynorm = ynum * (xdenom/g1) */8450 xdenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g1);8451 ynorm = C_s_a_u_i_integer_times(&a, 2, ynum, xdenom_g1);84528453 /* norm_sum = xnorm [+-] ynorm */8454 norm_sum = plusmin_op(&a, 2, xnorm, ynorm);84558456 /* g2 = gcd(norm_sum, g1) */8457 g2 = C_s_a_u_i_integer_gcd(&a, 2, norm_sum, g1);84588459 /* res_num = norm_sum / g2 */8460 res_num = C_s_a_u_i_integer_quotient(ptr, 2, norm_sum, g2);8461 if (res_num == C_fix(0)) {8462 res_denom = C_fix(0); /* No need to calculate denom: we'll return 0 */8463 } else {8464 /* res_denom = xdenom_g1 * (ydenom / g2) */8465 C_word res_tmp_denom = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g2);8466 res_denom = C_s_a_u_i_integer_times(ptr, 2, xdenom_g1, res_tmp_denom);84678468 /* Ensure they're allocated in the correct place */8469 res_num = move_buffer_object(ptr, ab, res_num);8470 res_denom = move_buffer_object(ptr, ab, res_denom);8471 clear_buffer_object(ab, res_tmp_denom);8472 }84738474 clear_buffer_object(ab, xdenom_g1);8475 clear_buffer_object(ab, ydenom_g1);8476 clear_buffer_object(ab, xnorm);8477 clear_buffer_object(ab, ynorm);8478 clear_buffer_object(ab, norm_sum);8479 clear_buffer_object(ab, g1);8480 clear_buffer_object(ab, g2);84818482 switch (res_denom) {8483 case C_fix(0): return C_fix(0);8484 case C_fix(1): return res_num;8485 default: return C_ratnum(ptr, res_num, res_denom);8486 }8487}84888489/* The maximum size this needs is that required to store a complex8490 * number result, where both real and imag parts consist of ratnums.8491 * The maximum size of those ratnums is if they consist of two "fix8492 * bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM *8493 * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!8494 */8495C_regparm C_word8496C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)8497{8498 if (x & C_FIXNUM_BIT) {8499 if (y & C_FIXNUM_BIT) {8500 return C_a_i_fixnum_plus(ptr, 2, x, y);8501 } else if (C_immediatep(y)) {8502 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8503 } else if (C_block_header(y) == C_FLONUM_TAG) {8504 return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y));8505 } else if (C_truep(C_bignump(y))) {8506 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8507 } else if (C_block_header(y) == C_RATNUM_TAG) {8508 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8509 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8510 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8511 imag = C_u_i_cplxnum_imag(y);8512 if (C_truep(C_u_i_inexactp(real_sum)))8513 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8514 return C_cplxnum(ptr, real_sum, imag);8515 } else {8516 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8517 }8518 } else if (C_immediatep(x)) {8519 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8520 } else if (C_block_header(x) == C_FLONUM_TAG) {8521 if (y & C_FIXNUM_BIT) {8522 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y));8523 } else if (C_immediatep(y)) {8524 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8525 } else if (C_block_header(y) == C_FLONUM_TAG) {8526 return C_a_i_flonum_plus(ptr, 2, x, y);8527 } else if (C_truep(C_bignump(y))) {8528 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y));8529 } else if (C_block_header(y) == C_RATNUM_TAG) {8530 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8531 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8532 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8533 imag = C_u_i_cplxnum_imag(y);8534 if (C_truep(C_u_i_inexactp(real_sum)))8535 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8536 return C_cplxnum(ptr, real_sum, imag);8537 } else {8538 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8539 }8540 } else if (C_truep(C_bignump(x))) {8541 if (y & C_FIXNUM_BIT) {8542 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8543 } else if (C_immediatep(y)) {8544 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8545 } else if (C_block_header(y) == C_FLONUM_TAG) {8546 return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y));8547 } else if (C_truep(C_bignump(y))) {8548 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8549 } else if (C_block_header(y) == C_RATNUM_TAG) {8550 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8551 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8552 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8553 imag = C_u_i_cplxnum_imag(y);8554 if (C_truep(C_u_i_inexactp(real_sum)))8555 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8556 return C_cplxnum(ptr, real_sum, imag);8557 } else {8558 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8559 }8560 } else if (C_block_header(x) == C_RATNUM_TAG) {8561 if (y & C_FIXNUM_BIT) {8562 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8563 } else if (C_immediatep(y)) {8564 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8565 } else if (C_block_header(y) == C_FLONUM_TAG) {8566 return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8567 } else if (C_truep(C_bignump(y))) {8568 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8569 } else if (C_block_header(y) == C_RATNUM_TAG) {8570 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus);8571 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8572 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8573 imag = C_u_i_cplxnum_imag(y);8574 if (C_truep(C_u_i_inexactp(real_sum)))8575 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8576 return C_cplxnum(ptr, real_sum, imag);8577 } else {8578 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8579 }8580 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8581 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8582 C_word real_sum, imag_sum;8583 real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y));8584 imag_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y));8585 if (C_truep(C_u_i_zerop2(imag_sum))) return real_sum;8586 else return C_cplxnum(ptr, real_sum, imag_sum);8587 } else {8588 C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y),8589 imag = C_u_i_cplxnum_imag(x);8590 if (C_truep(C_u_i_inexactp(real_sum)))8591 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8592 return C_cplxnum(ptr, real_sum, imag);8593 }8594 } else {8595 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8596 }8597}85988599C_regparm C_word8600C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y)8601{8602 if ((x & y) & C_FIXNUM_BIT) {8603 return C_a_i_fixnum_plus(ptr, 2, x, y);8604 } else {8605 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8606 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8607 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);86088609 if (C_bignum_negativep(x)) {8610 if (C_bignum_negativep(y)) {8611 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8612 } else {8613 return bignum_minus_unsigned(ptr, y, x);8614 }8615 } else {8616 if (C_bignum_negativep(y)) {8617 return bignum_minus_unsigned(ptr, x, y);8618 } else {8619 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8620 }8621 }8622 }8623}86248625void C_ccall C_plus(C_word c, C_word *av)8626{8627 /* C_word closure = av[ 0 ]; */8628 C_word k = av[ 1 ];8629 C_word next_val,8630 result = C_fix(0),8631 prev_result = result;8632 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;86338634 c -= 2;8635 av += 2;86368637 while (c--) {8638 next_val = *(av++);8639 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8640 result = C_s_a_i_plus(&a, 2, result, next_val);8641 result = move_buffer_object(&a, ab[(c+1)&1], result);8642 clear_buffer_object(ab[(c+1)&1], prev_result);8643 prev_result = result;8644 }86458646 C_kontinue(k, result);8647}86488649static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)8650{8651 C_word res, size;8652 C_uword *scan_r, *end_r, *scan_y, *end_y, difference, digit;8653 int borrow = 0;86548655 switch(bignum_cmp_unsigned(x, y)) {8656 case 0: /* x = y, return 0 */8657 return C_fix(0);8658 case -1: /* abs(x) < abs(y), return -(abs(y) - abs(x)) */8659 size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */8660 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_TRUE, C_SCHEME_FALSE);8661 size = y;8662 y = x;8663 x = size;8664 break;8665 case 1: /* abs(x) > abs(y), return abs(x) - abs(y) */8666 default:8667 size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */8668 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);8669 break;8670 }86718672 scan_r = C_bignum_digits(res);8673 end_r = scan_r + C_bignum_size(res);8674 scan_y = C_bignum_digits(y);8675 end_y = scan_y + C_bignum_size(y);86768677 bignum_digits_destructive_copy(res, x); /* See bignum_plus_unsigned */86788679 /* Destructively subtract y's digits w/ borrow from and back into r. */8680 while (scan_y < end_y) {8681 digit = *scan_r;8682 if (borrow) {8683 difference = digit - *scan_y++ - 1;8684 borrow = difference >= digit;8685 } else {8686 difference = digit - *scan_y++;8687 borrow = difference > digit;8688 }8689 (*scan_r++) = difference;8690 }86918692 /* The end of y, the smaller number. Propagate borrow into the rest of x. */8693 while (borrow) {8694 digit = *scan_r;8695 difference = digit - borrow;8696 borrow = difference >= digit;8697 (*scan_r++) = difference;8698 }86998700 assert(scan_r <= end_r);87018702 return C_bignum_simplify(res);8703}87048705/* Like C_s_a_i_plus, this needs at most 29 words */8706C_regparm C_word8707C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)8708{8709 if (x & C_FIXNUM_BIT) {8710 if (y & C_FIXNUM_BIT) {8711 return C_a_i_fixnum_difference(ptr, 2, x, y);8712 } else if (C_immediatep(y)) {8713 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8714 } else if (C_block_header(y) == C_FLONUM_TAG) {8715 return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y));8716 } else if (C_truep(C_bignump(y))) {8717 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8718 } else if (C_block_header(y) == C_RATNUM_TAG) {8719 return integer_minus_rat(ptr, x, y);8720 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8721 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8722 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8723 if (C_truep(C_u_i_inexactp(real_diff)))8724 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8725 return C_cplxnum(ptr, real_diff, imag);8726 } else {8727 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8728 }8729 } else if (C_immediatep(x)) {8730 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8731 } else if (C_block_header(x) == C_FLONUM_TAG) {8732 if (y & C_FIXNUM_BIT) {8733 return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y));8734 } else if (C_immediatep(y)) {8735 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8736 } else if (C_block_header(y) == C_FLONUM_TAG) {8737 return C_a_i_flonum_difference(ptr, 2, x, y);8738 } else if (C_truep(C_bignump(y))) {8739 return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y));8740 } else if (C_block_header(y) == C_RATNUM_TAG) {8741 return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8742 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8743 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8744 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8745 if (C_truep(C_u_i_inexactp(real_diff)))8746 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8747 return C_cplxnum(ptr, real_diff, imag);8748 } else {8749 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8750 }8751 } else if (C_truep(C_bignump(x))) {8752 if (y & C_FIXNUM_BIT) {8753 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8754 } else if (C_immediatep(y)) {8755 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8756 } else if (C_block_header(y) == C_FLONUM_TAG) {8757 return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y));8758 } else if (C_truep(C_bignump(y))) {8759 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8760 } else if (C_block_header(y) == C_RATNUM_TAG) {8761 return integer_minus_rat(ptr, x, y);8762 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8763 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8764 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8765 if (C_truep(C_u_i_inexactp(real_diff)))8766 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8767 return C_cplxnum(ptr, real_diff, imag);8768 } else {8769 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8770 }8771 } else if (C_block_header(x) == C_RATNUM_TAG) {8772 if (y & C_FIXNUM_BIT) {8773 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8774 } else if (C_immediatep(y)) {8775 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8776 } else if (C_block_header(y) == C_FLONUM_TAG) {8777 return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8778 } else if (C_truep(C_bignump(y))) {8779 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8780 } else if (C_block_header(y) == C_RATNUM_TAG) {8781 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus);8782 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8783 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8784 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8785 if (C_truep(C_u_i_inexactp(real_diff)))8786 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8787 return C_cplxnum(ptr, real_diff, imag);8788 } else {8789 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8790 }8791 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8792 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8793 C_word real_diff, imag_diff;8794 real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y));8795 imag_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_imag(x),C_u_i_cplxnum_imag(y));8796 if (C_truep(C_u_i_zerop2(imag_diff))) return real_diff;8797 else return C_cplxnum(ptr, real_diff, imag_diff);8798 } else {8799 C_word real_diff = C_s_a_i_minus(ptr, 2, C_u_i_cplxnum_real(x), y),8800 imag = C_u_i_cplxnum_imag(x);8801 if (C_truep(C_u_i_inexactp(real_diff)))8802 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8803 return C_cplxnum(ptr, real_diff, imag);8804 }8805 } else {8806 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8807 }8808}88098810C_regparm C_word8811C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y)8812{8813 if ((x & y) & C_FIXNUM_BIT) {8814 return C_a_i_fixnum_difference(ptr, 2, x, y);8815 } else {8816 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8817 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8818 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);88198820 if (C_bignum_negativep(x)) {8821 if (C_bignum_negativep(y)) {8822 return bignum_minus_unsigned(ptr, y, x);8823 } else {8824 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8825 }8826 } else {8827 if (C_bignum_negativep(y)) {8828 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8829 } else {8830 return bignum_minus_unsigned(ptr, x, y);8831 }8832 }8833 }8834}88358836void C_ccall C_minus(C_word c, C_word *av)8837{8838 /* C_word closure = av[ 0 ]; */8839 C_word k = av[ 1 ];8840 C_word next_val, result, prev_result;8841 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;88428843 if (c < 3) {8844 C_bad_min_argc(c, 3);8845 } else if (c == 3) {8846 a = ab[0];8847 C_kontinue(k, C_s_a_i_negate(&a, 1, av[ 2 ]));8848 } else {8849 prev_result = result = av[ 2 ];8850 c -= 3;8851 av += 3;88528853 while (c--) {8854 next_val = *(av++);8855 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8856 result = C_s_a_i_minus(&a, 2, result, next_val);8857 result = move_buffer_object(&a, ab[(c+1)&1], result);8858 clear_buffer_object(ab[(c+1)&1], prev_result);8859 prev_result = result;8860 }88618862 C_kontinue(k, result);8863 }8864}886588668867static C_regparm void8868integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8869{8870 if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */8871 if (x & C_FIXNUM_BIT) {8872 /* abs(x) < abs(y), so it will always be [0, x] except for this case: */8873 if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&8874 C_bignum_negated_fitsinfixnump(y)) {8875 if (q != NULL) *q = C_fix(-1);8876 if (r != NULL) *r = C_fix(0);8877 } else {8878 if (q != NULL) *q = C_fix(0);8879 if (r != NULL) *r = x;8880 }8881 } else {8882 bignum_divrem(ptr, x, y, q, r);8883 }8884 } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */8885 if (q != NULL) *q = C_a_i_fixnum_quotient_checked(ptr, 2, x, y);8886 if (r != NULL) *r = C_i_fixnum_remainder_checked(x, y);8887 } else { /* x is bignum, y is fixnum. */8888 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);88898890 if (y == C_fix(1)) {8891 if (q != NULL) *q = x;8892 if (r != NULL) *r = C_fix(0);8893 } else if (y == C_fix(-1)) {8894 if (q != NULL) *q = C_s_a_u_i_integer_negate(ptr, 1, x);8895 if (r != NULL) *r = C_fix(0);8896 } else if (C_fitsinbignumhalfdigitp(absy) ||8897 ((((C_uword)1 << (C_ilen(absy)-1)) == absy) &&8898 C_fitsinfixnump(absy))) {8899 assert(y != C_fix(0)); /* _must_ be checked by caller */8900 if (q != NULL) {8901 bignum_destructive_divide_unsigned_small(ptr, x, y, q, r);8902 } else { /* We assume r isn't NULL here (that makes no sense) */8903 C_word rem;8904 C_uword next_power = (C_uword)1 << (C_ilen(absy)-1);89058906 if (next_power == absy) { /* Is absy a power of two? */8907 rem = *(C_bignum_digits(x)) & (next_power - 1);8908 } else { /* Too bad, we have to do some real work */8909 rem = bignum_remainder_unsigned_halfdigit(x, absy);8910 }8911 *r = C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem);8912 }8913 } else { /* Just divide it as two bignums */8914 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;8915 bignum_divrem(ptr, x, C_a_u_i_fix_to_big(&a, y), q, r);8916 if (q != NULL) *q = move_buffer_object(ptr, ab, *q);8917 if (r != NULL) *r = move_buffer_object(ptr, ab, *r);8918 }8919 }8920}89218922/* This _always_ needs two bignum wrappers in ptr! */8923static C_regparm void8924bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8925{8926 C_word q_negp = C_mk_bool(C_bignum_negativep(y) != C_bignum_negativep(x)),8927 r_negp = C_mk_bool(C_bignum_negativep(x)), res, size;89288929 switch(bignum_cmp_unsigned(x, y)) {8930 case 0:8931 if (q != NULL) *q = C_truep(q_negp) ? C_fix(-1) : C_fix(1);8932 if (r != NULL) *r = C_fix(0);8933 break;8934 case -1:8935 if (q != NULL) *q = C_fix(0);8936 if (r != NULL) *r = x;8937 break;8938 case 1:8939 default:8940 res = C_SCHEME_FALSE;8941 size = C_bignum_size(x) - C_bignum_size(y);8942 if (C_bignum_size(y) > C_BURNIKEL_ZIEGLER_THRESHOLD &&8943 size > C_BURNIKEL_ZIEGLER_THRESHOLD) {8944 res = bignum_divide_burnikel_ziegler(ptr, x, y, q, r);8945 }89468947 if (!C_truep(res)) {8948 bignum_divide_unsigned(ptr, x, y, q, q_negp, r, r_negp);8949 if (q != NULL) *q = C_bignum_simplify(*q);8950 if (r != NULL) *r = C_bignum_simplify(*r);8951 }8952 break;8953 }8954}89558956/* Burnikel-Ziegler recursive division: Split high number (x) in three8957 * or four parts and divide by the lowest number (y), split in two8958 * parts. There are descriptions in [MpNT, 4.2], [MCA, 1.4.3] and the8959 * paper "Fast Recursive Division" by Christoph Burnikel & Joachim8960 * Ziegler is freely available. There is also a description in Karl8961 * Hasselstrom's thesis "Fast Division of Integers".8962 *8963 * The complexity of this is supposedly O(r*s^{log(3)-1} + r*log(s)),8964 * where s is the length of x, and r is the length of y (in digits).8965 *8966 * TODO: See if it's worthwhile to implement "division without remainder"8967 * from the Burnikel-Ziegler paper.8968 */8969static C_regparm C_word8970bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8971{8972 C_word ab[C_SIZEOF_FIX_BIGNUM*9], *a = ab,8973 lab[2][C_SIZEOF_FIX_BIGNUM*10], *la,8974 q_negp = (C_bignum_negativep(y) ? C_mk_nbool(C_bignum_negativep(x)) :8975 C_mk_bool(C_bignum_negativep(x))),8976 r_negp = C_mk_bool(C_bignum_negativep(x)), s, m, n, i, j, l, shift,8977 yhi, ylo, zi, zi_orig, newx, newy, quot, qi, ri;89788979 /* Ran out of stack? Fall back to non-recursive division */8980 C_stack_check1(return C_SCHEME_FALSE);89818982 x = C_s_a_u_i_integer_abs(&a, 1, x);8983 y = C_s_a_u_i_integer_abs(&a, 1, y);89848985 /* Define m as min{2^k|(2^k)*BURNIKEL_ZIEGLER_DIFF_THRESHOLD > s}8986 * This ensures we shift as little as possible (less pressure8987 * on the GC) while maintaining a power of two until we drop8988 * below the threshold, so we can always split N in half.8989 */8990 s = C_bignum_size(y);8991 m = 1 << C_ilen(s / C_BURNIKEL_ZIEGLER_THRESHOLD);8992 j = (s+m-1) / m; /* j = s/m, rounded up */8993 n = j * m;89948995 shift = (C_BIGNUM_DIGIT_LENGTH * n) - integer_length_abs(y);8996 newx = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(shift));8997 newy = C_s_a_i_arithmetic_shift(&a, 2, y, C_fix(shift));8998 if (shift != 0) {8999 clear_buffer_object(ab, x);9000 clear_buffer_object(ab, y);9001 }9002 x = newx;9003 y = newy;90049005 /* l needs to be the smallest value so that a < base^{l*n}/2 */9006 l = (C_bignum_size(x) + n) / n;9007 if ((C_BIGNUM_DIGIT_LENGTH * l) == integer_length_abs(x)) l++;9008 l = nmax(l, 2);90099010 yhi = bignum_extract_digits(&a, 3, y, C_fix(n >> 1), C_SCHEME_FALSE);9011 ylo = bignum_extract_digits(&a, 3, y, C_fix(0), C_fix(n >> 1));90129013 s = (l - 2) * n * C_BIGNUM_DIGIT_LENGTH;9014 zi_orig = zi = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(-s));9015 quot = C_fix(0);90169017 for(i = l - 2; i >= 0; --i) {9018 la = lab[i&1];90199020 burnikel_ziegler_2n_div_1n(&la, zi, y, yhi, ylo, C_fix(n), &qi, &ri);90219022 newx = C_s_a_i_arithmetic_shift(&la, 2, quot, C_fix(n*C_BIGNUM_DIGIT_LENGTH));9023 clear_buffer_object(lab, quot);9024 quot = C_s_a_u_i_integer_plus(&la, 2, newx, qi);9025 move_buffer_object(&la, lab[(i+1)&1], quot);9026 clear_buffer_object(lab, newx);9027 clear_buffer_object(lab, qi);90289029 if (i > 0) { /* Set z_{i-1} = [r{i}, x{i-1}] */9030 newx = bignum_extract_digits(&la, 3, x, C_fix(n * (i-1)), C_fix(n * i));9031 newy = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(n*C_BIGNUM_DIGIT_LENGTH));9032 clear_buffer_object(lab, zi);9033 zi = C_s_a_u_i_integer_plus(&la, 2, newx, newy);9034 move_buffer_object(&la, lab[(i+1)&1], zi);9035 move_buffer_object(&la, lab[(i+1)&1], quot);9036 clear_buffer_object(lab, newx);9037 clear_buffer_object(lab, newy);9038 clear_buffer_object(lab, ri);9039 }9040 }9041 clear_buffer_object(ab, x);9042 clear_buffer_object(ab, y);9043 clear_buffer_object(ab, yhi);9044 clear_buffer_object(ab, ylo);9045 clear_buffer_object(ab, zi_orig);9046 clear_buffer_object(lab, zi);90479048 if (q != NULL) {9049 if (C_truep(q_negp)) {9050 newx = C_s_a_u_i_integer_negate(&la, 1, quot);9051 clear_buffer_object(lab, quot);9052 quot = newx;9053 }9054 *q = move_buffer_object(ptr, lab, quot);9055 }9056 clear_buffer_object(lab, quot);90579058 if (r != NULL) {9059 newx = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(-shift));9060 if (C_truep(r_negp)) {9061 newy = C_s_a_u_i_integer_negate(ptr, 1, newx);9062 clear_buffer_object(lab, newx);9063 newx = newy;9064 }9065 *r = move_buffer_object(ptr, lab, newx);9066 }9067 clear_buffer_object(lab, ri);90689069 return C_SCHEME_TRUE;9070}90719072static C_regparm void9073burnikel_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)9074{9075 C_word kab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)], *ka = kab,9076 lab[2][C_SIZEOF_FIX_BIGNUM*4], *la,9077 size, tmp, less, qhat, rhat, r1, r1a3, i = 0;90789079 size = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;9080 tmp = C_s_a_i_arithmetic_shift(&ka, 2, a12, C_fix(-size));9081 less = C_i_integer_lessp(tmp, b1); /* a1 < b1 ? */9082 clear_buffer_object(kab, tmp);90839084 if (C_truep(less)) {9085 C_word atmpb[C_SIZEOF_FIX_BIGNUM*2], *atmp = atmpb, b11, b12, halfn;90869087 halfn = C_fix(C_unfix(n) >> 1);9088 b11 = bignum_extract_digits(&atmp, 3, b1, halfn, C_SCHEME_FALSE);9089 b12 = bignum_extract_digits(&atmp, 3, b1, C_fix(0), halfn);90909091 burnikel_ziegler_2n_div_1n(&ka, a12, b1, b11, b12, n, &qhat, &r1);9092 qhat = move_buffer_object(&ka, atmpb, qhat);9093 r1 = move_buffer_object(&ka, atmpb, r1);90949095 clear_buffer_object(atmpb, b11);9096 clear_buffer_object(atmpb, b12);9097 } else {9098 C_word atmpb[C_SIZEOF_FIX_BIGNUM*5], *atmp = atmpb, tmp2;90999100 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, C_fix(1), C_fix(size));9101 qhat = C_s_a_u_i_integer_minus(&ka, 2, tmp, C_fix(1)); /* B^n - 1 */9102 qhat = move_buffer_object(&ka, atmpb, qhat);9103 clear_buffer_object(atmpb, tmp);91049105 /* r1 = (a12 - b1*B^n) + b1 */9106 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, b1, C_fix(size));9107 tmp2 = C_s_a_u_i_integer_minus(&atmp, 2, a12, tmp);9108 r1 = C_s_a_u_i_integer_plus(&ka, 2, tmp2, b1);9109 r1 = move_buffer_object(&ka, atmpb, r1);9110 clear_buffer_object(atmpb, tmp);9111 clear_buffer_object(atmpb, tmp2);9112 }91139114 tmp = C_s_a_i_arithmetic_shift(&ka, 2, r1, C_fix(size));9115 clear_buffer_object(kab, r1);9116 r1a3 = C_s_a_u_i_integer_plus(&ka, 2, tmp, a3);9117 b2 = C_s_a_u_i_integer_times(&ka, 2, qhat, b2);91189119 la = lab[0];9120 rhat = C_s_a_u_i_integer_minus(&la, 2, r1a3, b2);9121 rhat = move_buffer_object(&la, kab, rhat);9122 qhat = move_buffer_object(&la, kab, qhat);91239124 clear_buffer_object(kab, tmp);9125 clear_buffer_object(kab, r1a3);9126 clear_buffer_object(kab, b2);91279128 while(C_truep(C_i_negativep(rhat))) {9129 la = lab[(++i)&1];9130 /* rhat += b */9131 r1 = C_s_a_u_i_integer_plus(&la, 2, rhat, b);9132 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9133 clear_buffer_object(lab[(i-1)&1], r1);9134 clear_buffer_object(lab[(i-1)&1], rhat);9135 clear_buffer_object(kab, rhat);9136 rhat = tmp;91379138 /* qhat -= 1 */9139 r1 = C_s_a_u_i_integer_minus(&la, 2, qhat, C_fix(1));9140 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9141 clear_buffer_object(lab[(i-1)&1], r1);9142 clear_buffer_object(lab[(i-1)&1], qhat);9143 clear_buffer_object(kab, qhat);9144 qhat = tmp;9145 }91469147 if (q != NULL) *q = move_buffer_object(ptr, lab, qhat);9148 if (r != NULL) *r = move_buffer_object(ptr, lab, rhat);9149 clear_buffer_object(lab, qhat);9150 clear_buffer_object(lab, rhat);9151}91529153static C_regparm void9154burnikel_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)9155{9156 C_word kab[2][C_SIZEOF_FIX_BIGNUM*7], *ka, a12, a3, a4,9157 q1 = C_fix(0), r1, q2 = C_fix(0), r2, *qp;9158 int stack_full = 0;91599160 C_stack_check1(stack_full = 1);91619162 n = C_unfix(n);9163 if (stack_full || (n & 1) || (n < C_BURNIKEL_ZIEGLER_THRESHOLD)) {9164 integer_divrem(ptr, a, b, q, r);9165 } else {9166 ka = kab[0];9167 a12 = bignum_extract_digits(&ka, 3, a, C_fix(n), C_SCHEME_FALSE);9168 a3 = bignum_extract_digits(&ka, 3, a, C_fix(n >> 1), C_fix(n));91699170 qp = (q == NULL) ? NULL : &q1;9171 ka = kab[1];9172 burnikel_ziegler_3n_div_2n(&ka, a12, a3, b, b1, b2, C_fix(n >> 1), qp, &r1);9173 q1 = move_buffer_object(&ka, kab[0], q1);9174 r1 = move_buffer_object(&ka, kab[0], r1);9175 clear_buffer_object(kab[0], a12);9176 clear_buffer_object(kab[0], a3);91779178 a4 = bignum_extract_digits(&ka, 3, a, C_fix(0), C_fix(n >> 1));91799180 qp = (q == NULL) ? NULL : &q2;9181 ka = kab[0];9182 burnikel_ziegler_3n_div_2n(&ka, r1, a4, b, b1, b2, C_fix(n >> 1), qp, r);9183 if (r != NULL) *r = move_buffer_object(ptr, kab[0], *r);9184 clear_buffer_object(kab[1], r1);91859186 if (q != NULL) {9187 C_word halfn_bits = (n >> 1) * C_BIGNUM_DIGIT_LENGTH;9188 r1 = C_s_a_i_arithmetic_shift(&ka, 2, q1, C_fix(halfn_bits));9189 *q = C_s_a_i_plus(ptr, 2, r1, q2); /* q = [q1, q2] */9190 *q = move_buffer_object(ptr, kab[0], *q);9191 clear_buffer_object(kab[0], r1);9192 clear_buffer_object(kab[1], q1);9193 clear_buffer_object(kab[0], q2);9194 }9195 clear_buffer_object(kab[1], a4);9196 }9197}919891999200static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y)9201{9202 C_uword *start = C_bignum_digits(x),9203 *scan = start + C_bignum_size(x),9204 rem = 0, two_digits;92059206 assert((y > 1) && (C_fitsinbignumhalfdigitp(y)));9207 while (start < scan) {9208 two_digits = (*--scan);9209 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % y;9210 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % y;9211 }9212 return rem;9213}92149215/* There doesn't seem to be a way to return two values from inline functions */9216void C_ccall C_quotient_and_remainder(C_word c, C_word *av)9217{9218 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab,9219 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE,9220 q, r, k, x, y;92219222 if (c != 4) C_bad_argc_2(c, 4, av[ 0 ]);92239224 k = av[ 1 ];9225 x = av[ 2 ];9226 y = av[ 3 ];92279228 if (!C_truep(C_i_integerp(x)))9229 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", x);9230 if (!C_truep(C_i_integerp(y)))9231 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", y);9232 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient&remainder");92339234 if (C_truep(C_i_flonump(x))) {9235 if C_truep(C_i_flonump(y)) {9236 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;92379238 C_modf(dx / dy, &tmp);9239 q = C_flonum(&a, tmp);9240 r = C_flonum(&a, dx - tmp * dy);9241 /* reuse av */9242 av[ 0 ] = C_SCHEME_UNDEFINED;9243 /* av[ 1 ] = k; */ /* stays the same */9244 av[ 2 ] = q;9245 av[ 3 ] = r;9246 C_values(4, av);9247 }9248 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9249 }9250 if (C_truep(C_i_flonump(y))) {9251 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9252 }92539254 integer_divrem(&a, x, y, &q, &r);92559256 if (C_truep(nx) || C_truep(ny)) {9257 C_word newq, newr;9258 newq = C_a_i_exact_to_inexact(&a, 1, q);9259 newr = C_a_i_exact_to_inexact(&a, 1, r);9260 clear_buffer_object(ab, q);9261 clear_buffer_object(ab, r);9262 q = newq;9263 r = newr;92649265 clear_buffer_object(ab, nx);9266 clear_buffer_object(ab, ny);9267 }9268 /* reuse av */9269 av[ 0 ] = C_SCHEME_UNDEFINED;9270 /* av[ 1 ] = k; */ /* stays the same */9271 av[ 2 ] = q;9272 av[ 3 ] = r;9273 C_values(4, av);9274}92759276void C_ccall C_u_integer_quotient_and_remainder(C_word c, C_word *av)9277{9278 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q, r;92799280 if (av[ 3 ] == C_fix(0)) C_div_by_zero_error("quotient&remainder");92819282 integer_divrem(&a, av[ 2 ], av[ 3 ], &q, &r);92839284 /* reuse av */9285 av[ 0 ] = C_SCHEME_UNDEFINED;9286 /* av[ 1 ] = k; */ /* stays the same */9287 av[ 2 ] = q;9288 av[ 3 ] = r;9289 C_values(4, av);9290}92919292C_regparm C_word9293C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)9294{9295 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, r,9296 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;92979298 if (!C_truep(C_i_integerp(x)))9299 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", x);9300 if (!C_truep(C_i_integerp(y)))9301 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", y);9302 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("remainder");93039304 if (C_truep(C_i_flonump(x))) {9305 if C_truep(C_i_flonump(y)) {9306 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;93079308 C_modf(dx / dy, &tmp);9309 return C_flonum(ptr, dx - tmp * dy);9310 }9311 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9312 }9313 if (C_truep(C_i_flonump(y))) {9314 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9315 }93169317 integer_divrem(&a, x, y, NULL, &r);93189319 if (C_truep(nx) || C_truep(ny)) {9320 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9321 clear_buffer_object(ab, r);9322 r = newr;93239324 clear_buffer_object(ab, nx);9325 clear_buffer_object(ab, ny);9326 }9327 return move_buffer_object(ptr, ab, r);9328}93299330C_regparm C_word9331C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)9332{9333 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, r;9334 if (y == C_fix(0)) C_div_by_zero_error("remainder");9335 integer_divrem(&a, x, y, NULL, &r);9336 return move_buffer_object(ptr, ab, r);9337}93389339/* Modulo's sign follows y (whereas remainder's sign follows x) */9340C_regparm C_word9341C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)9342{9343 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r,9344 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;93459346 if (!C_truep(C_i_integerp(x)))9347 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", x);9348 if (!C_truep(C_i_integerp(y)))9349 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", y);9350 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("modulo");93519352 if (C_truep(C_i_flonump(x))) {9353 if C_truep(C_i_flonump(y)) {9354 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;93559356 C_modf(dx / dy, &tmp);9357 tmp = dx - tmp * dy;9358 if ((dx > 0.0) != (dy > 0.0) && tmp != 0.0) {9359 return C_flonum(ptr, tmp + dy);9360 } else {9361 return C_flonum(ptr, tmp);9362 }9363 }9364 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9365 }9366 if (C_truep(C_i_flonump(y))) {9367 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9368 }93699370 integer_divrem(&a, x, y, NULL, &r);9371 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9372 C_word m = C_s_a_i_plus(ptr, 2, r, y);9373 m = move_buffer_object(ptr, ab, m);9374 clear_buffer_object(ab, r);9375 r = m;9376 }93779378 if (C_truep(nx) || C_truep(ny)) {9379 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9380 clear_buffer_object(ab, r);9381 r = newr;93829383 clear_buffer_object(ab, nx);9384 clear_buffer_object(ab, ny);9385 }93869387 return move_buffer_object(ptr, ab, r);9388}93899390C_regparm C_word9391C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)9392{9393 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;9394 if (y == C_fix(0)) C_div_by_zero_error("modulo");93959396 integer_divrem(&a, x, y, NULL, &r);9397 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9398 C_word m = C_s_a_u_i_integer_plus(ptr, 2, r, y);9399 m = move_buffer_object(ptr, ab, m);9400 clear_buffer_object(ab, r);9401 r = m;9402 }9403 return move_buffer_object(ptr, ab, r);9404}94059406C_regparm C_word9407C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)9408{9409 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, q,9410 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;94119412 if (!C_truep(C_i_integerp(x)))9413 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", x);9414 if (!C_truep(C_i_integerp(y)))9415 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", y);9416 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient");94179418 if (C_truep(C_i_flonump(x))) {9419 if C_truep(C_i_flonump(y)) {9420 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;94219422 C_modf(dx / dy, &tmp);9423 return C_flonum(ptr, tmp);9424 }9425 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9426 }9427 if (C_truep(C_i_flonump(y))) {9428 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9429 }94309431 integer_divrem(&a, x, y, &q, NULL);94329433 if (C_truep(nx) || C_truep(ny)) {9434 C_word newq = C_a_i_exact_to_inexact(ptr, 1, q);9435 clear_buffer_object(ab, q);9436 q = newq;94379438 clear_buffer_object(ab, nx);9439 clear_buffer_object(ab, ny);9440 }9441 return move_buffer_object(ptr, ab, q);9442}94439444C_regparm C_word9445C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y)9446{9447 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q;9448 if (y == C_fix(0)) C_div_by_zero_error("quotient");9449 integer_divrem(&a, x, y, &q, NULL);9450 return move_buffer_object(ptr, ab, q);9451}945294539454/* For help understanding this algorithm, see:9455 Knuth, Donald E., "The Art of Computer Programming",9456 volume 2, "Seminumerical Algorithms"9457 section 4.3.1, "Multiple-Precision Arithmetic".94589459 [Yeah, that's a nice book but that particular section is not9460 helpful at all, which is also pointed out by P. Brinch Hansen's9461 "Multiple-Length Division Revisited: A Tour Of The Minefield".9462 That's a more down-to-earth step-by-step explanation of the9463 algorithm. Add to this the C implementation in Hacker's Delight9464 (section 9-2, p141--142) and you may be able to grok this...9465 ...barely, if you're as math-challenged as I am -- sjamaan]94669467 This assumes that numerator >= denominator!9468*/9469static void9470bignum_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)9471{9472 C_word quotient = C_SCHEME_UNDEFINED, remainder = C_SCHEME_UNDEFINED,9473 return_rem = C_mk_nbool(r == NULL), size;94749475 if (q != NULL) {9476 size = C_fix(C_bignum_size(num) + 1 - C_bignum_size(denom));9477 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);9478 }94799480 /* An object is always required to receive the remainder */9481 size = C_fix(C_bignum_size(num) + 1);9482 remainder = C_allocate_scratch_bignum(ptr, size, r_negp, C_SCHEME_FALSE);9483 bignum_destructive_divide_full(num, denom, quotient, remainder, return_rem);94849485 /* Simplification must be done by the caller, for consistency */9486 if (q != NULL) *q = quotient;9487 if (r == NULL) {9488 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(remainder));9489 } else {9490 *r = remainder;9491 }9492}94939494/* Compare two numbers as ratnums. Either may be rat-, fix- or bignums */9495static C_word rat_cmp(C_word x, C_word y)9496{9497 C_word ab[C_SIZEOF_FIX_BIGNUM*4], *a = ab, x1, x2, y1, y2,9498 s, t, ssize, tsize, result, negp;9499 C_uword *scan;95009501 /* Check for 1 or 0; if x or y is this, the other must be the ratnum */9502 if (x == C_fix(0)) { /* Only the sign of y1 matters */9503 return basic_cmp(x, C_u_i_ratnum_num(y), "ratcmp", 0);9504 } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */9505 return basic_cmp(C_u_i_ratnum_denom(y), C_u_i_ratnum_num(y), "ratcmp", 0);9506 } else if (y == C_fix(0)) { /* Only the sign of x1 matters */9507 return basic_cmp(C_u_i_ratnum_num(x), y, "ratcmp", 0);9508 } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */9509 return basic_cmp(C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), "ratcmp", 0);9510 }95119512 /* Extract components x=x1/x2 and y=y1/y2 */9513 if (x & C_FIXNUM_BIT || C_truep(C_bignump(x))) {9514 x1 = x;9515 x2 = C_fix(1);9516 } else {9517 x1 = C_u_i_ratnum_num(x);9518 x2 = C_u_i_ratnum_denom(x);9519 }95209521 if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) {9522 y1 = y;9523 y2 = C_fix(1);9524 } else {9525 y1 = C_u_i_ratnum_num(y);9526 y2 = C_u_i_ratnum_denom(y);9527 }95289529 /* We only want to deal with bignums (this is tricky enough) */9530 if (x1 & C_FIXNUM_BIT) x1 = C_a_u_i_fix_to_big(&a, x1);9531 if (x2 & C_FIXNUM_BIT) x2 = C_a_u_i_fix_to_big(&a, x2);9532 if (y1 & C_FIXNUM_BIT) y1 = C_a_u_i_fix_to_big(&a, y1);9533 if (y2 & C_FIXNUM_BIT) y2 = C_a_u_i_fix_to_big(&a, y2);95349535 /* We multiply using schoolbook method, so this will be very slow in9536 * extreme cases. This is a tradeoff we make so that comparisons9537 * are inlineable, which makes a big difference for the common case.9538 */9539 ssize = C_bignum_size(x1) + C_bignum_size(y2);9540 negp = C_mk_bool(C_bignum_negativep(x1));9541 s = allocate_tmp_bignum(C_fix(ssize), negp, C_SCHEME_TRUE);9542 bignum_digits_multiply(x1, y2, s); /* Swap args if x1 < y2? */95439544 tsize = C_bignum_size(y1) + C_bignum_size(x2);9545 negp = C_mk_bool(C_bignum_negativep(y1));9546 t = allocate_tmp_bignum(C_fix(tsize), negp, C_SCHEME_TRUE);9547 bignum_digits_multiply(y1, x2, t); /* Swap args if y1 < x2? */95489549 /* Shorten the numbers if needed */9550 for (scan = C_bignum_digits(s)+ssize-1; *scan == 0; scan--) ssize--;9551 C_bignum_mutate_size(s, ssize);9552 for (scan = C_bignum_digits(t)+tsize-1; *scan == 0; scan--) tsize--;9553 C_bignum_mutate_size(t, tsize);95549555 result = C_i_bignum_cmp(s, t);95569557 free_tmp_bignum(t);9558 free_tmp_bignum(s);9559 return result;9560}95619562C_regparm double C_bignum_to_double(C_word bignum)9563{9564 double accumulator = 0;9565 C_uword *start = C_bignum_digits(bignum),9566 *scan = start + C_bignum_size(bignum);9567 while (start < scan) {9568 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9569 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9570 accumulator += (*--scan);9571 }9572 return(C_bignum_negativep(bignum) ? -accumulator : accumulator);9573}95749575C_regparm C_word9576C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x)9577{9578 int exponent;9579 double significand = frexp(C_flonum_magnitude(x), &exponent);95809581 assert(C_truep(C_u_i_fpintegerp(x)));95829583 if (exponent <= 0) {9584 return C_fix(0);9585 } else if (exponent == 1) { /* TODO: check significand * 2^exp fits fixnum? */9586 return significand < 0.0 ? C_fix(-1) : C_fix(1);9587 } else {9588 C_word size, negp = C_mk_bool(C_flonum_magnitude(x) < 0.0), result;9589 C_uword *start, *end;95909591 size = C_fix(C_BIGNUM_BITS_TO_DIGITS(exponent));9592 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);95939594 start = C_bignum_digits(result);9595 end = start + C_bignum_size(result);95969597 fabs_frexp_to_digits(exponent, fabs(significand), start, end);9598 return C_bignum_simplify(result);9599 }9600}96019602static void9603fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)9604{9605 C_uword digit, odd_bits = exp % C_BIGNUM_DIGIT_LENGTH;96069607 assert(C_isfinite(sign));9608 assert(0.5 <= sign && sign < 1); /* Guaranteed by frexp() and fabs() */9609 assert((scan - start) == C_BIGNUM_BITS_TO_DIGITS(exp));96109611 if (odd_bits > 0) { /* Handle most significant digit first */9612 sign *= (C_uword)1 << odd_bits;9613 digit = (C_uword)sign;9614 (*--scan) = digit;9615 sign -= (double)digit;9616 }96179618 while (start < scan && sign > 0) {9619 sign *= pow(2.0, C_BIGNUM_DIGIT_LENGTH);9620 digit = (C_uword)sign;9621 (*--scan) = digit;9622 sign -= (double)digit;9623 }96249625 /* Finish up by clearing any remaining, lower, digits */9626 while (start < scan)9627 (*--scan) = 0;9628}96299630/* This is a bit weird: We have to compare flonums as bignums due to9631 * precision loss on 64-bit platforms. For simplicity, we convert9632 * fixnums to bignums here.9633 */9634static C_word int_flo_cmp(C_word intnum, C_word flonum)9635{9636 C_word ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_FLONUM], *a = ab, flo_int, res;9637 double i, f;96389639 f = C_flonum_magnitude(flonum);96409641 if (C_isnan(f)) {9642 return C_SCHEME_FALSE; /* "mu" */9643 } else if (C_isinf(f)) {9644 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9645 } else {9646 f = modf(f, &i);96479648 flo_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));96499650 res = basic_cmp(intnum, flo_int, "int_flo_cmp", 0);9651 clear_buffer_object(ab, flo_int);96529653 if (res == C_fix(0)) /* Use fraction to break tie. If f > 0, x is smaller */9654 return C_fix((f > 0.0) ? -1 : ((f < 0.0) ? 1 : 0));9655 else9656 return res;9657 }9658}96599660/* For convenience (ie, to reduce the degree of mindfuck) */9661static C_word flo_int_cmp(C_word flonum, C_word intnum)9662{9663 C_word res = int_flo_cmp(intnum, flonum);9664 switch(res) {9665 case C_fix(1): return C_fix(-1);9666 case C_fix(-1): return C_fix(1);9667 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9668 }9669}96709671/* This code is a bit tedious, but it makes inline comparisons possible! */9672static C_word rat_flo_cmp(C_word ratnum, C_word flonum)9673{9674 C_word ab[C_SIZEOF_FIX_BIGNUM * 4 + C_SIZEOF_FLONUM], *a = ab,9675 num, denom, i_int, res, nscaled, iscaled, negp, shift_amount;9676 C_uword *scan;9677 double i, f;96789679 f = C_flonum_magnitude(flonum);96809681 if (C_isnan(f)) {9682 return C_SCHEME_FALSE; /* "mu" */9683 } else if (C_isinf(f)) {9684 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9685 } else {9686 /* Scale up the floating-point number to become a whole integer,9687 * and remember power of two (# of bits) to shift the numerator.9688 */9689 shift_amount = 0;96909691 /* TODO: This doesn't work for denormalized flonums! */9692 while (modf(f, &i) != 0.0) {9693 f = ldexp(f, 1);9694 shift_amount++;9695 }96969697 i = f; /* TODO: split i and f so it'll work for denormalized flonums */96989699 num = C_u_i_ratnum_num(ratnum);9700 negp = C_i_negativep(num);97019702 if (C_truep(negp) && i >= 0.0) { /* Save some time if signs differ */9703 return C_fix(-1);9704 } else if (!C_truep(negp) && i <= 0.0) { /* num is never 0 */9705 return C_fix(1);9706 } else {9707 denom = C_u_i_ratnum_denom(ratnum);9708 i_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));97099710 /* Multiply the scaled flonum integer by the denominator, and9711 * shift the numerator so that they may be directly compared. */9712 iscaled = C_s_a_u_i_integer_times(&a, 2, i_int, denom);9713 nscaled = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));97149715 /* Finally, we're ready to compare them! */9716 res = basic_cmp(nscaled, iscaled, "rat_flo_cmp", 0);9717 clear_buffer_object(ab, nscaled);9718 clear_buffer_object(ab, iscaled);9719 clear_buffer_object(ab, i_int);97209721 return res;9722 }9723 }9724}97259726static C_word flo_rat_cmp(C_word flonum, C_word ratnum)9727{9728 C_word res = rat_flo_cmp(ratnum, flonum);9729 switch(res) {9730 case C_fix(1): return C_fix(-1);9731 case C_fix(-1): return C_fix(1);9732 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9733 }9734}97359736/* The primitive comparison operator. eqp should be 1 if we're only9737 * interested in equality testing (can speed things up and in case of9738 * compnums, equality checking is the only available operation). This9739 * may return #f, in case there is no answer (for NaNs) or as a quick9740 * and dirty non-zero answer when eqp is true. Ugly but effective :)9741 */9742static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)9743{9744 if (x & C_FIXNUM_BIT) {9745 if (y & C_FIXNUM_BIT) {9746 return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0));9747 } else if (C_immediatep(y)) {9748 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9749 } else if (C_block_header(y) == C_FLONUM_TAG) {9750 return int_flo_cmp(x, y);9751 } else if (C_truep(C_bignump(y))) {9752 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9753 return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);9754 } else if (C_block_header(y) == C_RATNUM_TAG) {9755 if (eqp) return C_SCHEME_FALSE;9756 else return rat_cmp(x, y);9757 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9758 if (eqp) return C_SCHEME_FALSE;9759 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9760 } else {9761 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9762 }9763 } else if (C_immediatep(x)) {9764 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9765 } else if (C_block_header(x) == C_FLONUM_TAG) {9766 if (y & C_FIXNUM_BIT) {9767 return flo_int_cmp(x, y);9768 } else if (C_immediatep(y)) {9769 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9770 } else if (C_block_header(y) == C_FLONUM_TAG) {9771 double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);9772 if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */9773 else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));9774 } else if (C_truep(C_bignump(y))) {9775 return flo_int_cmp(x, y);9776 } else if (C_block_header(y) == C_RATNUM_TAG) {9777 return flo_rat_cmp(x, y);9778 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9779 if (eqp) return C_SCHEME_FALSE;9780 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9781 } else {9782 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9783 }9784 } else if (C_truep(C_bignump(x))) {9785 if (y & C_FIXNUM_BIT) {9786 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9787 return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));9788 } else if (C_immediatep(y)) {9789 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9790 } else if (C_block_header(y) == C_FLONUM_TAG) {9791 return int_flo_cmp(x, y);9792 } else if (C_truep(C_bignump(y))) {9793 return C_i_bignum_cmp(x, y);9794 } else if (C_block_header(y) == C_RATNUM_TAG) {9795 if (eqp) return C_SCHEME_FALSE;9796 else return rat_cmp(x, y);9797 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9798 if (eqp) return C_SCHEME_FALSE;9799 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9800 } else {9801 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9802 }9803 } else if (C_block_header(x) == C_RATNUM_TAG) {9804 if (y & C_FIXNUM_BIT) {9805 if (eqp) return C_SCHEME_FALSE;9806 else return rat_cmp(x, y);9807 } else if (C_immediatep(y)) {9808 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9809 } else if (C_block_header(y) == C_FLONUM_TAG) {9810 return rat_flo_cmp(x, y);9811 } else if (C_truep(C_bignump(y))) {9812 if (eqp) return C_SCHEME_FALSE;9813 else return rat_cmp(x, y);9814 } else if (C_block_header(y) == C_RATNUM_TAG) {9815 if (eqp) {9816 return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x),9817 C_u_i_ratnum_num(y)),9818 C_i_integer_equalp(C_u_i_ratnum_denom(x),9819 C_u_i_ratnum_denom(y))),9820 C_fix(0));9821 } else {9822 return rat_cmp(x, y);9823 }9824 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9825 if (eqp) return C_SCHEME_FALSE;9826 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9827 } else {9828 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9829 }9830 } else if (C_block_header(x) == C_CPLXNUM_TAG) {9831 if (!eqp) {9832 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x);9833 } else if (y & C_FIXNUM_BIT) {9834 return C_SCHEME_FALSE;9835 } else if (C_immediatep(y)) {9836 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9837 } else if (C_block_header(y) == C_FLONUM_TAG ||9838 C_truep(C_bignump(x)) ||9839 C_block_header(y) == C_RATNUM_TAG) {9840 return C_SCHEME_FALSE;9841 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9842 return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)),9843 C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))),9844 C_fix(0));9845 } else {9846 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9847 }9848 } else {9849 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9850 }9851}98529853static int bignum_cmp_unsigned(C_word x, C_word y)9854{9855 C_word xlen = C_bignum_size(x), ylen = C_bignum_size(y);98569857 if (xlen < ylen) {9858 return -1;9859 } else if (xlen > ylen) {9860 return 1;9861 } else if (x == y) {9862 return 0;9863 } else {9864 C_uword *startx = C_bignum_digits(x),9865 *scanx = startx + xlen,9866 *scany = C_bignum_digits(y) + ylen;98679868 while (startx < scanx) {9869 C_uword xdigit = (*--scanx), ydigit = (*--scany);9870 if (xdigit < ydigit)9871 return -1;9872 if (xdigit > ydigit)9873 return 1;9874 }9875 return 0;9876 }9877}98789879C_regparm C_word C_i_bignum_cmp(C_word x, C_word y)9880{9881 if (C_bignum_negativep(x)) {9882 if (C_bignum_negativep(y)) { /* Largest negative number is smallest */9883 return C_fix(bignum_cmp_unsigned(y, x));9884 } else {9885 return C_fix(-1);9886 }9887 } else {9888 if (C_bignum_negativep(y)) {9889 return C_fix(1);9890 } else {9891 return C_fix(bignum_cmp_unsigned(x, y));9892 }9893 }9894}98959896void C_ccall C_nequalp(C_word c, C_word *av)9897{9898 /* C_word closure = av[ 0 ]; */9899 C_word k = av[ 1 ];9900 C_word x, y, result = C_SCHEME_TRUE;99019902 c -= 2;9903 av += 2;9904 if (c == 0) C_kontinue(k, result);9905 x = *(av++);99069907 if (c == 1 && !C_truep(C_i_numberp(x)))9908 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);99099910 while(--c) {9911 y = *(av++);9912 result = C_i_nequalp(x, y);9913 if (result == C_SCHEME_FALSE) break;9914 }99159916 C_kontinue(k, result);9917}99189919C_regparm C_word C_i_nequalp(C_word x, C_word y)9920{9921 return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));9922}99239924C_regparm C_word C_i_integer_equalp(C_word x, C_word y)9925{9926 if (x & C_FIXNUM_BIT)9927 return C_mk_bool(x == y);9928 else if (y & C_FIXNUM_BIT)9929 return C_SCHEME_FALSE;9930 else9931 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(0));9932}993399349935void C_ccall C_greaterp(C_word c, C_word *av)9936{9937 C_word x, y,9938 /* closure = av[ 0 ] */9939 k = av[ 1 ],9940 result = C_SCHEME_TRUE;99419942 c -= 2;9943 av += 2;9944 if (c == 0) C_kontinue(k, result);99459946 x = *(av++);99479948 if (c == 1 && !C_truep(C_i_numberp(x)))9949 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">", x);99509951 while(--c) {9952 y = *(av++);9953 result = C_i_greaterp(x, y);9954 if (result == C_SCHEME_FALSE) break;9955 x = y;9956 }99579958 C_kontinue(k, result);9959}996099619962C_regparm C_word C_i_greaterp(C_word x, C_word y)9963{9964 return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));9965}99669967C_regparm C_word C_i_integer_greaterp(C_word x, C_word y)9968{9969 if (x & C_FIXNUM_BIT) {9970 if (y & C_FIXNUM_BIT) {9971 return C_mk_bool(C_unfix(x) > C_unfix(y));9972 } else {9973 return C_mk_bool(C_bignum_negativep(y));9974 }9975 } else if (y & C_FIXNUM_BIT) {9976 return C_mk_nbool(C_bignum_negativep(x));9977 } else {9978 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(1));9979 }9980}99819982void C_ccall C_lessp(C_word c, C_word *av)9983{9984 C_word x, y,9985 /* closure = av[ 0 ] */9986 k = av[ 1 ],9987 result = C_SCHEME_TRUE;99889989 c -= 2;9990 av += 2;9991 if (c == 0) C_kontinue(k, result);99929993 x = *(av++);99949995 if (c == 1 && !C_truep(C_i_numberp(x)))9996 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<", x);99979998 while(--c) {9999 y = *(av++);10000 result = C_i_lessp(x, y);10001 if (result == C_SCHEME_FALSE) break;10002 x = y;10003 }1000410005 C_kontinue(k, result);10006}100071000810009C_regparm C_word C_i_lessp(C_word x, C_word y)10010{10011 return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));10012}1001310014C_regparm C_word C_i_integer_lessp(C_word x, C_word y)10015{10016 if (x & C_FIXNUM_BIT) {10017 if (y & C_FIXNUM_BIT) {10018 return C_mk_bool(C_unfix(x) < C_unfix(y));10019 } else {10020 return C_mk_nbool(C_bignum_negativep(y));10021 }10022 } else if (y & C_FIXNUM_BIT) {10023 return C_mk_bool(C_bignum_negativep(x));10024 } else {10025 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(-1));10026 }10027}1002810029void C_ccall C_greater_or_equal_p(C_word c, C_word *av)10030{10031 C_word x, y,10032 /* closure = av[ 0 ] */10033 k = av[ 1 ],10034 result = C_SCHEME_TRUE;1003510036 c -= 2;10037 av += 2;10038 if (c == 0) C_kontinue(k, result);1003910040 x = *(av++);1004110042 if (c == 1 && !C_truep(C_i_numberp(x)))10043 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">=", x);1004410045 while(--c) {10046 y = *(av++);10047 result = C_i_greater_or_equalp(x, y);10048 if (result == C_SCHEME_FALSE) break;10049 x = y;10050 }1005110052 C_kontinue(k, result);10053}100541005510056C_regparm C_word C_i_greater_or_equalp(C_word x, C_word y)10057{10058 C_word res = basic_cmp(x, y, ">=", 0);10059 return C_mk_bool(res == C_fix(0) || res == C_fix(1));10060}1006110062C_regparm C_word C_i_integer_greater_or_equalp(C_word x, C_word y)10063{10064 if (x & C_FIXNUM_BIT) {10065 if (y & C_FIXNUM_BIT) {10066 return C_mk_bool(C_unfix(x) >= C_unfix(y));10067 } else {10068 return C_mk_bool(C_bignum_negativep(y));10069 }10070 } else if (y & C_FIXNUM_BIT) {10071 return C_mk_nbool(C_bignum_negativep(x));10072 } else {10073 C_word res = C_i_bignum_cmp(x, y);10074 return C_mk_bool(res == C_fix(0) || res == C_fix(1));10075 }10076}1007710078void C_ccall C_less_or_equal_p(C_word c, C_word *av)10079{10080 C_word x, y,10081 /* closure = av[ 0 ] */10082 k = av[ 1 ],10083 result = C_SCHEME_TRUE;1008410085 c -= 2;10086 av += 2;10087 if (c == 0) C_kontinue(k, result);1008810089 x = *(av++);1009010091 if (c == 1 && !C_truep(C_i_numberp(x)))10092 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<=", x);1009310094 while(--c) {10095 y = *(av++);10096 result = C_i_less_or_equalp(x, y);10097 if (result == C_SCHEME_FALSE) break;10098 x = y;10099 }1010010101 C_kontinue(k, result);10102}101031010410105C_regparm C_word C_i_less_or_equalp(C_word x, C_word y)10106{10107 C_word res = basic_cmp(x, y, "<=", 0);10108 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10109}101101011110112C_regparm C_word C_i_integer_less_or_equalp(C_word x, C_word y)10113{10114 if (x & C_FIXNUM_BIT) {10115 if (y & C_FIXNUM_BIT) {10116 return C_mk_bool(C_unfix(x) <= C_unfix(y));10117 } else {10118 return C_mk_nbool(C_bignum_negativep(y));10119 }10120 } else if (y & C_FIXNUM_BIT) {10121 return C_mk_bool(C_bignum_negativep(x));10122 } else {10123 C_word res = C_i_bignum_cmp(x, y);10124 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10125 }10126}101271012810129void C_ccall C_gc(C_word c, C_word *av)10130{10131 C_word10132 /* closure = av[ 0 ] */10133 k = av[ 1 ];10134 int f;10135 C_word10136 arg, *p,10137 size = 0;1013810139 if(c == 3) {10140 arg = av[ 2 ];10141 f = C_truep(arg);10142 }10143 else if(c != 2) C_bad_min_argc(c, 2);10144 else f = 1;1014510146 C_save(k);10147 p = C_temporary_stack;1014810149 if(c == 3) {10150 if((arg & C_FIXNUM_BIT) != 0) size = C_unfix(arg);10151 else if(arg == C_SCHEME_END_OF_LIST) size = percentage(heap_size, C_heap_growth);10152 }1015310154 if(size && !C_heap_size_is_fixed) {10155 C_rereclaim2(size, 0);10156 C_temporary_stack = C_temporary_stack_bottom;10157 gc_2(0, p);10158 }10159 else if(f) C_fromspace_top = C_fromspace_limit;1016010161 C_reclaim((void *)gc_2, 1);10162}101631016410165void C_ccall gc_2(C_word c, C_word *av)10166{10167 C_word k = av[ 0 ];10168 C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));10169}101701017110172void C_ccall C_open_file_port(C_word c, C_word *av)10173{10174 C_word10175 /* closure = av[ 0 ] */10176 k = av[ 1 ],10177 port = av[ 2 ],10178 channel = av[ 3 ],10179 mode = av[ 4 ];10180 C_FILEPTR fp = (C_FILEPTR)NULL;10181 C_char *fmode;10182 C_word n, bv, fbv;10183 C_char *buf;10184 C_WCHAR *fbuf;1018510186 switch(channel) {10187 case C_fix(0): fp = C_stdin; break;10188 case C_fix(1): fp = C_stdout; break;10189 case C_fix(2): fp = C_stderr; break;10190 default:10191 bv = C_block_item(channel, 0);10192 buf = C_c_string(bv);10193 fbv = C_block_item(mode, 0);10194 fmode = C_c_string(fbv);10195 if (C_header_size(C_block_item(channel, 0)) - 1 != strlen(buf))10196 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", channel);10197 if (C_header_size(C_block_item(mode, 0)) - 1 != strlen(fmode))10198 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", mode);10199 fbuf = C_OS_FILENAME(bv, 0);10200 fp = C_fopen(fbuf, C_OS_FILENAME(fbv, 1));10201 }1020210203 C_set_block_item(port, 0, (C_word)fp);10204 C_kontinue(k, C_mk_bool(fp != NULL));10205}102061020710208void C_ccall C_allocate_vector(C_word c, C_word *av)10209{10210 C_word10211 /* closure = av[ 0 ] */10212 k = av[ 1 ],10213 size, init, bytes, n, *p;1021410215 if(c != 4) C_bad_argc(c, 4);1021610217 size = av[ 2 ];10218 init = av[ 3 ];10219 n = C_unfix(size);1022010221 if(n > C_HEADER_SIZE_MASK || n < 0)10222 barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1022310224 bytes = C_wordstobytes(n) + sizeof(C_word);1022510226 C_save(k);10227 C_save(size);10228 C_save(init);10229 C_save(C_fix(bytes));1023010231 if(!C_demand(C_bytestowords(bytes))) {10232 /* Allocate on heap: */10233 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10234 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1023510236 C_save(C_SCHEME_TRUE);10237 /* We explicitly pass 5 here, that's the number of things saved.10238 * That's the arguments, plus one additional thing: the mode.10239 */10240 C_reclaim((void *)allocate_vector_2, 5);10241 }1024210243 C_save(C_SCHEME_FALSE);10244 p = C_temporary_stack;10245 C_temporary_stack = C_temporary_stack_bottom;10246 allocate_vector_2(0, p);10247}102481024910250void C_ccall allocate_vector_2(C_word c, C_word *av)10251{10252 C_word10253 mode = av[ 0 ],10254 bytes = C_unfix(av[ 1 ]),10255 init = av[ 2 ],10256 size = C_unfix(av[ 3 ]),10257 k = av[ 4 ],10258 *v0, v;1025910260 if(C_truep(mode)) {10261 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10262 if(C_heap_size_is_fixed)10263 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1026410265 C_save(init);10266 C_save(k);10267 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10268 k = C_restore;10269 init = C_restore;10270 }1027110272 v0 = (C_word *)C_align((C_word)C_fromspace_top);10273 C_fromspace_top += C_align(bytes);10274 }10275 else v0 = C_alloc(C_bytestowords(bytes));1027610277 v = (C_word)v0;10278 *(v0++) = C_VECTOR_TYPE | size;10279 while(size--) *(v0++) = init;10280 C_kontinue(k, v);10281}1028210283void C_ccall C_allocate_bytevector(C_word c, C_word *av)10284{10285 C_word10286 /* closure = av[ 0 ] */10287 k = av[ 1 ],10288 size, init, align8, bytes, str, n, *p;1028910290 if(c != 4) C_bad_argc(c, 4);1029110292 size = av[ 2 ];10293 init = av[ 3 ];10294 n = C_unfix(size);1029510296 if(n > C_HEADER_SIZE_MASK || n < 0)10297 barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1029810299 bytes = n + sizeof(C_word) * 2;1030010301 C_save(k);10302 C_save(size);10303 C_save(init);10304 C_save(C_fix(bytes));1030510306 if(!C_demand(C_bytestowords(bytes))) {10307 /* Allocate on heap: */10308 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10309 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1031010311 C_save(C_SCHEME_TRUE);10312 /* We explicitly pass 5 here, that's the number of things saved.10313 * That's the arguments, plus one additional thing: the mode.10314 */10315 C_reclaim((void *)allocate_bytevector_2, 5);10316 }1031710318 C_save(C_SCHEME_FALSE);10319 p = C_temporary_stack;10320 C_temporary_stack = C_temporary_stack_bottom;10321 allocate_bytevector_2(0, p);10322}103231032410325void C_ccall allocate_bytevector_2(C_word c, C_word *av)10326{10327 C_word10328 mode = av[ 0 ],10329 bytes = C_unfix(av[ 1 ]),10330 init = av[ 2 ],10331 size = C_unfix(av[ 3 ]),10332 k = av[ 4 ],10333 *v0, v;10334 char buf[ 4 ];1033510336 if(C_truep(mode)) {10337 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10338 if(C_heap_size_is_fixed)10339 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1034010341 C_save(init);10342 C_save(k);10343 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10344 k = C_restore;10345 init = C_restore;10346 }1034710348 v0 = (C_word *)C_align((C_word)C_fromspace_top);10349 C_fromspace_top += C_align(bytes);10350 }10351 else v0 = C_alloc(C_bytestowords(bytes));1035210353#ifndef C_SIXTY_FOUR10354 if(C_aligned8(v0)) ++v0;10355#endif1035610357 v = (C_word)v0;10358 *(v0++) = C_BYTEVECTOR_TYPE | size;1035910360 if(C_truep(init)) C_memset(v0, C_unfix(init), size);1036110362 C_kontinue(k, v);10363}1036410365static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)10366{10367 C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),10368 bigvec = (C_word)(mem + C_SIZEOF_BIGNUM_WRAPPER);10369 if (mem == NULL) abort(); /* TODO: panic */1037010371 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));10372 C_set_block_item(bigvec, 0, C_truep(negp));1037310374 if (C_truep(initp)) {10375 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10376 0, C_wordstobytes(C_unfix(size)));10377 }1037810379 return C_a_i_bignum_wrapper(&mem, bigvec);10380}1038110382C_regparm C_word10383C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)10384{10385 C_word big, bigvec = C_scratch_alloc(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));1038610387 C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));10388 C_set_block_item(bigvec, 0, C_truep(negp));1038910390 if (C_truep(initp)) {10391 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10392 0, C_wordstobytes(C_unfix(size)));10393 }1039410395 big = C_a_i_bignum_wrapper(ptr, bigvec);10396 C_mutate_scratch_slot(&C_internal_bignum_vector(big), bigvec);10397 return big;10398}1039910400/* Simplification: scan trailing zeroes, then return a fixnum if the10401 * value fits, or trim the bignum's length. If the bignum was stored10402 * in scratch space, we mark it as reclaimable. This means any10403 * references to the original bignum are invalid after simplification!10404 */10405C_regparm C_word C_bignum_simplify(C_word big)10406{10407 C_uword *start = C_bignum_digits(big),10408 *last_digit = start + C_bignum_size(big) - 1,10409 *scan = last_digit, tmp;10410 int length;1041110412 while (scan >= start && *scan == 0)10413 scan--;10414 length = scan - start + 1;1041510416 switch(length) {10417 case 0:10418 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10419 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10420 return C_fix(0);10421 case 1:10422 tmp = *start;10423 if (C_bignum_negativep(big) ?10424 !(tmp & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)tmp) :10425 C_ufitsinfixnump(tmp)) {10426 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10427 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10428 return C_bignum_negativep(big) ? C_fix(-(C_word)tmp) : C_fix(tmp);10429 }10430 /* FALLTHROUGH */10431 default:10432 if (scan < last_digit) C_bignum_mutate_size(big, length);10433 return big;10434 }10435}1043610437static void bignum_digits_destructive_negate(C_word result)10438{10439 C_uword *scan, *end, digit, sum;1044010441 scan = C_bignum_digits(result);10442 end = scan + C_bignum_size(result);1044310444 do {10445 digit = ~*scan;10446 sum = digit + 1;10447 *scan++ = sum;10448 } while (sum == 0 && scan < end);1044910450 for (; scan < end; scan++) {10451 *scan = ~*scan;10452 }10453}1045410455static C_uword10456bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)10457{10458 C_uword digit, p;1045910460 assert(C_fitsinbignumhalfdigitp(carry));10461 assert(C_fitsinbignumhalfdigitp(factor));1046210463 /* See fixnum_times. Substitute xlo = factor, xhi = 0, y = digit10464 * and simplify the result to reduce variable usage.10465 */10466 while (start < end) {10467 digit = (*start);1046810469 p = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;10470 carry = C_BIGNUM_DIGIT_LO_HALF(p);1047110472 p = factor * C_BIGNUM_DIGIT_HI_HALF(digit) + C_BIGNUM_DIGIT_HI_HALF(p);10473 (*start++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), carry);10474 carry = C_BIGNUM_DIGIT_HI_HALF(p);10475 }10476 return carry;10477}1047810479static C_uword10480bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator)10481{10482 C_uword digit, k = 0;10483 C_uhword q_j_hi, q_j_lo;1048410485 /* Single digit divisor case from Hacker's Delight, Figure 9-1,10486 * adapted to modify u[] in-place instead of writing to q[].10487 */10488 while (start < end) {10489 digit = (*--end);1049010491 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_HI_HALF(digit)); /* j */10492 q_j_hi = k / denominator;10493 k -= q_j_hi * denominator;1049410495 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */10496 q_j_lo = k / denominator;10497 k -= q_j_lo * denominator;1049810499 *end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);10500 }10501 return k;10502}1050310504static C_uword10505bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp)10506{10507 int shift_left = C_BIGNUM_DIGIT_LENGTH - shift_right;10508 C_uword digit, carry = negp ? ((~(C_uword)0) << shift_left) : 0;1050910510 assert(shift_right < C_BIGNUM_DIGIT_LENGTH);1051110512 while (start < end) {10513 digit = *(--end);10514 *end = (digit >> shift_right) | carry;10515 carry = digit << shift_left;10516 }10517 return carry >> shift_left; /* The bits that were shifted out to the right */10518}1051910520static C_uword10521bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left)10522{10523 C_uword carry = 0, digit;10524 int shift_right = C_BIGNUM_DIGIT_LENGTH - shift_left;1052510526 assert(shift_left < C_BIGNUM_DIGIT_LENGTH);1052710528 while (start < end) {10529 digit = *start;10530 (*start++) = (digit << shift_left) | carry;10531 carry = digit >> shift_right;10532 }10533 return carry; /* This would end up as most significant digit if it fit */10534}1053510536static C_regparm void10537bignum_digits_multiply(C_word x, C_word y, C_word result)10538{10539 C_uword product,10540 *xd = C_bignum_digits(x),10541 *yd = C_bignum_digits(y),10542 *rd = C_bignum_digits(result);10543 C_uhword carry, yj;10544 /* Lengths in halfwords */10545 int i, j, length_x = C_bignum_size(x) * 2, length_y = C_bignum_size(y) * 2;1054610547 /* From Hacker's Delight, Figure 8-1 (top part) */10548 for (j = 0; j < length_y; ++j) {10549 yj = C_uhword_ref(yd, j);10550 if (yj == 0) continue;10551 carry = 0;10552 for (i = 0; i < length_x; ++i) {10553 product = (C_uword)C_uhword_ref(xd, i) * yj +10554 (C_uword)C_uhword_ref(rd, i + j) + carry;10555 C_uhword_set(rd, i + j, product);10556 carry = C_BIGNUM_DIGIT_HI_HALF(product);10557 }10558 C_uhword_set(rd, j + length_x, carry);10559 }10560}105611056210563/* "small" is either a number that fits a halfdigit, or a power of two */10564static C_regparm void10565bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)10566{10567 C_word size, quotient, q_negp = C_mk_bool((y & C_INT_SIGN_BIT) ?10568 !(C_bignum_negativep(x)) :10569 C_bignum_negativep(x)),10570 r_negp = C_mk_bool(C_bignum_negativep(x));10571 C_uword *start, *end, remainder;10572 int shift_amount;1057310574 size = C_fix(C_bignum_size(x));10575 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);10576 bignum_digits_destructive_copy(quotient, x);1057710578 start = C_bignum_digits(quotient);10579 end = start + C_bignum_size(quotient);1058010581 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);1058210583 shift_amount = C_ilen(y) - 1;10584 if (((C_uword)1 << shift_amount) == y) { /* Power of two? Shift! */10585 remainder = bignum_digits_destructive_shift_right(start,end,shift_amount,0);10586 assert(C_ufitsinfixnump(remainder));10587 } else {10588 remainder = bignum_digits_destructive_scale_down(start, end, y);10589 assert(C_fitsinbignumhalfdigitp(remainder));10590 }1059110592 if (r != NULL) *r = C_truep(r_negp) ? C_fix(-remainder) : C_fix(remainder);10593 /* Calling this function only makes sense if quotient is needed */10594 *q = C_bignum_simplify(quotient);10595}1059610597static C_regparm void10598bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder)10599{10600 C_word length = C_bignum_size(denominator);10601 C_uword d1 = *(C_bignum_digits(denominator) + length - 1),10602 *startr = C_bignum_digits(remainder),10603 *endr = startr + C_bignum_size(remainder);10604 int shift;1060510606 shift = C_BIGNUM_DIGIT_LENGTH - C_ilen(d1); /* nlz */1060710608 /* We have to work on halfdigits, so we shift out only the necessary10609 * amount in order fill out that halfdigit (base is halved).10610 * This trick is shamelessly stolen from Gauche :)10611 * See below for part 2 of the trick.10612 */10613 if (shift >= C_BIGNUM_HALF_DIGIT_LENGTH)10614 shift -= C_BIGNUM_HALF_DIGIT_LENGTH;1061510616 /* Code below won't always set high halfdigit of quotient, so do it here. */10617 if (quotient != C_SCHEME_UNDEFINED)10618 C_bignum_digits(quotient)[C_bignum_size(quotient)-1] = 0;1061910620 bignum_digits_destructive_copy(remainder, numerator);10621 *(endr-1) = 0; /* Ensure most significant digit is initialised */10622 if (shift == 0) { /* Already normalized */10623 bignum_destructive_divide_normalized(remainder, denominator, quotient);10624 } else { /* Requires normalisation; allocate scratch denominator for this */10625 C_uword *startnd;10626 C_word ndenom;1062710628 bignum_digits_destructive_shift_left(startr, endr, shift);1062910630 ndenom = allocate_tmp_bignum(C_fix(length), C_SCHEME_FALSE, C_SCHEME_FALSE);10631 startnd = C_bignum_digits(ndenom);10632 bignum_digits_destructive_copy(ndenom, denominator);10633 bignum_digits_destructive_shift_left(startnd, startnd+length, shift);1063410635 bignum_destructive_divide_normalized(remainder, ndenom, quotient);10636 if (C_truep(return_remainder)) /* Otherwise, don't bother shifting back */10637 bignum_digits_destructive_shift_right(startr, endr, shift, 0);1063810639 free_tmp_bignum(ndenom);10640 }10641}1064210643static C_regparm void10644bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)10645{10646 C_uword *v = C_bignum_digits(big_v),10647 *u = C_bignum_digits(big_u),10648 *q = big_q == C_SCHEME_UNDEFINED ? NULL : C_bignum_digits(big_q),10649 p, /* product of estimated quotient & "denominator" */10650 hat, qhat, rhat, /* estimated quotient and remainder digit */10651 vn_1, vn_2; /* "cached" values v[n-1], v[n-2] */10652 C_word t, k; /* Two helpers: temp/final remainder and "borrow" */10653 /* We use plain ints here, which theoretically may not be enough on10654 * 64-bit for an insanely huge number, but it is a _lot_ faster.10655 */10656 int n = C_bignum_size(big_v) * 2, /* in halfwords */10657 m = (C_bignum_size(big_u) * 2) - 2; /* Correct for extra digit */10658 int i, j; /* loop vars */1065910660 /* Part 2 of Gauche's aforementioned trick: */10661 if (C_uhword_ref(v, n-1) == 0) n--;1066210663 /* These won't change during the loop, but are used in every step. */10664 vn_1 = C_uhword_ref(v, n-1);10665 vn_2 = C_uhword_ref(v, n-2);1066610667 /* See also Hacker's Delight, Figure 9-1. This is almost exactly that. */10668 for (j = m - n; j >= 0; j--) {10669 hat = C_BIGNUM_DIGIT_COMBINE(C_uhword_ref(u, j+n), C_uhword_ref(u, j+n-1));10670 if (hat == 0) {10671 if (q != NULL) C_uhword_set(q, j, 0);10672 continue;10673 }10674 qhat = hat / vn_1;10675 rhat = hat % vn_1;1067610677 /* Two whiles is faster than one big check with an OR. Thanks, Gauche! */10678 while(qhat >= ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) { qhat--; rhat += vn_1; }10679 while(qhat * vn_2 > C_BIGNUM_DIGIT_COMBINE(rhat, C_uhword_ref(u, j+n-2))10680 && rhat < ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) {10681 qhat--;10682 rhat += vn_1;10683 }1068410685 /* Multiply and subtract */10686 k = 0;10687 for (i = 0; i < n; i++) {10688 p = qhat * C_uhword_ref(v, i);10689 t = C_uhword_ref(u, i+j) - k - C_BIGNUM_DIGIT_LO_HALF(p);10690 C_uhword_set(u, i+j, t);10691 k = C_BIGNUM_DIGIT_HI_HALF(p) - (t >> C_BIGNUM_HALF_DIGIT_LENGTH);10692 }10693 t = C_uhword_ref(u,j+n) - k;10694 C_uhword_set(u, j+n, t);1069510696 if (t < 0) { /* Subtracted too much? */10697 qhat--;10698 k = 0;10699 for (i = 0; i < n; i++) {10700 t = (C_uword)C_uhword_ref(u, i+j) + C_uhword_ref(v, i) + k;10701 C_uhword_set(u, i+j, t);10702 k = t >> C_BIGNUM_HALF_DIGIT_LENGTH;10703 }10704 C_uhword_set(u, j+n, (C_uhword_ref(u, j+n) + k));10705 }10706 if (q != NULL) C_uhword_set(q, j, qhat);10707 } /* end j */10708}107091071010711/* XXX this should be an inline_allocate routine */10712void C_ccall C_string_to_symbol(C_word c, C_word *av)10713{10714 C_word10715 /* closure = av[ 0 ] */10716 k = av[ 1 ];10717 int len, key;10718 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;10719 C_char *name;1072010721 b = av[ 2 ];10722 len = C_header_size(b) - 1;10723 name = C_c_string(b);1072410725 key = hash_string(len, name, symbol_table->size, symbol_table->rand);10726 if(!C_truep(s = lookup(key, len, name, symbol_table)))10727 s = add_symbol(&a, key, b, symbol_table);1072810729 C_kontinue(k, s);10730}1073110732/* XXX this should be an inline_allocate routine */10733void C_ccall C_string_to_keyword(C_word c, C_word *av)10734{10735 C_word10736 /* closure = av[ 0 ] */10737 k = av[ 1 ];10738 int len, key;10739 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;10740 C_char *name;1074110742 b = av[ 2 ];10743 len = C_header_size(b) - 1;10744 name = C_c_string(b);10745 key = hash_string(len, name, keyword_table->size, keyword_table->rand);1074610747 if(!C_truep(s = lookup(key, len, name, keyword_table))) {10748 s = add_symbol(&a, key, b, keyword_table);10749 C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */10750 C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */10751 }10752 C_kontinue(k, s);10753}1075410755/* This will usually return a flonum, but it may also return a cplxnum10756 * consisting of two flonums, making for a total of 11 words.10757 */10758C_regparm C_word10759C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)10760{10761 if (n & C_FIXNUM_BIT) {10762 return C_flonum(ptr, (double)C_unfix(n));10763 } else if (C_immediatep(n)) {10764 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10765 } else if (C_block_header(n) == C_FLONUM_TAG) {10766 return n;10767 } else if (C_truep(C_bignump(n))) {10768 return C_a_u_i_big_to_flo(ptr, c, n);10769 } else if (C_block_header(n) == C_CPLXNUM_TAG) {10770 return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)),10771 C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n)));10772 /* The horribly painful case: ratnums */10773 } else if (C_block_header(n) == C_RATNUM_TAG) {10774 /* This tries to keep the numbers within representable ranges and10775 * tries to drop as few significant digits as possible by bringing10776 * the two numbers to within the same powers of two. See10777 * algorithms M & N in Knuth, 4.2.1.10778 */10779 C_word num = C_u_i_ratnum_num(n), denom = C_u_i_ratnum_denom(n),10780 /* e = approx. distance between the numbers in powers of 2.10781 * ie, 2^e-1 < n/d < 2^e+1 (e is the *un*biased value of10782 * e_w in M2. TODO: What if b!=2 (ie, flonum-radix isn't 2)?10783 */10784 e = integer_length_abs(num) - integer_length_abs(denom),10785 ab[C_SIZEOF_FIX_BIGNUM*5+C_SIZEOF_FLONUM], *a = ab, tmp, q, r, len,10786 shift_amount, negp = C_i_integer_negativep(num);10787 C_uword *d;10788 double res, fraction;1078910790 /* Align by shifting the smaller to the size of the larger */10791 if (e < 0) num = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(-e));10792 else if (e > 0) denom = C_s_a_i_arithmetic_shift(&a, 2, denom, C_fix(e));1079310794 /* Here, 1/2 <= n/d < 2 [N3] */10795 if (C_truep(C_i_integer_lessp(num, denom))) { /* n/d < 1? */10796 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(1));10797 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10798 num = tmp;10799 e--;10800 }1080110802 /* Here, 1 <= n/d < 2 (normalized) [N5] */10803 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));1080410805 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));10806 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10807 num = tmp;1080810809 /* Now, calculate round(num/denom). We start with a quotient&remainder */10810 integer_divrem(&a, num, denom, &q, &r);1081110812 /* We multiply the remainder by two to simulate adding 1/2 for10813 * round. However, we don't do it if num = denom (q=1,r=0) */10814 if (!((q == C_fix(1) || q == C_fix(-1)) && r == C_fix(0))) {10815 tmp = C_s_a_i_arithmetic_shift(&a, 2, r, C_fix(1));10816 clear_buffer_object(ab, r); /* "knows" shift creates fresh numbers */10817 r = tmp;10818 }1081910820 /* Now q is the quotient, but to "round" result we need to10821 * adjust. This follows the semantics of the "round" procedure:10822 * Round away from zero on positive numbers (ignoring sign). In10823 * case of exactly halfway, we round up if odd.10824 */10825 tmp = C_a_i_exact_to_inexact(&a, 1, q);10826 fraction = fabs(C_flonum_magnitude(tmp));10827 switch (basic_cmp(r, denom, "", 0)) {10828 case C_fix(0):10829 if (C_truep(C_i_oddp(q))) fraction += 1.0;10830 break;10831 case C_fix(1):10832 fraction += 1.0;10833 break;10834 default: /* if r <= denom, we're done */ break;10835 }1083610837 clear_buffer_object(ab, num);10838 clear_buffer_object(ab, denom);10839 clear_buffer_object(ab, q);10840 clear_buffer_object(ab, r);1084110842 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));10843 res = ldexp(fraction, e - shift_amount);10844 return C_flonum(ptr, C_truep(negp) ? -res : res);10845 } else {10846 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10847 }10848}108491085010851/* this is different from C_a_i_flonum_round, for R5RS compatibility */10852C_regparm C_word C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)10853{10854 double fn, i, f, i2, r;1085510856 fn = C_flonum_magnitude(n);10857 if(fn < 0.0) {10858 f = modf(-fn, &i);10859 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10860 r = -i;10861 else10862 r = -(i + 1.0);10863 }10864 else if(fn == 0.0/* || fn == -0.0*/)10865 r = fn;10866 else {10867 f = modf(fn, &i);10868 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10869 r = i;10870 else10871 r = i + 1.0;10872 }1087310874 return C_flonum(ptr, r);10875}1087610877C_regparm C_word10878C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)10879{10880 double xub, yub, r;1088110882 if (!C_truep(C_u_i_fpintegerp(x)))10883 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);10884 if (!C_truep(C_u_i_fpintegerp(y)))10885 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);1088610887 xub = C_flonum_magnitude(x);10888 yub = C_flonum_magnitude(y);1088910890 if (xub < 0.0) xub = -xub;10891 if (yub < 0.0) yub = -yub;1089210893 while(yub != 0.0) {10894 r = fmod(xub, yub);10895 xub = yub;10896 yub = r;10897 }10898 return C_flonum(p, xub);10899}1090010901/* This is Lehmer's GCD algorithm with Jebelean's quotient test, as10902 * it is presented in the paper "An Analysis of Lehmer’s Euclidean10903 * GCD Algorithm", by J. Sorenson. Fuck the ACM and their goddamn10904 * paywall; you can currently find the paper here:10905 * http://www.csie.nuk.edu.tw/~cychen/gcd/An%20analysis%20of%20Lehmer%27s%20Euclidean%20GCD%20algorithm.pdf10906 * If that URI fails, it's also explained in [MpNT, 5.2]10907 *10908 * The basic idea is to avoid divisions which yield only small10909 * quotients, in which the remainder won't reduce the numbers by10910 * much. This can be detected by dividing only the leading k bits.10911 * In our case, k = C_WORD_SIZE - 2.10912 */10913inline static void lehmer_gcd(C_word **ptr, C_word u, C_word v, C_word *x, C_word *y)10914{10915 int i_even = 1, done = 0;10916 C_word shift_amount = integer_length_abs(u) - (C_WORD_SIZE - 2),10917 ab[C_SIZEOF_BIGNUM(2)*2+C_SIZEOF_FIX_BIGNUM*2], *a = ab,10918 uhat, vhat, qhat, xnext, ynext,10919 xprev = 1, yprev = 0, xcurr = 0, ycurr = 1;1092010921 uhat = C_s_a_i_arithmetic_shift(&a, 2, u, C_fix(-shift_amount));10922 vhat = C_s_a_i_arithmetic_shift(&a, 2, v, C_fix(-shift_amount));10923 assert(uhat & C_FIXNUM_BIT); uhat = C_unfix(uhat);10924 assert(vhat & C_FIXNUM_BIT); vhat = C_unfix(vhat);1092510926 do {10927 qhat = uhat / vhat; /* Estimated quotient for this step */10928 xnext = xprev - qhat * xcurr;10929 ynext = yprev - qhat * ycurr;1093010931 /* Euclidean GCD swap on uhat and vhat (shift_amount is not needed): */10932 shift_amount = vhat;10933 vhat = uhat - qhat * vhat;10934 uhat = shift_amount;1093510936 i_even = !i_even;10937 if (i_even)10938 done = (vhat < -xnext) || ((uhat - vhat) < (ynext - ycurr));10939 else10940 done = (vhat < -ynext) || ((uhat - vhat) < (xnext - xcurr));1094110942 if (!done) {10943 xprev = xcurr; yprev = ycurr;10944 xcurr = xnext; ycurr = ynext;10945 }10946 } while (!done);1094710948 /* x = xprev * u + yprev * v */10949 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xprev), u);10950 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(yprev), v);10951 *x = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10952 *x = move_buffer_object(ptr, ab, *x);10953 clear_buffer_object(ab, uhat);10954 clear_buffer_object(ab, vhat);1095510956 /* y = xcurr * u + ycurr * v */10957 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xcurr), u);10958 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(ycurr), v);10959 *y = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10960 *y = move_buffer_object(ptr, ab, *y);10961 clear_buffer_object(ab, uhat);10962 clear_buffer_object(ab, vhat);10963}1096410965/* Because this must be inlineable (due to + and - using this for10966 * ratnums), we can't use burnikel-ziegler division here, until we10967 * have a C implementation that doesn't consume stack. However,10968 * we *can* use Lehmer's GCD.10969 */10970C_regparm C_word10971C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)10972{10973 C_word ab[2][C_SIZEOF_BIGNUM(2) * 2], *a, newx, newy, size, i = 0;1097410975 if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1097610977 a = ab[i++];10978 x = C_s_a_u_i_integer_abs(&a, 1, x);10979 y = C_s_a_u_i_integer_abs(&a, 1, y);1098010981 if (!C_truep(C_i_integer_greaterp(x, y))) {10982 newx = y; y = x; x = newx; /* Ensure loop invariant: abs(x) >= abs(y) */10983 }1098410985 while(y != C_fix(0)) {10986 assert(integer_length_abs(x) >= integer_length_abs(y));10987 /* x and y are stored in the same buffer, as well as a result */10988 a = ab[i++];10989 if (i == 2) i = 0;1099010991 if (x & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1099210993 /* First, see if we should run a Lehmer step */10994 if ((integer_length_abs(x) - integer_length_abs(y)) < C_HALF_WORD_SIZE) {10995 lehmer_gcd(&a, x, y, &newx, &newy);10996 newx = move_buffer_object(&a, ab[i], newx);10997 newy = move_buffer_object(&a, ab[i], newy);10998 clear_buffer_object(ab[i], x);10999 clear_buffer_object(ab[i], y);11000 x = newx;11001 y = newy;11002 a = ab[i++]; /* Ensure x and y get cleared correctly below */11003 if (i == 2) i = 0;11004 }1100511006 newy = C_s_a_u_i_integer_remainder(&a, 2, x, y);11007 newy = move_buffer_object(&a, ab[i], newy);11008 newx = move_buffer_object(&a, ab[i], y);11009 clear_buffer_object(ab[i], x);11010 clear_buffer_object(ab[i], y);11011 x = newx;11012 y = newy;11013 }1101411015 newx = C_s_a_u_i_integer_abs(ptr, 1, x);11016 newx = move_buffer_object(ptr, ab, newx);11017 clear_buffer_object(ab, x);11018 clear_buffer_object(ab, y);11019 return newx;11020}110211102211023C_regparm C_word11024C_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)11025{11026 if (start == end) {11027 return C_SCHEME_FALSE;11028 } else {11029 size_t nbits;11030 char *s = C_c_string(C_block_item(str, 0));11031 C_word result, size;11032 end = C_unfix(end);11033 start = C_unfix(start);11034 radix = C_unfix(radix);1103511036 assert((radix > 1) && C_fitsinbignumhalfdigitp(radix));1103711038 nbits = (end - start) * C_ilen(radix - 1);11039 size = C_BIGNUM_BITS_TO_DIGITS(nbits);11040 if (size == 1) {11041 result = C_bignum1(ptr, C_truep(negp), 0);11042 } else if (size == 2) {11043 result = C_bignum2(ptr, C_truep(negp), 0, 0);11044 } else {11045 size = C_fix(size);11046 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);11047 }1104811049 return str_to_bignum(result, s + start, s + end, radix);11050 }11051}1105211053inline static int hex_char_to_digit(int ch)11054{11055 if (ch == (int)'#') return 0; /* Hash characters in numbers are mapped to 0 */11056 else if (ch >= (int)'a') return ch - (int)'a' + 10; /* lower hex */11057 else if (ch >= (int)'A') return ch - (int)'A' + 10; /* upper hex */11058 else return ch - (int)'0'; /* decimal (OR INVALID; handled elsewhere) */11059}1106011061/* Write from digit character stream to bignum. Bignum does not need11062 * to be initialised. Returns the bignum, or a fixnum. Assumes the11063 * string contains only digits that fit within radix (checked by11064 * string->number).11065 */11066static C_regparm C_word11067str_to_bignum(C_word bignum, char *str, char *str_end, int radix)11068{11069 int radix_shift, str_digit;11070 C_uword *digits = C_bignum_digits(bignum),11071 *end_digits = digits + C_bignum_size(bignum), big_digit = 0;1107211073 /* Below, we try to save up as much as possible in big_digit, and11074 * only when it exceeds what we would be able to multiply easily, we11075 * scale up the bignum and add what we saved up.11076 */11077 radix_shift = C_ilen(radix) - 1;11078 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11079 int n = 0; /* Number of bits read so far into current big digit */1108011081 /* Read from least to most significant digit to avoid shifting or scaling */11082 while (str_end > str) {11083 str_digit = hex_char_to_digit((int)*--str_end);1108411085 big_digit |= (C_uword)str_digit << n;11086 n += radix_shift;1108711088 if (n >= C_BIGNUM_DIGIT_LENGTH) {11089 n -= C_BIGNUM_DIGIT_LENGTH;11090 *digits++ = big_digit;11091 big_digit = str_digit >> (radix_shift - n);11092 }11093 }11094 assert(n < C_BIGNUM_DIGIT_LENGTH);11095 /* If radix isn't an exact divisor of digit length, write final digit */11096 if (n > 0) *digits++ = big_digit;11097 assert(digits == end_digits);11098 } else { /* Not a power of two */11099 C_uword *last_digit = digits, factor; /* bignum starts as zero */1110011101 do {11102 factor = radix;11103 while (str < str_end && C_fitsinbignumhalfdigitp(factor)) {11104 str_digit = hex_char_to_digit((int)*str++);11105 factor *= radix;11106 big_digit = radix * big_digit + str_digit;11107 }1110811109 big_digit = bignum_digits_destructive_scale_up_with_carry(11110 digits, last_digit, factor / radix, big_digit);1111111112 if (big_digit) {11113 (*last_digit++) = big_digit; /* Move end */11114 big_digit = 0;11115 }11116 } while (str < str_end);1111711118 /* Set remaining digits to zero so bignum_simplify can do its work */11119 assert(last_digit <= end_digits);11120 while (last_digit < end_digits) *last_digit++ = 0;11121 }1112211123 return C_bignum_simplify(bignum);11124}111251112611127static C_regparm double decode_flonum_literal(C_char *str)11128{11129 C_char *eptr;11130 double flo;11131 int len = C_strlen(str);1113211133 /* We only need to be able to parse what C_flonum_to_string() emits,11134 * so we avoid too much error checking.11135 */11136 if (len == 6) { /* Only perform comparisons when necessary */11137 if (!C_strcmp(str, "-inf.0")) return -1.0 / 0.0;11138 if (!C_strcmp(str, "+inf.0")) return 1.0 / 0.0;11139 if (!C_strcmp(str, "+nan.0")) return 0.0 / 0.0;11140 }1114111142 errno = 0;11143 flo = C_strtod(str, &eptr);1114411145 if((flo == HUGE_VAL && errno != 0) ||11146 (flo == -HUGE_VAL && errno != 0) ||11147 (*eptr != '\0' && C_strcmp(eptr, ".0") != 0)) {11148 panic(C_text("could not decode flonum literal"));11149 }1115011151 return flo;11152}111531115411155static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum)11156{11157 static char *digits = "0123456789abcdef";11158 char *p;11159 C_uword shift = C_ilen(base) - 1;11160 int mask = (1 << shift) - 1;11161 if (as_flonum) {11162 buffer[68] = '\0';11163 buffer[67] = '0';11164 buffer[66] = '.';11165 } else {11166 buffer[66] = '\0';11167 }11168 p = buffer + 66;11169 if (mask == base - 1) {11170 do {11171 *(--p) = digits [ num & mask ];11172 num >>= shift;11173 } while (num);11174 } else {11175 do {11176 *(--p) = digits [ num % base ];11177 num /= base;11178 } while (num);11179 }11180 if (negp) *(--p) = '-';11181 return p;11182}111831118411185void C_ccall C_number_to_string(C_word c, C_word *av)11186{11187 C_word radix, num;1118811189 if(c == 3) {11190 radix = C_fix(10);11191 } else if(c == 4) {11192 radix = av[ 3 ];11193 if(!(radix & C_FIXNUM_BIT))11194 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);11195 } else {11196 C_bad_argc(c, 3);11197 }1119811199 num = av[ 2 ];1120011201 if(num & C_FIXNUM_BIT) {11202 C_fixnum_to_string(c, av); /* reuse av */11203 } else if (C_immediatep(num)) {11204 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);11205 } else if(C_block_header(num) == C_FLONUM_TAG) {11206 C_flonum_to_string(c, av); /* reuse av */11207 } else if (C_truep(C_bignump(num))) {11208 C_integer_to_string(c, av); /* reuse av */11209 } else {11210 C_word k = av[ 1 ];11211 try_extended_number("##sys#extended-number->string", 3, k, num, radix);11212 }11213}1121411215void C_ccall C_fixnum_to_string(C_word c, C_word *av)11216{11217 C_char *p;11218 C_word *a,11219 /* self = av[ 0 ] */11220 k = av[ 1 ],11221 num = av[ 2 ],11222 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ])),11223 neg = ((num & C_INT_SIGN_BIT) ? 1 : 0);1122411225 if (radix < 2 || radix > 16) {11226 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11227 }1122811229 num = neg ? -C_unfix(num) : C_unfix(num);11230 p = to_n_nary(num, radix, neg, 0);1123111232 num = C_strlen(p);11233 a = C_alloc(C_SIZEOF_STRING(num));11234 C_kontinue(k, C_string(&a, num, p));11235}1123611237void C_ccall C_flonum_to_string(C_word c, C_word *av)11238{11239 C_char *p;11240 double f, fa, m;11241 C_word *a,11242 /* self = av[ 0 ] */11243 k = av[ 1 ],11244 num = av[ 2 ],11245 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1124611247 f = C_flonum_magnitude(num);11248 fa = fabs(f);1124911250 /* XXX TODO: Should inexacts be printable in other bases than 10?11251 * Perhaps output a string starting with #i?11252 * Right now something like (number->string 1e40 16) results in11253 * a string that can't be read back using string->number.11254 */11255 if((radix < 2) || (radix > 16)){11256 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11257 }1125811259 if(f == 0.0 || (C_modf(f, &m) == 0.0 && log2(fa) < C_WORD_SIZE)) { /* Use fast int code */11260 if(signbit(f)) {11261 p = to_n_nary((C_uword)-f, radix, 1, 1);11262 } else {11263 p = to_n_nary((C_uword)f, radix, 0, 1);11264 }11265 } else if(C_isnan(f)) {11266 p = "+nan.0";11267 } else if(C_isinf(f)) {11268 p = f > 0 ? "+inf.0" : "-inf.0";11269 } else { /* Doesn't fit an unsigned int and not "special"; use system libc */11270 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),11271 /* XXX: flonum_print_precision */11272 (int)C_unfix(C_get_print_precision()), f);11273 buffer[STRING_BUFFER_SIZE-1] = '\0';1127411275 if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {11276 /* Already checked for these, so shouldn't happen */11277 assert(*buffer != 'i'); /* "inf" */11278 assert(*buffer != 'n'); /* "nan" */11279 /* Ensure integral flonums w/o expt are always terminated by .0 */11280#if defined(HAVE_STRLCAT) || !defined(C_strcat)11281 C_strlcat(buffer, C_text(".0"), sizeof(buffer));11282#else11283 C_strcat(buffer, C_text(".0"));11284#endif11285 }11286 p = buffer;11287 }1128811289 radix = C_strlen(p);11290 a = C_alloc(C_SIZEOF_STRING(radix));11291 radix = C_string(&a, radix, p);11292 C_kontinue(k, radix);11293}1129411295void C_ccall C_integer_to_string(C_word c, C_word *av)11296{11297 C_word11298 /* self = av[ 0 ] */11299 k = av[ 1 ],11300 num = av[ 2 ],11301 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1130211303 if (num & C_FIXNUM_BIT) {11304 C_fixnum_to_string(4, av); /* reuse av */11305 } else {11306 int len, radix_shift;11307 size_t nbits;1130811309 if ((radix < 2) || (radix > 16)) {11310 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11311 }1131211313 /* Approximation of the number of radix digits we'll need. We try11314 * to be as precise as possible to avoid memmove overhead at the end11315 * of the non-powers of two part of the conversion procedure, which11316 * we may need to do because we write strings back-to-front, and11317 * pointers must be aligned (even for byte blocks).11318 */11319 len = C_bignum_size(num)-1;1132011321 nbits = (size_t)len * C_BIGNUM_DIGIT_LENGTH;11322 nbits += C_ilen(C_bignum_digits(num)[len]);1132311324 len = C_ilen(radix)-1;11325 len = (nbits + len - 1) / len;11326 len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */1132711328 radix_shift = C_ilen(radix) - 1;11329 if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&11330 /* The power of two fast path is much faster than recursion */11331 ((C_uword)1 << radix_shift) != radix) {11332 try_extended_number("##sys#integer->string/recursive",11333 4, k, num, C_fix(radix), C_fix(len));11334 } else {11335 C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[4];1133611337 kav[ 0 ] = (C_word)NULL; /* No "self" closure */11338 kav[ 1 ] = C_closure(&ka, 4, (C_word)bignum_to_str_2,11339 k, num, C_fix(radix));11340 kav[ 2 ] = C_fix(len + 1);11341 kav[ 3 ] = C_SCHEME_FALSE; /* No initialization */11342 C_allocate_bytevector(4, kav);11343 }11344 }11345}1134611347static void bignum_to_str_2(C_word c, C_word *av)11348{11349 static char *characters = "0123456789abcdef";11350 C_word11351 self = av[ 0 ],11352 string = av[ 1 ],11353 k = C_block_item(self, 1),11354 bignum = C_block_item(self, 2),11355 radix = C_unfix(C_block_item(self, 3));11356 char11357 *buf = C_c_string(string),11358 *index = buf + C_header_size(string) - 2;11359 int radix_shift,11360 negp = (C_bignum_negativep(bignum) ? 1 : 0);11361 C_word us[ 5 ], *a = us;1136211363 *(index + 1) = '\0';11364 radix_shift = C_ilen(radix) - 1;11365 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11366 int radix_mask = radix - 1, big_digit_len = 0, radix_digit;11367 C_uword *scan, *end, big_digit = 0;1136811369 scan = C_bignum_digits(bignum);11370 end = scan + C_bignum_size(bignum);1137111372 while (scan < end) {11373 /* If radix isn't an exact divisor of digit length, handle overlap */11374 if (big_digit_len == 0) {11375 big_digit = *scan++;11376 big_digit_len = C_BIGNUM_DIGIT_LENGTH;11377 } else {11378 assert(index >= buf);11379 radix_digit = big_digit;11380 big_digit = *scan++;11381 radix_digit |= ((unsigned int)big_digit << big_digit_len) & radix_mask;11382 *index-- = characters[radix_digit];11383 big_digit >>= (radix_shift - big_digit_len);11384 big_digit_len = C_BIGNUM_DIGIT_LENGTH - (radix_shift - big_digit_len);11385 }1138611387 while(big_digit_len >= radix_shift && index >= buf) {11388 radix_digit = big_digit & radix_mask;11389 *index-- = characters[radix_digit];11390 big_digit >>= radix_shift;11391 big_digit_len -= radix_shift;11392 }11393 }1139411395 assert(big_digit < radix);1139611397 /* Final digit (like overlap at start of while loop) */11398 if (big_digit) *index-- = characters[big_digit];1139911400 if (negp) {11401 /* Loop above might've overwritten sign position with a zero */11402 if (*(index+1) == '0') *(index+1) = '-';11403 else *index-- = '-';11404 }1140511406 /* Length calculation is always precise for radix powers of two. */11407 assert(index == buf-1);11408 } else {11409 C_uword base, *start, *scan, big_digit;11410 C_word working_copy;11411 int steps, i;1141211413 working_copy = allocate_tmp_bignum(C_fix(C_bignum_size(bignum)),11414 C_mk_bool(negp), C_SCHEME_FALSE);11415 bignum_digits_destructive_copy(working_copy, bignum);1141611417 start = C_bignum_digits(working_copy);1141811419 scan = start + C_bignum_size(bignum);11420 /* Calculate the largest power of radix that fits a halfdigit:11421 * steps = log10(2^halfdigit_bits), base = 10^steps11422 */11423 for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)11424 steps++;1142511426 base /= radix; /* Back down: we overshot in the loop */1142711428 while (scan > start) {11429 big_digit = bignum_digits_destructive_scale_down(start, scan, base);1143011431 if (*(scan-1) == 0) scan--; /* Adjust if we exhausted the highest digit */1143211433 for(i = 0; i < steps && index >= buf; ++i) {11434 C_word tmp = big_digit / radix;11435 *index-- = characters[big_digit - (tmp*radix)]; /* big_digit % radix */11436 big_digit = tmp;11437 }11438 }11439 assert(index >= buf-1);11440 free_tmp_bignum(working_copy);1144111442 /* Move index onto first nonzero digit. We're writing a bignum11443 here: it can't consist of only zeroes. */11444 while(*++index == '0');1144511446 if (negp) *--index = '-';1144711448 /* Shorten with distance between start and index. */11449 if (buf != index) {11450 i = C_header_size(string) - (index - buf);11451 C_memmove(buf, index, i); /* Move start of number to beginning. */11452 buf[ i ] = '\0'; /* terminating 0 */11453 C_block_header(string) = C_BYTEVECTOR_TYPE | i; /* Mutate strlength. */11454 }11455 }1145611457 C_kontinue(k, C_a_ustring(&a, 0, string, C_fix(C_header_size(string) - 1)));11458}114591146011461/* XXX replace with inline routine */11462void C_ccall C_make_structure(C_word c, C_word *av)11463{11464 C_word11465 /* closure = av[ 0 ] */11466 k = av[ 1 ],11467 type = av[ 2 ],11468 size = c - 3,11469 *s, s0;1147011471 if(!C_demand(size + 2))11472 C_save_and_reclaim((void *)C_make_structure, c, av);1147311474 s = C_alloc(C_SIZEOF_STRUCTURE(size + 1)),11475 s0 = (C_word)s;11476 *(s++) = C_STRUCTURE_TYPE | (size + 1);11477 *(s++) = type;11478 av += 3;1147911480 while(size--)11481 *(s++) = *(av++);1148211483 C_kontinue(k, s0);11484}114851148611487/* XXX replace with inline routine */11488void C_ccall C_make_symbol(C_word c, C_word *av)11489{11490 C_word11491 /* closure = av[ 0 ] */11492 k = av[ 1 ],11493 name = av[ 2 ],11494 ab[ C_SIZEOF_SYMBOL ],11495 *a = ab,11496 s0 = (C_word)a;1149711498 *(a++) = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);11499 *(a++) = C_SCHEME_UNBOUND;11500 *(a++) = name;11501 *a = C_SCHEME_END_OF_LIST;11502 C_kontinue(k, s0);11503}115041150511506/* XXX replace with inline routine */11507void C_ccall C_make_pointer(C_word c, C_word *av)11508{11509 C_word11510 /* closure = av[ 0 ] */11511 k = av[ 1 ],11512 ab[ 2 ],11513 *a = ab,11514 p;1151511516 p = C_mpointer(&a, NULL);11517 C_kontinue(k, p);11518}115191152011521/* XXX replace with inline routine */11522void C_ccall C_make_tagged_pointer(C_word c, C_word *av)11523{11524 C_word11525 /* closure = av[ 0 ] */11526 k = av[ 1 ],11527 tag = av[ 2 ],11528 ab[ 3 ],11529 *a = ab,11530 p;1153111532 p = C_taggedmpointer(&a, tag, NULL);11533 C_kontinue(k, p);11534}115351153611537void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)11538{11539 C_word11540 /* closure = av[ 0 ] */11541 k = av[ 1 ],11542 n = av[ 2 ],11543 *p;1154411545 C_save(k);1154611547 if(!C_demand(C_bytestowords(C_unfix(n))))11548 C_reclaim((void *)generic_trampoline, 1);1154911550 p = C_temporary_stack;11551 C_temporary_stack = C_temporary_stack_bottom;11552 generic_trampoline(0, p);11553}115541155511556void C_ccall generic_trampoline(C_word c, C_word *av)11557{11558 C_word k = av[ 0 ];1155911560 C_kontinue(k, C_SCHEME_UNDEFINED);11561}115621156311564void C_ccall C_return_to_host(C_word c, C_word *av)11565{11566 C_word11567 /* closure = av[ 0 ] */11568 k = av[ 1 ];1156911570 return_to_host = 1;11571 C_save(k);11572 C_reclaim((void *)generic_trampoline, 1);11573}115741157511576void C_ccall C_get_symbol_table_info(C_word c, C_word *av)11577{11578 C_word11579 /* closure = av[ 0 ] */11580 k = av[ 1 ];11581 double d1, d2;11582 int n = 0, total;11583 C_SYMBOL_TABLE *stp;11584 C_word11585 x, y,11586 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_VECTOR(4) ],11587 *a = ab;1158811589 for(stp = symbol_table_list; stp != NULL; stp = stp->next)11590 ++n;1159111592 d1 = compute_symbol_table_load(&d2, &total);11593 x = C_flonum(&a, d1); /* load */11594 y = C_flonum(&a, d2); /* avg bucket length */11595 C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));11596}115971159811599void C_ccall C_get_memory_info(C_word c, C_word *av)11600{11601 C_word11602 /* closure = av[ 0 ] */11603 k = av[ 1 ],11604 ab[ C_SIZEOF_VECTOR(2) ],11605 *a = ab;1160611607 C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));11608}116091161011611void C_ccall C_context_switch(C_word c, C_word *av)11612{11613 C_word11614 /* closure = av[ 0 ] */11615 state = av[ 2 ],11616 n = C_header_size(state) - 1,11617 adrs = C_block_item(state, 0),11618 *av2;11619 C_proc tp = (C_proc)C_block_item(adrs,0);1162011621 /* Copy argvector because it may be mutated in-place. The state11622 * vector should not be re-invoked(?), but it can be kept alive11623 * during GC, so the mutated argvector/state slots may turn stale.11624 */11625 av2 = C_alloc(n);11626 C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word));11627 tp(n, av2);11628}116291163011631void C_ccall C_peek_signed_integer(C_word c, C_word *av)11632{11633 C_word11634 /* closure = av[ 0 ] */11635 k = av[ 1 ],11636 v = av[ 2 ],11637 index = av[ 3 ],11638 x = C_block_item(v, C_unfix(index)),11639 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1164011641 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1164211643 C_kontinue(k, C_int_to_num(&a, num));11644}116451164611647void C_ccall C_peek_unsigned_integer(C_word c, C_word *av)11648{11649 C_word11650 /* closure = av[ 0 ] */11651 k = av[ 1 ],11652 v = av[ 2 ],11653 index = av[ 3 ],11654 x = C_block_item(v, C_unfix(index)),11655 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1165611657 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1165811659 C_kontinue(k, C_unsigned_int_to_num(&a, num));11660}1166111662void C_ccall C_peek_int64(C_word c, C_word *av)11663{11664 C_word11665 /* closure = av[ 0 ] */11666 k = av[ 1 ],11667 v = av[ 2 ],11668 index = av[ 3 ],11669 x = C_block_item(v, C_unfix(index)),11670 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1167111672 C_s64 num = ((C_s64 *)C_data_pointer(v))[ C_unfix(index) ];1167311674 C_kontinue(k, C_int64_to_num(&a, num));11675}116761167711678void C_ccall C_peek_uint64(C_word c, C_word *av)11679{11680 C_word11681 /* closure = av[ 0 ] */11682 k = av[ 1 ],11683 v = av[ 2 ],11684 index = av[ 3 ],11685 x = C_block_item(v, C_unfix(index)),11686 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1168711688 C_u64 num = ((C_u64 *)C_data_pointer(v))[ C_unfix(index) ];1168911690 C_kontinue(k, C_uint64_to_num(&a, num));11691}116921169311694void C_ccall C_decode_seconds(C_word c, C_word *av)11695{11696 C_word11697 /* closure = av[ 0 ] */11698 k = av[ 1 ],11699 secs = av[ 2 ],11700 mode = av[ 3 ];11701 time_t tsecs;11702 struct tm *tmt;11703 C_word11704 ab[ C_SIZEOF_VECTOR(10) ],11705 *a = ab,11706 info;1170711708 tsecs = (time_t)C_num_to_int64(secs);1170911710 if(mode == C_SCHEME_FALSE) tmt = C_localtime(&tsecs);11711 else tmt = C_gmtime(&tsecs);1171211713 if(tmt == NULL)11714 C_kontinue(k, C_SCHEME_FALSE);1171511716 info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),11717 C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),11718 C_fix(tmt->tm_wday), C_fix(tmt->tm_yday),11719 tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,11720#ifdef C_GNU_ENV11721 /* negative for west of UTC, but we want positive */11722 C_fix(-tmt->tm_gmtoff)11723#elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)11724 C_fix(mode == C_SCHEME_FALSE ? _timezone : 0) /* does not account for DST */11725#else11726 C_fix(mode == C_SCHEME_FALSE ? timezone : 0) /* does not account for DST */11727#endif11728 );11729 C_kontinue(k, info);11730}117311173211733void C_ccall C_machine_byte_order(C_word c, C_word *av)11734{11735 C_word11736 /* closure = av[ 0 ] */11737 k = av[ 1 ];11738 char *str;11739 C_word *a, s;1174011741 if(c != 2) C_bad_argc(c, 2);1174211743#if defined(C_MACHINE_BYTE_ORDER)11744 str = C_MACHINE_BYTE_ORDER;11745#else11746 C_cblock11747 static C_word one_two_three = 123;11748 str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";11749 C_cblockend;11750#endif1175111752 a = C_alloc(C_SIZEOF_STRING(strlen(str)));11753 s = C_string2(&a, str);1175411755 C_kontinue(k, s);11756}117571175811759void C_ccall C_machine_type(C_word c, C_word *av)11760{11761 C_word11762 /* closure = av[ 0 ] */11763 k = av[ 1 ],11764 *a, s;1176511766 if(c != 2) C_bad_argc(c, 2);1176711768 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_MACHINE_TYPE)));11769 s = C_string2(&a, C_MACHINE_TYPE);1177011771 C_kontinue(k, s);11772}117731177411775void C_ccall C_software_type(C_word c, C_word *av)11776{11777 C_word11778 /* closure = av[ 0 ] */11779 k = av[ 1 ],11780 *a, s;1178111782 if(c != 2) C_bad_argc(c, 2);1178311784 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_TYPE)));11785 s = C_string2(&a, C_SOFTWARE_TYPE);1178611787 C_kontinue(k, s);11788}117891179011791void C_ccall C_build_platform(C_word c, C_word *av)11792{11793 C_word11794 /* closure = av[ 0 ] */11795 k = av[ 1 ],11796 *a, s;1179711798 if(c != 2) C_bad_argc(c, 2);1179911800 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_BUILD_PLATFORM)));11801 s = C_string2(&a, C_BUILD_PLATFORM);1180211803 C_kontinue(k, s);11804}118051180611807void C_ccall C_software_version(C_word c, C_word *av)11808{11809 C_word11810 /* closure = av[ 0 ] */11811 k = av[ 1 ],11812 *a, s;1181311814 if(c != 2) C_bad_argc(c, 2);1181511816 a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_VERSION)));11817 s = C_string2(&a, C_SOFTWARE_VERSION);1181811819 C_kontinue(k, s);11820}118211182211823/* Register finalizer: */1182411825void C_ccall C_register_finalizer(C_word c, C_word *av)11826{11827 C_word11828 /* closure = av[ 0 ]) */11829 k = av[ 1 ],11830 x = av[ 2 ],11831 proc = av[ 3 ];1183211833 if(C_immediatep(x) ||11834 (!C_in_stackp(x) && !C_in_heapp(x) && !C_in_scratchspacep(x)))11835 C_kontinue(k, x); /* not GCable */1183611837 C_do_register_finalizer(x, proc);11838 C_kontinue(k, x);11839}118401184111842/*XXX could this be made static? is it used in eggs somewhere?11843 if not, declare as fcall/regparm (and static, remove from chicken.h)11844 */11845void C_ccall C_do_register_finalizer(C_word x, C_word proc)11846{11847 C_word *ptr;11848 int n, i;11849 FINALIZER_NODE *flist;1185011851 if(finalizer_free_list == NULL) {11852 if((flist = (FINALIZER_NODE *)C_malloc(sizeof(FINALIZER_NODE))) == NULL)11853 panic(C_text("out of memory - cannot allocate finalizer node"));1185411855 ++allocated_finalizer_count;11856 }11857 else {11858 flist = finalizer_free_list;11859 finalizer_free_list = flist->next;11860 }1186111862 if(finalizer_list != NULL) finalizer_list->previous = flist;1186311864 flist->previous = NULL;11865 flist->next = finalizer_list;11866 finalizer_list = flist;1186711868 if(C_in_stackp(x)) C_mutate_slot(&flist->item, x);11869 else flist->item = x;1187011871 if(C_in_stackp(proc)) C_mutate_slot(&flist->finalizer, proc);11872 else flist->finalizer = proc;1187311874 ++live_finalizer_count;11875}118761187711878/*XXX same here */11879int C_do_unregister_finalizer(C_word x)11880{11881 int n;11882 FINALIZER_NODE *flist;1188311884 for(flist = finalizer_list; flist != NULL; flist = flist->next) {11885 if(flist->item == x) {11886 if(flist->previous == NULL) finalizer_list = flist->next;11887 else flist->previous->next = flist->next;1188811889 return 1;11890 }11891 }1189211893 return 0;11894}118951189611897/* Dynamic loading of shared objects: */1189811899void C_ccall C_set_dlopen_flags(C_word c, C_word *av)11900{11901 C_word11902 /* closure = av[ 0 ] */11903 k = av[ 1 ],11904 now = av[ 2 ],11905 global = av[ 3 ];1190611907#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)11908 dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);11909#endif11910 C_kontinue(k, C_SCHEME_UNDEFINED);11911}119121191311914void C_ccall C_dload(C_word c, C_word *av)11915{11916 C_word11917 /* closure = av[ 0 ] */11918 k = av[ 1 ],11919 name = av[ 2 ],11920 entry = av[ 3 ];1192111922#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))11923 /* Force minor GC: otherwise the lf may contain pointers to stack-data11924 (stack allocated interned symbols, for example) */11925 C_save_and_reclaim_args((void *)dload_2, 3, k, name, entry);11926#endif1192711928 C_kontinue(k, C_SCHEME_FALSE);11929}119301193111932#ifdef DLOAD_2_DEFINED11933# undef DLOAD_2_DEFINED11934#endif1193511936#if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)11937# ifdef __hpux__11938# define DLOAD_2_DEFINED11939void C_ccall dload_2(C_word c, C_word *av0)11940{11941 void *handle, *p;11942 C_word11943 entry = av0[ 0 ],11944 name = av0[ 1 ],11945 k = av0[ 2 ],,11946 av[ 2 ];11947 C_char *mname = C_c_string(name);1194811949 /*11950 * C_fprintf(C_stderr,11951 * "shl_loading %s : %s\n",11952 * (char *) C_c_string(name),11953 * (char *) C_c_string(entry));11954 */1195511956 if ((handle = (void *) shl_load(mname,11957 BIND_IMMEDIATE | DYNAMIC_PATH,11958 0L)) != NULL) {11959 shl_t shl_handle = (shl_t) handle;1196011961 /*** This version does not check for C_dynamic_and_unsafe. Fix it. */11962 if (shl_findsym(&shl_handle, (char *) C_c_string(entry), TYPE_PROCEDURE, &p) == 0) {11963 current_module_name = C_strdup(mname);11964 current_module_handle = handle;1196511966 if(debug_mode) {11967 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11968 current_module_name, (C_uword)current_module_handle);11969 }1197011971 av[ 0 ] = C_SCHEME_UNDEFINED;11972 av[ 1 ] = k;11973 ((C_proc)p)(2, av); /* doesn't return */11974 } else {11975 C_dlerror = (char *) C_strerror(errno);11976 shl_unload(shl_handle);11977 }11978 } else {11979 C_dlerror = (char *) C_strerror(errno);11980 }1198111982 C_kontinue(k, C_SCHEME_FALSE);11983}11984# endif11985#endif119861198711988#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)11989# ifndef __hpux__11990# define DLOAD_2_DEFINED11991void C_ccall dload_2(C_word c, C_word *av0)11992{11993 void *handle, *p, *p2;11994 C_word11995 entry = av0[ 0 ],11996 name = av0[ 1 ],11997 k = av0[ 2 ],11998 av[ 2 ];11999 C_char *topname = (C_char *)C_c_string(entry);12000 C_char *mname = (C_char *)C_c_string(name);12001 C_char *tmp;12002 int tmp_len = 0;1200312004 if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {12005 if((p = C_dlsym(handle, topname)) == NULL) {12006 tmp_len = C_strlen(topname) + 2;12007 tmp = (C_char *)C_malloc(tmp_len);1200812009 if(tmp == NULL)12010 panic(C_text("out of memory - cannot allocate toplevel name string"));1201112012 C_strlcpy(tmp, C_text("_"), tmp_len);12013 C_strlcat(tmp, topname, tmp_len);12014 p = C_dlsym(handle, tmp);12015 C_free(tmp);12016 }1201712018 if(p != NULL) {12019 current_module_name = C_strdup(mname);12020 current_module_handle = handle;1202112022 if(debug_mode) {12023 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),12024 current_module_name, (C_uword)current_module_handle);12025 }1202612027 av[ 0 ] = C_SCHEME_UNDEFINED;12028 av[ 1 ] = k;12029 ((C_proc)p)(2, av); /* doesn't return */12030 }1203112032 C_dlclose(handle);12033 }1203412035 C_dlerror = (char *)dlerror();12036 C_kontinue(k, C_SCHEME_FALSE);12037}12038# endif12039#endif120401204112042#if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)12043# define DLOAD_2_DEFINED12044void C_ccall dload_2(C_word c, C_word *av0)12045{12046 HINSTANCE handle;12047 FARPROC p = NULL, p2;12048 C_word12049 entry = av0[ 0 ],12050 name = av0[ 1 ],12051 k = av0[ 2 ],12052 av[ 2 ];12053 C_char *topname = (C_char *)C_c_string(entry);12054 C_char *mname = (C_char *)C_c_string(name);1205512056 /* cannot use LoadLibrary on non-DLLs, so we use extension checking */12057 if (C_strlen(mname) >= 5) {12058 C_char *n = mname;12059 int l = C_strlen(mname);12060 if (C_strncmp(".dll", n+l-4, 4) &&12061 C_strncmp(".DLL", n+l-4, 4) &&12062 C_strncmp(".so", n+l-3, 3) &&12063 C_strncmp(".SO", n+l-3, 3))12064 C_kontinue(k, C_SCHEME_FALSE);12065 }1206612067 if((handle = LoadLibrary(mname)) != NULL) {12068 if ((p = GetProcAddress(handle, topname)) != NULL) {12069 current_module_name = C_strdup(mname);12070 current_module_handle = handle;1207112072 if(debug_mode) {12073 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),12074 current_module_name, (C_uword)current_module_handle);12075 }1207612077 av[ 0 ] = C_SCHEME_UNDEFINED;12078 av[ 1 ] = k;12079 ((C_proc)p)(2, av); /* doesn't return */12080 }12081 else FreeLibrary(handle);12082 }1208312084 C_dlerror = (char *) C_strerror(errno);12085 C_kontinue(k, C_SCHEME_FALSE);12086}12087#endif120881208912090void C_ccall C_become(C_word c, C_word *av)12091{12092 C_word12093 /* closure = av[ 0 ] */12094 k = av[ 1 ],12095 table = av[ 2 ],12096 tp, x, old, neu, i, *p;1209712098 i = forwarding_table_size;12099 p = forwarding_table;1210012101 for(tp = table; tp != C_SCHEME_END_OF_LIST; tp = C_u_i_cdr(tp)) {12102 x = C_u_i_car(tp);12103 old = C_u_i_car(x);12104 neu = C_u_i_cdr(x);1210512106 if(i == 0) {12107 if((forwarding_table = (C_word *)realloc(forwarding_table, (forwarding_table_size + 1) * 4 * sizeof(C_word))) == NULL)12108 panic(C_text("out of memory - cannot re-allocate forwarding table"));1210912110 i = forwarding_table_size;12111 p = forwarding_table + forwarding_table_size * 2;12112 forwarding_table_size *= 2;12113 }1211412115 *(p++) = old;12116 *(p++) = neu;12117 --i;12118 }1211912120 *p = 0;12121 C_fromspace_top = C_fromspace_limit;12122 C_save_and_reclaim_args((void *)become_2, 1, k);12123}121241212512126void C_ccall become_2(C_word c, C_word *av)12127{12128 C_word k = av[ 0 ];1212912130 *forwarding_table = 0;12131 C_kontinue(k, C_SCHEME_UNDEFINED);12132}121331213412135C_regparm C_word12136C_a_i_cpu_time(C_word **a, int c, C_word buf)12137{12138 C_word u, s = C_fix(0);1213912140#if defined(C_NONUNIX) || defined(__CYGWIN__)12141 if(CLOCKS_PER_SEC == 1000) u = clock();12142 else u = C_uint64_to_num(a, ((C_u64)clock() / CLOCKS_PER_SEC) * 1000);12143#else12144 struct rusage ru;1214512146 if(C_getrusage(RUSAGE_SELF, &ru) == -1) u = 0;12147 else {12148 u = C_uint64_to_num(a, (C_u64)ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000);12149 s = C_uint64_to_num(a, (C_u64)ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000);12150 }12151#endif1215212153 /* buf must not be in nursery */12154 C_set_block_item(buf, 0, u);12155 C_set_block_item(buf, 1, s);12156 return buf;12157}121581215912160C_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)12161{12162 C_word *loc = *a;12163 int offset, i, in = C_unfix(index);12164 *a = loc + C_SIZEOF_LOCATIVE;1216512166 loc[ 0 ] = C_LOCATIVE_TAG;1216712168 switch(C_unfix(type)) {12169 case C_SLOT_LOCATIVE: in *= sizeof(C_word); break;12170 case C_U16_LOCATIVE:12171 case C_S16_LOCATIVE: in *= 2; break;12172 case C_U32_LOCATIVE:12173 case C_F32_LOCATIVE:12174 case C_S32_LOCATIVE: in *= 4; break;12175 case C_U64_LOCATIVE:12176 case C_S64_LOCATIVE:12177 case C_F64_LOCATIVE: in *= 8; break;12178 }1217912180 offset = in + sizeof(C_header);12181 loc[ 1 ] = object + offset;12182 loc[ 2 ] = C_fix(offset);12183 loc[ 3 ] = type;12184 loc[ 4 ] = C_truep(weak) ? C_SCHEME_FALSE : object;1218512186 return (C_word)loc;12187}1218812189C_regparm C_word C_a_i_locative_ref(C_word **a, int c, C_word loc)12190{12191 C_word *ptr;1219212193 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12194 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);1219512196 ptr = (C_word *)C_block_item(loc, 0);1219712198 if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);1219912200 switch(C_unfix(C_block_item(loc, 2))) {12201 case C_SLOT_LOCATIVE: return *ptr;12202 case C_CHAR_LOCATIVE: return C_utf_decode_ptr((C_char *)ptr);12203 case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));12204 case C_S8_LOCATIVE: return C_fix(*((char *)ptr));12205 case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));12206 case C_S16_LOCATIVE: return C_fix(*((short *)ptr));12207 case C_U32_LOCATIVE: return C_unsigned_int_to_num(a, *((C_u32 *)ptr));12208 case C_S32_LOCATIVE: return C_int_to_num(a, *((C_s32 *)ptr));12209 case C_U64_LOCATIVE: return C_uint64_to_num(a, *((C_u64 *)ptr));12210 case C_S64_LOCATIVE: return C_int64_to_num(a, *((C_s64 *)ptr));12211 case C_F32_LOCATIVE: return C_flonum(a, *((float *)ptr));12212 case C_F64_LOCATIVE: return C_flonum(a, *((double *)ptr));12213 default: panic(C_text("bad locative type"));12214 }12215}1221612217C_regparm C_word C_i_locative_set(C_word loc, C_word x)12218{12219 C_word *ptr, val;1222012221 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12222 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);1222312224 ptr = (C_word *)C_block_item(loc, 0);1222512226 if(ptr == NULL)12227 barf(C_LOST_LOCATIVE_ERROR, "locative-set!", loc);1222812229 switch(C_unfix(C_block_item(loc, 2))) {12230 case C_SLOT_LOCATIVE: C_mutate(ptr, x); break;1223112232 case C_CHAR_LOCATIVE:12233 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)12234 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1223512236 /* does not check for exceeded buffer length! */12237 C_utf_encode((C_char *)ptr, C_character_code(x));12238 break;1223912240 case C_U8_LOCATIVE:12241 if((x & C_FIXNUM_BIT) == 0)12242 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1224312244 *((unsigned char *)ptr) = C_unfix(x);12245 break;1224612247 case C_S8_LOCATIVE:12248 if((x & C_FIXNUM_BIT) == 0)12249 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1225012251 *((char *)ptr) = C_unfix(x);12252 break;1225312254 case C_U16_LOCATIVE:12255 if((x & C_FIXNUM_BIT) == 0)12256 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1225712258 *((unsigned short *)ptr) = C_unfix(x);12259 break;1226012261 case C_S16_LOCATIVE:12262 if((x & C_FIXNUM_BIT) == 0)12263 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1226412265 *((short *)ptr) = C_unfix(x);12266 break;1226712268 case C_U32_LOCATIVE:12269 if(!C_truep(C_i_exact_integerp(x)))12270 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1227112272 *((C_u32 *)ptr) = C_num_to_unsigned_int(x);12273 break;1227412275 case C_S32_LOCATIVE:12276 if(!C_truep(C_i_exact_integerp(x)))12277 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1227812279 *((C_s32 *)ptr) = C_num_to_int(x);12280 break;1228112282 case C_U64_LOCATIVE:12283 if(!C_truep(C_i_exact_integerp(x)))12284 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1228512286 *((C_u64 *)ptr) = C_num_to_uint64(x);12287 break;1228812289 case C_S64_LOCATIVE:12290 if(!C_truep(C_i_exact_integerp(x)))12291 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1229212293 *((C_s64 *)ptr) = C_num_to_int64(x);12294 break;1229512296 case C_F32_LOCATIVE:12297 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12298 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1229912300 *((float *)ptr) = C_flonum_magnitude(x);12301 break;1230212303 case C_F64_LOCATIVE:12304 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12305 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1230612307 *((double *)ptr) = C_flonum_magnitude(x);12308 break;1230912310 default: panic(C_text("bad locative type"));12311 }1231212313 return C_SCHEME_UNDEFINED;12314}123151231612317C_regparm C_word C_i_locative_to_object(C_word loc)12318{12319 C_word *ptr;1232012321 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12322 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative->object", loc);1232312324 ptr = (C_word *)C_block_item(loc, 0);1232512326 if(ptr == NULL) return C_SCHEME_FALSE;12327 else return (C_word)ptr - C_unfix(C_block_item(loc, 1));12328}123291233012331C_regparm C_word C_i_locative_index(C_word loc)12332{12333 int bytes;1233412335 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12336 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-index", loc);1233712338 bytes = C_unfix(C_block_item(loc, 1)) - sizeof(C_header);1233912340 switch(C_unfix(C_block_item(loc, 2))) {12341 case C_SLOT_LOCATIVE: return C_fix(bytes/sizeof(C_word)); break;1234212343 case C_CHAR_LOCATIVE:12344 { C_word x = C_i_locative_to_object(loc);12345 if(x == C_SCHEME_FALSE)12346 barf(C_LOST_LOCATIVE_ERROR, "locative-index", loc);12347 return C_fix(C_utf_char_position(x, bytes)); }1234812349 case C_U8_LOCATIVE:12350 case C_S8_LOCATIVE: return C_fix(bytes); break;1235112352 case C_U16_LOCATIVE:12353 case C_S16_LOCATIVE: return C_fix(bytes/2); break;1235412355 case C_U32_LOCATIVE:12356 case C_S32_LOCATIVE:12357 case C_F32_LOCATIVE: return C_fix(bytes/4); break;1235812359 case C_U64_LOCATIVE:12360 case C_S64_LOCATIVE:12361 case C_F64_LOCATIVE: return C_fix(bytes/8); break;1236212363 default: panic(C_text("bad locative type"));12364 }12365}123661236712368/* GC protection of user-variables: */1236912370C_regparm void C_gc_protect(C_word **addr, int n)12371{12372 int k;1237312374 if(collectibles_top + n >= collectibles_limit) {12375 k = collectibles_limit - collectibles;12376 collectibles = (C_word **)C_realloc(collectibles, sizeof(C_word *) * k * 2);1237712378 if(collectibles == NULL)12379 panic(C_text("out of memory - cannot allocate GC protection vector"));1238012381 collectibles_top = collectibles + k;12382 collectibles_limit = collectibles + k * 2;12383 }1238412385 C_memcpy(collectibles_top, addr, n * sizeof(C_word *));12386 collectibles_top += n;12387}123881238912390C_regparm void C_gc_unprotect(int n)12391{12392 collectibles_top -= n;12393}123941239512396/* Map procedure-ptr to id or id to ptr: */1239712398C_char *C_lookup_procedure_id(void *ptr)12399{12400 LF_LIST *lfl;12401 C_PTABLE_ENTRY *pt;1240212403 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12404 pt = lfl->ptable;1240512406 if(pt != NULL) {12407 while(pt->id != NULL) {12408 if(pt->ptr == ptr) return pt->id;12409 else ++pt;12410 }12411 }12412 }1241312414 return NULL;12415}124161241712418void *C_lookup_procedure_ptr(C_char *id)12419{12420 LF_LIST *lfl;12421 C_PTABLE_ENTRY *pt;1242212423 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12424 pt = lfl->ptable;1242512426 if(pt != NULL) {12427 while(pt->id != NULL) {12428 if(!C_strcmp(id, pt->id)) return pt->ptr;12429 else ++pt;12430 }12431 }12432 }1243312434 return NULL;12435}124361243712438void C_ccall C_copy_closure(C_word c, C_word *av)12439{12440 C_word12441 /* closure = av[ 0 ] */12442 k = av[ 1 ],12443 proc = av[ 2 ],12444 *p;12445 int n = C_header_size(proc);1244612447 if(!C_demand(n + 1))12448 C_save_and_reclaim_args((void *)copy_closure_2, 2, proc, k);12449 else {12450 C_save(proc);12451 C_save(k);12452 p = C_temporary_stack;12453 C_temporary_stack = C_temporary_stack_bottom;12454 copy_closure_2(0, p);12455 }12456}124571245812459static void C_ccall copy_closure_2(C_word c, C_word *av)12460{12461 C_word12462 k = av[ 0 ],12463 proc = av[ 1 ];12464 int cells = C_header_size(proc);12465 C_word12466 *ptr = C_alloc(C_SIZEOF_CLOSURE(cells)),12467 *p = ptr;1246812469 *(p++) = C_CLOSURE_TYPE | cells;12470 /* this is only allowed because the storage is freshly allocated: */12471 C_memcpy_slots(p, C_data_pointer(proc), cells);12472 C_kontinue(k, (C_word)ptr);12473}124741247512476/* Ph'nglui mglw'nafh Cthulhu R'lyeh wgah'nagl fhtagn */1247712478void C_ccall C_call_with_cthulhu(C_word c, C_word *av)12479{12480 C_word12481 proc = av[ 2 ],12482 *a = C_alloc(C_SIZEOF_CLOSURE(1)),12483 av2[ 2 ];1248412485 av2[ 0 ] = proc;12486 av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */12487 C_do_apply(2, av2);12488}124891249012491/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)12492 These routines return #f if the operation failed due to overflow.12493 */1249412495C_regparm C_word C_i_o_fixnum_plus(C_word n1, C_word n2)12496{12497 C_word x1, x2, s;1249812499 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1250012501 x1 = C_unfix(n1);12502 x2 = C_unfix(n2);12503 s = x1 + x2;1250412505#ifdef C_SIXTY_FOUR12506 if((((s ^ x1) & (s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12507#else12508 if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12509#endif12510 else return C_fix(s);12511}125121251312514C_regparm C_word C_i_o_fixnum_difference(C_word n1, C_word n2)12515{12516 C_word x1, x2, s;1251712518 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1251912520 x1 = C_unfix(n1);12521 x2 = C_unfix(n2);12522 s = x1 - x2;1252312524#ifdef C_SIXTY_FOUR12525 if((((s ^ x1) & ~(s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12526#else12527 if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12528#endif12529 else return C_fix(s);12530}125311253212533C_regparm C_word C_i_o_fixnum_times(C_word n1, C_word n2)12534{12535 C_word x1, x2;12536 C_uword x1u, x2u;12537#ifdef C_SIXTY_FOUR12538# ifdef C_LLP12539 C_uword c = 1ULL<<63ULL;12540# else12541 C_uword c = 1UL<<63UL;12542# endif12543#else12544 C_uword c = 1UL<<31UL;12545#endif1254612547 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1254812549 if((n1 & C_INT_SIGN_BIT) == (n2 & C_INT_SIGN_BIT)) --c;1255012551 x1 = C_unfix(n1);12552 x2 = C_unfix(n2);12553 x1u = x1 < 0 ? -x1 : x1;12554 x2u = x2 < 0 ? -x2 : x2;1255512556 if(x2u != 0 && x1u > (c / x2u)) return C_SCHEME_FALSE;1255712558 x1 = x1 * x2;1255912560 if(C_fitsinfixnump(x1)) return C_fix(x1);12561 else return C_SCHEME_FALSE;12562}125631256412565C_regparm C_word C_i_o_fixnum_quotient(C_word n1, C_word n2)12566{12567 C_word x1, x2;1256812569 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1257012571 x1 = C_unfix(n1);12572 x2 = C_unfix(n2);1257312574 if(x2 == 0)12575 barf(C_DIVISION_BY_ZERO_ERROR, "fx/?");1257612577#ifdef C_SIXTY_FOUR12578 if(x1 == 0x8000000000000000L && x2 == -1) return C_SCHEME_FALSE;12579#else12580 if(x1 == 0x80000000L && x2 == -1) return C_SCHEME_FALSE;12581#endif1258212583 x1 = x1 / x2;1258412585 if(C_fitsinfixnump(x1)) return C_fix(x1);12586 else return C_SCHEME_FALSE;12587}125881258912590C_regparm C_word C_i_o_fixnum_and(C_word n1, C_word n2)12591{12592 C_uword x1, x2, r;1259312594 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1259512596 x1 = C_unfix(n1);12597 x2 = C_unfix(n2);12598 r = x1 & x2;1259912600 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12601 else return C_fix(r);12602}126031260412605C_regparm C_word C_i_o_fixnum_ior(C_word n1, C_word n2)12606{12607 C_uword x1, x2, r;1260812609 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1261012611 x1 = C_unfix(n1);12612 x2 = C_unfix(n2);12613 r = x1 | x2;1261412615 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12616 else return C_fix(r);12617}126181261912620C_regparm C_word C_i_o_fixnum_xor(C_word n1, C_word n2)12621{12622 C_uword x1, x2, r;1262312624 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1262512626 x1 = C_unfix(n1);12627 x2 = C_unfix(n2);12628 r = x1 ^ x2;1262912630 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12631 else return C_fix(r);12632}126331263412635/* decoding of literals in compressed format */1263612637static C_regparm C_uword decode_size(C_char **str)12638{12639 C_uchar **ustr = (C_uchar **)str;12640 C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */1264112642 size |= (*((*ustr)++) & 0xff) << 8;12643 size |= (*((*ustr)++) & 0xff);12644 return size;12645}126461264712648static C_regparm C_word decode_literal2(C_word **ptr, C_char **str,12649 C_word *dest)12650{12651 C_ulong bits = *((*str)++) & 0xff;12652 C_word *data, *dptr, val;12653 C_uword size;1265412655 /* vvv this can be taken out at a later stage (once it works reliably) vvv */12656 if(bits != 0xfe)12657 panic(C_text("invalid encoded literal format"));1265812659 bits = *((*str)++) & 0xff;12660 /* ^^^ */1266112662#ifdef C_SIXTY_FOUR12663 bits <<= 24 + 32;12664#else12665 bits <<= 24;12666#endif1266712668 if(bits == C_HEADER_BITS_MASK) { /* special/immediate */12669 switch(0xff & *((*str)++)) {12670 case C_BOOLEAN_BITS:12671 return C_mk_bool(*((*str)++));1267212673 case C_CHARACTER_BITS:12674 return C_make_character(decode_size(str));1267512676 case C_SCHEME_END_OF_LIST:12677 case C_SCHEME_UNDEFINED:12678 case C_SCHEME_END_OF_FILE:12679 case C_SCHEME_BROKEN_WEAK_PTR:12680 return (C_word)(*(*str - 1));1268112682 case C_FIXNUM_BIT:12683 val = (C_uword)(signed char)*((*str)++) << 24; /* always big endian */12684 val |= ((C_uword)*((*str)++) & 0xff) << 16;12685 val |= ((C_uword)*((*str)++) & 0xff) << 8;12686 val |= ((C_uword)*((*str)++) & 0xff);12687 return C_fix(val);1268812689/* XXX Handle legacy bignum encoding */12690#ifdef C_SIXTY_FOUR12691 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12692#else12693 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12694#endif12695 bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);12696 break;12697/* XXX */1269812699#ifdef C_SIXTY_FOUR12700 case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12701#else12702 case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12703#endif12704 bits = (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT);12705 break;1270612707 default:12708 panic(C_text("invalid encoded special literal"));12709 }12710 }1271112712#ifndef C_SIXTY_FOUR12713 if((bits & C_8ALIGN_BIT) != 0) {12714 /* Align _data_ on 8-byte boundary: */12715 if(C_aligned8(*ptr)) ++(*ptr);12716 }12717#endif1271812719 val = (C_word)(*ptr);1272012721 if((bits & C_SPECIALBLOCK_BIT) != 0)12722 panic(C_text("literals with special bit cannot be decoded"));1272312724 if(bits == C_FLONUM_TYPE) {12725 val = C_flonum(ptr, decode_flonum_literal(*str));12726 while(*((*str)++) != '\0'); /* skip terminating '\0' */12727 return val;12728 }1272912730 size = decode_size(str);1273112732 switch(bits) {12733 /* This cannot be encoded as a bytevector due to endianness differences */1273412735 /* XXX legacy bignum encoding: */12736 case (C_STRING_TYPE | C_BYTEBLOCK_BIT | C_GC_FORWARDING_BIT): /* This represents "exact int" */12737 /* XXX */12738 case (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */12739 /* bignums are also allocated statically */12740 val = C_static_bignum(ptr, size, *str);12741 *str += size;12742 break;1274312744 /* XXX legacy encoding: */12745 case (C_STRING_TYPE | C_BYTEBLOCK_BIT):12746 /* strings are always allocated statically */12747 val = C_static_string(ptr, size, *str);12748 *str += size;12749 break;12750 /* XXX */1275112752 case C_STRING_TYPE:12753 /* strings are always allocated statically */12754 val = C_static_string(ptr, size - 1, *str);12755 *str += size;12756 break;1275712758 case C_BYTEVECTOR_TYPE:12759 /* ... as are bytevectors */12760 val = C_static_bytevector(ptr, size, *str);12761 *str += size;12762 break;1276312764 case C_SYMBOL_TYPE:12765 if(dest == NULL)12766 panic(C_text("invalid literal symbol destination"));1276712768 if (**str == '\1') {12769 val = C_h_intern(dest, size, ++*str);12770 } else if (**str == '\2') {12771 val = C_h_intern_kw(dest, size, ++*str);12772 } else {12773 C_snprintf(buffer, sizeof(buffer), C_text("Unknown symbol subtype: %d"), (int)**str);12774 panic(buffer);12775 }12776 *str += size;12777 break;1277812779 case C_LAMBDA_INFO_TYPE:12780 /* lambda infos are always allocated statically */12781 val = C_static_lambda_info(ptr, size, *str);12782 *str += size;12783 break;1278412785 default:12786 *((*ptr)++) = C_make_header(bits, size);12787 data = *ptr;1278812789 if((bits & C_BYTEBLOCK_BIT) != 0) {12790 C_memcpy(data, *str, size);12791 size = C_align(size);12792 *str += size;12793 *ptr = (C_word *)C_align((C_word)(*ptr) + size);12794 }12795 else {12796 C_word *dptr = *ptr;12797 *ptr += size;1279812799 while(size--) {12800 *dptr = decode_literal2(ptr, str, dptr);12801 ++dptr;12802 }12803 }12804 }1280512806 return val;12807}128081280912810C_regparm C_word12811C_decode_literal(C_word **ptr, C_char *str)12812{12813 return decode_literal2(ptr, &str, NULL);12814}128151281612817void12818C_use_private_repository(C_char *path)12819{12820 private_repository = path;12821}128221282312824C_char *12825C_private_repository_path()12826{12827 return private_repository;12828}1282912830C_char *12831C_executable_pathname() {12832#ifdef SEARCH_EXE_PATH12833 return C_main_exe == NULL ? NULL : C_strdup(C_main_exe);12834#else12835 return C_resolve_executable_pathname(NULL);12836#endif12837}1283812839C_char *12840C_executable_dirname() {12841 int len;12842 C_char *path;1284312844 if((path = C_executable_pathname()) == NULL)12845 return NULL;1284612847#if defined(_WIN32) && !defined(__CYGWIN__)12848 for(len = C_strlen(path); len >= 0 && path[len] != '\\'; len--);12849#else12850 for(len = C_strlen(path); len >= 0 && path[len] != '/'; len--);12851#endif1285212853 path[len] = '\0';12854 return path;12855}1285612857C_char *12858C_resolve_executable_pathname(C_char *fname)12859{12860 int n;12861 C_WCHAR *buffer = (C_WCHAR *) C_malloc(C_MAX_PATH);1286212863 if(buffer == NULL) return NULL;1286412865#if defined(__linux__) || defined(__sun)12866 C_char linkname[64]; /* /proc/<pid>/exe */12867 pid_t pid = C_getpid();1286812869# ifdef __linux__12870 C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);12871# else12872 C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */12873# endif1287412875 n = C_readlink(linkname, buffer, C_MAX_PATH);12876 if(n < 0 || n >= C_MAX_PATH)12877 goto error;1287812879 buffer[n] = '\0';12880 return buffer;12881#elif defined(_WIN32) && !defined(__CYGWIN__)12882 n = GetModuleFileNameW(NULL, buffer, C_MAX_PATH);12883 if(n == 0 || n >= C_MAX_PATH)12884 goto error;1288512886 C_char *buf2 = C_strdup(C_utf8(buffer));12887 C_free(buffer);12888 return buf2;12889#elif defined(C_MACOSX)12890 C_char buf[C_MAX_PATH];12891 C_u32 size = C_MAX_PATH;1289212893 if(_NSGetExecutablePath(buf, &size) != 0)12894 goto error;1289512896 if(C_realpath(buf, buffer) == NULL)12897 goto error;1289812899 return buffer;12900#elif defined(__HAIKU__)12901{12902 image_info info;12903 int32 cookie = 0;1290412905 while (get_next_image_info(0, &cookie, &info) == B_OK) {12906 if (info.type == B_APP_IMAGE) {12907 C_strlcpy(buffer, info.name, C_MAX_PATH);12908 return buffer;12909 }12910 }12911}12912#elif defined(SEARCH_EXE_PATH)12913 int len;12914 C_char *path, buf[C_MAX_PATH];1291512916 /* no name given (execve) */12917 if(fname == NULL)12918 goto error;1291912920 /* absolute pathname */12921 if(fname[0] == '/') {12922 if(C_realpath(fname, buffer) == NULL)12923 goto error;12924 else12925 return buffer;12926 }1292712928 /* current directory */12929 if(C_strchr(fname, '/') != NULL) {12930 if(C_getcwd(buffer, C_MAX_PATH) == NULL)12931 goto error;1293212933 n = C_snprintf(buf, C_MAX_PATH, "%s/%s", buffer, fname);12934 if(n < 0 || n >= C_MAX_PATH)12935 goto error;1293612937 if(C_access(buf, X_OK) == 0) {12938 if(C_realpath(buf, buffer) == NULL)12939 goto error;12940 else12941 return buffer;12942 }12943 }1294412945 /* walk PATH */12946 if((path = getenv("PATH")) == NULL)12947 goto error;1294812949 do {12950 /* check PATH entry length */12951 len = C_strcspn(path, ":");12952 if(len == 0 || len >= C_MAX_PATH)12953 continue;1295412955 /* "<path>/<fname>" to buf */12956 C_strncpy(buf, path, len);12957 n = C_snprintf(buf + len, C_MAX_PATH - len, "/%s", fname);12958 if(n < 0 || n + len >= C_MAX_PATH)12959 continue;1296012961 if(C_access(buf, X_OK) != 0)12962 continue;1296312964 /* fname found, resolve links */12965 if(C_realpath(buf, buffer) != NULL)12966 return buffer;1296712968 /* seek next entry, skip colon */12969 } while (path += len, *path++);12970#else12971# error "Please either define SEARCH_EXE_PATH in Makefile.<platform> or implement C_resolve_executable_pathname for your platform!"12972#endif1297312974error:12975 C_free(buffer);12976 return NULL;12977}1297812979C_regparm C_word12980C_i_getprop(C_word sym, C_word prop, C_word def)12981{12982 C_word pl = C_symbol_plist(sym);1298312984 while(pl != C_SCHEME_END_OF_LIST) {12985 if(C_block_item(pl, 0) == prop)12986 return C_u_i_car(C_u_i_cdr(pl));12987 else pl = C_u_i_cdr(C_u_i_cdr(pl));12988 }1298912990 return def;12991}129921299312994C_regparm C_word12995C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)12996{12997 C_word pl = C_symbol_plist(sym);1299812999 /* Newly added plist? Ensure the symbol stays! */13000 if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym);1300113002 while(pl != C_SCHEME_END_OF_LIST) {13003 if(C_block_item(pl, 0) == prop) {13004 C_mutate(&C_u_i_car(C_u_i_cdr(pl)), val);13005 return val;13006 }13007 else pl = C_u_i_cdr(C_u_i_cdr(pl));13008 }1300913010 pl = C_a_pair(ptr, val, C_symbol_plist(sym));13011 pl = C_a_pair(ptr, prop, pl);13012 C_mutate_slot(&C_symbol_plist(sym), pl);13013 return val;13014}130151301613017C_regparm C_word13018C_i_get_keyword(C_word kw, C_word args, C_word def)13019{13020 while(!C_immediatep(args)) {13021 if(C_header_type(args) == C_PAIR_TYPE) {13022 if(kw == C_u_i_car(args)) {13023 args = C_u_i_cdr(args);1302413025 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)13026 return def;13027 else return C_u_i_car(args);13028 }13029 else {13030 args = C_u_i_cdr(args);1303113032 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)13033 return def;13034 else args = C_u_i_cdr(args);13035 }13036 }13037 }1303813039 return def;13040}1304113042C_word C_i_dump_statistical_profile()13043{13044 PROFILE_BUCKET *b, *b2, **bp;13045 FILE *fp;13046 C_char *k1, *k2 = NULL;13047 int n;13048 double ms;1304913050 assert(profiling);13051 assert(profile_table != NULL);1305213053 set_profile_timer(0);1305413055 profiling = 0; /* In case a SIGPROF is delivered late */13056 bp = profile_table;1305713058 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("PROFILE.%d"), C_getpid());1305913060 if(debug_mode)13061 C_dbg(C_text("debug"), C_text("dumping statistical profile to `%s'...\n"), buffer);13062 fp = fopen(buffer, "w");13063 if (fp == NULL)13064 panic(C_text("could not write profile!"));1306513066 C_fputs(C_text("statistical\n"), fp);13067 for(n = 0; n < PROFILE_TABLE_SIZE; ++n) {13068 for(b = bp[ n ]; b != NULL; b = b2) {13069 b2 = b->next;1307013071 k1 = b->key;13072 C_fputs(C_text("(|"), fp);13073 /* Dump raw C string as if it were a symbol */13074 while((k2 = C_strpbrk(k1, C_text("\\|"))) != NULL) {13075 C_fwrite(k1, 1, k2-k1, fp);13076 C_fputc('\\', fp);13077 C_fputc(*k2, fp);13078 k1 = k2+1;13079 }13080 C_fputs(k1, fp);13081 ms = (double)b->sample_count * (double)profile_frequency / 1000.0;13082 C_fprintf(fp, C_text("| " UWORD_COUNT_FORMAT_STRING " %lf)\n"),13083 b->call_count, ms);13084 C_free(b);13085 }13086 }1308713088 C_fclose(fp);13089 C_free(profile_table);13090 profile_table = NULL;1309113092 return C_SCHEME_UNDEFINED;13093}1309413095void C_ccall C_dump_heap_state(C_word c, C_word *av)13096{13097 C_word13098 /* closure = av[ 0 ] */13099 k = av[ 1 ];1310013101 /* make sure heap is compacted */13102 C_save(k);13103 C_fromspace_top = C_fromspace_limit; /* force major GC */13104 C_reclaim((void *)dump_heap_state_2, 1);13105}131061310713108static C_ulong13109hdump_hash(C_word key)13110{13111 return (C_ulong)key % HDUMP_TABLE_SIZE;13112}131131311413115static void13116hdump_count(C_word key, int n, int t)13117{13118 HDUMP_BUCKET **bp = hdump_table + hdump_hash(key);13119 HDUMP_BUCKET *b = *bp;1312013121 while(b != NULL) {13122 if(b->key == key) {13123 b->count += n;13124 b->total += t;13125 return;13126 }13127 else b = b->next;13128 }1312913130 b = (HDUMP_BUCKET *)C_malloc(sizeof(HDUMP_BUCKET));1313113132 if(b == 0)13133 panic(C_text("out of memory - can not allocate heap-dump table-bucket"));1313413135 b->next = *bp;13136 b->key = key;13137 *bp = b;13138 b->count = n;13139 b->total = t;13140}131411314213143static void C_ccall dump_heap_state_2(C_word c, C_word *av)13144{13145 C_word k = av[ 0 ];13146 HDUMP_BUCKET *b, *b2, **bp;13147 int n, bytes;13148 C_byte *scan;13149 C_SCHEME_BLOCK *sbp;13150 C_header h;13151 C_word x, key, *p;13152 int imm = 0, blk = 0;1315313154 hdump_table = (HDUMP_BUCKET **)C_malloc(HDUMP_TABLE_SIZE * sizeof(HDUMP_BUCKET *));1315513156 if(hdump_table == NULL)13157 panic(C_text("out of memory - can not allocate heap-dump table"));1315813159 C_memset(hdump_table, 0, sizeof(HDUMP_BUCKET *) * HDUMP_TABLE_SIZE);1316013161 scan = fromspace_start;1316213163 while(scan < C_fromspace_top) {13164 ++blk;13165 sbp = (C_SCHEME_BLOCK *)scan;1316613167 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13168 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1316913170 n = C_header_size(sbp);13171 h = sbp->header;13172 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13173 key = (C_word)(h & C_HEADER_BITS_MASK);13174 p = sbp->data;1317513176 if(key == C_STRUCTURE_TYPE) key = *p;1317713178 hdump_count(key, 1, bytes);1317913180 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {13181 if((h & C_SPECIALBLOCK_BIT) != 0) {13182 --n;13183 ++p;13184 }1318513186 while(n--) {13187 x = *(p++);1318813189 if(C_immediatep(x)) {13190 ++imm;1319113192 if((x & C_FIXNUM_BIT) != 0) key = C_fix(1);13193 else {13194 switch(x & C_IMMEDIATE_TYPE_BITS) {13195 case C_BOOLEAN_BITS: key = C_SCHEME_TRUE; break;13196 case C_CHARACTER_BITS: key = C_make_character('A'); break;13197 default: key = x;13198 }13199 }1320013201 hdump_count(key, 1, 0);13202 }13203 }13204 }1320513206 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13207 }1320813209 bp = hdump_table;13210 /* HACK */13211#define C_WEAK_PAIR_TYPE (C_PAIR_TYPE | C_SPECIALBLOCK_BIT)1321213213 for(n = 0; n < HDUMP_TABLE_SIZE; ++n) {13214 for(b = bp[ n ]; b != NULL; b = b2) {13215 b2 = b->next;1321613217 switch(b->key) {13218 case C_fix(1): C_fprintf(C_stderr, C_text("fixnum ")); break;13219 case C_SCHEME_TRUE: C_fprintf(C_stderr, C_text("boolean ")); break;13220 case C_SCHEME_END_OF_LIST: C_fprintf(C_stderr, C_text("null ")); break;13221 case C_SCHEME_UNDEFINED : C_fprintf(C_stderr, C_text("void ")); break;13222 case C_SCHEME_BROKEN_WEAK_PTR: C_fprintf(C_stderr, C_text("broken weak ptr")); break;13223 case C_make_character('A'): C_fprintf(C_stderr, C_text("character ")); break;13224 case C_SCHEME_END_OF_FILE: C_fprintf(C_stderr, C_text("eof ")); break;13225 case C_SCHEME_UNBOUND: C_fprintf(C_stderr, C_text("unbound ")); break;13226 case C_SYMBOL_TYPE: C_fprintf(C_stderr, C_text("symbol ")); break;13227 case C_STRING_TYPE: C_fprintf(C_stderr, C_text("string ")); break;13228 case C_PAIR_TYPE: C_fprintf(C_stderr, C_text("pair ")); break;13229 case C_CLOSURE_TYPE: C_fprintf(C_stderr, C_text("closure ")); break;13230 case C_FLONUM_TYPE: C_fprintf(C_stderr, C_text("flonum ")); break;13231 case C_PORT_TYPE: C_fprintf(C_stderr, C_text("port ")); break;13232 case C_POINTER_TYPE: C_fprintf(C_stderr, C_text("pointer ")); break;13233 case C_LOCATIVE_TYPE: C_fprintf(C_stderr, C_text("locative ")); break;13234 case C_TAGGED_POINTER_TYPE: C_fprintf(C_stderr, C_text("tagged pointer ")); break;13235 case C_LAMBDA_INFO_TYPE: C_fprintf(C_stderr, C_text("lambda info ")); break;13236 case C_WEAK_PAIR_TYPE: C_fprintf(C_stderr, C_text("weak pair ")); break;13237 case C_VECTOR_TYPE: C_fprintf(C_stderr, C_text("vector ")); break;13238 case C_BYTEVECTOR_TYPE: C_fprintf(C_stderr, C_text("bytevector ")); break;13239 case C_BIGNUM_TYPE: C_fprintf(C_stderr, C_text("bignum ")); break;13240 case C_CPLXNUM_TYPE: C_fprintf(C_stderr, C_text("cplxnum ")); break;13241 case C_RATNUM_TYPE: C_fprintf(C_stderr, C_text("ratnum ")); break;13242 /* XXX this is sort of funny: */13243 case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("bytevector ")); break;13244 default:13245 x = b->key;1324613247 if(!C_immediatep(x) && C_header_bits(x) == C_SYMBOL_TYPE) {13248 x = C_block_item(x, 1);13249 C_fprintf(C_stderr, C_text("`%.*s'"), (int)C_header_size(x), C_c_string(x));13250 }13251 else C_fprintf(C_stderr, C_text("unknown key " UWORD_FORMAT_STRING), (C_uword)b->key);13252 }1325313254 C_fprintf(C_stderr, C_text("\t%d"), b->count);1325513256 if(b->total > 0)13257 C_fprintf(C_stderr, C_text("\t%d bytes"), b->total);1325813259 C_fputc('\n', C_stderr);13260 C_free(b);13261 }13262 }1326313264 C_fprintf(C_stderr, C_text("\ntotal number of blocks: %d, immediates: %d\n"),13265 blk, imm);13266 C_free(hdump_table);13267 C_kontinue(k, C_SCHEME_UNDEFINED);13268}132691327013271static void C_ccall filter_heap_objects_2(C_word c, C_word *av)13272{13273 void *func = C_pointer_address(av[ 0 ]);13274 C_word13275 userarg = av[ 1 ],13276 vector = av[ 2 ],13277 k = av[ 3 ];13278 int n, bytes;13279 C_byte *scan;13280 C_SCHEME_BLOCK *sbp;13281 C_header h;13282 C_word *p;13283 int vecsize = C_header_size(vector);13284 typedef int (*filterfunc)(C_word x, C_word userarg);13285 filterfunc ff = (filterfunc)func;13286 int vcount = 0;1328713288 scan = fromspace_start;1328913290 while(scan < C_fromspace_top) {13291 sbp = (C_SCHEME_BLOCK *)scan;1329213293 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13294 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1329513296 n = C_header_size(sbp);13297 h = sbp->header;13298 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13299 p = sbp->data;1330013301 if(ff((C_word)sbp, userarg)) {13302 if(vcount < vecsize) {13303 C_set_block_item(vector, vcount, (C_word)sbp);13304 ++vcount;13305 }13306 else {13307 C_kontinue(k, C_fix(-1));13308 }13309 }1331013311 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13312 }1331313314 C_kontinue(k, C_fix(vcount));13315}133161331713318void C_ccall C_filter_heap_objects(C_word c, C_word *av)13319{13320 C_word13321 /* closure = av[ 0 ] */13322 k = av[ 1 ],13323 func = av[ 2 ],13324 vector = av[ 3 ],13325 userarg = av[ 4 ];1332613327 /* make sure heap is compacted */13328 C_save(k);13329 C_save(vector);13330 C_save(userarg);13331 C_save(func);13332 C_fromspace_top = C_fromspace_limit; /* force major GC */13333 C_reclaim((void *)filter_heap_objects_2, 4);13334}1333513336C_regparm C_word C_i_process_sleep(C_word n)13337{13338#if defined(_WIN32) && !defined(__CYGWIN__)13339 Sleep(C_unfix(n) * 1000);13340 return C_fix(0);13341#else13342 return C_fix(sleep(C_unfix(n)));13343#endif13344}1334513346C_regparm C_word13347C_i_file_exists_p(C_word name, C_word file, C_word dir)13348{13349#if defined(_WIN32) && !defined(__CYGWIN__)13350 struct _stat64i32 buf;13351#else13352 struct stat buf;13353#endif13354 int res;1335513356 res = C_stat(C_OS_FILENAME(name, 0), &buf);1335713358 if(res != 0) {13359 switch(errno) {13360 case ENOENT: return C_SCHEME_FALSE;13361 case EOVERFLOW: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13362 case ENOTDIR: return C_SCHEME_FALSE;13363 default: return C_fix(res);13364 }13365 }1336613367 switch(buf.st_mode & S_IFMT) {13368 case S_IFDIR: return C_truep(file) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13369 default: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13370 }13371}133721337313374C_regparm C_word13375C_i_pending_interrupt(C_word dummy)13376{13377 if(pending_interrupts_count > 0) {13378 handling_interrupts = 1; /* Lock out further forced GCs until we're done */13379 return C_fix(pending_interrupts[ --pending_interrupts_count ]);13380 } else {13381 handling_interrupts = 0; /* OK, can go on */13382 return C_SCHEME_FALSE;13383 }13384}133851338613387/* random numbers, mostly lifted from13388 https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c13389*/1339013391#ifdef __linux__13392# include <sys/syscall.h>13393#endif133941339513396#if !defined(_WIN32)13397static C_word random_urandom(C_word buf, int count)13398{13399 static int fd = -1;13400 int off = 0, r;1340113402 if(fd == -1) {13403 fd = open("/dev/urandom", O_RDONLY);1340413405 if(fd == -1) return C_SCHEME_FALSE;13406 }1340713408 while(count > 0) {13409 r = read(fd, C_data_pointer(buf) + off, count);1341013411 if(r == -1) {13412 if(errno != EINTR && errno != EAGAIN) return C_SCHEME_FALSE;13413 else r = 0;13414 }1341513416 count -= r;13417 off += r;13418 }1341913420 return C_SCHEME_TRUE;13421}13422#endif134231342413425C_word C_random_bytes(C_word buf, C_word size)13426{13427 int count = C_unfix(size);13428 int r = 0;13429 int off = 0;1343013431#if defined(__OpenBSD__) || defined(__FreeBSD__)13432 arc4random_buf(C_data_pointer(buf), count);13433#elif defined(SYS_getrandom) && defined(__NR_getrandom)13434 static int use_urandom = 0;1343513436 if(use_urandom) return random_urandom(buf, count);1343713438 while(count > 0) {13439 /* GRND_NONBLOCK = 0x0001 */13440 r = syscall(SYS_getrandom, C_data_pointer(buf) + off, count, 1);1344113442 if(r == -1) {13443 if(errno == ENOSYS) {13444 use_urandom = 1;13445 return random_urandom(buf, count);13446 }13447 else if(errno != EINTR) return C_SCHEME_FALSE;13448 else r = 0;13449 }1345013451 count -= r;13452 off += r;13453 }13454#elif defined(_WIN32) && !defined(__CYGWIN__)13455 typedef BOOLEAN (*func)(PVOID, ULONG);13456 static func RtlGenRandom = NULL;1345713458 if(RtlGenRandom == NULL) {13459 HMODULE mod = LoadLibrary("advapi32.dll");1346013461 if(mod == NULL) return C_SCHEME_FALSE;1346213463 if((RtlGenRandom = (func)GetProcAddress(mod, "SystemFunction036")) == NULL)13464 return C_SCHEME_FALSE;13465 }1346613467 if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))13468 return C_SCHEME_FALSE;13469#else13470 return random_urandom(buf, count);13471#endif1347213473 return C_SCHEME_TRUE;13474}134751347613477/* WELL512 pseudo random number generator, see also:13478 https://en.wikipedia.org/wiki/Well_equidistributed_long-period_linear13479 http://lomont.org/Math/Papers/2008/Lomont_PRNG_2008.pdf13480*/1348113482static C_uword random_word(void)13483{13484 C_uword a, b, c, d, r;13485 a = random_state[random_state_index];13486 c = random_state[(random_state_index+13)&15];13487 b = a^c^(a<<16)^(c<<15);13488 c = random_state[(random_state_index+9)&15];13489 c ^= (c>>11);13490 a = random_state[random_state_index] = b^c;13491 d = a^((a<<5)&0xDA442D24UL);13492 random_state_index = (random_state_index + 15)&15;13493 a = random_state[random_state_index];13494 random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);13495 r = random_state[random_state_index];13496 return r;13497}134981349913500static C_uword random_uniform(C_uword bound)13501{13502 C_uword r, min;1350313504 if (bound < 2) return 0;1350513506 min = (1U + ~bound) % bound; /* = 2**<wordsize> mod bound */1350713508 do r = random_word(); while (r < min);1350913510 /* r is now clamped to a set whose size mod upper_bound == 013511 * the worst case (2**<wordsize-1>+1) requires ~ 2 attempts */1351213513 return r % bound;13514}135151351613517C_regparm C_word C_random_fixnum(C_word n)13518{13519 C_word nf;1352013521 if (!(n & C_FIXNUM_BIT))13522 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "pseudo-random-integer", n);1352313524 nf = C_unfix(n);1352513526 if(nf < 0)13527 barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", n, C_fix(0));1352813529 return C_fix(random_uniform(nf));13530}135311353213533C_regparm C_word13534C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)13535{13536 C_uword *start, *end;1353713538 if(C_bignum_negativep(rn))13539 barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", rn, C_fix(0));1354013541 int len = integer_length_abs(rn);13542 C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));13543 C_word result = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);13544 C_uword *p;13545 C_uword highest_word = C_bignum_digits(rn)[C_bignum_size(rn)-1];13546 start = C_bignum_digits(result);13547 end = start + C_bignum_size(result);1354813549 for(p = start; p < (end - 1); ++p) {13550 *p = random_word();13551 len -= sizeof(C_uword);13552 }1355313554 *p = random_uniform(highest_word);13555 return C_bignum_simplify(result);13556}1355713558/*13559 * C_a_i_random_real: Generate a stream of bits uniformly at random and13560 * interpret it as the fractional part of the binary expansion of a13561 * number in [0, 1], 0.00001010011111010100...; then round it.13562 * More information on https://mumble.net/~campbell/2014/04/28/uniform-random-float13563 */1356413565static inline C_u64 random64() {13566#ifdef C_SIXTY_FOUR13567 return random_word();13568#else13569 C_u64 v = 0;13570 v |= ((C_u64) random_word()) << 32;13571 v |= (C_u64) random_word();13572 return v;13573#endif13574}1357513576#if defined(__GNUC__) && !defined(__TINYC__)13577# define clz64 __builtin_clzll13578#else13579/* https://en.wikipedia.org/wiki/Find_first_set#CLZ */13580static const C_uchar clz_table_4bit[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 };1358113582int clz32(C_u32 x)13583{13584 int n;13585 if ((x & 0xFFFF0000) == 0) {n = 16; x <<= 16;} else {n = 0;}13586 if ((x & 0xFF000000) == 0) {n += 8; x <<= 8;}13587 if ((x & 0xF0000000) == 0) {n += 4; x <<= 4;}13588 n += (int)clz_table_4bit[x >> (32-4)];13589 return n;13590}1359113592int clz64(C_u64 x)13593{13594 int y = clz32(x >> 32);1359513596 if(y == 32) return y + clz32(x);1359713598 return y;13599}13600#endif1360113602C_regparm C_word13603C_a_i_random_real(C_word **ptr, C_word n) {13604 int exponent = -64;13605 uint64_t significand;13606 unsigned shift;1360713608 while (C_unlikely((significand = random64()) == 0)) {13609 exponent -= 64;13610 if (C_unlikely(exponent < -1074))13611 return 0;13612 }1361313614 shift = clz64(significand);13615 if (shift != 0) {13616 exponent -= shift;13617 significand <<= shift;13618 significand |= (random64() >> (64 - shift));13619 }1362013621 significand |= 1;13622 return C_flonum(ptr, ldexp((double)significand, exponent));13623}1362413625C_word C_set_random_seed(C_word buf, C_word n)13626{13627 int i, nsu = C_unfix(n) / sizeof(C_uword);13628 int off = 0;1362913630 for(i = 0; i < (C_RANDOM_STATE_SIZE / sizeof(C_uword)); ++i) {13631 if(off >= nsu) off = 0;1363213633 random_state[ i ] = *((C_uword *)C_data_pointer(buf) + off);13634 ++off;13635 }1363613637 random_state_index = 0;13638 return C_SCHEME_FALSE;13639}1364013641C_word C_a_extract_struct_2(C_word **ptr, size_t sz, void *sp)13642{13643 C_word bv = C_scratch_alloc(C_SIZEOF_BYTEVECTOR(sz));13644 C_word w;13645 C_block_header_init(bv, C_make_header(C_BYTEVECTOR_TYPE, sz));13646 C_memcpy(C_data_pointer(bv), sp, sz);13647 w = C_a_i_record2(ptr, 2, C_SCHEME_FALSE, bv);13648 return w;13649}1365013651C_regparm C_word C_i_setenv(C_word var, C_word val)13652{13653#if defined(_WIN32) && !defined(__CYGWIN__)13654 C_WCHAR *wvar = C_utf16(var,0);13655 C_WCHAR *wval = val == C_SCHEME_FALSE ? NULL : C_utf16(val, 1);13656 SetEnvironmentVariableW(wvar, wval);13657 return C_fix(0);13658#elif defined(HAVE_SETENV)13659 C_char *cvar = C_c_string(var);13660 if(val == C_SCHEME_FALSE) unsetenv(C_c_string(var));13661 else setenv(C_c_string(var), C_c_string(val), 1);13662 return(C_fix(0));13663#else13664 char *sx = C_c_string(C_var),13665 *sy = (val == C_SCHEME_FALSE ? "" : C_c_string(val));13666 int n1 = C_strlen(sx), n2 = C_strlen(sy);13667 int buf_len = n1 + n2 + 2;13668 char *buf = (char *)C_malloc(buf_len);13669 if(buf == NULL) return(C_fix(0));13670 else {13671 C_strlcpy(buf, sx, buf_len);13672 C_strlcat(buf, "=", buf_len);13673 C_strlcat(buf, sy, buf_len);13674 return(C_fix(putenv(buf)));13675 }13676#endif13677}1367813679C_char *C_getenv(C_word var)13680{13681#if defined(_WIN32) && !defined(__CYGWIN__)13682 C_WCHAR *wvar = C_utf16(var, 0);13683 if(GetEnvironmentVariableW(wvar, (C_WCHAR *)buffer, STRING_BUFFER_SIZE) ==13684 0) return NULL;13685 return C_utf8((C_WCHAR *)buffer);13686#else13687 return getenv(C_c_string(var));13688#endif13689}1369013691#ifdef HAVE_CRT_EXTERNS_H13692# include <crt_externs.h>13693# define environ (*_NSGetEnviron())13694#elif !defined(_WIN32) || defined(__CYGWIN__)13695extern char **environ;13696#endif1369713698C_char *C_getenventry(int i)13699{13700#if defined(_WIN32) && !defined(__CYGWIN__)13701 C_WCHAR *env = GetEnvironmentStringsW();13702 C_WCHAR *p = env;13703 while(i--) {13704 while(*p != 0) ++p;13705 if(*(++p) == 0) return NULL;13706 }13707 C_char *s = C_strdup(C_utf8(p));13708 FreeEnvironmentStringsW(env);13709 return s;13710#else13711 return environ[ i ] == NULL ? NULL : C_strdup(environ[ i ]);13712#endif13713}