~ chicken-core (chicken-5) /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 C_TLS 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 C_fcall (*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_TLS C_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_TLS C_long318 C_timer_interrupt_counter,319 C_initial_timer_interrupt_period;320C_TLS C_byte321 *C_fromspace_top,322 *C_fromspace_limit;323#ifdef HAVE_SIGSETJMP324C_TLS sigjmp_buf C_restart;325#else326C_TLS jmp_buf C_restart;327#endif328C_TLS void *C_restart_trampoline;329C_TLS C_word C_restart_c;330C_TLS int C_entry_point_status;331C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);332C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);333C_TLS void (*C_panic_hook)(C_char *msg) = NULL;334C_TLS void (*C_pre_gc_hook)(int mode) = NULL;335C_TLS void (*C_post_gc_hook)(int mode, C_long ms) = NULL;336C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc) = NULL;337338C_TLS int339 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_TLS C_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;355C_TLS time_t356 C_startup_time_sec,357 C_startup_time_msec,358 profile_frequency = 10000;359C_TLS char360 **C_main_argv,361#ifdef SEARCH_EXE_PATH362 *C_main_exe = NULL,363#endif364 *C_dlerror;365366static C_TLS TRACE_INFO367 *trace_buffer,368 *trace_buffer_limit,369 *trace_buffer_top;370371static C_TLS 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_TLS 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_TLS C_char390 buffer[ STRING_BUFFER_SIZE ],391 *private_repository = NULL,392 *current_module_name,393 *save_string;394static C_TLS C_SYMBOL_TABLE395 *symbol_table,396 *symbol_table_list,397 *keyword_table;398static C_TLS 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 u8vector_symbol,416 s8vector_symbol,417 u16vector_symbol,418 s16vector_symbol,419 u32vector_symbol,420 s32vector_symbol,421 u64vector_symbol,422 s64vector_symbol,423 f32vector_symbol,424 f64vector_symbol,425 *forwarding_table;426static C_TLS int427 trace_buffer_full,428 forwarding_table_size,429 return_to_host,430 page_size,431 show_trace,432 fake_tty_flag,433 debug_mode,434 dump_heap_on_exit,435 gc_bell,436 gc_report_flag = 0,437 gc_mode,438 gc_count_1,439 gc_count_1_total,440 gc_count_2,441 stack_size_changed,442 dlopen_flags,443 heap_size_changed,444 random_state_initialized = 0,445 chicken_is_running,446 chicken_ran_once,447 pass_serious_signals = 1,448 callback_continuation_level;449static volatile C_TLS int450 serious_signal_occurred = 0,451 profiling = 0;452static C_TLS unsigned int453 mutation_count,454 tracked_mutation_count,455 stack_check_demand,456 stack_size;457static C_TLS int chicken_is_initialized;458#ifdef HAVE_SIGSETJMP459static C_TLS sigjmp_buf gc_restart;460#else461static C_TLS jmp_buf gc_restart;462#endif463static C_TLS double464 timer_start_ms,465 gc_ms,466 timer_accumulated_gc_ms,467 interrupt_time,468 last_interrupt_latency;469static C_TLS LF_LIST *lf_list;470static C_TLS int signal_mapping_table[ NSIG ];471static C_TLS int472 live_finalizer_count,473 allocated_finalizer_count,474 pending_finalizer_count,475 callback_returned_flag;476static C_TLS C_GC_ROOT *gc_root_list = NULL;477static C_TLS FINALIZER_NODE478 *finalizer_list,479 *finalizer_free_list,480 **pending_finalizer_indices;481static C_TLS void *current_module_handle;482static C_TLS int flonum_print_precision = FLONUM_PRINT_PRECISION;483static C_TLS HDUMP_BUCKET **hdump_table;484static C_TLS PROFILE_BUCKET485 *next_profile_bucket = NULL,486 **profile_table = NULL;487static C_TLS int488 pending_interrupts[ MAX_PENDING_INTERRUPTS ],489 pending_interrupts_count,490 handling_interrupts;491static C_TLS C_uword random_state[ C_RANDOM_STATE_SIZE / sizeof(C_uword) ];492static C_TLS int random_state_index = 0;493494495/* Prototypes: */496497static void parse_argv(C_char *cmds);498static void initialize_symbol_table(void);499static void global_signal_handler(int signum);500static C_word arg_val(C_char *arg);501static void barf(int code, char *loc, ...) C_noret;502static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_noret;503static void panic(C_char *msg) C_noret;504static void usual_panic(C_char *msg) C_noret;505static void horror(C_char *msg) C_noret;506static void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;507static C_cpsproc(values_continuation) C_noret;508static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);509static C_regparm int C_fcall C_in_new_heapp(C_word x);510static C_regparm C_word bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);511static C_regparm C_word bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end);512513static C_regparm C_word bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp);514static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);515static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op);516static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat);517static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op);518static C_word rat_times_integer(C_word **ptr, C_word x, C_word y);519static C_word rat_times_rat(C_word **ptr, C_word x, C_word y);520static C_word cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy);521static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y);522static C_regparm void integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);523static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y);524static C_regparm void bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);525static C_regparm C_word bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);526static 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);527static 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);528static C_word rat_cmp(C_word x, C_word y);529static void fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan);530static C_word int_flo_cmp(C_word intnum, C_word flonum);531static C_word flo_int_cmp(C_word flonum, C_word intnum);532static C_word rat_flo_cmp(C_word ratnum, C_word flonum);533static C_word flo_rat_cmp(C_word flonum, C_word ratnum);534static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp);535static int bignum_cmp_unsigned(C_word x, C_word y);536static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci) C_regparm;537static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;538static C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm;539static double compute_symbol_table_load(double *avg_bucket_len, int *total);540static double C_fcall decode_flonum_literal(C_char *str) C_regparm;541static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);542static void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;543static void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;544static void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;545static C_word C_fcall intern0(C_char *name) C_regparm;546static void C_fcall update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;547static void C_fcall update_locatives(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;548static LF_LIST *find_module_handle(C_char *name);549static void set_profile_timer(C_uword freq);550static void take_profile_sample();551552static C_cpsproc(call_cc_wrapper) C_noret;553static C_cpsproc(call_cc_values_wrapper) C_noret;554static C_cpsproc(gc_2) C_noret;555static C_cpsproc(allocate_vector_2) C_noret;556static C_cpsproc(generic_trampoline) C_noret;557static void handle_interrupt(void *trampoline) C_noret;558static C_cpsproc(callback_return_continuation) C_noret;559static C_cpsproc(termination_continuation) C_noret;560static C_cpsproc(become_2) C_noret;561static C_cpsproc(copy_closure_2) C_noret;562static C_cpsproc(dump_heap_state_2) C_noret;563static C_cpsproc(sigsegv_trampoline) C_noret;564static C_cpsproc(sigill_trampoline) C_noret;565static C_cpsproc(sigfpe_trampoline) C_noret;566static C_cpsproc(sigbus_trampoline) C_noret;567static C_cpsproc(bignum_to_str_2) C_noret;568569static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp);570static C_word allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp);571static void bignum_digits_destructive_negate(C_word bignum);572static C_uword bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry);573static C_uword bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator);574static C_uword bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp);575static C_uword bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left);576static C_regparm void bignum_digits_multiply(C_word x, C_word y, C_word result);577static void bignum_divide_unsigned(C_word **ptr, C_word num, C_word denom, C_word *q, C_word q_negp, C_word *r, C_word r_negp);578static C_regparm void bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r);579static C_regparm void bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder);580static C_regparm void bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q);581582static C_PTABLE_ENTRY *create_initial_ptable();583584#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))585static void C_ccall dload_2(C_word, C_word *) C_noret;586#endif587588static void589C_dbg(C_char *prefix, C_char *fstr, ...)590{591 va_list va;592593 va_start(va, fstr);594#ifdef __ANDROID__595 __android_log_vprint(ANDROID_LOG_DEBUG, prefix, fstr, va);596#else597 C_fflush(C_stdout);598 C_fprintf(C_stderr, "[%s] ", prefix);599 C_vfprintf(C_stderr, fstr, va);600 C_fflush(C_stderr);601#endif602 va_end(va);603}604605/* Startup code: */606607int CHICKEN_main(int argc, char *argv[], void *toplevel)608{609 C_word h, s, n;610611 if(C_gui_mode) {612#ifdef _WIN32613 parse_argv(GetCommandLine());614 argc = C_main_argc;615 argv = C_main_argv;616#else617 /* ??? */618#endif619 }620621 pass_serious_signals = 0;622 CHICKEN_parse_command_line(argc, argv, &h, &s, &n);623624 if(!CHICKEN_initialize(h, s, n, toplevel))625 panic(C_text("cannot initialize - out of memory"));626627 CHICKEN_run(NULL);628 return 0;629}630631632/* Custom argv parser for Windoze: */633634void parse_argv(C_char *cmds)635{636 C_char *ptr = cmds,637 *bptr0, *bptr, *aptr;638 int n = 0;639640 C_main_argv = (C_char **)malloc(MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS * sizeof(C_char *));641642 if(C_main_argv == NULL)643 panic(C_text("cannot allocate argument-list buffer"));644645 C_main_argc = 0;646647 for(;;) {648 while(isspace((int)(*ptr))) ++ptr;649650 if(*ptr == '\0') break;651652 for(bptr0 = bptr = buffer; !isspace((int)(*ptr)) && *ptr != '\0'; *(bptr++) = *(ptr++))653 ++n;654655 *bptr = '\0';656657 aptr = (C_char*) malloc(sizeof(C_char) * (n + 1));658 if (!aptr)659 panic(C_text("cannot allocate argument buffer"));660661 C_strlcpy(aptr, bptr0, sizeof(C_char) * (n + 1));662663 C_main_argv[ C_main_argc++ ] = aptr;664 }665}666667668/* Initialize runtime system: */669670int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)671{672 C_SCHEME_BLOCK *k0;673 int i;674#ifdef HAVE_SIGACTION675 struct sigaction sa;676#endif677678 /* FIXME Should have C_tzset in chicken.h? */679#if defined(__MINGW32__)680# if defined(__MINGW64_VERSION_MAJOR)681 ULONGLONG tick_count = GetTickCount64();682# else683 /* mingw32 doesn't yet have GetTickCount64 support */684 ULONGLONG tick_count = GetTickCount();685# endif686 C_startup_time_sec = tick_count / 1000;687 C_startup_time_msec = tick_count % 1000;688 /* Make sure _tzname, _timezone, and _daylight are set */689 _tzset();690#else691 struct timeval tv;692 C_gettimeofday(&tv, NULL);693 C_startup_time_sec = tv.tv_sec;694 C_startup_time_msec = tv.tv_usec / 1000;695 /* Make sure tzname, timezone, and daylight are set */696 tzset();697#endif698699 if(chicken_is_initialized) return 1;700 else chicken_is_initialized = 1;701702#if defined(__ANDROID__) && defined(DEBUGBUILD)703 debug_mode = 2;704#endif705706 if(debug_mode)707 C_dbg(C_text("debug"), C_text("application startup...\n"));708709 C_panic_hook = usual_panic;710 symbol_table_list = NULL;711712 symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE);713714 if(symbol_table == NULL)715 return 0;716717 keyword_table = C_new_symbol_table("kw", symbols ? symbols / 4 : DEFAULT_KEYWORD_TABLE_SIZE);718719 if(keyword_table == NULL)720 return 0;721722 page_size = 0;723 stack_size = stack ? stack : DEFAULT_STACK_SIZE;724 C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);725726 /* Allocate temporary stack: */727 temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;728 if((C_temporary_stack_limit = (C_word *)C_malloc(temporary_stack_size * sizeof(C_word))) == NULL)729 return 0;730731 C_temporary_stack_bottom = C_temporary_stack_limit + temporary_stack_size;732 C_temporary_stack = C_temporary_stack_bottom;733734 /* Allocate mutation stack: */735 mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));736737 if(mutation_stack_bottom == NULL) return 0;738739 mutation_stack_top = mutation_stack_bottom;740 mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;741 C_gc_mutation_hook = NULL;742 C_gc_trace_hook = NULL;743744 /* Initialize finalizer lists: */745 finalizer_list = NULL;746 finalizer_free_list = NULL;747 pending_finalizer_indices =748 (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));749750 if(pending_finalizer_indices == NULL) return 0;751752 /* Initialize forwarding table: */753 forwarding_table =754 (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));755756 if(forwarding_table == NULL) return 0;757758 *forwarding_table = 0;759 forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;760761 /* Setup collectibles: */762 collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);763764 if(collectibles == NULL) return 0;765766 collectibles_top = collectibles;767 collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;768 gc_root_list = NULL;769770#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)771 dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;772#else773 dlopen_flags = 0;774#endif775776#ifdef HAVE_SIGACTION777 sa.sa_flags = 0;778 sigfillset(&sa.sa_mask); /* See note in C_establish_signal_handler() */779 sa.sa_handler = global_signal_handler;780#endif781782 /* setup signal handlers */783 if(!pass_serious_signals) {784#ifdef HAVE_SIGACTION785 C_sigaction(SIGBUS, &sa, NULL);786 C_sigaction(SIGFPE, &sa, NULL);787 C_sigaction(SIGILL, &sa, NULL);788 C_sigaction(SIGSEGV, &sa, NULL);789#else790 C_signal(SIGBUS, global_signal_handler);791 C_signal(SIGILL, global_signal_handler);792 C_signal(SIGFPE, global_signal_handler);793 C_signal(SIGSEGV, global_signal_handler);794#endif795 }796797 tracked_mutation_count = mutation_count = gc_count_1 = gc_count_1_total = gc_count_2 = maximum_heap_usage = 0;798 lf_list = NULL;799 C_register_lf2(NULL, 0, create_initial_ptable());800 C_restart_trampoline = (void *)toplevel;801 trace_buffer = NULL;802 C_clear_trace_buffer();803 chicken_is_running = chicken_ran_once = 0;804 pending_interrupts_count = 0;805 handling_interrupts = 0;806 last_interrupt_latency = 0;807 C_interrupts_enabled = 1;808 C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;809 C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;810 memset(signal_mapping_table, 0, sizeof(int) * NSIG);811 C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";812 error_location = C_SCHEME_FALSE;813 C_pre_gc_hook = NULL;814 C_post_gc_hook = NULL;815 C_scratchspace_start = NULL;816 C_scratchspace_top = NULL;817 C_scratchspace_limit = NULL;818 C_scratch_usage = 0;819 scratchspace_size = 0;820 live_finalizer_count = 0;821 allocated_finalizer_count = 0;822 current_module_name = NULL;823 current_module_handle = NULL;824 callback_continuation_level = 0;825 weak_pair_chain = (C_word)NULL;826 locative_chain = (C_word)NULL;827 gc_ms = 0;828 if (!random_state_initialized) {829 srand(time(NULL));830 random_state_initialized = 1;831 }832833 for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_uword); ++i)834 random_state[ i ] = rand();835836 initialize_symbol_table();837838 if (profiling) {839#ifndef C_NONUNIX840# ifdef HAVE_SIGACTION841 C_sigaction(C_PROFILE_SIGNAL, &sa, NULL);842# else843 C_signal(C_PROFILE_SIGNAL, global_signal_handler);844# endif845#endif846847 profile_table = (PROFILE_BUCKET **)C_malloc(PROFILE_TABLE_SIZE * sizeof(PROFILE_BUCKET *));848849 if(profile_table == NULL)850 panic(C_text("out of memory - can not allocate profile table"));851852 C_memset(profile_table, 0, sizeof(PROFILE_BUCKET *) * PROFILE_TABLE_SIZE);853 }854855 /* create k to invoke code for system-startup: */856 k0 = (C_SCHEME_BLOCK *)C_align((C_word)C_fromspace_top);857 C_fromspace_top += C_align(2 * sizeof(C_word));858 k0->header = C_CLOSURE_TYPE | 1;859 C_set_block_item(k0, 0, (C_word)termination_continuation);860 C_save(k0);861 C_save(C_SCHEME_UNDEFINED);862 C_restart_c = 2;863 return 1;864}865866867void *C_get_statistics(void) {868 static void *stats[ 8 ];869870 stats[ 0 ] = fromspace_start;871 stats[ 1 ] = C_fromspace_limit;872 stats[ 2 ] = C_scratchspace_start;873 stats[ 3 ] = C_scratchspace_limit;874 stats[ 4 ] = C_stack_limit;875 stats[ 5 ] = stack_bottom;876 stats[ 6 ] = C_fromspace_top;877 stats[ 7 ] = C_scratchspace_top;878 return stats;879}880881882static C_PTABLE_ENTRY *create_initial_ptable()883{884 /* IMPORTANT: hardcoded table size -885 this must match the number of C_pte calls + 1 (NULL terminator)! */886 C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 63);887 int i = 0;888889 if(pt == NULL)890 panic(C_text("out of memory - cannot create initial ptable"));891892 C_pte(termination_continuation);893 C_pte(callback_return_continuation);894 C_pte(values_continuation);895 C_pte(call_cc_values_wrapper);896 C_pte(call_cc_wrapper);897 C_pte(C_gc);898 C_pte(C_allocate_vector);899 C_pte(C_make_structure);900 C_pte(C_ensure_heap_reserve);901 C_pte(C_return_to_host);902 C_pte(C_get_symbol_table_info);903 C_pte(C_get_memory_info);904 C_pte(C_decode_seconds);905 C_pte(C_stop_timer);906 C_pte(C_dload);907 C_pte(C_set_dlopen_flags);908 C_pte(C_become);909 C_pte(C_apply_values);910 C_pte(C_times);911 C_pte(C_minus);912 C_pte(C_plus);913 C_pte(C_nequalp);914 C_pte(C_greaterp);915 /* IMPORTANT: have you read the comments at the start and the end of this function? */916 C_pte(C_lessp);917 C_pte(C_greater_or_equal_p);918 C_pte(C_less_or_equal_p);919 C_pte(C_number_to_string);920 C_pte(C_make_symbol);921 C_pte(C_string_to_symbol);922 C_pte(C_string_to_keyword);923 C_pte(C_apply);924 C_pte(C_call_cc);925 C_pte(C_values);926 C_pte(C_call_with_values);927 C_pte(C_continuation_graft);928 C_pte(C_open_file_port);929 C_pte(C_software_type);930 C_pte(C_machine_type);931 C_pte(C_machine_byte_order);932 C_pte(C_software_version);933 C_pte(C_build_platform);934 C_pte(C_make_pointer);935 /* IMPORTANT: have you read the comments at the start and the end of this function? */936 C_pte(C_make_tagged_pointer);937 C_pte(C_peek_signed_integer);938 C_pte(C_peek_unsigned_integer);939 C_pte(C_peek_int64);940 C_pte(C_peek_uint64);941 C_pte(C_context_switch);942 C_pte(C_register_finalizer);943 C_pte(C_copy_closure);944 C_pte(C_dump_heap_state);945 C_pte(C_filter_heap_objects);946 C_pte(C_fixnum_to_string);947 C_pte(C_integer_to_string);948 C_pte(C_flonum_to_string);949 C_pte(C_signum);950 C_pte(C_quotient_and_remainder);951 C_pte(C_u_integer_quotient_and_remainder);952 C_pte(C_bitwise_and);953 C_pte(C_bitwise_ior);954 C_pte(C_bitwise_xor);955956 /* IMPORTANT: did you remember the hardcoded pte table size? */957 pt[ i ].id = NULL;958 return pt;959}960961962void *CHICKEN_new_gc_root_2(int finalizable)963{964 C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));965966 if(r == NULL)967 panic(C_text("out of memory - cannot allocate GC root"));968969 r->value = C_SCHEME_UNDEFINED;970 r->next = gc_root_list;971 r->prev = NULL;972 r->finalizable = finalizable;973974 if(gc_root_list != NULL) gc_root_list->prev = r;975976 gc_root_list = r;977 return (void *)r;978}979980981void *CHICKEN_new_gc_root()982{983 return CHICKEN_new_gc_root_2(0);984}985986987void *CHICKEN_new_finalizable_gc_root()988{989 return CHICKEN_new_gc_root_2(1);990}991992993void CHICKEN_delete_gc_root(void *root)994{995 C_GC_ROOT *r = (C_GC_ROOT *)root;996997 if(r->prev == NULL) gc_root_list = r->next;998 else r->prev->next = r->next;9991000 if(r->next != NULL) r->next->prev = r->prev;10011002 C_free(root);1003}100410051006void *CHICKEN_global_lookup(char *name)1007{1008 int1009 len = C_strlen(name),1010 key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);1011 C_word s;1012 void *root = CHICKEN_new_gc_root();10131014 if(C_truep(s = lookup(key, len, name, symbol_table))) {1015 if(C_block_item(s, 0) != C_SCHEME_UNBOUND) {1016 CHICKEN_gc_root_set(root, s);1017 return root;1018 }1019 }10201021 return NULL;1022}102310241025int CHICKEN_is_running()1026{1027 return chicken_is_running;1028}102910301031void CHICKEN_interrupt()1032{1033 C_timer_interrupt_counter = 0;1034}103510361037C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)1038{1039 C_SYMBOL_TABLE *stp;1040 int i;10411042 if((stp = C_find_symbol_table(name)) != NULL) return stp;10431044 if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)1045 return NULL;10461047 stp->name = name;1048 stp->size = size;1049 stp->next = symbol_table_list;1050 stp->rand = rand();10511052 if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)1053 return NULL;10541055 for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);10561057 symbol_table_list = stp;1058 return stp;1059}106010611062C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)1063{1064 C_SYMBOL_TABLE *stp;10651066 for(stp = symbol_table_list; stp != NULL; stp = stp->next)1067 if(!C_strcmp(name, stp->name)) return stp;10681069 return NULL;1070}107110721073C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)1074{1075 C_char *sptr = C_c_string(str);1076 int len = C_header_size(str);1077 int key;1078 C_word s;10791080 if(stable == NULL) stable = symbol_table;10811082 key = hash_string(len, sptr, stable->size, stable->rand, 0);10831084 if(C_truep(s = lookup(key, len, sptr, stable))) return s;1085 else return C_SCHEME_FALSE;1086}108710881089/* Setup symbol-table with internally used symbols; */10901091void initialize_symbol_table(void)1092{1093 int i;10941095 for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);10961097 /* Obtain reference to hooks for later: */1098 core_provided_symbol = C_intern2(C_heaptop, C_text("##core#provided"));1099 interrupt_hook_symbol = C_intern2(C_heaptop, C_text("##sys#interrupt-hook"));1100 error_hook_symbol = C_intern2(C_heaptop, C_text("##sys#error-hook"));1101 callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("##sys#callback-continuation-stack"), C_SCHEME_END_OF_LIST);1102 pending_finalizers_symbol = C_intern2(C_heaptop, C_text("##sys#pending-finalizers"));1103 current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);11041105 /* SRFI-4 tags */1106 u8vector_symbol = C_intern2(C_heaptop, C_text("u8vector"));1107 s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));1108 u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));1109 s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));1110 u32vector_symbol = C_intern2(C_heaptop, C_text("u32vector"));1111 s32vector_symbol = C_intern2(C_heaptop, C_text("s32vector"));1112 u64vector_symbol = C_intern2(C_heaptop, C_text("u64vector"));1113 s64vector_symbol = C_intern2(C_heaptop, C_text("s64vector"));1114 f32vector_symbol = C_intern2(C_heaptop, C_text("f32vector"));1115 f64vector_symbol = C_intern2(C_heaptop, C_text("f64vector"));1116}111711181119C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)1120{1121 C_char *sptr = C_c_string(str);1122 int len = C_header_size(str);1123 int key;1124 C_word s;11251126 if(kwtable == NULL) kwtable = keyword_table;11271128 key = hash_string(len, sptr, kwtable->size, kwtable->rand, 0);11291130 if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;1131 else return C_SCHEME_FALSE;1132}113311341135void C_ccall sigsegv_trampoline(C_word c, C_word *av)1136{1137 barf(C_MEMORY_VIOLATION_ERROR, NULL);1138}113911401141void C_ccall sigbus_trampoline(C_word c, C_word *av)1142{1143 barf(C_BUS_ERROR, NULL);1144}114511461147void C_ccall sigfpe_trampoline(C_word c, C_word *av)1148{1149 barf(C_FLOATING_POINT_EXCEPTION_ERROR, NULL);1150}115111521153void C_ccall sigill_trampoline(C_word c, C_word *av)1154{1155 barf(C_ILLEGAL_INSTRUCTION_ERROR, NULL);1156}115711581159/* This is called from POSIX signals: */11601161void global_signal_handler(int signum)1162{1163#if defined(HAVE_SIGPROCMASK)1164 if(signum == SIGSEGV || signum == SIGFPE || signum == SIGILL || signum == SIGBUS) {1165 sigset_t sset;11661167 if(serious_signal_occurred || !chicken_is_running) {1168 switch(signum) {1169 case SIGSEGV: panic(C_text("unrecoverable segmentation violation"));1170 case SIGFPE: panic(C_text("unrecoverable floating-point exception"));1171 case SIGILL: panic(C_text("unrecoverable illegal instruction error"));1172 case SIGBUS: panic(C_text("unrecoverable bus error"));1173 default: panic(C_text("unrecoverable serious condition"));1174 }1175 }1176 else serious_signal_occurred = 1;11771178 /* unblock signal to avoid nested invocation of the handler */1179 sigemptyset(&sset);1180 sigaddset(&sset, signum);1181 C_sigprocmask(SIG_UNBLOCK, &sset, NULL);11821183 switch(signum) {1184 case SIGSEGV: C_reclaim(sigsegv_trampoline, 0);1185 case SIGFPE: C_reclaim(sigfpe_trampoline, 0);1186 case SIGILL: C_reclaim(sigill_trampoline, 0);1187 case SIGBUS: C_reclaim(sigbus_trampoline, 0);1188 default: panic(C_text("invalid serious signal"));1189 }1190 }1191#endif11921193 /* TODO: Make full use of sigaction: check that /our/ timer expired */1194 if (signum == C_PROFILE_SIGNAL && profiling) take_profile_sample();1195 else C_raise_interrupt(signal_mapping_table[ signum ]);11961197#ifndef HAVE_SIGACTION1198 /* not necessarily needed, but older UNIXen may not leave the handler installed: */1199 C_signal(signum, global_signal_handler);1200#endif1201}120212031204/* Align memory to page boundary */12051206static void *align_to_page(void *mem)1207{1208 return (void *)C_align((C_uword)mem);1209}121012111212static C_byte *1213heap_alloc (size_t size, C_byte **page_aligned)1214{1215 C_byte *p;1216 p = (C_byte *)C_malloc (size + page_size);12171218 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12191220 return p;1221}122212231224static void1225heap_free (C_byte *ptr, size_t size)1226{1227 C_free (ptr);1228}122912301231static C_byte *1232heap_realloc (C_byte *ptr, size_t old_size,1233 size_t new_size, C_byte **page_aligned)1234{1235 C_byte *p;1236 p = (C_byte *)C_realloc (ptr, new_size + page_size);12371238 if (p != NULL && page_aligned) *page_aligned = align_to_page (p);12391240 return p;1241}124212431244/* Modify heap size at runtime: */12451246void C_set_or_change_heap_size(C_word heap, int reintern)1247{1248 C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;1249 C_word size = heap / 2;12501251 if(heap_size_changed && fromspace_start) return;12521253 if(fromspace_start && heap_size >= heap) return;12541255 if(debug_mode)1256 C_dbg(C_text("debug"), C_text("heap resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), heap);12571258 heap_size = heap;12591260 if((ptr1 = heap_realloc (fromspace_start,1261 C_fromspace_limit - fromspace_start,1262 size, &ptr1a)) == NULL ||1263 (ptr2 = heap_realloc (tospace_start,1264 tospace_limit - tospace_start,1265 size, &ptr2a)) == NULL)1266 panic(C_text("out of memory - cannot allocate heap"));12671268 heapspace1 = ptr1;1269 heapspace1_size = size;1270 heapspace2 = ptr2;1271 heapspace2_size = size;1272 fromspace_start = ptr1a;1273 C_fromspace_top = fromspace_start;1274 C_fromspace_limit = fromspace_start + size;1275 tospace_start = ptr2a;1276 tospace_top = tospace_start;1277 tospace_limit = tospace_start + size;1278 mutation_stack_top = mutation_stack_bottom;12791280 if(reintern) initialize_symbol_table();1281}128212831284/* Modify stack-size at runtime: */12851286void C_do_resize_stack(C_word stack)1287{1288 C_uword old = stack_size,1289 diff = stack - old;12901291 if(diff != 0 && !stack_size_changed) {1292 if(debug_mode)1293 C_dbg(C_text("debug"), C_text("stack resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), stack);12941295 stack_size = stack;12961297#if C_STACK_GROWS_DOWNWARD1298 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit - diff);1299#else1300 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_hard_limit + diff);1301#endif1302 C_stack_limit = C_stack_hard_limit;1303 }1304}130513061307/* Check whether nursery is sufficiently big: */13081309void C_check_nursery_minimum(C_word words)1310{1311 if(words >= C_bytestowords(stack_size))1312 panic(C_text("nursery is too small - try higher setting using the `-:s' option"));1313}13141315C_word C_resize_pending_finalizers(C_word size) {1316 int sz = C_num_to_int(size);13171318 FINALIZER_NODE **newmem =1319 (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));13201321 if (newmem == NULL)1322 return C_SCHEME_FALSE;13231324 pending_finalizer_indices = newmem;1325 C_max_pending_finalizers = sz;1326 return C_SCHEME_TRUE;1327}132813291330/* Parse runtime options from command-line: */13311332void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols)1333{1334 int i;1335 char *ptr;1336 C_word x;13371338 C_main_argc = argc;1339 C_main_argv = argv;13401341 *heap = DEFAULT_HEAP_SIZE;1342 *stack = DEFAULT_STACK_SIZE;1343 *symbols = DEFAULT_SYMBOL_TABLE_SIZE;13441345 for(i = 1; i < C_main_argc; ++i) {1346 if (strncmp(C_main_argv[ i ], C_text("-:"), 2))1347 break; /* Stop parsing on first non-runtime option */13481349 ptr = &C_main_argv[ i ][ 2 ];1350 if (*ptr == '\0')1351 break; /* Also stop parsing on first "empty" option (i.e. "-:") */13521353 do {1354 switch(*(ptr++)) {1355 case '?':1356 C_dbg("Runtime options", "\n\n"1357 " -:? display this text\n"1358 " -:c always treat stdin as console\n"1359 " -:d enable debug output\n"1360 " -:D enable more debug output\n"1361 " -:g show GC information\n"1362 " -:o disable stack overflow checks\n"1363 " -:hiSIZE set initial heap size\n"1364 " -:hmSIZE set maximal heap size\n"1365 " -:hfSIZE set minimum unused heap size\n"1366 " -:hgPERCENTAGE set heap growth percentage\n"1367 " -:hsPERCENTAGE set heap shrink percentage\n"1368 " -:huPERCENTAGE set percentage of memory used at which heap will be shrunk\n"1369 " -:hSIZE set fixed heap size\n"1370 " -:r write trace output to stderr\n"1371 " -:RSEED initialize rand() seed with SEED (helpful for benchmark stability)\n"1372 " -:p collect statistical profile and write to file at exit\n"1373 " -:PFREQUENCY like -:p, specifying sampling frequency in us (default: 10000)\n"1374 " -:sSIZE set nursery (stack) size\n"1375 " -:tSIZE set symbol-table size\n"1376 " -:fSIZE set maximal number of pending finalizers\n"1377 " -:x deliver uncaught exceptions of other threads to primordial one\n"1378 " -:B sound bell on major GC\n"1379 " -:G force GUI mode\n"1380 " -:aSIZE set trace-buffer/call-chain size\n"1381 " -:ASIZE set fixed temporary stack size\n"1382 " -:H dump heap state on exit\n"1383 " -:S do not handle segfaults or other serious conditions\n"1384 "\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"1385 " times 1024, 1048576, and 1073741824, respectively.\n\n");1386 C_exit_runtime(C_fix(0));13871388 case 'h':1389 switch(*ptr) {1390 case 'i':1391 *heap = arg_val(ptr + 1);1392 heap_size_changed = 1;1393 goto next;1394 case 'f':1395 C_heap_half_min_free = arg_val(ptr + 1);1396 goto next;1397 case 'g':1398 C_heap_growth = arg_val(ptr + 1);1399 goto next;1400 case 'm':1401 C_maximal_heap_size = arg_val(ptr + 1);1402 goto next;1403 case 's':1404 C_heap_shrinkage = arg_val(ptr + 1);1405 goto next;1406 case 'u':1407 C_heap_shrinkage_used = arg_val(ptr + 1);1408 goto next;1409 default:1410 *heap = arg_val(ptr);1411 heap_size_changed = 1;1412 C_heap_size_is_fixed = 1;1413 goto next;1414 }14151416 case 'o':1417 C_disable_overflow_check = 1;1418 break;14191420 case 'B':1421 gc_bell = 1;1422 break;14231424 case 'G':1425 C_gui_mode = 1;1426 break;14271428 case 'H':1429 dump_heap_on_exit = 1;1430 break;14311432 case 'S':1433 pass_serious_signals = 1;1434 break;14351436 case 's':1437 *stack = arg_val(ptr);1438 stack_size_changed = 1;1439 goto next;14401441 case 'f':1442 C_max_pending_finalizers = arg_val(ptr);1443 goto next;14441445 case 'a':1446 C_trace_buffer_size = arg_val(ptr);1447 goto next;14481449 case 'A':1450 fixed_temporary_stack_size = arg_val(ptr);1451 goto next;14521453 case 't':1454 *symbols = arg_val(ptr);1455 goto next;14561457 case 'c':1458 fake_tty_flag = 1;1459 break;14601461 case 'd':1462 debug_mode = 1;1463 break;14641465 case 'D':1466 debug_mode = 2;1467 break;14681469 case 'g':1470 gc_report_flag = 2;1471 break;14721473 case 'P':1474 profiling = 1;1475 profile_frequency = arg_val(ptr);1476 goto next;14771478 case 'p':1479 profiling = 1;1480 break;14811482 case 'r':1483 show_trace = 1;1484 break;14851486 case 'R':1487 srand((unsigned int)arg_val(ptr));1488 random_state_initialized = 1;1489 goto next;14901491 case 'x':1492 C_abort_on_thread_exceptions = 1;1493 break;14941495 default: panic(C_text("illegal runtime option"));1496 }1497 } while(*ptr != '\0');14981499 next:;1500 }1501}150215031504C_word arg_val(C_char *arg)1505{1506 int len;1507 C_char *end;1508 C_long val, mul = 1;15091510 if (arg == NULL) panic(C_text("illegal runtime-option argument"));15111512 len = C_strlen(arg);15131514 if(len < 1) panic(C_text("illegal runtime-option argument"));15151516 switch(arg[ len - 1 ]) {1517 case 'k':1518 case 'K': mul = 1024; break;15191520 case 'm':1521 case 'M': mul = 1024 * 1024; break;15221523 case 'g':1524 case 'G': mul = 1024 * 1024 * 1024; break;15251526 default: mul = 1;1527 }15281529 val = C_strtow(arg, &end, 10);15301531 if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))1532 panic(C_text("invalid runtime-option argument suffix"));15331534 return val * mul;1535}153615371538/* Run embedded code with arguments: */15391540C_word CHICKEN_run(void *toplevel)1541{1542 if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))1543 panic(C_text("could not initialize"));15441545 if(chicken_is_running)1546 panic(C_text("re-invocation of Scheme world while process is already running"));15471548 chicken_is_running = chicken_ran_once = 1;1549 return_to_host = 0;15501551 if(profiling) set_profile_timer(profile_frequency);15521553#if C_STACK_GROWS_DOWNWARD1554 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);1555#else1556 C_stack_hard_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);1557#endif1558 C_stack_limit = C_stack_hard_limit;15591560 stack_bottom = C_stack_pointer;15611562 if(debug_mode)1563 C_dbg(C_text("debug"), C_text("stack bottom is 0x%lx\n"), (C_word)stack_bottom);15641565 /* The point of (usually) no return... */1566#ifdef HAVE_SIGSETJMP1567 C_sigsetjmp(C_restart, 0);1568#else1569 C_setjmp(C_restart);1570#endif15711572 serious_signal_occurred = 0;15731574 if(!return_to_host) {1575 /* We must copy the argvector onto the stack, because1576 * any subsequent save() will otherwise clobber it.1577 */1578 C_word *p = C_alloc(C_restart_c);1579 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));1580 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));1581 C_temporary_stack = C_temporary_stack_bottom;1582 ((C_proc)C_restart_trampoline)(C_restart_c, p);1583 }15841585 if(profiling) set_profile_timer(0);15861587 chicken_is_running = 0;1588 return C_restore;1589}159015911592C_word CHICKEN_continue(C_word k)1593{1594 if(C_temporary_stack_bottom != C_temporary_stack)1595 panic(C_text("invalid temporary stack level"));15961597 if(!chicken_is_initialized)1598 panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));15991600 C_save(k);1601 return CHICKEN_run(NULL);1602}160316041605/* The final continuation: */16061607void C_ccall termination_continuation(C_word c, C_word *av)1608{1609 if(debug_mode) {1610 C_dbg(C_text("debug"), C_text("application terminated normally\n"));1611 }16121613 C_exit_runtime(C_fix(0));1614}161516161617/* Signal unrecoverable runtime error: */16181619void panic(C_char *msg)1620{1621 if(C_panic_hook != NULL) C_panic_hook(msg);16221623 usual_panic(msg);1624}162516261627void usual_panic(C_char *msg)1628{1629 C_char *dmp = C_dump_trace(0);16301631 C_dbg_hook(C_SCHEME_UNDEFINED);16321633 if(C_gui_mode) {1634 C_snprintf(buffer, sizeof(buffer), C_text("%s\n\n%s"), msg, dmp);1635#if defined(_WIN32) && !defined(__CYGWIN__)1636 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1637 ExitProcess(1);1638#endif1639 } /* fall through if not WIN32 GUI app */16401641 C_dbg("panic", C_text("%s - execution terminated\n\n%s"), msg, dmp);1642 C_exit_runtime(C_fix(1));1643}164416451646void horror(C_char *msg)1647{1648 C_dbg_hook(C_SCHEME_UNDEFINED);16491650 if(C_gui_mode) {1651 C_snprintf(buffer, sizeof(buffer), C_text("%s"), msg);1652#if defined(_WIN32) && !defined(__CYGWIN__)1653 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);1654 ExitProcess(1);1655#endif1656 } /* fall through */16571658 C_dbg("horror", C_text("\n%s - execution terminated"), msg);1659 C_exit_runtime(C_fix(1));1660}166116621663/* Error-hook, called from C-level runtime routines: */16641665void barf(int code, char *loc, ...)1666{1667 C_char *msg;1668 C_word err = error_hook_symbol;1669 int c, i;1670 va_list v;1671 C_word *av;16721673 C_dbg_hook(C_SCHEME_UNDEFINED);16741675 C_temporary_stack = C_temporary_stack_bottom;1676 err = C_block_item(err, 0);16771678 switch(code) {1679 case C_BAD_ARGUMENT_COUNT_ERROR:1680 msg = C_text("bad argument count");1681 c = 3;1682 break;16831684 case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:1685 msg = C_text("too few arguments");1686 c = 3;1687 break;16881689 case C_BAD_ARGUMENT_TYPE_ERROR:1690 msg = C_text("bad argument type");1691 c = 1;1692 break;16931694 case C_UNBOUND_VARIABLE_ERROR:1695 msg = C_text("unbound variable");1696 c = 1;1697 break;16981699 case C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR:1700 msg = C_text("bad argument type - not a keyword");1701 c = 1;1702 break;17031704 case C_OUT_OF_MEMORY_ERROR:1705 msg = C_text("not enough memory");1706 c = 0;1707 break;17081709 case C_DIVISION_BY_ZERO_ERROR:1710 msg = C_text("division by zero");1711 c = 0;1712 break;17131714 case C_OUT_OF_RANGE_ERROR:1715 msg = C_text("out of range");1716 c = 2;1717 break;17181719 case C_NOT_A_CLOSURE_ERROR:1720 msg = C_text("call of non-procedure");1721 c = 1;1722 break;17231724 case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:1725 msg = C_text("continuation cannot receive multiple values");1726 c = 1;1727 break;17281729 case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:1730 msg = C_text("bad argument type - not a non-cyclic list");1731 c = 1;1732 break;17331734 case C_TOO_DEEP_RECURSION_ERROR:1735 msg = C_text("recursion too deep");1736 c = 0;1737 break;17381739 case C_CANT_REPRESENT_INEXACT_ERROR:1740 msg = C_text("inexact number cannot be represented as an exact number");1741 c = 1;1742 break;17431744 case C_NOT_A_PROPER_LIST_ERROR:1745 msg = C_text("bad argument type - not a proper list");1746 c = 1;1747 break;17481749 case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:1750 msg = C_text("bad argument type - not a fixnum");1751 c = 1;1752 break;17531754 case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:1755 msg = C_text("bad argument type - not a string");1756 c = 1;1757 break;17581759 case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:1760 msg = C_text("bad argument type - not a pair");1761 c = 1;1762 break;17631764 case C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR:1765 msg = C_text("bad argument type - not a boolean");1766 c = 1;1767 break;17681769 case C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR:1770 msg = C_text("bad argument type - not a locative");1771 c = 1;1772 break;17731774 case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:1775 msg = C_text("bad argument type - not a list");1776 c = 1;1777 break;17781779 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:1780 msg = C_text("bad argument type - not a number");1781 c = 1;1782 break;17831784 case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:1785 msg = C_text("bad argument type - not a symbol");1786 c = 1;1787 break;17881789 case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:1790 msg = C_text("bad argument type - not a vector");1791 c = 1;1792 break;17931794 case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:1795 msg = C_text("bad argument type - not a character");1796 c = 1;1797 break;17981799 case C_STACK_OVERFLOW_ERROR:1800 msg = C_text("stack overflow");1801 c = 0;1802 break;18031804 case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:1805 msg = C_text("bad argument type - not a structure of the required type");1806 c = 2;1807 break;18081809 case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:1810 msg = C_text("bad argument type - not a blob");1811 c = 1;1812 break;18131814 case C_LOST_LOCATIVE_ERROR:1815 msg = C_text("locative refers to reclaimed object");1816 c = 1;1817 break;18181819 case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:1820 msg = C_text("bad argument type - not a object");1821 c = 1;1822 break;18231824 case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:1825 msg = C_text("bad argument type - not a number vector");1826 c = 2;1827 break;18281829 case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:1830 msg = C_text("bad argument type - not an integer");1831 c = 1;1832 break;18331834 case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:1835 msg = C_text("bad argument type - not an unsigned integer");1836 c = 1;1837 break;18381839 case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:1840 msg = C_text("bad argument type - not a pointer");1841 c = 1;1842 break;18431844 case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:1845 msg = C_text("bad argument type - not a tagged pointer");1846 c = 2;1847 break;18481849 case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:1850 msg = C_text("bad argument type - not a flonum");1851 c = 1;1852 break;18531854 case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:1855 msg = C_text("bad argument type - not a procedure");1856 c = 1;1857 break;18581859 case C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR:1860 msg = C_text("bad argument type - invalid base");1861 c = 1;1862 break;18631864 case C_CIRCULAR_DATA_ERROR:1865 msg = C_text("recursion too deep or circular data encountered");1866 c = 0;1867 break;18681869 case C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR:1870 msg = C_text("bad argument type - not a port");1871 c = 1;1872 break;18731874 case C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR:1875 msg = C_text("bad argument type - not a port of the correct type");1876 c = 1;1877 break;18781879 case C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR:1880 msg = C_text("bad argument type - not an input-port");1881 c = 1;1882 break;18831884 case C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR:1885 msg = C_text("bad argument type - not an output-port");1886 c = 1;1887 break;18881889 case C_PORT_CLOSED_ERROR:1890 msg = C_text("port already closed");1891 c = 1;1892 break;18931894 case C_ASCIIZ_REPRESENTATION_ERROR:1895 msg = C_text("cannot represent string with NUL bytes as C string");1896 c = 1;1897 break;18981899 case C_MEMORY_VIOLATION_ERROR:1900 msg = C_text("segmentation violation");1901 c = 0;1902 break;19031904 case C_FLOATING_POINT_EXCEPTION_ERROR:1905 msg = C_text("floating point exception");1906 c = 0;1907 break;19081909 case C_ILLEGAL_INSTRUCTION_ERROR:1910 msg = C_text("illegal instruction");1911 c = 0;1912 break;19131914 case C_BUS_ERROR:1915 msg = C_text("bus error");1916 c = 0;1917 break;19181919 case C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR:1920 msg = C_text("bad argument type - not an exact number");1921 c = 1;1922 break;19231924 case C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR:1925 msg = C_text("bad argument type - not an inexact number");1926 c = 1;1927 break;19281929 case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:1930 msg = C_text("bad argument type - not an real");1931 c = 1;1932 break;19331934 case C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR:1935 msg = C_text("bad argument type - complex number has no ordering");1936 c = 1;1937 break;19381939 case C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR:1940 msg = C_text("bad argument type - not an exact integer");1941 c = 1;1942 break;19431944 case C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION:1945 msg = C_text("number does not fit in foreign type");1946 c = 1;1947 break;19481949 case C_BAD_ARGUMENT_TYPE_COMPLEX_ABS:1950 msg = C_text("cannot compute absolute value of complex number");1951 c = 1;1952 break;19531954 case C_REST_ARG_OUT_OF_BOUNDS_ERROR:1955 msg = C_text("attempted rest argument access beyond end of list");1956 c = 3;1957 break;19581959 default: panic(C_text("illegal internal error code"));1960 }19611962 if(C_immediatep(err)) {1963 C_dbg(C_text("error"), C_text("%s\n"), msg);1964 panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));1965 } else {1966 av = C_alloc(c + 4);1967 va_start(v, loc);1968 av[ 0 ] = err;1969 /* No continuation is passed: '##sys#error-hook' may not return: */1970 av[ 1 ] = C_SCHEME_UNDEFINED;1971 av[ 2 ] = C_fix(code);19721973 if(loc != NULL)1974 av[ 3 ] = intern0(loc);1975 else {1976 av[ 3 ] = error_location;1977 error_location = C_SCHEME_FALSE;1978 }19791980 for(i = 0; i < c; ++i)1981 av[ i + 4 ] = va_arg(v, C_word);19821983 va_end(v);1984 C_do_apply(c + 4, av);1985 }1986}198719881989/* Never use extended number hook procedure names longer than this! */1990/* Current longest name: ##sys#integer->string/recursive */1991#define MAX_EXTNUM_HOOK_NAME 3219921993/* This exists so that we don't have to create any extra closures */1994static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...)1995{1996 static C_word ab[C_SIZEOF_STRING(MAX_EXTNUM_HOOK_NAME)];1997 int i;1998 va_list v;1999 C_word ext_proc_sym, ext_proc = C_SCHEME_FALSE, *a = ab;20002001 ext_proc_sym = C_lookup_symbol(C_intern2(&a, ext_proc_name));20022003 if(!C_immediatep(ext_proc_sym))2004 ext_proc = C_block_item(ext_proc_sym, 0);20052006 if (!C_immediatep(ext_proc) && C_closurep(ext_proc)) {2007 C_word *av = C_alloc(c + 1);2008 av[ 0 ] = ext_proc;2009 av[ 1 ] = k;2010 va_start(v, k);20112012 for(i = 0; i < c - 1; ++i)2013 av[ i + 2 ] = va_arg(v, C_word);20142015 va_end(v);2016 C_do_apply(c + 1, av);2017 } else {2018 barf(C_UNBOUND_VARIABLE_ERROR, NULL, ext_proc_sym);2019 }2020}202120222023/* Hook for setting breakpoints */20242025C_word C_dbg_hook(C_word dummy)2026{2027 return dummy;2028}202920302031/* Timing routines: */20322033/* DEPRECATED */2034C_regparm C_u64 C_fcall C_milliseconds(void)2035{2036 return C_current_process_milliseconds();2037}20382039C_regparm C_u64 C_fcall C_current_process_milliseconds(void)2040{2041#if defined(__MINGW32__)2042# if defined(__MINGW64_VERSION_MAJOR)2043 ULONGLONG tick_count = GetTickCount64();2044# else2045 ULONGLONG tick_count = GetTickCount();2046# endif2047 return tick_count - (C_startup_time_sec * 1000) - C_startup_time_msec;2048#else2049 struct timeval tv;20502051 if(C_gettimeofday(&tv, NULL) == -1) return 0;2052 else return (tv.tv_sec - C_startup_time_sec) * 1000 + tv.tv_usec / 1000 - C_startup_time_msec;2053#endif2054}205520562057C_regparm time_t C_fcall C_seconds(C_long *ms)2058{2059#ifdef C_NONUNIX2060 if(ms != NULL) *ms = 0;20612062 return (time_t)(clock() / CLOCKS_PER_SEC);2063#else2064 struct timeval tv;20652066 if(C_gettimeofday(&tv, NULL) == -1) {2067 if(ms != NULL) *ms = 0;20682069 return (time_t)0;2070 }2071 else {2072 if(ms != NULL) *ms = tv.tv_usec / 1000;20732074 return tv.tv_sec;2075 }2076#endif2077}207820792080C_regparm C_u64 C_fcall C_cpu_milliseconds(void)2081{2082#if defined(C_NONUNIX) || defined(__CYGWIN__)2083 if(CLOCKS_PER_SEC == 1000) return clock();2084 else return ((C_u64)clock() / CLOCKS_PER_SEC) * 1000;2085#else2086 struct rusage ru;20872088 if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;2089 else return (((C_u64)ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 10002090 + ((C_u64)ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000);2091#endif2092}209320942095/* Support code for callbacks: */20962097int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)2098{2099 C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));21002101 C_mutate_slot(&C_block_item(callback_continuation_stack_symbol, 0), p);2102 return ++callback_continuation_level;2103}210421052106C_word C_fcall C_restore_callback_continuation(void)2107{2108 /* obsolete, but retained for keeping old code working */2109 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2110 k;21112112 assert(!C_immediatep(p) && C_header_type(p) == C_PAIR_TYPE);2113 k = C_u_i_car(p);21142115 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2116 --callback_continuation_level;2117 return k;2118}211921202121C_word C_fcall C_restore_callback_continuation2(int level)2122{2123 C_word p = C_block_item(callback_continuation_stack_symbol, 0),2124 k;21252126 if(level != callback_continuation_level || C_immediatep(p) || C_header_type(p) != C_PAIR_TYPE)2127 panic(C_text("unbalanced callback continuation stack"));21282129 k = C_u_i_car(p);21302131 C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));2132 --callback_continuation_level;2133 return k;2134}213521362137C_word C_fcall C_callback(C_word closure, int argc)2138{2139#ifdef HAVE_SIGSETJMP2140 sigjmp_buf prev;2141#else2142 jmp_buf prev;2143#endif2144 C_word2145 *a = C_alloc(C_SIZEOF_CLOSURE(2)),2146 k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE),2147 *av;2148 int old = chicken_is_running;21492150 if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)2151 panic(C_text("callback invoked in non-safe context"));21522153 C_memcpy(&prev, &C_restart, sizeof(C_restart));2154 callback_returned_flag = 0;2155 chicken_is_running = 1;2156 av = C_alloc(argc + 2);2157 av[ 0 ] = closure;2158 av[ 1 ] = k;2159 /*XXX is the order of arguments an issue? */2160 C_memcpy(av + 2, C_temporary_stack, argc * sizeof(C_word));2161 C_temporary_stack = C_temporary_stack_bottom;21622163#ifdef HAVE_SIGSETJMP2164 if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc + 2, av);2165#else2166 if(!C_setjmp(C_restart)) C_do_apply(argc + 2, av);2167#endif21682169 serious_signal_occurred = 0;21702171 if(!callback_returned_flag) {2172 /* We must copy the argvector onto the stack, because2173 * any subsequent save() will otherwise clobber it.2174 */2175 C_word *p = C_alloc(C_restart_c);2176 assert(C_restart_c == (C_temporary_stack_bottom - C_temporary_stack));2177 C_memcpy(p, C_temporary_stack, C_restart_c * sizeof(C_word));2178 C_temporary_stack = C_temporary_stack_bottom;2179 ((C_proc)C_restart_trampoline)(C_restart_c, p);2180 }2181 else {2182 C_memcpy(&C_restart, &prev, sizeof(C_restart));2183 callback_returned_flag = 0;2184 }21852186 chicken_is_running = old;2187 return C_restore;2188}218921902191void C_fcall C_callback_adjust_stack(C_word *a, int size)2192{2193 if(!chicken_is_running && !C_in_stackp((C_word)a)) {2194 if(debug_mode)2195 C_dbg(C_text("debug"),2196 C_text("callback invoked in lower stack region - adjusting limits:\n"2197 "[debug] current: \t%p\n"2198 "[debug] previous: \t%p (bottom) - %p (limit)\n"),2199 a, stack_bottom, C_stack_limit);22002201#if C_STACK_GROWS_DOWNWARD2202 C_stack_hard_limit = (C_word *)((C_byte *)a - stack_size);2203 stack_bottom = a + size;2204#else2205 C_stack_hard_limit = (C_word *)((C_byte *)a + stack_size);2206 stack_bottom = a;2207#endif2208 C_stack_limit = C_stack_hard_limit;22092210 if(debug_mode)2211 C_dbg(C_text("debug"), C_text("new: \t%p (bottom) - %p (limit)\n"),2212 stack_bottom, C_stack_limit);2213 }2214}221522162217C_word C_fcall C_callback_wrapper(void *proc, int argc)2218{2219 C_word2220 *a = C_alloc(C_SIZEOF_CLOSURE(1)),2221 closure = C_closure(&a, 1, (C_word)proc),2222 result;22232224 result = C_callback(closure, argc);2225 assert(C_temporary_stack == C_temporary_stack_bottom);2226 return result;2227}222822292230void C_ccall callback_return_continuation(C_word c, C_word *av)2231{2232 C_word self = av[0];2233 C_word r = av[1];22342235 if(C_block_item(self, 1) == C_SCHEME_TRUE)2236 panic(C_text("callback returned twice"));22372238 assert(callback_returned_flag == 0);2239 callback_returned_flag = 1;2240 C_set_block_item(self, 1, C_SCHEME_TRUE);2241 C_save(r);2242 C_reclaim(NULL, 0);2243}224422452246/* Register/unregister literal frame: */22472248void C_initialize_lf(C_word *lf, int count)2249{2250 while(count-- > 0)2251 *(lf++) = C_SCHEME_UNBOUND;2252}225322542255void *C_register_lf(C_word *lf, int count)2256{2257 return C_register_lf2(lf, count, NULL);2258}225922602261void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)2262{2263 LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));2264 LF_LIST *np;2265 int status = 0;22662267 node->lf = lf;2268 node->count = count;2269 node->ptable = ptable;2270 node->module_name = current_module_name;2271 node->module_handle = current_module_handle;2272 current_module_handle = NULL;22732274 if(lf_list) lf_list->prev = node;22752276 node->next = lf_list;2277 node->prev = NULL;2278 lf_list = node;2279 return (void *)node;2280}228122822283LF_LIST *find_module_handle(char *name)2284{2285 LF_LIST *np;22862287 for(np = lf_list; np != NULL; np = np->next) {2288 if(np->module_name != NULL && !C_strcmp(np->module_name, name))2289 return np;2290 }22912292 return NULL;2293}229422952296void C_unregister_lf(void *handle)2297{2298 LF_LIST *node = (LF_LIST *) handle;22992300 if (node->next) node->next->prev = node->prev;23012302 if (node->prev) node->prev->next = node->next;23032304 if (lf_list == node) lf_list = node->next;23052306 C_free(node->module_name);2307 C_free(node);2308}230923102311/* Intern symbol into symbol-table: */23122313C_regparm C_word C_fcall C_intern(C_word **ptr, int len, C_char *str)2314{2315 return C_intern_in(ptr, len, str, symbol_table);2316}231723182319C_regparm C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str)2320{2321 return C_h_intern_in(slot, len, str, symbol_table);2322}232323242325C_regparm C_word C_fcall C_intern_kw(C_word **ptr, int len, C_char *str)2326{2327 C_word kw = C_intern_in(ptr, len, str, keyword_table);2328 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2329 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2330 return kw;2331}233223332334C_regparm C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str)2335{2336 C_word kw = C_h_intern_in(slot, len, str, keyword_table);2337 C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */2338 C_set_block_item(kw, 2, C_SCHEME_FALSE); /* Keywords have no plists */2339 return kw;2340}23412342C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)2343{2344 int key;2345 C_word s;23462347 if(stable == NULL) stable = symbol_table;23482349 key = hash_string(len, str, stable->size, stable->rand, 0);23502351 if(C_truep(s = lookup(key, len, str, stable))) return s;23522353 s = C_string(ptr, len, str);2354 return add_symbol(ptr, key, s, stable);2355}235623572358C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)2359{2360 /* Intern as usual, but remember slot, and allocate in static2361 * memory. If symbol already exists, replace its string by a fresh2362 * statically allocated string to ensure it never gets collected, as2363 * lf[] entries are not tracked by the GC.2364 */2365 int key;2366 C_word s;23672368 if(stable == NULL) stable = symbol_table;23692370 key = hash_string(len, str, stable->size, stable->rand, 0);23712372 if(C_truep(s = lookup(key, len, str, stable))) {2373 if(C_in_stackp(s)) C_mutate_slot(slot, s);23742375 if(!C_truep(C_permanentp(C_symbol_name(s)))) {2376 /* Replace by statically allocated string, and persist it */2377 C_set_block_item(s, 1, C_static_string(C_heaptop, len, str));2378 C_i_persist_symbol(s);2379 }2380 return s;2381 }23822383 s = C_static_string(C_heaptop, len, str);2384 return add_symbol(C_heaptop, key, s, stable);2385}238623872388C_regparm C_word C_fcall intern0(C_char *str)2389{2390 int len = C_strlen(str);2391 int key = hash_string(len, str, symbol_table->size, symbol_table->rand, 0);2392 C_word s;23932394 if(C_truep(s = lookup(key, len, str, symbol_table))) return s;2395 else return C_SCHEME_FALSE;2396}239723982399C_regparm C_word C_fcall C_lookup_symbol(C_word sym)2400{2401 int key;2402 C_word str = C_block_item(sym, 1);2403 int len = C_header_size(str);24042405 key = hash_string(len, C_c_string(str), symbol_table->size, symbol_table->rand, 0);24062407 return lookup(key, len, C_c_string(str), symbol_table);2408}240924102411C_regparm C_word C_fcall C_intern2(C_word **ptr, C_char *str)2412{2413 return C_intern_in(ptr, C_strlen(str), str, symbol_table);2414}241524162417C_regparm C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value)2418{2419 C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);24202421 C_mutate(&C_block_item(s,0), value);2422 C_i_persist_symbol(s); /* Symbol has a value now; persist it */2423 return s;2424}242524262427C_regparm C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci)2428{2429 C_uword key = r;24302431 if (ci)2432 while(len--) key ^= (key << 6) + (key >> 2) + C_tolower((int)(*str++));2433 else2434 while(len--) key ^= (key << 6) + (key >> 2) + *(str++);24352436 return (C_word)(key % (C_uword)m);2437}243824392440C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)2441{2442 C_word bucket, last = 0, sym, s;24432444 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2445 bucket = C_block_item(bucket,1)) {2446 sym = C_block_item(bucket,0);24472448 /* If the symbol is unreferenced, drop it: */2449 if (sym == C_SCHEME_BROKEN_WEAK_PTR) {2450 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2451 else stable->table[ key ] = C_block_item(bucket,1);2452 } else {2453 last = bucket;2454 s = C_block_item(sym, 1);24552456 if(C_header_size(s) == (C_word)len2457 && !C_memcmp(str, (C_char *)C_data_pointer(s), len))2458 return sym;2459 }2460 }24612462 return C_SCHEME_FALSE;2463}24642465/* Mark a symbol as "persistent", to prevent it from being GC'ed */2466C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)2467{2468 C_word bucket;2469 C_SYMBOL_TABLE *stp;24702471 /* Normally, this will get called with a symbol, but in2472 * C_h_intern_kw we may call it with keywords too.2473 */2474 if(!C_truep(C_i_symbolp(sym)) && !C_truep(C_i_keywordp(sym))) {2475 error_location = C_SCHEME_FALSE;2476 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, sym);2477 }24782479 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2480 bucket = lookup_bucket(sym, stp);24812482 if (C_truep(bucket)) {2483 /* Change weak to strong ref to ensure long-term survival */2484 C_block_header(bucket) = C_block_header(bucket) & ~C_SPECIALBLOCK_BIT;2485 /* Ensure survival on next minor GC */2486 if (C_in_stackp(sym)) C_mutate_slot(&C_block_item(bucket, 0), sym);2487 }2488 }2489 return C_SCHEME_UNDEFINED;2490}24912492/* Possibly remove "persistence" of symbol, to allowed it to be GC'ed.2493 * This is only done if the symbol is unbound, has an empty plist and2494 * is allocated in managed memory.2495 */2496C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym)2497{2498 C_word bucket;2499 C_SYMBOL_TABLE *stp;25002501 C_i_check_symbol(sym);25022503 if (C_persistable_symbol(sym) ||2504 C_truep(C_permanentp(C_symbol_name(sym)))) {2505 return C_SCHEME_FALSE;2506 }25072508 for(stp = symbol_table_list; stp != NULL; stp = stp->next) {2509 bucket = lookup_bucket(sym, NULL);25102511 if (C_truep(bucket)) {2512 /* Turn it into a weak ref */2513 C_block_header(bucket) = C_block_header(bucket) | C_SPECIALBLOCK_BIT;2514 return C_SCHEME_TRUE;2515 }2516 }2517 return C_SCHEME_FALSE;2518}25192520C_regparm C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)2521{2522 C_word bucket, str = C_block_item(sym, 1);2523 int key, len = C_header_size(str);25242525 if (stable == NULL) stable = symbol_table;25262527 key = hash_string(len, C_c_string(str), stable->size, stable->rand, 0);25282529 for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;2530 bucket = C_block_item(bucket,1)) {2531 if (C_block_item(bucket,0) == sym) return bucket;2532 }2533 return C_SCHEME_FALSE;2534}253525362537double compute_symbol_table_load(double *avg_bucket_len, int *total_n)2538{2539 C_word bucket, last;2540 int i, j, alen = 0, bcount = 0, total = 0;25412542 for(i = 0; i < symbol_table->size; ++i) {2543 last = 0;2544 j = 0;2545 for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST;2546 bucket = C_block_item(bucket,1)) {2547 /* If the symbol is unreferenced, drop it: */2548 if (C_block_item(bucket,0) == C_SCHEME_BROKEN_WEAK_PTR) {2549 if (last) C_set_block_item(last, 1, C_block_item(bucket, 1));2550 else symbol_table->table[ i ] = C_block_item(bucket,1);2551 } else {2552 last = bucket;2553 ++j;2554 }2555 }25562557 if(j > 0) {2558 alen += j;2559 ++bcount;2560 }25612562 total += j;2563 }25642565 if(avg_bucket_len != NULL)2566 *avg_bucket_len = (double)alen / (double)bcount;25672568 *total_n = total;25692570 /* return load: */2571 return (double)total / (double)symbol_table->size;2572}257325742575C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable)2576{2577 C_word bucket, sym, b2, *p;25782579 p = *ptr;2580 sym = (C_word)p;2581 p += C_SIZEOF_SYMBOL;2582 C_block_header_init(sym, C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1));2583 C_set_block_item(sym, 0, C_SCHEME_UNBOUND);2584 C_set_block_item(sym, 1, string);2585 C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);2586 *ptr = p;2587 b2 = stable->table[ key ]; /* previous bucket */25882589 /* Create new weak or strong bucket depending on persistability */2590 if (C_truep(C_permanentp(string))) {2591 bucket = C_a_pair(ptr, sym, b2);2592 } else {2593 bucket = C_a_weak_pair(ptr, sym, b2);2594 }25952596 if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);2597 else {2598 /* If a stack-allocated bucket was here, and we allocate from2599 heap-top (say, in a toplevel literal frame allocation) then we have2600 to inform the memory manager that a 2nd gen. block points to a2601 1st gen. block, hence the mutation: */2602 C_mutate(&C_block_item(bucket,1), b2);2603 stable->table[ key ] = bucket;2604 }26052606 return sym;2607}260826092610C_regparm int C_in_stackp(C_word x)2611{2612 C_word *ptr = (C_word *)(C_uword)x;26132614#if C_STACK_GROWS_DOWNWARD2615 return ptr >= C_stack_pointer_test && ptr <= stack_bottom;2616#else2617 return ptr < C_stack_pointer_test && ptr >= stack_bottom;2618#endif2619}262026212622C_regparm int C_fcall C_in_heapp(C_word x)2623{2624 C_byte *ptr = (C_byte *)(C_uword)x;2625 return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||2626 (ptr >= tospace_start && ptr < tospace_limit);2627}26282629/* Only used during major GC (heap realloc) */2630static C_regparm int C_fcall C_in_new_heapp(C_word x)2631{2632 C_byte *ptr = (C_byte *)(C_uword)x;2633 return (ptr >= new_tospace_start && ptr < new_tospace_limit);2634}26352636C_regparm int C_fcall C_in_fromspacep(C_word x)2637{2638 C_byte *ptr = (C_byte *)(C_uword)x;2639 return (ptr >= fromspace_start && ptr < C_fromspace_limit);2640}26412642C_regparm int C_fcall C_in_scratchspacep(C_word x)2643{2644 C_word *ptr = (C_word *)(C_uword)x;2645 return (ptr >= C_scratchspace_start && ptr < C_scratchspace_limit);2646}26472648/* Cons the rest-aguments together: */26492650C_regparm C_word C_fcall C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)2651{2652 C_word2653 x = C_SCHEME_END_OF_LIST,2654 *p = *ptr;2655 C_SCHEME_BLOCK *node;26562657 av += c;26582659 while(--c >= n) {2660 node = (C_SCHEME_BLOCK *)p;2661 p += 3;2662 node->header = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2663 node->data[ 0 ] = *(--av);2664 node->data[ 1 ] = x;2665 x = (C_word)node;2666 }26672668 *ptr = p;2669 return x;2670}267126722673/* Print error messages and exit: */26742675void C_bad_memory(void)2676{2677 panic(C_text("there is not enough stack-space to run this executable"));2678}267926802681void C_bad_memory_2(void)2682{2683 panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));2684}268526862687/* The following two can be thrown out in the next release... */26882689void C_bad_argc(int c, int n)2690{2691 C_bad_argc_2(c, n, C_SCHEME_FALSE);2692}269326942695void C_bad_min_argc(int c, int n)2696{2697 C_bad_min_argc_2(c, n, C_SCHEME_FALSE);2698}269927002701void C_bad_argc_2(int c, int n, C_word closure)2702{2703 barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2704}270527062707void C_bad_min_argc_2(int c, int n, C_word closure)2708{2709 barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);2710}271127122713void C_stack_overflow(C_char *loc)2714{2715 barf(C_STACK_OVERFLOW_ERROR, loc);2716}271727182719void C_unbound_error(C_word sym)2720{2721 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);2722}272327242725void C_no_closure_error(C_word x)2726{2727 barf(C_NOT_A_CLOSURE_ERROR, NULL, x);2728}272927302731void C_div_by_zero_error(char *loc)2732{2733 barf(C_DIVISION_BY_ZERO_ERROR, loc);2734}27352736void C_not_an_integer_error(char *loc, C_word x)2737{2738 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);2739}27402741void C_not_an_uinteger_error(char *loc, C_word x)2742{2743 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x);2744}27452746void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka)2747{2748 C_rest_arg_out_of_bounds_error_2(c, n, ka, C_SCHEME_FALSE);2749}27502751void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure)2752{2753 barf(C_REST_ARG_OUT_OF_BOUNDS_ERROR, NULL, C_u_fixnum_difference(c, ka), C_u_fixnum_difference(n, ka), closure);2754}27552756/* Allocate and initialize record: */27572758C_regparm C_word C_fcall C_string(C_word **ptr, int len, C_char *str)2759{2760 C_word strblock = (C_word)(*ptr);27612762 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));2763 C_block_header_init(strblock, C_STRING_TYPE | len);2764 C_memcpy(C_data_pointer(strblock), str, len);2765 return strblock;2766}276727682769C_regparm C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str)2770{2771 C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len));2772 C_word strblock;27732774 if(dptr == NULL)2775 panic(C_text("out of memory - cannot allocate static string"));27762777 strblock = (C_word)dptr;2778 C_block_header_init(strblock, C_STRING_TYPE | len);2779 C_memcpy(C_data_pointer(strblock), str, len);2780 return strblock;2781}27822783C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)2784{2785 C_word *dptr, bignum, bigvec, retval, size, negp = 0;27862787 if (*str == '+' || *str == '-') {2788 negp = ((*str++) == '-') ? 1 : 0;2789 --len;2790 }2791 size = C_BIGNUM_BITS_TO_DIGITS((unsigned int)len << 2);27922793 dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(size)));2794 if(dptr == NULL)2795 panic(C_text("out of memory - cannot allocate static bignum"));27962797 bigvec = (C_word)dptr;2798 C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(size + 1));2799 C_set_block_item(bigvec, 0, negp);2800 /* This needs to be allocated at ptr, not dptr, because GC moves type tag */2801 bignum = C_a_i_bignum_wrapper(ptr, bigvec);28022803 retval = str_to_bignum(bignum, str, str + len, 16);2804 if (retval & C_FIXNUM_BIT)2805 C_free(dptr); /* Might have been simplified */2806 return retval;2807}28082809C_regparm C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str)2810{2811 int dlen = sizeof(C_header) + C_align(len);2812 void *dptr = C_malloc(dlen);2813 C_word strblock;28142815 if(dptr == NULL)2816 panic(C_text("out of memory - cannot allocate static lambda info"));28172818 strblock = (C_word)dptr;2819 C_block_header_init(strblock, C_LAMBDA_INFO_TYPE | len);2820 C_memcpy(C_data_pointer(strblock), str, len);2821 return strblock;2822}282328242825C_regparm C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str)2826{2827 C_word strblock = C_string(ptr, len, str);28282829 (void)C_string_to_bytevector(strblock);2830 return strblock;2831}283228332834C_regparm C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str)2835{2836 C_word strblock = C_static_string(ptr, len, str);28372838 C_block_header_init(strblock, C_BYTEVECTOR_TYPE | len);2839 return strblock;2840}284128422843C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)2844{2845 C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));28462847 if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent blob"));28482849 pbv->header = C_BYTEVECTOR_TYPE | len;2850 C_memcpy(pbv->data, str, len);2851 return (C_word)pbv;2852}285328542855C_regparm C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str)2856{2857 C_word *p = *ptr,2858 *p0;28592860#ifndef C_SIXTY_FOUR2861 /* Align on 8-byte boundary: */2862 if(C_aligned8(p)) ++p;2863#endif28642865 p0 = p;2866 *ptr = p + 1 + C_bytestowords(len);2867 *(p++) = C_STRING_TYPE | C_8ALIGN_BIT | len;2868 C_memcpy(p, str, len);2869 return (C_word)p0;2870}287128722873C_regparm C_word C_fcall C_string2(C_word **ptr, C_char *str)2874{2875 C_word strblock = (C_word)(*ptr);2876 int len;28772878 if(str == NULL) return C_SCHEME_FALSE;28792880 len = C_strlen(str);2881 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));2882 C_block_header_init(strblock, C_STRING_TYPE | len);2883 C_memcpy(C_data_pointer(strblock), str, len);2884 return strblock;2885}288628872888C_regparm C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str)2889{2890 C_word strblock = (C_word)(*ptr);2891 int len;28922893 if(str == NULL) return C_SCHEME_FALSE;28942895 len = C_strlen(str);28962897 if(len >= max) {2898 C_snprintf(buffer, sizeof(buffer), C_text("foreign string result exceeded maximum of %d bytes"), max);2899 panic(buffer);2900 }29012902 *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));2903 C_block_header_init(strblock, C_STRING_TYPE | len);2904 C_memcpy(C_data_pointer(strblock), str, len);2905 return strblock;2906}290729082909C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)2910{2911 va_list va;2912 C_word *p = *ptr,2913 *p0 = p;29142915 *p = C_CLOSURE_TYPE | cells;2916 *(++p) = proc;29172918 for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));29192920 va_end(va);2921 *ptr = p + 1;2922 return (C_word)p0;2923}292429252926/* obsolete: replaced by C_a_pair in chicken.h */2927C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)2928{2929 C_word *p = *ptr,2930 *p0 = p;29312932 *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);2933 *(p++) = car;2934 *(p++) = cdr;2935 *ptr = p;2936 return (C_word)p0;2937}293829392940C_regparm C_word C_fcall C_number(C_word **ptr, double n)2941{2942 C_word2943 *p = *ptr,2944 *p0;2945 double m;29462947 if(n <= (double)C_MOST_POSITIVE_FIXNUM2948 && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0) {2949 return C_fix(n);2950 }29512952#ifndef C_SIXTY_FOUR2953#ifndef C_DOUBLE_IS_32_BITS2954 /* Align double on 8-byte boundary: */2955 if(C_aligned8(p)) ++p;2956#endif2957#endif29582959 p0 = p;2960 *(p++) = C_FLONUM_TAG;2961 *((double *)p) = n;2962 *ptr = p + sizeof(double) / sizeof(C_word);2963 return (C_word)p0;2964}296529662967C_regparm C_word C_fcall C_mpointer(C_word **ptr, void *mp)2968{2969 C_word2970 *p = *ptr,2971 *p0 = p;29722973 *(p++) = C_POINTER_TYPE | 1;2974 *((void **)p) = mp;2975 *ptr = p + 1;2976 return (C_word)p0;2977}297829792980C_regparm C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp)2981{2982 C_word2983 *p = *ptr,2984 *p0 = p;29852986 if(mp == NULL) return C_SCHEME_FALSE;29872988 *(p++) = C_POINTER_TYPE | 1;2989 *((void **)p) = mp;2990 *ptr = p + 1;2991 return (C_word)p0;2992}299329942995C_regparm C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp)2996{2997 C_word2998 *p = *ptr,2999 *p0 = p;30003001 *(p++) = C_TAGGED_POINTER_TAG;3002 *((void **)p) = mp;3003 *(++p) = tag;3004 *ptr = p + 1;3005 return (C_word)p0;3006}300730083009C_regparm C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)3010{3011 C_word3012 *p = *ptr,3013 *p0 = p;30143015 if(mp == NULL) return C_SCHEME_FALSE;30163017 *(p++) = C_TAGGED_POINTER_TAG;3018 *((void **)p) = mp;3019 *(++p) = tag;3020 *ptr = p + 1;3021 return (C_word)p0;3022}302330243025C_word C_vector(C_word **ptr, int n, ...)3026{3027 va_list v;3028 C_word3029 *p = *ptr,3030 *p0 = p;30313032 *(p++) = C_VECTOR_TYPE | n;3033 va_start(v, n);30343035 while(n--)3036 *(p++) = va_arg(v, C_word);30373038 *ptr = p;3039 va_end(v);3040 return (C_word)p0;3041}304230433044C_word C_structure(C_word **ptr, int n, ...)3045{3046 va_list v;3047 C_word *p = *ptr,3048 *p0 = p;30493050 *(p++) = C_STRUCTURE_TYPE | n;3051 va_start(v, n);30523053 while(n--)3054 *(p++) = va_arg(v, C_word);30553056 *ptr = p;3057 va_end(v);3058 return (C_word)p0;3059}306030613062C_regparm C_word C_fcall3063C_mutate_slot(C_word *slot, C_word val)3064{3065 unsigned int mssize, newmssize, bytes;30663067 ++mutation_count;3068 /* Mutation stack exists to track mutations pointing from elsewhere3069 * into nursery. Stuff pointing anywhere else can be skipped, as3070 * well as mutations on nursery objects.3071 */3072 if(!C_in_stackp(val) || C_in_stackp((C_word)slot))3073 return *slot = val;30743075#ifdef C_GC_HOOKS3076 if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;3077#endif30783079 if(mutation_stack_top >= mutation_stack_limit) {3080 assert(mutation_stack_top == mutation_stack_limit);3081 mssize = mutation_stack_top - mutation_stack_bottom;3082 newmssize = mssize * 2;3083 bytes = newmssize * sizeof(C_word *);30843085 if(debug_mode)3086 C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),3087 (mssize * sizeof(C_word *)) / 1024, bytes / 1024);30883089 mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, bytes);30903091 if(mutation_stack_bottom == NULL)3092 panic(C_text("out of memory - cannot re-allocate mutation stack"));30933094 mutation_stack_limit = mutation_stack_bottom + newmssize;3095 mutation_stack_top = mutation_stack_bottom + mssize;3096 }30973098 *(mutation_stack_top++) = slot;3099 ++tracked_mutation_count;3100 return *slot = val;3101}31023103/* Allocate memory in scratch space, "size" is in words, like C_alloc.3104 * The memory in the scratch space is laid out as follows: First,3105 * there's a count that indicates how big the object originally was,3106 * followed by a pointer to the slot in the object which points to the3107 * object in scratch space, finally followed by the object itself.3108 * The reason we store the slot pointer is so that we can figure out3109 * whether the object is still "live" when reallocating; that's3110 * because we don't have a saved continuation from where we can trace3111 * the live data. The reason we store the total length of the object3112 * is because we may be mutating in-place the lengths of the stored3113 * objects, and we need to know how much to skip over while scanning.3114 *3115 * If the allocating function returns, it *must* first mark all the3116 * values in scratch space as reclaimable. This is needed because3117 * there is no way to distinguish between a stale pointer into scratch3118 * space that's still somewhere on the stack in "uninitialized" memory3119 * versus a word that's been recycled by the next called function,3120 * which now holds a value that happens to have the same bit pattern3121 * but represents another thing entirely.3122 */3123C_regparm C_word C_fcall C_scratch_alloc(C_uword size)3124{3125 C_word result;31263127 if (C_scratchspace_top + size + 2 >= C_scratchspace_limit) {3128 C_word *new_scratch_start, *new_scratch_top, *new_scratch_limit;3129 C_uword needed = C_scratch_usage + size + 2,3130 new_size = nmax(scratchspace_size << 1, 2UL << C_ilen(needed));31313132 /* Shrink if the needed size is much smaller, but not below minimum */3133 if (needed < (new_size >> 4)) new_size >>= 1;3134 new_size = nmax(new_size, DEFAULT_SCRATCH_SPACE_SIZE);31353136 /* TODO: Maybe we should work with two semispaces to reduce mallocs? */3137 new_scratch_start = (C_word *)C_malloc(C_wordstobytes(new_size));3138 if (new_scratch_start == NULL)3139 panic(C_text("out of memory - cannot (re-)allocate scratch space"));3140 new_scratch_top = new_scratch_start;3141 new_scratch_limit = new_scratch_start + new_size;31423143 if(debug_mode) {3144 C_dbg(C_text("debug"), C_text("resizing scratchspace dynamically from "3145 UWORD_COUNT_FORMAT_STRING "k to "3146 UWORD_COUNT_FORMAT_STRING "k ...\n"),3147 C_wordstobytes(scratchspace_size) / 1024,3148 C_wordstobytes(new_size) / 1024);3149 }31503151 if(gc_report_flag) {3152 C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING3153 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3154 (C_word)C_scratchspace_start, (C_word)C_scratchspace_limit);3155 C_dbg(C_text("GC"), C_text("(new) scratchspace: \tstart=" UWORD_FORMAT_STRING3156 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3157 (C_word)new_scratch_start, (C_word)new_scratch_limit);3158 }31593160 /* Move scratch data into new space and mutate slots pointing there.3161 * This is basically a much-simplified version of really_mark.3162 */3163 if (C_scratchspace_start != NULL) {3164 C_word val, *sscan, *slot;3165 C_uword n, words;3166 C_header h;3167 C_SCHEME_BLOCK *p, *p2;31683169 sscan = C_scratchspace_start;31703171 while (sscan < C_scratchspace_top) {3172 words = *sscan;3173 slot = (C_word *)*(sscan+1);31743175 if (*(sscan+2) == ALIGNMENT_HOLE_MARKER) val = (C_word)(sscan+3);3176 else val = (C_word)(sscan+2);31773178 sscan += words + 2;31793180 p = (C_SCHEME_BLOCK *)val;3181 h = p->header;3182 if (is_fptr(h)) /* TODO: Support scratch->scratch pointers? */3183 panic(C_text("Unexpected forwarding pointer in scratch space"));31843185 p2 = (C_SCHEME_BLOCK *)(new_scratch_top+2);31863187#ifndef C_SIXTY_FOUR3188 if ((h & C_8ALIGN_BIT) && C_aligned8(p2) &&3189 (C_word *)p2 < new_scratch_limit) {3190 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3191 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3192 }3193#endif31943195 /* If orig slot still points here, copy data and update it */3196 if (slot != NULL) {3197 assert(C_in_stackp((C_word)slot) && *slot == val);3198 n = C_header_size(p);3199 n = (h & C_BYTEBLOCK_BIT) ? C_bytestowords(n) : n;32003201 *slot = (C_word)p2;3202 /* size = header plus block size plus optional alignment hole */3203 *new_scratch_top = ((C_word *)p2-(C_word *)new_scratch_top-2) + n + 1;3204 *(new_scratch_top+1) = (C_word)slot;32053206 new_scratch_top = (C_word *)p2 + n + 1;3207 if(new_scratch_top > new_scratch_limit)3208 panic(C_text("out of memory - scratch space full while resizing"));32093210 p2->header = h;3211 p->header = ptr_to_fptr((C_uword)p2);3212 C_memcpy(p2->data, p->data, C_wordstobytes(n));3213 }3214 }3215 free(C_scratchspace_start);3216 }3217 C_scratchspace_start = new_scratch_start;3218 C_scratchspace_top = new_scratch_top;3219 C_scratchspace_limit = new_scratch_limit;3220 /* Scratch space is now tightly packed */3221 C_scratch_usage = (new_scratch_top - new_scratch_start);3222 scratchspace_size = new_size;3223 }3224 assert(C_scratchspace_top + size + 2 <= C_scratchspace_limit);32253226 *C_scratchspace_top = size;3227 *(C_scratchspace_top+1) = (C_word)NULL; /* Nothing points here 'til mutated */3228 result = (C_word)(C_scratchspace_top+2);3229 C_scratchspace_top += size + 2;3230 /* This will only be marked as "used" when it's claimed by a pointer */3231 /* C_scratch_usage += size + 2; */3232 return result;3233}32343235/* Given a root object, scan its slots recursively (the objects3236 * themselves should be shallow and non-recursive), and migrate every3237 * object stored between the memory boundaries to the supplied3238 * pointer. Scratch data pointed to by objects between the memory3239 * boundaries is updated to point to the new memory region. If the3240 * supplied pointer is NULL, the scratch memory is marked reclaimable.3241 */3242C_regparm C_word C_fcall3243C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)3244{3245 C_word size, header, *data, *p = NULL, obj_in_buffer;32463247 if (C_immediatep(obj)) return obj;32483249 size = C_header_size(obj);3250 header = C_block_header(obj);3251 data = C_data_pointer(obj);3252 obj_in_buffer = (obj >= (C_word)start && obj < (C_word)end);32533254 /* Only copy object if we have a target pointer and it's in the buffer */3255 if (ptr != NULL && obj_in_buffer) {3256 p = *ptr;3257 obj = (C_word)p; /* Return the object's new location at the end */3258 }32593260 if (p != NULL) *p++ = header;32613262 if (header & C_BYTEBLOCK_BIT) {3263 if (p != NULL) {3264 *ptr = (C_word *)((C_byte *)(*ptr) + sizeof(C_header) + C_align(size));3265 C_memcpy(p, data, size);3266 }3267 } else {3268 if (p != NULL) *ptr += size + 1;32693270 if(header & C_SPECIALBLOCK_BIT) {3271 if (p != NULL) *(p++) = *data;3272 size--;3273 data++;3274 }32753276 /* TODO: See if we can somehow make this use Cheney's algorithm */3277 while(size--) {3278 C_word slot = *data;32793280 if(!C_immediatep(slot)) {3281 if (C_in_scratchspacep(slot)) {3282 if (obj_in_buffer) { /* Otherwise, don't touch scratch backpointer */3283 /* TODO: Support recursing into objects in scratch space? */3284 C_word *sp = (C_word *)slot;32853286 if (*(sp-1) == ALIGNMENT_HOLE_MARKER) --sp;3287 if (*(sp-1) != (C_word)NULL && p == NULL)3288 C_scratch_usage -= *(sp-2) + 2;3289 *(sp-1) = (C_word)p; /* This is why we traverse even if p = NULL */32903291 *data = C_SCHEME_UNBOUND; /* Ensure old reference is killed dead */3292 }3293 } else { /* Slot is not a scratchspace object: check sub-objects */3294 slot = C_migrate_buffer_object(ptr, start, end, slot);3295 }3296 }3297 if (p != NULL) *(p++) = slot;3298 else *data = slot; /* Sub-object may have moved! */3299 data++;3300 }3301 }3302 return obj; /* Should be NULL if ptr was NULL */3303}33043305/* Register an object's slot as holding data to scratch space. Only3306 * one slot can point to a scratch space object; the object in scratch3307 * space is preceded by a pointer that points to this slot (or NULL).3308 */3309C_regparm C_word C_fcall C_mutate_scratch_slot(C_word *slot, C_word val)3310{3311 C_word *ptr = (C_word *)val;3312 assert(C_in_scratchspacep(val));3313 assert(slot == NULL || C_in_stackp((C_word)slot));3314 if (*(ptr-1) == ALIGNMENT_HOLE_MARKER) --ptr;3315 if (*(ptr-1) == (C_word)NULL && slot != NULL)3316 C_scratch_usage += *(ptr-2) + 2;3317 if (*(ptr-1) != (C_word)NULL && slot == NULL)3318 C_scratch_usage -= *(ptr-2) + 2;3319 *(ptr-1) = (C_word)slot; /* Remember the slot pointing here, for realloc */3320 if (slot != NULL) *slot = val;3321 return val;3322}33233324/* Initiate garbage collection: */332533263327void C_save_and_reclaim(void *trampoline, int n, C_word *av)3328{3329 C_word new_size = nmax((C_word)1 << C_ilen(n), DEFAULT_TEMPORARY_STACK_SIZE);33303331 assert(av > C_temporary_stack_bottom || av < C_temporary_stack_limit);3332 assert(C_temporary_stack == C_temporary_stack_bottom);33333334 /* Don't *immediately* slam back to default size */3335 if (new_size < temporary_stack_size / 4)3336 new_size = temporary_stack_size >> 1;33373338 if (new_size != temporary_stack_size) {33393340 if(fixed_temporary_stack_size)3341 panic(C_text("fixed temporary stack overflow (\"apply\" called with too many arguments?)"));33423343 if(gc_report_flag) {3344 C_dbg(C_text("GC"), C_text("resizing temporary stack dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),3345 C_wordstobytes(temporary_stack_size) / 1024,3346 C_wordstobytes(new_size) / 1024);3347 }33483349 C_free(C_temporary_stack_limit);33503351 if((C_temporary_stack_limit = (C_word *)C_malloc(new_size * sizeof(C_word))) == NULL)3352 panic(C_text("out of memory - could not resize temporary stack"));33533354 C_temporary_stack_bottom = C_temporary_stack_limit + new_size;3355 C_temporary_stack = C_temporary_stack_bottom;3356 temporary_stack_size = new_size;3357 }33583359 C_temporary_stack = C_temporary_stack_bottom - n;33603361 assert(C_temporary_stack >= C_temporary_stack_limit);33623363 C_memmove(C_temporary_stack, av, n * sizeof(C_word));3364 C_reclaim(trampoline, n);3365}336633673368void C_save_and_reclaim_args(void *trampoline, int n, ...)3369{3370 va_list v;3371 int i;33723373 va_start(v, n);33743375 for(i = 0; i < n; ++i)3376 C_save(va_arg(v, C_word));33773378 va_end(v);3379 C_reclaim(trampoline, n);3380}338133823383#ifdef __SUNPRO_C3384static void _mark(C_word *x, C_byte *s, C_byte **t, C_byte *l) { \3385 C_word *_x = (x), _val = *_x; \3386 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3387}3388#else3389# define _mark(x,s,t,l) \3390 C_cblock \3391 C_word *_x = (x), _val = *_x; \3392 if(!C_immediatep(_val)) really_mark(_x,s,t,l); \3393 C_cblockend3394#endif33953396/* NOTE: This macro is particularly unhygienic! */3397#define mark(x) _mark(x, tgt_space_start, tgt_space_top, tgt_space_limit)33983399C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)3400{3401 int i, j, fcount;3402 C_uword count;3403 C_word **msp, last;3404 C_byte *tmp, *start;3405 C_GC_ROOT *gcrp;3406 double tgc = 0;3407 volatile int finalizers_checked;3408 FINALIZER_NODE *flist;3409 C_DEBUG_INFO cell;3410 C_byte *tgt_space_start, **tgt_space_top, *tgt_space_limit;34113412 /* assert(C_timer_interrupt_counter >= 0); */34133414 if(pending_interrupts_count > 0 && C_interrupts_enabled) {3415 stack_check_demand = 0; /* forget demand: we're not going to gc yet */3416 handle_interrupt(trampoline);3417 }34183419 cell.enabled = 0;3420 cell.event = C_DEBUG_GC;3421 cell.loc = "<runtime>";3422 cell.val = "GC_MINOR";3423 C_debugger(&cell, 0, NULL);34243425 /* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */3426 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);34273428 finalizers_checked = 0;3429 C_restart_trampoline = trampoline;3430 C_restart_c = c;3431 gc_mode = GC_MINOR;3432 tgt_space_start = fromspace_start;3433 tgt_space_top = &C_fromspace_top;3434 tgt_space_limit = C_fromspace_limit;3435 weak_pair_chain = (C_word)NULL;3436 locative_chain = (C_word)NULL;34373438 start = C_fromspace_top;34393440 /* Entry point for second-level GC (on explicit request or because of full fromspace): */3441#ifdef HAVE_SIGSETJMP3442 if(C_sigsetjmp(gc_restart, 0) || start >= C_fromspace_limit) {3443#else3444 if(C_setjmp(gc_restart) || start >= C_fromspace_limit) {3445#endif3446 if(gc_bell) {3447 C_putchar(7);3448 C_fflush(stdout);3449 }34503451 tgc = C_cpu_milliseconds();34523453 if(gc_mode == GC_REALLOC) {3454 cell.val = "GC_REALLOC";3455 C_debugger(&cell, 0, NULL);3456 C_rereclaim2(percentage(heap_size, C_heap_growth), 0);3457 gc_mode = GC_MAJOR;34583459 tgt_space_start = tospace_start;3460 tgt_space_top = &tospace_top;3461 tgt_space_limit= tospace_limit;34623463 count = (C_uword)tospace_top - (C_uword)tospace_start;3464 goto never_mind_edsger;3465 }34663467 start = (C_byte *)C_align((C_uword)tospace_top);3468 gc_mode = GC_MAJOR;3469 tgt_space_start = tospace_start;3470 tgt_space_top = &tospace_top;3471 tgt_space_limit= tospace_limit;3472 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into tospace */3473 locative_chain = (C_word)NULL; /* same for locatives */34743475 cell.val = "GC_MAJOR";3476 C_debugger(&cell, 0, NULL);34773478 mark_live_heap_only_objects(tgt_space_start, tgt_space_top, tgt_space_limit);34793480 /* mark normal GC roots (see below for finalizer handling): */3481 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3482 if(!gcrp->finalizable) mark(&gcrp->value);3483 }3484 }3485 else {3486 /* Mark mutated slots: */3487 for(msp = mutation_stack_bottom; msp < mutation_stack_top; ++msp)3488 mark(*msp);3489 }34903491 mark_live_objects(tgt_space_start, tgt_space_top, tgt_space_limit);34923493 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);3494 start = *tgt_space_top;34953496 if(gc_mode == GC_MINOR) {3497 count = (C_uword)C_fromspace_top - (C_uword)start;3498 ++gc_count_1;3499 ++gc_count_1_total;3500 update_locatives(GC_MINOR, start, *tgt_space_top);3501 update_weak_pairs(GC_MINOR, start, *tgt_space_top);3502 }3503 else {3504 /* Mark finalizer list and remember pointers to non-forwarded items: */3505 last = C_block_item(pending_finalizers_symbol, 0);35063507 if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {3508 /* still finalizers pending: just mark table items... */3509 if(gc_report_flag)3510 C_dbg(C_text("GC"), C_text("%d finalized item(s) still pending\n"), j);35113512 j = fcount = 0;35133514 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3515 mark(&flist->item);3516 mark(&flist->finalizer);3517 ++fcount;3518 }35193520 /* mark finalizable GC roots: */3521 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3522 if(gcrp->finalizable) mark(&gcrp->value);3523 }35243525 if(gc_report_flag && fcount > 0)3526 C_dbg(C_text("GC"), C_text("%d finalizer value(s) marked\n"), fcount);3527 }3528 else {3529 j = fcount = 0;35303531 /* move into pending */3532 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3533 if(j < C_max_pending_finalizers) {3534 if(!is_fptr(C_block_header(flist->item)))3535 pending_finalizer_indices[ j++ ] = flist;3536 }3537 }35383539 /* mark */3540 for(flist = finalizer_list; flist != NULL; flist = flist->next) {3541 mark(&flist->item);3542 mark(&flist->finalizer);3543 }35443545 /* mark finalizable GC roots: */3546 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {3547 if(gcrp->finalizable) mark(&gcrp->value);3548 }3549 }35503551 pending_finalizer_count = j;3552 finalizers_checked = 1;35533554 if(pending_finalizer_count > 0 && gc_report_flag)3555 C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),3556 pending_finalizer_count, live_finalizer_count);35573558 /* Once more mark nested objects after (maybe) copying finalizer objects: */3559 mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);35603561 /* Copy finalized items with remembered indices into `##sys#pending-finalizers'3562 (and release finalizer node): */3563 if(pending_finalizer_count > 0) {3564 if(gc_report_flag)3565 C_dbg(C_text("GC"), C_text("queueing %d finalizer(s)\n"), pending_finalizer_count);35663567 last = C_block_item(pending_finalizers_symbol, 0);3568 assert(C_block_item(last, 0) == C_fix(0));3569 C_set_block_item(last, 0, C_fix(pending_finalizer_count));35703571 for(i = 0; i < pending_finalizer_count; ++i) {3572 flist = pending_finalizer_indices[ i ];3573 C_set_block_item(last, 1 + i * 2, flist->item);3574 C_set_block_item(last, 2 + i * 2, flist->finalizer);35753576 if(flist->previous != NULL) flist->previous->next = flist->next;3577 else finalizer_list = flist->next;35783579 if(flist->next != NULL) flist->next->previous = flist->previous;35803581 flist->next = finalizer_free_list;3582 flist->previous = NULL;3583 finalizer_free_list = flist;3584 --live_finalizer_count;3585 }3586 }35873588 update_locatives(gc_mode, start, *tgt_space_top);3589 update_weak_pairs(gc_mode, start, *tgt_space_top);35903591 count = (C_uword)tospace_top - (C_uword)tospace_start; // Actual used, < heap_size/235923593 {3594 C_uword min_half = count + C_heap_half_min_free;3595 C_uword low_half = percentage(heap_size/2, C_heap_shrinkage_used);3596 C_uword grown = percentage(heap_size, C_heap_growth);3597 C_uword shrunk = percentage(heap_size, C_heap_shrinkage);35983599 if (count < low_half) {3600 heap_shrink_counter++;3601 } else {3602 heap_shrink_counter = 0;3603 }36043605 /*** isn't gc_mode always GC_MAJOR here? */3606 if(gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3607 C_heap_shrinkage > 0 &&3608 // This prevents grow, shrink, grow, shrink... spam3609 HEAP_SHRINK_COUNTS < heap_shrink_counter &&3610 (min_half * 2) <= shrunk && // Min. size trumps shrinkage3611 heap_size > MINIMAL_HEAP_SIZE) {3612 if(gc_report_flag) {3613 C_dbg(C_text("GC"), C_text("Heap low water mark hit (%d%%), shrinking...\n"),3614 C_heap_shrinkage_used);3615 }3616 heap_shrink_counter = 0;3617 C_rereclaim2(shrunk, 0);3618 } else if (gc_mode == GC_MAJOR && !C_heap_size_is_fixed &&3619 (heap_size / 2) < min_half) {3620 if(gc_report_flag) {3621 C_dbg(C_text("GC"), C_text("Heap high water mark hit, growing...\n"));3622 }3623 heap_shrink_counter = 0;3624 C_rereclaim2(grown, 0);3625 } else {3626 C_fromspace_top = tospace_top;3627 tmp = fromspace_start;3628 fromspace_start = tospace_start;3629 tospace_start = tospace_top = tmp;3630 tmp = C_fromspace_limit;3631 C_fromspace_limit = tospace_limit;3632 tospace_limit = tmp;3633 }3634 }36353636 never_mind_edsger:3637 ++gc_count_2;3638 }36393640 if(gc_mode == GC_MAJOR) {3641 tgc = C_cpu_milliseconds() - tgc;3642 gc_ms += tgc;3643 timer_accumulated_gc_ms += tgc;3644 }36453646 /* Display GC report:3647 Note: stubbornly writes to stderr - there is no provision for other output-ports */3648 if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {3649 C_dbg(C_text("GC"), C_text("level %d\tgcs(minor) %d\tgcs(major) %d\n"),3650 gc_mode, gc_count_1, gc_count_2);3651 i = (C_uword)C_stack_pointer;36523653#if C_STACK_GROWS_DOWNWARD3654 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3655 (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);3656#else3657 C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3658 (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);3659#endif36603661 if(gc_mode == GC_MINOR)3662 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);36633664 C_fputc('\n', C_stderr);3665 C_dbg("GC", C_text(" from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),3666 (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);36673668 if(gc_mode == GC_MAJOR)3669 C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);36703671 C_fputc('\n', C_stderr);3672 C_dbg("GC", C_text(" to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),3673 (C_uword)tospace_start, (C_uword)tospace_top,3674 (C_uword)tospace_limit);3675 }36763677 /* GC will have copied any live objects out of scratch space: clear it */3678 if (C_scratchspace_start != C_scratchspace_top) {3679 /* And drop the scratchspace in case of a major or reallocating collection */3680 if (gc_mode != GC_MINOR) {3681 C_free(C_scratchspace_start);3682 C_scratchspace_start = NULL;3683 C_scratchspace_limit = NULL;3684 scratchspace_size = 0;3685 }3686 C_scratchspace_top = C_scratchspace_start;3687 C_scratch_usage = 0;3688 }36893690 if(gc_mode == GC_MAJOR) {3691 gc_count_1 = 0;3692 maximum_heap_usage = count > maximum_heap_usage ? count : maximum_heap_usage;3693 }36943695 if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc);36963697 /* Unwind stack completely */3698#ifdef HAVE_SIGSETJMP3699 C_siglongjmp(C_restart, 1);3700#else3701 C_longjmp(C_restart, 1);3702#endif3703}370437053706/* Mark live objects which can exist in the nursery and/or the heap */3707static C_regparm void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3708{3709 C_word *p;3710 TRACE_INFO *tinfo;37113712 assert(C_temporary_stack >= C_temporary_stack_limit);37133714 /* Mark live values from the currently running closure: */3715 for(p = C_temporary_stack; p < C_temporary_stack_bottom; ++p)3716 mark(p);37173718 /* Clear the mutated slot stack: */3719 mutation_stack_top = mutation_stack_bottom;37203721 /* Mark trace-buffer: */3722 for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {3723 mark(&tinfo->cooked_location);3724 mark(&tinfo->cooked1);3725 mark(&tinfo->cooked2);3726 mark(&tinfo->thread);3727 }3728}372937303731/*3732 * Mark all live *heap* objects that don't need GC mode-specific3733 * treatment. Thus, no finalizers or other GC roots.3734 *3735 * Finalizers are excluded because these need special handling:3736 * finalizers referring to dead objects must be marked and queued.3737 * However, *pending* finalizers (for objects previously determined3738 * to be collectable) are marked so that these objects stick around3739 * until after the finalizer has been run.3740 *3741 * This function does not need to be called on a minor GC, since these3742 * objects won't ever exist in the nursery.3743 */3744static C_regparm void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3745{3746 LF_LIST *lfn;3747 C_word *p, **msp, last;3748 unsigned int i;3749 C_SYMBOL_TABLE *stp;37503751 /* Mark items in forwarding table: */3752 for(p = forwarding_table; *p != 0; p += 2) {3753 last = p[ 1 ];3754 mark(&p[ 1 ]);3755 C_block_header(p[ 0 ]) = C_block_header(last);3756 }37573758 /* Mark literal frames: */3759 for(lfn = lf_list; lfn != NULL; lfn = lfn->next)3760 for(i = 0; i < (unsigned int)lfn->count; ++i)3761 mark(&lfn->lf[i]);37623763 /* Mark symbol tables: */3764 for(stp = symbol_table_list; stp != NULL; stp = stp->next)3765 for(i = 0; i < stp->size; ++i)3766 mark(&stp->table[i]);37673768 /* Mark collectibles: */3769 for(msp = collectibles; msp < collectibles_top; ++msp)3770 if(*msp != NULL) mark(*msp);37713772 /* Mark system globals */3773 mark(&core_provided_symbol);3774 mark(&interrupt_hook_symbol);3775 mark(&error_hook_symbol);3776 mark(&callback_continuation_stack_symbol);3777 mark(&pending_finalizers_symbol);3778 mark(¤t_thread_symbol);37793780 mark(&u8vector_symbol);3781 mark(&s8vector_symbol);3782 mark(&u16vector_symbol);3783 mark(&s16vector_symbol);3784 mark(&u32vector_symbol);3785 mark(&s32vector_symbol);3786 mark(&u64vector_symbol);3787 mark(&s64vector_symbol);3788 mark(&f32vector_symbol);3789 mark(&f64vector_symbol);3790}379137923793/*3794 * Mark nested values in already moved (i.e., marked) blocks in3795 * breadth-first manner (Cheney's algorithm).3796 */3797static C_regparm void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3798{3799 int n;3800 C_word bytes;3801 C_word *p;3802 C_header h;3803 C_SCHEME_BLOCK *bp;38043805 while(heap_scan_top < *tgt_space_top) {3806 bp = (C_SCHEME_BLOCK *)heap_scan_top;38073808 if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)3809 bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);38103811 n = C_header_size(bp);3812 h = bp->header;3813 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);3814 p = bp->data;38153816 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {3817 if(h & C_SPECIALBLOCK_BIT) {3818 --n;3819 ++p;3820 }38213822 while(n--) mark(p++);3823 }38243825 heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);3826 }3827}382838293830static C_regparm void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)3831{3832 C_word val;3833 C_uword n, bytes;3834 C_header h;3835 C_SCHEME_BLOCK *p, *p2;38363837 val = *x;38383839 if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_scratchspacep(val)) {3840#ifdef C_GC_HOOKS3841 if(C_gc_trace_hook != NULL)3842 C_gc_trace_hook(x, gc_mode);3843#endif3844 return;3845 }38463847 p = (C_SCHEME_BLOCK *)val;3848 h = p->header;38493850 while(is_fptr(h)) { /* TODO: Pass in fptr chain limit? */3851 val = fptr_to_ptr(h);3852 p = (C_SCHEME_BLOCK *)val;3853 h = p->header;3854 }38553856 /* Already in target space, probably as result of chasing fptrs */3857 if ((C_uword)val >= (C_uword)tgt_space_start && (C_uword)val < (C_uword)*tgt_space_top) {3858 *x = val;3859 return;3860 }38613862 p2 = (C_SCHEME_BLOCK *)C_align((C_uword)*tgt_space_top);38633864#ifndef C_SIXTY_FOUR3865 if((h & C_8ALIGN_BIT) && C_aligned8(p2) && (C_byte *)p2 < tgt_space_limit) {3866 *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;3867 p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);3868 }3869#endif38703871 n = C_header_size(p);3872 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);38733874 if(C_unlikely(((C_byte *)p2 + bytes + sizeof(C_word)) > tgt_space_limit)) {3875 if (gc_mode == GC_MAJOR) {3876 /* Detect impossibilities before GC_REALLOC to preserve state: */3877 if (C_in_stackp((C_word)p) && bytes > stack_size)3878 panic(C_text("Detected corrupted data in stack"));3879 if (C_in_heapp((C_word)p) && bytes > (heap_size / 2))3880 panic(C_text("Detected corrupted data in heap"));3881 if(C_heap_size_is_fixed)3882 panic(C_text("out of memory - heap full"));38833884 gc_mode = GC_REALLOC;3885 } else if (gc_mode == GC_REALLOC) {3886 if (new_tospace_top > new_tospace_limit) {3887 panic(C_text("out of memory - heap full while resizing"));3888 }3889 }3890#ifdef HAVE_SIGSETJMP3891 C_siglongjmp(gc_restart, 1);3892#else3893 C_longjmp(gc_restart, 1);3894#endif3895 }38963897 *tgt_space_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);38983899 *x = (C_word)p2;3900 p2->header = h;3901 p->header = ptr_to_fptr((C_uword)p2);3902 C_memcpy(p2->data, p->data, bytes);3903 if (h == C_WEAK_PAIR_TAG && !C_immediatep(p2->data[0])) {3904 p->data[0] = weak_pair_chain; /* "Recycle" the weak pair's CAR to point to prev head */3905 weak_pair_chain = (C_word)p; /* Make this fwd ptr the new head of the weak pair chain */3906 } else if (h == C_LOCATIVE_TAG) {3907 p->data[0] = locative_chain; /* "Recycle" the locative pointer field to point to prev head */3908 locative_chain = (C_word)p; /* Make this fwd ptr the new head of the locative chain */3909 }3910}391139123913/* Do a major GC into a freshly allocated heap: */39143915#define remark(x) _mark(x, new_tospace_start, &new_tospace_top, new_tospace_limit)39163917C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)3918{3919 int i;3920 C_GC_ROOT *gcrp;3921 FINALIZER_NODE *flist;3922 C_byte *new_heapspace, *start;3923 size_t new_heapspace_size;39243925 if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);39263927 /*3928 * Normally, size is "absolute": it indicates the desired size of3929 * the entire new heap. With relative_resize, size is a demanded3930 * increase of the heap, so we'll have to add it. This calculation3931 * doubles the current heap size because heap_size is already both3932 * halves. We add size*2 because we'll eventually divide the size3933 * by 2 for both halves. We also add stack_size*2 because all the3934 * nursery data is also copied to the heap on GC, and the requested3935 * memory "size" must be available after the GC.3936 */3937 if(relative_resize) size = (heap_size + size + stack_size) * 2;39383939 if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;39403941 /*3942 * When heap grows, ensure it's enough to accommodate first3943 * generation (nursery). Because we're calculating the total heap3944 * size here (fromspace *AND* tospace), we have to double the stack3945 * size, otherwise we'd accommodate only half the stack in the tospace.3946 */3947 if(size > heap_size && size - heap_size < stack_size * 2)3948 size = heap_size + stack_size * 2;39493950 /*3951 * The heap has grown but we've already hit the maximal size with the current3952 * heap, we can't do anything else but panic.3953 */3954 if(size > heap_size && heap_size >= C_maximal_heap_size)3955 panic(C_text("out of memory - heap has reached its maximum size"));39563957 if(size > C_maximal_heap_size) size = C_maximal_heap_size;39583959 if(debug_mode) {3960 C_dbg(C_text("debug"), C_text("resizing heap dynamically from "3961 UWORD_COUNT_FORMAT_STRING "k to "3962 UWORD_COUNT_FORMAT_STRING "k ...\n"),3963 heap_size / 1024, size / 1024);3964 }39653966 if(gc_report_flag) {3967 C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING3968 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3969 (C_word)fromspace_start, (C_word)C_fromspace_limit);3970 C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING3971 ", \tlimit=" UWORD_FORMAT_STRING "\n"),3972 (C_word)tospace_start, (C_word)tospace_limit);3973 }39743975 heap_size = size; /* Total heap size of the two halves... */3976 size /= 2; /* ...each half is this big */39773978 /*3979 * Start by allocating the new heap's fromspace. After remarking,3980 * allocate the other half of the new heap (its tospace).3981 *3982 * To clarify: what we call "new_space" here is what will eventually3983 * be cycled over to "fromspace" when re-reclamation has finished3984 * (that is, after the old one has been freed).3985 */3986 if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)3987 panic(C_text("out of memory - cannot allocate heap segment"));3988 new_heapspace_size = size;39893990 new_tospace_top = new_tospace_start;3991 new_tospace_limit = new_tospace_start + size;3992 start = new_tospace_top;3993 weak_pair_chain = (C_word)NULL; /* only chain up weak pairs forwarded into new heap */3994 locative_chain = (C_word)NULL; /* same for locatives */39953996 /* Mark standard live objects in nursery and heap */3997 mark_live_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);3998 mark_live_heap_only_objects(new_tospace_start, &new_tospace_top, new_tospace_limit);39994000 /* Mark finalizer table: */4001 for(flist = finalizer_list; flist != NULL; flist = flist->next) {4002 remark(&flist->item);4003 remark(&flist->finalizer);4004 }40054006 /* Mark *all* GC roots */4007 for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {4008 remark(&gcrp->value);4009 }40104011 /* Mark nested values in already moved (marked) blocks in breadth-first manner: */4012 mark_nested_objects(start, new_tospace_start, &new_tospace_top, new_tospace_limit);4013 update_locatives(GC_REALLOC, new_tospace_top, new_tospace_top);4014 update_weak_pairs(GC_REALLOC, new_tospace_top, new_tospace_top);40154016 heap_free (heapspace1, heapspace1_size);4017 heap_free (heapspace2, heapspace2_size);40184019 if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)4020 panic(C_text("out of memory - cannot allocate next heap segment"));4021 heapspace2_size = size;40224023 heapspace1 = new_heapspace;4024 heapspace1_size = new_heapspace_size;4025 tospace_limit = tospace_start + size;4026 tospace_top = tospace_start;4027 fromspace_start = new_tospace_start;4028 C_fromspace_top = new_tospace_top;4029 C_fromspace_limit = new_tospace_limit;40304031 if(gc_report_flag) {4032 C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);4033 C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING4034 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4035 (C_word)fromspace_start, (C_word)C_fromspace_limit);4036 C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING4037 ", \tlimit=" UWORD_FORMAT_STRING "\n"),4038 (C_word)tospace_start, (C_word)tospace_limit);4039 }40404041 if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);4042}404340444045/* When a weak pair is encountered by GC, it turns it into a4046 * forwarding reference as usual, but then it re-uses the now-defunct4047 * pair's CAR field. It clobbers that field with a plain C pointer to4048 * the current "weak pair chain". Then, the weak pair chain is4049 * updated to point to this new forwarding pointer, creating a crude4050 * linked list of sorts.4051 *4052 * We can get away with this because the slots of an object are4053 * unused/dead when it is turned into a forwarding pointer - the4054 * forwarding pointer itself is just a header, but those data fields4055 * remain allocated. Since the weak pair chain is a linked list that4056 * can *only* contain weak-pairs-turned-forwarding-pointer, we may4057 * freely access the first slot of such forwarding pointers.4058 */4059static C_regparm void C_fcall update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end)4060{4061 int weakn = 0;4062 C_word p, pair, car, h;4063 C_byte *car_ptr;40644065 /* NOTE: Don't use C_block_item() because it asserts the block is4066 * big enough in DEBUGBUILD, but forwarding pointers have size 0.4067 */4068 for (p = weak_pair_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4069 /* NOTE: We only chain up the weak pairs' forwarding pointers into4070 * the new space. This is safe because already forwarded weak4071 * pairs in nursery/fromspace will be forwarded *again* into4072 * tospace/new heap. That forwarding pointer is chained up.4073 * Still-unforwarded weak pairs will be forwarded straight to the4074 * new space, and also chained up.4075 */4076 h = C_block_header(p);4077 assert(is_fptr(h));4078 pair = fptr_to_ptr(h);4079 assert(!is_fptr(C_block_header(pair)));40804081 /* The pair itself should be live */4082 assert((mode == GC_MINOR && !C_in_stackp(pair)) ||4083 (mode == GC_MAJOR && !C_in_stackp(pair) && !C_in_fromspacep(pair)) ||4084 (mode == GC_REALLOC && !C_in_stackp(pair) && !C_in_heapp(pair))); /* NB: *old* heap! */40854086 car = C_block_item(pair, 0);4087 assert(!C_immediatep(car)); /* should be ensured when adding it to the chain */4088 h = C_block_header(car);4089 while (is_fptr(h)) {4090 car = fptr_to_ptr(h);4091 h = C_block_header(car);4092 }40934094 car_ptr = (C_byte *)(C_uword)car;4095 /* If the car is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4096 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4097 if((mode == GC_MINOR && C_in_stackp(car)) ||4098 (mode == GC_MAJOR && (C_in_stackp(car) || C_in_fromspacep(car) || (car_ptr >= undead_start && car_ptr < undead_end))) ||4099 (mode == GC_REALLOC && (C_in_stackp(car) || C_in_heapp(car) || (car_ptr >= undead_start && car_ptr < undead_end)))) { /* NB: *old* heap! */41004101 C_set_block_item(pair, 0, C_SCHEME_BROKEN_WEAK_PTR);4102 ++weakn;4103 } else {4104 /* Might have moved, re-set the car to the target value */4105 C_set_block_item(pair, 0, car);4106 }4107 }4108 weak_pair_chain = (C_word)NULL;4109 if(gc_report_flag && weakn)4110 C_dbg("GC", C_text("%d recoverable weak pairs found\n"), weakn);4111}41124113/* Same as weak pairs (see above), but for locatives. Note that this4114 * also includes non-weak locatives, as these point *into* an object,4115 * so the updating of that pointer is not handled by the GC proper4116 * (which only deals with full objects).4117 */4118static C_regparm void C_fcall update_locatives(int mode, C_byte *undead_start, C_byte *undead_end)4119{4120 int weakn = 0;4121 C_word p, loc, ptr, obj, h, offset;4122 C_byte *obj_ptr;41234124 for (p = locative_chain; p != (C_word)NULL; p = *((C_word *)C_data_pointer(p))) {4125 h = C_block_header(p);4126 assert(is_fptr(h));4127 loc = fptr_to_ptr(h);4128 assert(!is_fptr(C_block_header(loc)));41294130 /* The locative object itself should be live */4131 assert((mode == GC_MINOR && !C_in_stackp(loc)) ||4132 (mode == GC_MAJOR && !C_in_stackp(loc) && !C_in_fromspacep(loc)) ||4133 (mode == GC_REALLOC && !C_in_stackp(loc) && !C_in_heapp(loc))); /* NB: *old* heap! */41344135 ptr = C_block_item(loc, 0); /* fix up ptr */4136 if (ptr == 0) continue; /* Skip already dropped weak locatives */4137 offset = C_unfix(C_block_item(loc, 1));4138 obj = ptr - offset;41394140 h = C_block_header(obj);4141 while (is_fptr(h)) {4142 obj = fptr_to_ptr(h);4143 h = C_block_header(obj);4144 }41454146 obj_ptr = (C_byte *)(C_uword)obj;4147 /* If the object is unreferenced by anyone else, it wasn't moved by GC. Or, if it's in the "undead" portion of4148 the new heap, it was moved because it was only referenced by a revived finalizable object. In either case, drop it: */4149 if((mode == GC_MINOR && C_in_stackp(obj)) ||4150 (mode == GC_MAJOR && (C_in_stackp(obj) || C_in_fromspacep(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end))) ||4151 (mode == GC_REALLOC && (C_in_stackp(obj) || C_in_heapp(obj) || (obj_ptr >= undead_start && obj_ptr < undead_end)))) { /* NB: *old* heap! */41524153 /* NOTE: This does *not* use BROKEN_WEAK_POINTER. This slot4154 * holds an unaligned raw C pointer, not a Scheme object */4155 C_set_block_item(loc, 0, 0);4156 ++weakn;4157 } else {4158 /* Might have moved, re-set the object to the target value */4159 C_set_block_item(loc, 0, obj + offset);4160 }4161 }4162 locative_chain = (C_word)NULL;4163 if(gc_report_flag && weakn)4164 C_dbg("GC", C_text("%d recoverable weak locatives found\n"), weakn);4165}416641674168void handle_interrupt(void *trampoline)4169{4170 C_word *p, h, reason, state, proc, n;4171 double c;4172 C_word av[ 4 ];41734174 /* Build vector with context information: */4175 n = C_temporary_stack_bottom - C_temporary_stack;4176 p = C_alloc(C_SIZEOF_VECTOR(2) + C_SIZEOF_VECTOR(n));4177 proc = (C_word)p;4178 *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | sizeof(C_word);4179 *(p++) = (C_word)trampoline;4180 state = (C_word)p;4181 *(p++) = C_VECTOR_TYPE | (n + 1);4182 *(p++) = proc;4183 C_memcpy(p, C_temporary_stack, n * sizeof(C_word));41844185 /* Restore state to the one at the time of the interrupt: */4186 C_temporary_stack = C_temporary_stack_bottom;4187 C_stack_limit = C_stack_hard_limit;41884189 /* Invoke high-level interrupt handler: */4190 reason = C_fix(pending_interrupts[ --pending_interrupts_count ]);4191 proc = C_block_item(interrupt_hook_symbol, 0);41924193 if(C_immediatep(proc))4194 panic(C_text("`##sys#interrupt-hook' is not defined"));41954196 c = C_cpu_milliseconds() - interrupt_time;4197 last_interrupt_latency = c;4198 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4199 /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */4200 av[ 0 ] = proc;4201 av[ 1 ] = C_SCHEME_UNDEFINED;4202 av[ 2 ] = reason;4203 av[ 3 ] = state;4204 C_do_apply(4, av);4205}420642074208void4209C_unbound_variable(C_word sym)4210{4211 barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);4212}421342144215/* XXX: This needs to be given a better name.4216 C_retrieve used to exist but it just called C_fast_retrieve */4217C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)4218{4219 C_word *p;4220 int len;42214222 if(val == C_SCHEME_UNBOUND) {4223 len = C_strlen(name);4224 /* this is ok: we won't return from `C_retrieve2'4225 * (or the value isn't needed). */4226 p = C_alloc(C_SIZEOF_STRING(len));4227 C_unbound_variable(C_string2(&p, name));4228 }42294230 return val;4231}423242334234void C_ccall C_invalid_procedure(C_word c, C_word *av)4235{4236 C_word self = av[0];4237 barf(C_NOT_A_CLOSURE_ERROR, NULL, self);4238}423942404241C_regparm void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name)4242{4243 C_word *p;4244 int len;42454246 if(val == C_SCHEME_UNBOUND) {4247 len = C_strlen(name);4248 /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */4249 p = C_alloc(C_SIZEOF_STRING(len));4250 barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));4251 }42524253 return C_fast_retrieve_proc(val);4254}42554256#ifdef C_NONUNIX4257VOID CALLBACK win_timer(PVOID data_ignored, BOOLEAN wait_or_fired)4258{4259 if (profiling) take_profile_sample();4260}4261#endif42624263static void set_profile_timer(C_uword freq)4264{4265#ifdef C_NONUNIX4266 static HANDLE timer = NULL;42674268 if (freq == 0) {4269 assert(timer != NULL);4270 if (!DeleteTimerQueueTimer(NULL, timer, NULL)) goto error;4271 timer = NULL;4272 } else if (freq < 1000) {4273 panic(C_text("On Windows, sampling can only be done in milliseconds"));4274 } else {4275 if (!CreateTimerQueueTimer(&timer, NULL, win_timer, NULL, 0, freq/1000, 0))4276 goto error;4277 }4278#else4279 struct itimerval itv;42804281 itv.it_value.tv_sec = freq / 1000000;4282 itv.it_value.tv_usec = freq % 1000000;4283 itv.it_interval.tv_sec = itv.it_value.tv_sec;4284 itv.it_interval.tv_usec = itv.it_value.tv_usec;42854286 if (setitimer(C_PROFILE_TIMER, &itv, NULL) == -1) goto error;4287#endif42884289 return;42904291error:4292 if (freq == 0) panic(C_text("error clearing timer for profiling"));4293 else panic(C_text("error setting timer for profiling"));4294}42954296/* Bump profile count for current top of trace buffer */4297static void take_profile_sample()4298{4299 PROFILE_BUCKET **bp, *b;4300 C_char *key;4301 TRACE_INFO *tb;4302 /* To count distinct calls of a procedure, remember last call */4303 static C_char *prev_key = NULL;4304 static TRACE_INFO *prev_tb = NULL;43054306 /* trace_buffer_top points *beyond* the topmost entry: Go back one */4307 if (trace_buffer_top == trace_buffer) {4308 if (!trace_buffer_full) return; /* No data yet */4309 tb = trace_buffer_limit - 1;4310 } else {4311 tb = trace_buffer_top - 1;4312 }43134314 if (tb->raw_location != NULL) {4315 key = tb->raw_location;4316 } else {4317 key = "<eval>"; /* Location string is GCable, can't use it */4318 }43194320 /* We could also just hash the pointer but that's a bit trickier */4321 bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0, 0);4322 b = *bp;43234324 /* First try to find pre-existing item in hash table */4325 while(b != NULL) {4326 if(b->key == key) {4327 b->sample_count++;4328 if (prev_key != key && prev_tb != tb)4329 b->call_count++;4330 goto done;4331 }4332 else b = b->next;4333 }43344335 /* Not found, allocate a new item and use it as bucket's new head */4336 b = next_profile_bucket;4337 next_profile_bucket = NULL;43384339 assert(b != NULL);43404341 b->next = *bp;4342 b->key = key;4343 *bp = b;4344 b->sample_count = 1;4345 b->call_count = 1;43464347done:4348 prev_tb = tb;4349 prev_key = key;4350}435143524353C_regparm void C_fcall C_trace(C_char *name)4354{4355 C_word thread;43564357 if(show_trace) {4358 C_fputs(name, C_stderr);4359 C_fputc('\n', C_stderr);4360 }43614362 /*4363 * When profiling, pre-allocate profile bucket if necessary. This4364 * is used in the signal handler, because it may not malloc.4365 */4366 if(profiling && next_profile_bucket == NULL) {4367 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4368 if (next_profile_bucket == NULL) {4369 panic(C_text("out of memory - cannot allocate profile table-bucket"));4370 }4371 }43724373 if(trace_buffer_top >= trace_buffer_limit) {4374 trace_buffer_top = trace_buffer;4375 trace_buffer_full = 1;4376 }43774378 trace_buffer_top->raw_location = name;4379 trace_buffer_top->cooked_location = C_SCHEME_FALSE;4380 trace_buffer_top->cooked1 = C_SCHEME_FALSE;4381 trace_buffer_top->cooked2 = C_SCHEME_FALSE;4382 thread = C_block_item(current_thread_symbol, 0);4383 trace_buffer_top->thread = C_and(C_blockp(thread), C_thread_id(thread));4384 ++trace_buffer_top;4385}438643874388C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)4389{4390 /* See above */4391 if(profiling && next_profile_bucket == NULL) {4392 next_profile_bucket = (PROFILE_BUCKET *)C_malloc(sizeof(PROFILE_BUCKET));4393 if (next_profile_bucket == NULL) {4394 panic(C_text("out of memory - cannot allocate profile table-bucket"));4395 }4396 }43974398 if(trace_buffer_top >= trace_buffer_limit) {4399 trace_buffer_top = trace_buffer;4400 trace_buffer_full = 1;4401 }44024403 trace_buffer_top->raw_location = raw;4404 trace_buffer_top->cooked_location = l;4405 trace_buffer_top->cooked1 = x;4406 trace_buffer_top->cooked2 = y;4407 trace_buffer_top->thread = t;4408 ++trace_buffer_top;4409 return x;4410}441144124413C_char *C_dump_trace(int start)4414{4415 TRACE_INFO *ptr;4416 C_char *result;4417 int i, result_len;44184419 result_len = STRING_BUFFER_SIZE;4420 if((result = (char *)C_malloc(result_len)) == NULL)4421 horror(C_text("out of memory - cannot allocate trace-dump buffer"));44224423 *result = '\0';44244425 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4426 if(trace_buffer_full) {4427 i = C_trace_buffer_size;4428 C_strlcat(result, C_text("...more...\n"), result_len);4429 }4430 else i = trace_buffer_top - trace_buffer;44314432 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4433 ptr += start;4434 i -= start;44354436 for(;i--; ++ptr) {4437 if(ptr >= trace_buffer_limit) ptr = trace_buffer;44384439 if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {4440 result_len = C_strlen(result) * 2;4441 result = C_realloc(result, result_len);4442 if(result == NULL)4443 horror(C_text("out of memory - cannot reallocate trace-dump buffer"));4444 }44454446 if (ptr->raw_location != NULL) {4447 C_strlcat(result, ptr->raw_location, result_len);4448 } else if (ptr->cooked_location != C_SCHEME_FALSE) {4449 C_strlcat(result, C_c_string(ptr->cooked_location), nmin(C_header_size(ptr->cooked_location), result_len));4450 } else {4451 C_strlcat(result, "<unknown>", result_len);4452 }44534454 if(i > 0) C_strlcat(result, "\n", result_len);4455 else C_strlcat(result, " \t<--\n", result_len);4456 }4457 }44584459 return result;4460}446144624463C_regparm void C_fcall C_clear_trace_buffer(void)4464{4465 int i, old_profiling = profiling;44664467 profiling = 0;44684469 if(trace_buffer == NULL) {4470 if(C_trace_buffer_size < MIN_TRACE_BUFFER_SIZE)4471 C_trace_buffer_size = MIN_TRACE_BUFFER_SIZE;44724473 trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);44744475 if(trace_buffer == NULL)4476 panic(C_text("out of memory - cannot allocate trace-buffer"));4477 }44784479 trace_buffer_top = trace_buffer;4480 trace_buffer_limit = trace_buffer + C_trace_buffer_size;4481 trace_buffer_full = 0;44824483 for(i = 0; i < C_trace_buffer_size; ++i) {4484 trace_buffer[ i ].raw_location = NULL;4485 trace_buffer[ i ].cooked_location = C_SCHEME_FALSE;4486 trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;4487 trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;4488 trace_buffer[ i ].thread = C_SCHEME_FALSE;4489 }44904491 profiling = old_profiling;4492}44934494C_word C_resize_trace_buffer(C_word size) {4495 int old_size = C_trace_buffer_size, old_profiling = profiling;4496 assert(trace_buffer);4497 profiling = 0;4498 free(trace_buffer);4499 trace_buffer = NULL;4500 C_trace_buffer_size = C_unfix(size);4501 C_clear_trace_buffer();4502 profiling = old_profiling;4503 return(C_fix(old_size));4504}45054506C_word C_fetch_trace(C_word starti, C_word buffer)4507{4508 TRACE_INFO *ptr;4509 int i, p = 0, start = C_unfix(starti);45104511 if(trace_buffer_top > trace_buffer || trace_buffer_full) {4512 if(trace_buffer_full) i = C_trace_buffer_size;4513 else i = trace_buffer_top - trace_buffer;45144515 ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;4516 ptr += start;4517 i -= start;45184519 if(C_header_size(buffer) < i * 5)4520 panic(C_text("destination buffer too small for call-chain"));45214522 for(;i--; ++ptr) {4523 if(ptr >= trace_buffer_limit) ptr = trace_buffer;45244525 /* outside-pointer, will be ignored by GC */4526 C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw_location);45274528 /* subject to GC */4529 C_mutate(&C_block_item(buffer, p++), ptr->cooked_location);4530 C_mutate(&C_block_item(buffer, p++), ptr->cooked1);4531 C_mutate(&C_block_item(buffer, p++), ptr->cooked2);4532 C_mutate(&C_block_item(buffer, p++), ptr->thread);4533 }4534 }45354536 return C_fix(p);4537}45384539C_regparm C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd)4540{4541 int len = C_header_size(str);4542 C_char *ptr = C_data_pointer(str);4543 return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 0));4544}45454546C_regparm C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd)4547{4548 int len = C_header_size(str);4549 C_char *ptr = C_data_pointer(str);4550 return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 1));4551}45524553C_regparm void C_fcall C_toplevel_entry(C_char *name)4554{4555 if(debug_mode)4556 C_dbg(C_text("debug"), C_text("entering %s...\n"), name);4557}45584559C_regparm C_word C_fcall C_a_i_provide(C_word **a, int c, C_word id)4560{4561 if (debug_mode == 2) {4562 C_word str = C_block_item(id, 1);4563 C_snprintf(buffer, C_header_size(str) + 1, C_text("%s"), (C_char *) C_data_pointer(str));4564 C_dbg(C_text("debug"), C_text("providing %s...\n"), buffer);4565 }4566 return C_a_i_putprop(a, 3, core_provided_symbol, id, C_SCHEME_TRUE);4567}45684569C_regparm C_word C_fcall C_i_providedp(C_word id)4570{4571 return C_i_getprop(core_provided_symbol, id, C_SCHEME_FALSE);4572}45734574C_word C_halt(C_word msg)4575{4576 C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;45774578 if(C_gui_mode) {4579 if(msg != C_SCHEME_FALSE) {4580 int n = C_header_size(msg);45814582 if (n >= sizeof(buffer))4583 n = sizeof(buffer) - 1;4584 C_strlcpy(buffer, (C_char *)C_data_pointer(msg), n);4585 /* XXX msg isn't checked for NUL bytes, but we can't barf here either! */4586 }4587 else C_strlcpy(buffer, C_text("(aborted)"), sizeof(buffer));45884589 C_strlcat(buffer, C_text("\n\n"), sizeof(buffer));45904591 if(dmp != NULL) C_strlcat(buffer, dmp, sizeof(buffer));45924593#if defined(_WIN32) && !defined(__CYGWIN__)4594 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);4595 ExitProcess(1);4596#endif4597 } /* otherwise fall through */45984599 if(msg != C_SCHEME_FALSE) {4600 C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);4601 C_fputc('\n', C_stderr);4602 }46034604 if(dmp != NULL)4605 C_dbg("", C_text("\n%s"), dmp);46064607 C_exit_runtime(C_fix(EX_SOFTWARE));4608 return 0;4609}461046114612C_word C_message(C_word msg)4613{4614 unsigned int n = C_header_size(msg);4615 /*4616 * Strictly speaking this isn't necessary for the non-gui-mode,4617 * but let's try and keep this consistent across modes.4618 */4619 if (C_memchr(C_c_string(msg), '\0', n) != NULL)4620 barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);46214622 if(C_gui_mode) {4623 if (n >= sizeof(buffer))4624 n = sizeof(buffer) - 1;4625 C_strncpy(buffer, C_c_string(msg), n);4626 buffer[ n ] = '\0';4627#if defined(_WIN32) && !defined(__CYGWIN__)4628 MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONEXCLAMATION);4629 return C_SCHEME_UNDEFINED;4630#endif4631 } /* fall through */46324633 C_fwrite(C_c_string(msg), n, sizeof(C_char), stdout);4634 C_putchar('\n');4635 return C_SCHEME_UNDEFINED;4636}463746384639C_regparm C_word C_fcall C_equalp(C_word x, C_word y)4640{4641 C_header header;4642 C_word bits, n, i;46434644 C_stack_check1(barf(C_CIRCULAR_DATA_ERROR, "equal?"));46454646 loop:4647 if(x == y) return 1;46484649 if(C_immediatep(x) || C_immediatep(y)) return 0;46504651 /* NOTE: Extra check at the end is special consideration for pairs being equal to weak pairs */4652 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;4653 else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {4654 if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)4655 return C_ub_i_flonum_eqvp(C_flonum_magnitude(x),4656 C_flonum_magnitude(y));4657 else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);4658 }4659 else if(header == C_SYMBOL_TAG) return 0;4660 else {4661 i = 0;4662 n = header & C_HEADER_SIZE_MASK;46634664 if(bits & C_SPECIALBLOCK_BIT) {4665 /* do not recurse into closures */4666 if(C_header_bits(x) == C_CLOSURE_TYPE)4667 return !C_memcmp(C_data_pointer(x), C_data_pointer(y), n * sizeof(C_word));4668 else if(C_block_item(x, 0) != C_block_item(y, 0)) return 0;4669 else ++i;46704671 if(n == 1) return 1;4672 }46734674 if(--n < 0) return 1;46754676 while(i < n)4677 if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;4678 else ++i;46794680 x = C_block_item(x, i);4681 y = C_block_item(y, i);4682 goto loop;4683 }4684}468546864687C_regparm C_word C_fcall C_set_gc_report(C_word flag)4688{4689 if(flag == C_SCHEME_FALSE) gc_report_flag = 0;4690 else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;4691 else gc_report_flag = 1;46924693 return C_SCHEME_UNDEFINED;4694}46954696C_regparm C_word C_fcall C_i_accumulated_gc_time(void)4697{4698 double tgc;46994700 tgc = timer_accumulated_gc_ms;4701 timer_accumulated_gc_ms = 0;4702 return C_fix(tgc);4703}47044705C_regparm C_word C_fcall C_start_timer(void)4706{4707 tracked_mutation_count = 0;4708 mutation_count = 0;4709 gc_count_1_total = 0;4710 gc_count_2 = 0;4711 timer_start_ms = C_cpu_milliseconds();4712 gc_ms = 0;4713 maximum_heap_usage = 0;4714 return C_SCHEME_UNDEFINED;4715}471647174718void C_ccall C_stop_timer(C_word c, C_word *av)4719{4720 C_word4721 closure = av[ 0 ],4722 k = av[ 1 ];4723 double t0 = C_cpu_milliseconds() - timer_start_ms;4724 C_word4725 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_BIGNUM(1) + C_SIZEOF_VECTOR(7) ],4726 *a = ab,4727 elapsed = C_flonum(&a, t0 / 1000.0),4728 gc_time = C_flonum(&a, gc_ms / 1000.0),4729 heap_usage = C_unsigned_int_to_num(&a, maximum_heap_usage),4730 info;47314732 info = C_vector(&a, 7, elapsed, gc_time, C_fix(mutation_count),4733 C_fix(tracked_mutation_count), C_fix(gc_count_1_total),4734 C_fix(gc_count_2), heap_usage);4735 C_kontinue(k, info);4736}473747384739C_word C_exit_runtime(C_word code)4740{4741 C_fflush(NULL);4742 C__exit(C_unfix(code));4743}474447454746C_regparm C_word C_fcall C_set_print_precision(C_word n)4747{4748 flonum_print_precision = C_unfix(n);4749 return C_SCHEME_UNDEFINED;4750}475147524753C_regparm C_word C_fcall C_get_print_precision(void)4754{4755 return C_fix(flonum_print_precision);4756}475747584759C_regparm C_word C_fcall C_read_char(C_word port)4760{4761 C_FILEPTR fp = C_port_file(port);4762 int c = C_getc(fp);47634764 if(c == EOF) {4765 if(ferror(fp)) {4766 clearerr(fp);4767 return C_fix(-1);4768 }4769 /* Found here:4770 http://mail.python.org/pipermail/python-bugs-list/2002-July/012579.html */4771#if defined(_WIN32) && !defined(__CYGWIN__)4772 else if(GetLastError() == ERROR_OPERATION_ABORTED) return C_fix(-1);4773#endif4774 else return C_SCHEME_END_OF_FILE;4775 }47764777 return C_make_character(c);4778}477947804781C_regparm C_word C_fcall C_peek_char(C_word port)4782{4783 C_FILEPTR fp = C_port_file(port);4784 int c = C_getc(fp);47854786 if(c == EOF) {4787 if(ferror(fp)) {4788 clearerr(fp);4789 return C_fix(-1);4790 }4791 /* see above */4792#if defined(_WIN32) && !defined(__CYGWIN__)4793 else if(GetLastError() == ERROR_OPERATION_ABORTED) return C_fix(-1);4794#endif4795 else return C_SCHEME_END_OF_FILE;4796 }47974798 C_ungetc(c, fp);4799 return C_make_character(c);4800}480148024803C_regparm C_word C_fcall C_execute_shell_command(C_word string)4804{4805 int n = C_header_size(string);4806 char *buf = buffer;48074808 /* Windows doc says to flush all output streams before calling system.4809 Probably a good idea for all platforms. */4810 (void)fflush(NULL);48114812 if(n >= STRING_BUFFER_SIZE) {4813 if((buf = (char *)C_malloc(n + 1)) == NULL)4814 barf(C_OUT_OF_MEMORY_ERROR, "system");4815 }48164817 C_memcpy(buf, C_data_pointer(string), n);4818 buf[ n ] = '\0';4819 if (n != strlen(buf))4820 barf(C_ASCIIZ_REPRESENTATION_ERROR, "system", string);48214822 n = C_system(buf);48234824 if(buf != buffer) C_free(buf);48254826 return C_fix(n);4827}48284829/*4830 * TODO: Implement something for Windows that supports selecting on4831 * arbitrary fds (there, select() only works on network sockets and4832 * poll() is not available at all).4833 */4834C_regparm int C_fcall C_check_fd_ready(int fd)4835{4836#ifdef NO_POSIX_POLL4837 fd_set in;4838 struct timeval tm;4839 int rv;4840 FD_ZERO(&in);4841 FD_SET(fd, &in);4842 tm.tv_sec = tm.tv_usec = 0;4843 rv = select(fd + 1, &in, NULL, NULL, &tm);4844 if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }4845 return rv;4846#else4847 struct pollfd ps;4848 ps.fd = fd;4849 ps.events = POLLIN;4850 return poll(&ps, 1, 0);4851#endif4852}48534854C_regparm C_word C_fcall C_char_ready_p(C_word port)4855{4856#if defined(C_NONUNIX)4857 /* The best we can currently do on Windows... */4858 return C_SCHEME_TRUE;4859#else4860 int fd = C_fileno(C_port_file(port));4861 return C_mk_bool(C_check_fd_ready(fd) == 1);4862#endif4863}48644865C_regparm C_word C_fcall C_i_tty_forcedp(void)4866{4867 return C_mk_bool(fake_tty_flag);4868}48694870C_regparm C_word C_fcall C_i_debug_modep(void)4871{4872 return C_mk_bool(debug_mode);4873}48744875C_regparm C_word C_fcall C_i_dump_heap_on_exitp(void)4876{4877 return C_mk_bool(dump_heap_on_exit);4878}48794880C_regparm C_word C_fcall C_i_profilingp(void)4881{4882 return C_mk_bool(profiling);4883}48844885C_regparm C_word C_fcall C_i_live_finalizer_count(void)4886{4887 return C_fix(live_finalizer_count);4888}48894890C_regparm C_word C_fcall C_i_allocated_finalizer_count(void)4891{4892 return C_fix(allocated_finalizer_count);4893}489448954896C_regparm void C_fcall C_raise_interrupt(int reason)4897{4898 if(C_interrupts_enabled) {4899 if(pending_interrupts_count == 0 && !handling_interrupts) {4900 pending_interrupts[ pending_interrupts_count++ ] = reason;4901 /*4902 * Force the next "soft" stack check to fail by faking a "full"4903 * stack. This causes save_and_reclaim() to be called, which4904 * invokes handle_interrupt(), which restores the stack limit.4905 */4906 C_stack_limit = stack_bottom;4907 interrupt_time = C_cpu_milliseconds();4908 } else if(pending_interrupts_count < MAX_PENDING_INTERRUPTS) {4909 int i;4910 /*4911 * Drop signals if too many, but don't queue up multiple entries4912 * for the same signal.4913 */4914 for (i = 0; i < pending_interrupts_count; ++i) {4915 if (pending_interrupts[i] == reason)4916 return;4917 }4918 pending_interrupts[ pending_interrupts_count++ ] = reason;4919 }4920 }4921}492249234924C_regparm C_word C_fcall C_enable_interrupts(void)4925{4926 C_timer_interrupt_counter = C_initial_timer_interrupt_period;4927 /* assert(C_timer_interrupt_counter > 0); */4928 C_interrupts_enabled = 1;4929 return C_SCHEME_UNDEFINED;4930}493149324933C_regparm C_word C_fcall C_disable_interrupts(void)4934{4935 C_interrupts_enabled = 0;4936 return C_SCHEME_UNDEFINED;4937}493849394940C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason)4941{4942 int sig = C_unfix(signum);4943#if defined(HAVE_SIGACTION)4944 struct sigaction newsig;4945#endif49464947 if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);4948 else if(reason == C_SCHEME_TRUE) C_signal(sig, SIG_DFL);4949 else {4950 signal_mapping_table[ sig ] = C_unfix(reason);4951#if defined(HAVE_SIGACTION)4952 newsig.sa_flags = 0;4953 /* The global signal handler is used for all signals, and4954 manipulates a single queue. Don't allow other signals to4955 concurrently arrive while it's doing this, to avoid races. */4956 sigfillset(&newsig.sa_mask);4957 newsig.sa_handler = global_signal_handler;4958 C_sigaction(sig, &newsig, NULL);4959#else4960 C_signal(sig, global_signal_handler);4961#endif4962 }49634964 return C_SCHEME_UNDEFINED;4965}496649674968/* Copy blocks into collected or static memory: */49694970C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)4971{4972 int n = C_header_size(from);4973 C_long bytes;49744975 if(C_header_bits(from) & C_BYTEBLOCK_BIT) {4976 bytes = n;4977 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4978 }4979 else {4980 bytes = C_wordstobytes(n);4981 C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4982 }49834984 return to;4985}498649874988C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)4989{4990 int n = C_header_size(from);4991 C_long bytes;4992 C_word *p = (C_word *)C_pointer_address(ptr);49934994 if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;4995 else bytes = C_wordstobytes(n);49964997 C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));4998 return (C_word)p;4999}500050015002/* Inline versions of some standard procedures: */50035004C_regparm C_word C_fcall C_i_listp(C_word x)5005{5006 C_word fast = x, slow = x;50075008 while(fast != C_SCHEME_END_OF_LIST)5009 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5010 fast = C_u_i_cdr(fast);50115012 if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;5013 else if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {5014 fast = C_u_i_cdr(fast);5015 slow = C_u_i_cdr(slow);50165017 if(fast == slow) return C_SCHEME_FALSE;5018 }5019 else return C_SCHEME_FALSE;5020 }5021 else return C_SCHEME_FALSE;50225023 return C_SCHEME_TRUE;5024}50255026C_regparm C_word C_fcall C_i_u8vectorp(C_word x)5027{5028 return C_i_structurep(x, u8vector_symbol);5029}50305031C_regparm C_word C_fcall C_i_s8vectorp(C_word x)5032{5033 return C_i_structurep(x, s8vector_symbol);5034}50355036C_regparm C_word C_fcall C_i_u16vectorp(C_word x)5037{5038 return C_i_structurep(x, u16vector_symbol);5039}50405041C_regparm C_word C_fcall C_i_s16vectorp(C_word x)5042{5043 return C_i_structurep(x, s16vector_symbol);5044}50455046C_regparm C_word C_fcall C_i_u32vectorp(C_word x)5047{5048 return C_i_structurep(x, u32vector_symbol);5049}50505051C_regparm C_word C_fcall C_i_s32vectorp(C_word x)5052{5053 return C_i_structurep(x, s32vector_symbol);5054}50555056C_regparm C_word C_fcall C_i_u64vectorp(C_word x)5057{5058 return C_i_structurep(x, u64vector_symbol);5059}50605061C_regparm C_word C_fcall C_i_s64vectorp(C_word x)5062{5063 return C_i_structurep(x, s64vector_symbol);5064}50655066C_regparm C_word C_fcall C_i_f32vectorp(C_word x)5067{5068 return C_i_structurep(x, f32vector_symbol);5069}50705071C_regparm C_word C_fcall C_i_f64vectorp(C_word x)5072{5073 return C_i_structurep(x, f64vector_symbol);5074}507550765077C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)5078{5079 C_word n;50805081 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5082 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);50835084 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5085 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);50865087 n = C_header_size(x);50885089 return C_mk_bool(n == C_header_size(y)5090 && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));5091}509250935094C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)5095{5096 C_word n;5097 char *p1, *p2;50985099 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)5100 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);51015102 if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)5103 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);51045105 n = C_header_size(x);51065107 if(n != C_header_size(y)) return C_SCHEME_FALSE;51085109 p1 = (char *)C_data_pointer(x);5110 p2 = (char *)C_data_pointer(y);51115112 while(n--) {5113 if(C_tolower((int)(*(p1++))) != C_tolower((int)(*(p2++))))5114 return C_SCHEME_FALSE;5115 }51165117 return C_SCHEME_TRUE;5118}511951205121C_word C_a_i_list(C_word **a, int c, ...)5122{5123 va_list v;5124 C_word x, last, current,5125 first = C_SCHEME_END_OF_LIST;51265127 va_start(v, c);51285129 for(last = C_SCHEME_UNDEFINED; c--; last = current) {5130 x = va_arg(v, C_word);5131 current = C_a_pair(a, x, C_SCHEME_END_OF_LIST);51325133 if(last != C_SCHEME_UNDEFINED)5134 C_set_block_item(last, 1, current);5135 else first = current;5136 }51375138 va_end(v);5139 return first;5140}514151425143C_word C_a_i_string(C_word **a, int c, ...)5144{5145 va_list v;5146 C_word x, s = (C_word)(*a);5147 char *p;51485149 *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(c));5150 C_block_header_init(s, C_STRING_TYPE | c);5151 p = (char *)C_data_pointer(s);5152 va_start(v, c);51535154 for(; c; c--) {5155 x = va_arg(v, C_word);51565157 if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)5158 *(p++) = C_character_code(x);5159 else break;5160 }51615162 va_end(v);5163 if (c) barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);5164 return s;5165}516651675168C_word C_a_i_record(C_word **ptr, int n, ...)5169{5170 va_list v;5171 C_word *p = *ptr,5172 *p0 = p;51735174 *(p++) = C_STRUCTURE_TYPE | n;5175 va_start(v, n);51765177 while(n--)5178 *(p++) = va_arg(v, C_word);51795180 *ptr = p;5181 va_end(v);5182 return (C_word)p0;5183}518451855186C_word C_a_i_port(C_word **ptr, int n)5187{5188 C_word5189 *p = *ptr,5190 *p0 = p;5191 int i;51925193 *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);5194 *(p++) = (C_word)NULL;51955196 for(i = 0; i < C_SIZEOF_PORT - 2; ++i)5197 *(p++) = C_SCHEME_FALSE;51985199 *ptr = p;5200 return (C_word)p0;5201}520252035204C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)5205{5206 C_word *p = *ptr,5207 *p0;5208 int n = C_unfix(num);52095210#ifndef C_SIXTY_FOUR5211 /* Align on 8-byte boundary: */5212 if(C_aligned8(p)) ++p;5213#endif52145215 p0 = p;5216 *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);5217 *ptr = p + n;5218 return (C_word)p0;5219}522052215222C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)5223{5224 C_word5225 *p = *ptr,5226 *p0 = p;5227 void *mp;52285229 if(C_immediatep(x)) mp = NULL;5230 else if((C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);5231 else mp = C_data_pointer(x);52325233 *(p++) = C_POINTER_TYPE | 1;5234 *((void **)p) = mp;5235 *ptr = p + 1;5236 return (C_word)p0;5237}52385239C_regparm C_word C_fcall C_i_nanp(C_word x)5240{5241 if (x & C_FIXNUM_BIT) {5242 return C_SCHEME_FALSE;5243 } else if (C_immediatep(x)) {5244 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5245 } else if (C_block_header(x) == C_FLONUM_TAG) {5246 return C_u_i_flonum_nanp(x);5247 } else if (C_truep(C_bignump(x))) {5248 return C_SCHEME_FALSE;5249 } else if (C_block_header(x) == C_RATNUM_TAG) {5250 return C_SCHEME_FALSE;5251 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5252 return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) ||5253 C_truep(C_i_nanp(C_u_i_cplxnum_imag(x))));5254 } else {5255 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);5256 }5257}52585259C_regparm C_word C_fcall C_i_finitep(C_word x)5260{5261 if (x & C_FIXNUM_BIT) {5262 return C_SCHEME_TRUE;5263 } else if (C_immediatep(x)) {5264 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5265 } else if (C_block_header(x) == C_FLONUM_TAG) {5266 return C_u_i_flonum_finitep(x);5267 } else if (C_truep(C_bignump(x))) {5268 return C_SCHEME_TRUE;5269 } else if (C_block_header(x) == C_RATNUM_TAG) {5270 return C_SCHEME_TRUE;5271 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5272 return C_and(C_i_finitep(C_u_i_cplxnum_real(x)),5273 C_i_finitep(C_u_i_cplxnum_imag(x)));5274 } else {5275 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);5276 }5277}52785279C_regparm C_word C_fcall C_i_infinitep(C_word x)5280{5281 if (x & C_FIXNUM_BIT) {5282 return C_SCHEME_FALSE;5283 } else if (C_immediatep(x)) {5284 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5285 } else if (C_block_header(x) == C_FLONUM_TAG) {5286 return C_u_i_flonum_infinitep(x);5287 } else if (C_truep(C_bignump(x))) {5288 return C_SCHEME_FALSE;5289 } else if (C_block_header(x) == C_RATNUM_TAG) {5290 return C_SCHEME_FALSE;5291 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5292 return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) ||5293 C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x))));5294 } else {5295 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);5296 }5297}52985299C_regparm C_word C_fcall C_i_exactp(C_word x)5300{5301 if (x & C_FIXNUM_BIT) {5302 return C_SCHEME_TRUE;5303 } else if (C_immediatep(x)) {5304 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5305 } else if (C_block_header(x) == C_FLONUM_TAG) {5306 return C_SCHEME_FALSE;5307 } else if (C_truep(C_bignump(x))) {5308 return C_SCHEME_TRUE;5309 } else if (C_block_header(x) == C_RATNUM_TAG) {5310 return C_SCHEME_TRUE;5311 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5312 return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5313 } else {5314 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);5315 }5316}531753185319C_regparm C_word C_fcall C_i_inexactp(C_word x)5320{5321 if (x & C_FIXNUM_BIT) {5322 return C_SCHEME_FALSE;5323 } else if (C_immediatep(x)) {5324 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5325 } else if (C_block_header(x) == C_FLONUM_TAG) {5326 return C_SCHEME_TRUE;5327 } else if (C_truep(C_bignump(x))) {5328 return C_SCHEME_FALSE;5329 } else if (C_block_header(x) == C_RATNUM_TAG) {5330 return C_SCHEME_FALSE;5331 } else if (C_block_header(x) == C_CPLXNUM_TAG) {5332 return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */5333 } else {5334 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);5335 }5336}533753385339C_regparm C_word C_fcall C_i_zerop(C_word x)5340{5341 if (x & C_FIXNUM_BIT) {5342 return C_mk_bool(x == C_fix(0));5343 } else if (C_immediatep(x)) {5344 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5345 } else if (C_block_header(x) == C_FLONUM_TAG) {5346 return C_mk_bool(C_flonum_magnitude(x) == 0.0);5347 } else if (C_block_header(x) == C_BIGNUM_TAG ||5348 C_block_header(x) == C_RATNUM_TAG ||5349 C_block_header(x) == C_CPLXNUM_TAG) {5350 return C_SCHEME_FALSE;5351 } else {5352 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);5353 }5354}53555356/* DEPRECATED */5357C_regparm C_word C_fcall C_u_i_zerop(C_word x)5358{5359 return C_mk_bool(x == C_fix(0) ||5360 (!C_immediatep(x) &&5361 C_block_header(x) == C_FLONUM_TAG &&5362 C_flonum_magnitude(x) == 0.0));5363}536453655366C_regparm C_word C_fcall C_i_positivep(C_word x)5367{5368 if (x & C_FIXNUM_BIT)5369 return C_i_fixnum_positivep(x);5370 else if (C_immediatep(x))5371 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5372 else if (C_block_header(x) == C_FLONUM_TAG)5373 return C_mk_bool(C_flonum_magnitude(x) > 0.0);5374 else if (C_truep(C_bignump(x)))5375 return C_mk_nbool(C_bignum_negativep(x));5376 else if (C_block_header(x) == C_RATNUM_TAG)5377 return C_i_integer_positivep(C_u_i_ratnum_num(x));5378 else if (C_block_header(x) == C_CPLXNUM_TAG)5379 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x);5380 else5381 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);5382}53835384C_regparm C_word C_fcall C_i_integer_positivep(C_word x)5385{5386 if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);5387 else return C_mk_nbool(C_bignum_negativep(x));5388}53895390C_regparm C_word C_fcall C_i_negativep(C_word x)5391{5392 if (x & C_FIXNUM_BIT)5393 return C_i_fixnum_negativep(x);5394 else if (C_immediatep(x))5395 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5396 else if (C_block_header(x) == C_FLONUM_TAG)5397 return C_mk_bool(C_flonum_magnitude(x) < 0.0);5398 else if (C_truep(C_bignump(x)))5399 return C_mk_bool(C_bignum_negativep(x));5400 else if (C_block_header(x) == C_RATNUM_TAG)5401 return C_i_integer_negativep(C_u_i_ratnum_num(x));5402 else if (C_block_header(x) == C_CPLXNUM_TAG)5403 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x);5404 else5405 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);5406}540754085409C_regparm C_word C_fcall C_i_integer_negativep(C_word x)5410{5411 if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);5412 else return C_mk_bool(C_bignum_negativep(x));5413}541454155416C_regparm C_word C_fcall C_i_evenp(C_word x)5417{5418 if(x & C_FIXNUM_BIT) {5419 return C_i_fixnumevenp(x);5420 } else if(C_immediatep(x)) {5421 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5422 } else if (C_block_header(x) == C_FLONUM_TAG) {5423 double val, dummy;5424 val = C_flonum_magnitude(x);5425 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5426 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5427 else5428 return C_mk_bool(fmod(val, 2.0) == 0.0);5429 } else if (C_truep(C_bignump(x))) {5430 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5431 } else { /* No need to try extended number */5432 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5433 }5434}54355436C_regparm C_word C_fcall C_i_integer_evenp(C_word x)5437{5438 if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);5439 return C_mk_nbool(C_bignum_digits(x)[0] & 1);5440}544154425443C_regparm C_word C_fcall C_i_oddp(C_word x)5444{5445 if(x & C_FIXNUM_BIT) {5446 return C_i_fixnumoddp(x);5447 } else if(C_immediatep(x)) {5448 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5449 } else if(C_block_header(x) == C_FLONUM_TAG) {5450 double val, dummy;5451 val = C_flonum_magnitude(x);5452 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0)5453 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5454 else5455 return C_mk_bool(fmod(val, 2.0) != 0.0);5456 } else if (C_truep(C_bignump(x))) {5457 return C_mk_bool(C_bignum_digits(x)[0] & 1);5458 } else {5459 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5460 }5461}546254635464C_regparm C_word C_fcall C_i_integer_oddp(C_word x)5465{5466 if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);5467 return C_mk_bool(C_bignum_digits(x)[0] & 1);5468}546954705471C_regparm C_word C_fcall C_i_car(C_word x)5472{5473 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5474 barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);54755476 return C_u_i_car(x);5477}547854795480C_regparm C_word C_fcall C_i_cdr(C_word x)5481{5482 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)5483 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);54845485 return C_u_i_cdr(x);5486}548754885489C_regparm C_word C_fcall C_i_caar(C_word x)5490{5491 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5492 bad:5493 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x);5494 }54955496 x = C_u_i_car(x);54975498 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;54995500 return C_u_i_car(x);5501}550255035504C_regparm C_word C_fcall C_i_cadr(C_word x)5505{5506 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5507 bad:5508 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);5509 }55105511 x = C_u_i_cdr(x);55125513 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55145515 return C_u_i_car(x);5516}551755185519C_regparm C_word C_fcall C_i_cdar(C_word x)5520{5521 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5522 bad:5523 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x);5524 }55255526 x = C_u_i_car(x);55275528 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55295530 return C_u_i_cdr(x);5531}553255335534C_regparm C_word C_fcall C_i_cddr(C_word x)5535{5536 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5537 bad:5538 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);5539 }55405541 x = C_u_i_cdr(x);5542 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55435544 return C_u_i_cdr(x);5545}554655475548C_regparm C_word C_fcall C_i_caddr(C_word x)5549{5550 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5551 bad:5552 barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);5553 }55545555 x = C_u_i_cdr(x);5556 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5557 x = C_u_i_cdr(x);5558 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55595560 return C_u_i_car(x);5561}556255635564C_regparm C_word C_fcall C_i_cdddr(C_word x)5565{5566 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5567 bad:5568 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);5569 }55705571 x = C_u_i_cdr(x);5572 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5573 x = C_u_i_cdr(x);5574 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;55755576 return C_u_i_cdr(x);5577}557855795580C_regparm C_word C_fcall C_i_cadddr(C_word x)5581{5582 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {5583 bad:5584 barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);5585 }55865587 x = C_u_i_cdr(x);5588 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) goto bad;5589 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_car(x);5595}559655975598C_regparm C_word C_fcall C_i_cddddr(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, "cddddr", 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_cdr(x);5613}561456155616C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)5617{5618 C_word lst0 = lst;5619 int n;56205621 if(lst != C_SCHEME_END_OF_LIST &&5622 (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))5623 barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst);56245625 if(i & C_FIXNUM_BIT) n = C_unfix(i);5626 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);56275628 while(n--) {5629 if(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)5630 barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);56315632 lst = C_u_i_cdr(lst);5633 }56345635 return lst;5636}563756385639C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)5640{5641 int j;56425643 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5644 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);56455646 if(i & C_FIXNUM_BIT) {5647 j = C_unfix(i);56485649 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-ref", v, i);56505651 return C_block_item(v, j);5652 }56535654 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);5655 return C_SCHEME_UNDEFINED;5656}565756585659C_regparm C_word C_fcall C_i_u8vector_ref(C_word v, C_word i)5660{5661 int j;56625663 if(!C_truep(C_i_u8vectorp(v)))5664 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", v);56655666 if(i & C_FIXNUM_BIT) {5667 j = C_unfix(i);56685669 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-ref", v, i);56705671 return C_fix(((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j]);5672 }56735674 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", i);5675 return C_SCHEME_UNDEFINED;5676}56775678C_regparm C_word C_fcall C_i_s8vector_ref(C_word v, C_word i)5679{5680 int j;56815682 if(!C_truep(C_i_s8vectorp(v)))5683 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", v);56845685 if(i & C_FIXNUM_BIT) {5686 j = C_unfix(i);56875688 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-ref", v, i);56895690 return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);5691 }56925693 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);5694 return C_SCHEME_UNDEFINED;5695}56965697C_regparm C_word C_fcall C_i_u16vector_ref(C_word v, C_word i)5698{5699 int j;57005701 if(!C_truep(C_i_u16vectorp(v)))5702 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", v);57035704 if(i & C_FIXNUM_BIT) {5705 j = C_unfix(i);57065707 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);57085709 return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);5710 }57115712 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);5713 return C_SCHEME_UNDEFINED;5714}57155716C_regparm C_word C_fcall C_i_s16vector_ref(C_word v, C_word i)5717{5718 C_word size;5719 int j;57205721 if(C_immediatep(v) || C_header_bits(v) != C_STRUCTURE_TYPE ||5722 C_header_size(v) != 2 || C_block_item(v, 0) != s16vector_symbol)5723 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", v);57245725 if(i & C_FIXNUM_BIT) {5726 j = C_unfix(i);57275728 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);57295730 return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);5731 }57325733 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);5734 return C_SCHEME_UNDEFINED;5735}57365737C_regparm C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5738{5739 int j;57405741 if(!C_truep(C_i_u32vectorp(v)))5742 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", v);57435744 if(i & C_FIXNUM_BIT) {5745 j = C_unfix(i);57465747 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-ref", v, i);57485749 return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);5750 }57515752 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);5753 return C_SCHEME_UNDEFINED;5754}57555756C_regparm C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5757{5758 int j;57595760 if(!C_truep(C_i_s32vectorp(v)))5761 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", v);57625763 if(i & C_FIXNUM_BIT) {5764 j = C_unfix(i);57655766 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-ref", v, i);57675768 return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);5769 }57705771 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);5772 return C_SCHEME_UNDEFINED;5773}57745775C_regparm C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5776{5777 int j;57785779 if(!C_truep(C_i_u64vectorp(v)))5780 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", v);57815782 if(i & C_FIXNUM_BIT) {5783 j = C_unfix(i);57845785 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-ref", v, i);57865787 return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);5788 }57895790 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);5791 return C_SCHEME_UNDEFINED;5792}57935794C_regparm C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5795{5796 int j;57975798 if(!C_truep(C_i_s64vectorp(v)))5799 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", v);58005801 if(i & C_FIXNUM_BIT) {5802 j = C_unfix(i);58035804 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-ref", v, i);58055806 return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);5807 }58085809 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);5810 return C_SCHEME_UNDEFINED;5811}58125813C_regparm C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5814{5815 int j;58165817 if(!C_truep(C_i_f32vectorp(v)))5818 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", v);58195820 if(i & C_FIXNUM_BIT) {5821 j = C_unfix(i);58225823 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-ref", v, i);58245825 return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);5826 }58275828 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);5829 return C_SCHEME_UNDEFINED;5830}58315832C_regparm C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)5833{5834 C_word size;5835 int j;58365837 if(!C_truep(C_i_f64vectorp(v)))5838 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", v);58395840 if(i & C_FIXNUM_BIT) {5841 j = C_unfix(i);58425843 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-ref", v, i);58445845 return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);5846 }58475848 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);5849 return C_SCHEME_UNDEFINED;5850}585158525853C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)5854{5855 int j;58565857 if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)5858 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);58595860 if(i & C_FIXNUM_BIT) {5861 j = C_unfix(i);58625863 if(j < 0 || j >= C_header_size(x)) barf(C_OUT_OF_RANGE_ERROR, "##sys#block-ref", x, i);58645865 return C_block_item(x, j);5866 }58675868 barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);5869 return C_SCHEME_UNDEFINED;5870}587158725873C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)5874{5875 int j;58765877 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5878 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);58795880 if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)5881 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);58825883 if(i & C_FIXNUM_BIT) {5884 j = C_unfix(i);58855886 if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-set!", s, i);58875888 return C_setsubchar(s, i, c);5889 }58905891 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);5892 return C_SCHEME_UNDEFINED;5893}589458955896C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)5897{5898 int j;58995900 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)5901 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);59025903 if(i & C_FIXNUM_BIT) {5904 j = C_unfix(i);59055906 if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-ref", s, i);59075908 return C_subchar(s, i);5909 }59105911 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);5912 return C_SCHEME_UNDEFINED;5913}591459155916C_regparm C_word C_fcall C_i_vector_length(C_word v)5917{5918 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)5919 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);59205921 return C_fix(C_header_size(v));5922}59235924C_regparm C_word C_fcall C_i_u8vector_length(C_word v)5925{5926 if(!C_truep(C_i_u8vectorp(v)))5927 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-length", v);59285929 return C_fix(C_header_size(C_block_item(v, 1)));5930}59315932C_regparm C_word C_fcall C_i_s8vector_length(C_word v)5933{5934 if(!C_truep(C_i_s8vectorp(v)))5935 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);59365937 return C_fix(C_header_size(C_block_item(v, 1)));5938}59395940C_regparm C_word C_fcall C_i_u16vector_length(C_word v)5941{5942 if(!C_truep(C_i_u16vectorp(v)))5943 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);59445945 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5946}59475948C_regparm C_word C_fcall C_i_s16vector_length(C_word v)5949{5950 if(!C_truep(C_i_s16vectorp(v)))5951 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);59525953 return C_fix(C_header_size(C_block_item(v, 1)) >> 1);5954}59555956C_regparm C_word C_fcall C_i_u32vector_length(C_word v)5957{5958 if(!C_truep(C_i_u32vectorp(v)))5959 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);59605961 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5962}59635964C_regparm C_word C_fcall C_i_s32vector_length(C_word v)5965{5966 if(!C_truep(C_i_s32vectorp(v)))5967 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);59685969 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5970}59715972C_regparm C_word C_fcall C_i_u64vector_length(C_word v)5973{5974 if(!C_truep(C_i_u64vectorp(v)))5975 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);59765977 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5978}59795980C_regparm C_word C_fcall C_i_s64vector_length(C_word v)5981{5982 if(!C_truep(C_i_s64vectorp(v)))5983 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);59845985 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);5986}598759885989C_regparm C_word C_fcall C_i_f32vector_length(C_word v)5990{5991 if(!C_truep(C_i_f32vectorp(v)))5992 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);59935994 return C_fix(C_header_size(C_block_item(v, 1)) >> 2);5995}59965997C_regparm C_word C_fcall C_i_f64vector_length(C_word v)5998{5999 if(!C_truep(C_i_f64vectorp(v)))6000 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);60016002 return C_fix(C_header_size(C_block_item(v, 1)) >> 3);6003}600460056006C_regparm C_word C_fcall C_i_string_length(C_word s)6007{6008 if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)6009 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);60106011 return C_fix(C_header_size(s));6012}601360146015C_regparm C_word C_fcall C_i_length(C_word lst)6016{6017 C_word fast = lst, slow = lst;6018 int n = 0;60196020 while(slow != C_SCHEME_END_OF_LIST) {6021 if(fast != C_SCHEME_END_OF_LIST) {6022 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6023 fast = C_u_i_cdr(fast);60246025 if(fast != C_SCHEME_END_OF_LIST) {6026 if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {6027 fast = C_u_i_cdr(fast);6028 }6029 else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);6030 }60316032 if(fast == slow)6033 barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);6034 }6035 }60366037 if(C_immediatep(slow) || C_header_type(slow) != C_PAIR_TYPE)6038 barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);60396040 slow = C_u_i_cdr(slow);6041 ++n;6042 }60436044 return C_fix(n);6045}604660476048C_regparm C_word C_fcall C_u_i_length(C_word lst)6049{6050 int n = 0;60516052 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {6053 lst = C_u_i_cdr(lst);6054 ++n;6055 }60566057 return C_fix(n);6058}60596060C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)6061{6062 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6063 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);60646065 C_mutate(&C_u_i_car(x), val);6066 return C_SCHEME_UNDEFINED;6067}606860696070C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)6071{6072 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)6073 barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);60746075 C_mutate(&C_u_i_cdr(x), val);6076 return C_SCHEME_UNDEFINED;6077}607860796080C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)6081{6082 int j;60836084 if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)6085 barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);60866087 if(i & C_FIXNUM_BIT) {6088 j = C_unfix(i);60896090 if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-set!", v, i);60916092 C_mutate(&C_block_item(v, j), x);6093 }6094 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);60956096 return C_SCHEME_UNDEFINED;6097}609860996100C_regparm C_word C_fcall C_i_u8vector_set(C_word v, C_word i, C_word x)6101{6102 int j;6103 C_word n;61046105 if(!C_truep(C_i_u8vectorp(v)))6106 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", v);61076108 if(i & C_FIXNUM_BIT) {6109 j = C_unfix(i);61106111 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", v, i);61126113 if(x & C_FIXNUM_BIT) {6114 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 8) n = C_unfix(x);6115 else barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", x);6116 }6117 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", x);6118 }6119 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", i);61206121 ((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j] = n;6122 return C_SCHEME_UNDEFINED;6123}61246125C_regparm C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x)6126{6127 int j;6128 C_word n;61296130 if(!C_truep(C_i_s8vectorp(v)))6131 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", v);61326133 if(i & C_FIXNUM_BIT) {6134 j = C_unfix(i);61356136 if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-set!", v, i);61376138 if(x & C_FIXNUM_BIT) {6139 if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);6140 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);6141 }6142 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);6143 }6144 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", i);61456146 ((signed char *)C_data_pointer(C_block_item(v, 1)))[j] = n;6147 return C_SCHEME_UNDEFINED;6148}61496150C_regparm C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x)6151{6152 int j;6153 C_word n;61546155 if(!C_truep(C_i_u16vectorp(v)))6156 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", v);61576158 if(i & C_FIXNUM_BIT) {6159 j = C_unfix(i);61606161 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);61626163 if(x & C_FIXNUM_BIT) {6164 if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);6165 else barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", x);6166 }6167 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);6168 }6169 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", i);61706171 ((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6172 return C_SCHEME_UNDEFINED;6173}61746175C_regparm C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x)6176{6177 int j;6178 C_word n;61796180 if(!C_truep(C_i_s16vectorp(v)))6181 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", v);61826183 if(i & C_FIXNUM_BIT) {6184 j = C_unfix(i);61856186 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);61876188 if(x & C_FIXNUM_BIT) {6189 if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);6190 else barf(C_OUT_OF_RANGE_ERROR, "s16vector-set!", x);6191 }6192 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);6193 }6194 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", i);61956196 ((short *)C_data_pointer(C_block_item(v, 1)))[j] = n;6197 return C_SCHEME_UNDEFINED;6198}61996200C_regparm C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x)6201{6202 int j;6203 C_u32 n;62046205 if(!C_truep(C_i_u32vectorp(v)))6206 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", v);62076208 if(i & C_FIXNUM_BIT) {6209 j = C_unfix(i);62106211 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", v, i);62126213 if(C_truep(C_i_exact_integerp(x))) {6214 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);6215 else barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", x);6216 }6217 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);6218 }6219 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", i);62206221 ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6222 return C_SCHEME_UNDEFINED;6223}62246225C_regparm C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x)6226{6227 int j;6228 C_s32 n;62296230 if(!C_truep(C_i_s32vectorp(v)))6231 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", v);62326233 if(i & C_FIXNUM_BIT) {6234 j = C_unfix(i);62356236 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", v, i);62376238 if(C_truep(C_i_exact_integerp(x))) {6239 if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);6240 else barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", x);6241 }6242 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);6243 }6244 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", i);62456246 ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6247 return C_SCHEME_UNDEFINED;6248}62496250C_regparm C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x)6251{6252 int j;6253 C_u64 n;62546255 if(!C_truep(C_i_u64vectorp(v)))6256 barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", v);62576258 if(i & C_FIXNUM_BIT) {6259 j = C_unfix(i);62606261 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", v, i);62626263 if(C_truep(C_i_exact_integerp(x))) {6264 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);6265 else barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", x);6266 }6267 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);6268 }6269 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", i);62706271 ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6272 return C_SCHEME_UNDEFINED;6273}62746275C_regparm C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x)6276{6277 int j;6278 C_s64 n;62796280 if(!C_truep(C_i_s64vectorp(v)))6281 barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", v);62826283 if(i & C_FIXNUM_BIT) {6284 j = C_unfix(i);62856286 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", v, i);62876288 if(C_truep(C_i_exact_integerp(x))) {6289 if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);6290 else barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", x);6291 }6292 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);6293 }6294 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", i);62956296 ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j] = n;6297 return C_SCHEME_UNDEFINED;6298}62996300C_regparm C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x)6301{6302 int j;6303 double f;63046305 if(!C_truep(C_i_f32vectorp(v)))6306 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", v);63076308 if(i & C_FIXNUM_BIT) {6309 j = C_unfix(i);63106311 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-set!", v, i);63126313 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6314 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6315 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6316 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", x);6317 }6318 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);63196320 ((float *)C_data_pointer(C_block_item(v, 1)))[j] = (float)f;6321 return C_SCHEME_UNDEFINED;6322}63236324C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x)6325{6326 int j;6327 double f;63286329 if(!C_truep(C_i_f64vectorp(v)))6330 barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", v);63316332 if(i & C_FIXNUM_BIT) {6333 j = C_unfix(i);63346335 if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-set!", v, i);63366337 if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);6338 else if(x & C_FIXNUM_BIT) f = C_unfix(x);6339 else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);6340 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", x);63416342 }6343 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);63446345 ((double *)C_data_pointer(C_block_item(v, 1)))[j] = f;6346 return C_SCHEME_UNDEFINED;6347}634863496350/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */6351C_regparm C_word C_fcall6352C_s_a_i_abs(C_word **ptr, C_word n, C_word x)6353{6354 if (x & C_FIXNUM_BIT) {6355 return C_a_i_fixnum_abs(ptr, 1, x);6356 } else if (C_immediatep(x)) {6357 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6358 } else if (C_block_header(x) == C_FLONUM_TAG) {6359 return C_a_i_flonum_abs(ptr, 1, x);6360 } else if (C_truep(C_bignump(x))) {6361 return C_s_a_u_i_integer_abs(ptr, 1, x);6362 } else if (C_block_header(x) == C_RATNUM_TAG) {6363 return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)),6364 C_u_i_ratnum_denom(x));6365 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6366 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x);6367 } else {6368 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x);6369 }6370}63716372void C_ccall C_signum(C_word c, C_word *av)6373{6374 C_word k = av[ 1 ], x, y;63756376 if (c != 3) C_bad_argc_2(c, 3, av[ 0 ]);63776378 x = av[ 2 ];6379 y = av[ 3 ];63806381 if (x & C_FIXNUM_BIT) {6382 C_kontinue(k, C_i_fixnum_signum(x));6383 } else if (C_immediatep(x)) {6384 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);6385 } else if (C_block_header(x) == C_FLONUM_TAG) {6386 C_word *a = C_alloc(C_SIZEOF_FLONUM);6387 C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));6388 } else if (C_truep(C_bignump(x))) {6389 C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));6390 } else {6391 try_extended_number("##sys#extended-signum", 2, k, x);6392 }6393}639463956396/* The maximum this can allocate is a cplxnum which consists of two6397 * ratnums that consist of 2 fix bignums each. So that's6398 * C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!6399 */6400C_regparm C_word C_fcall6401C_s_a_i_negate(C_word **ptr, C_word n, C_word x)6402{6403 if (x & C_FIXNUM_BIT) {6404 return C_a_i_fixnum_negate(ptr, 1, x);6405 } else if (C_immediatep(x)) {6406 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6407 } else if (C_block_header(x) == C_FLONUM_TAG) {6408 return C_a_i_flonum_negate(ptr, 1, x);6409 } else if (C_truep(C_bignump(x))) {6410 return C_s_a_u_i_integer_negate(ptr, 1, x);6411 } else if (C_block_header(x) == C_RATNUM_TAG) {6412 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)),6413 C_u_i_ratnum_denom(x));6414 } else if (C_block_header(x) == C_CPLXNUM_TAG) {6415 return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)),6416 C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x)));6417 } else {6418 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);6419 }6420}64216422/* Copy all the digits from source to target, obliterating what was6423 * there. If target is larger than source, the most significant6424 * digits will remain untouched.6425 */6426inline static void bignum_digits_destructive_copy(C_word target, C_word source)6427{6428 C_memcpy(C_bignum_digits(target), C_bignum_digits(source),6429 C_wordstobytes(C_bignum_size(source)));6430}64316432C_regparm C_word C_fcall6433C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)6434{6435 if (x & C_FIXNUM_BIT) {6436 return C_a_i_fixnum_negate(ptr, 1, x);6437 } else {6438 if (C_bignum_negated_fitsinfixnump(x)) {6439 return C_fix(C_MOST_NEGATIVE_FIXNUM);6440 } else {6441 C_word res, negp = C_mk_nbool(C_bignum_negativep(x)),6442 size = C_fix(C_bignum_size(x));6443 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);6444 bignum_digits_destructive_copy(res, x);6445 return C_bignum_simplify(res);6446 }6447 }6448}644964506451/* Faster version that ignores sign */6452inline static int integer_length_abs(C_word x)6453{6454 if (x & C_FIXNUM_BIT) {6455 return C_ilen(C_wabs(C_unfix(x)));6456 } else {6457 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6458 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6459 last_digit_length = C_ilen(*last_digit);6460 return result + last_digit_length;6461 }6462}64636464C_regparm C_word C_fcall C_i_integer_length(C_word x)6465{6466 if (x & C_FIXNUM_BIT) {6467 return C_i_fixnum_length(x);6468 } else if (C_truep(C_i_bignump(x))) {6469 C_uword result = (C_bignum_size(x) - 1) * C_BIGNUM_DIGIT_LENGTH,6470 *last_digit = C_bignum_digits(x) + C_bignum_size(x) - 1,6471 last_digit_length = C_ilen(*last_digit);64726473 /* If *only* the highest bit is set, negating will give one less bit */6474 if (C_bignum_negativep(x) &&6475 *last_digit == ((C_uword)1 << (last_digit_length-1))) {6476 C_uword *startx = C_bignum_digits(x);6477 while (startx < last_digit && *startx == 0) ++startx;6478 if (startx == last_digit) result--;6479 }6480 return C_fix(result + last_digit_length);6481 } else {6482 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "integer-length", x);6483 }6484}64856486/* This is currently only used by Karatsuba multiplication and6487 * Burnikel-Ziegler division. */6488static C_regparm C_word6489bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end)6490{6491 if (x & C_FIXNUM_BIT) { /* Needed? */6492 if (C_unfix(start) == 0 && (end == C_SCHEME_FALSE || C_unfix(end) > 0))6493 return x;6494 else6495 return C_fix(0);6496 } else {6497 C_word negp, size;64986499 negp = C_mk_bool(C_bignum_negativep(x)); /* Always false */65006501 start = C_unfix(start);6502 /* We might get passed larger values than actually fits; pad w/ zeroes */6503 if (end == C_SCHEME_FALSE) end = C_bignum_size(x);6504 else end = nmin(C_unfix(end), C_bignum_size(x));6505 assert(start >= 0);65066507 size = end - start;65086509 if (size == 0 || start >= C_bignum_size(x)) {6510 return C_fix(0);6511 } else {6512 C_uword res, *res_digits, *x_digits;6513 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6514 res_digits = C_bignum_digits(res);6515 x_digits = C_bignum_digits(x);6516 /* Can't use bignum_digits_destructive_copy because that assumes6517 * target is at least as big as source.6518 */6519 C_memcpy(res_digits, x_digits + start, C_wordstobytes(end - start));6520 return C_bignum_simplify(res);6521 }6522 }6523}65246525/* This returns a tmp bignum negated copy of X (must be freed!) when6526 * the number is negative, or #f if it doesn't need to be negated.6527 * The size can be larger or smaller than X (it may be 1-padded).6528 */6529inline static C_word maybe_negate_bignum_for_bitwise_op(C_word x, C_word size)6530{6531 C_word nx = C_SCHEME_FALSE, xsize;6532 if (C_bignum_negativep(x)) {6533 nx = allocate_tmp_bignum(C_fix(size), C_SCHEME_FALSE, C_SCHEME_FALSE);6534 xsize = C_bignum_size(x);6535 /* Copy up until requested size, and init any remaining upper digits */6536 C_memcpy(C_bignum_digits(nx), C_bignum_digits(x),6537 C_wordstobytes(nmin(size, xsize)));6538 if (size > xsize)6539 C_memset(C_bignum_digits(nx)+xsize, 0, C_wordstobytes(size-xsize));6540 bignum_digits_destructive_negate(nx);6541 }6542 return nx;6543}65446545/* DEPRECATED */6546C_regparm C_word C_fcall C_i_bit_to_bool(C_word n, C_word i)6547{6548 if (!C_truep(C_i_exact_integerp(n))) {6549 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit->boolean", n);6550 } else if (!(i & C_FIXNUM_BIT)) {6551 if (!C_immediatep(i) && C_truep(C_bignump(i)) && !C_bignum_negativep(i)) {6552 return C_i_integer_negativep(n); /* A bit silly, but strictly correct */6553 } else {6554 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6555 }6556 } else if (i & C_INT_SIGN_BIT) {6557 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit->boolean", i);6558 } else {6559 i = C_unfix(i);6560 if (n & C_FIXNUM_BIT) {6561 if (i >= C_WORD_SIZE) return C_mk_bool(n & C_INT_SIGN_BIT);6562 else return C_mk_bool((C_unfix(n) & ((C_word)1 << i)) != 0);6563 } else {6564 C_word nn, d;6565 d = i / C_BIGNUM_DIGIT_LENGTH;6566 if (d >= C_bignum_size(n)) return C_mk_bool(C_bignum_negativep(n));65676568 /* TODO: this isn't necessary, is it? */6569 if (C_truep(nn = maybe_negate_bignum_for_bitwise_op(n, d))) n = nn;65706571 i %= C_BIGNUM_DIGIT_LENGTH;6572 d = C_mk_bool((C_bignum_digits(n)[d] & (C_uword)1 << i) != 0);6573 if (C_truep(nn)) free_tmp_bignum(nn);6574 return d;6575 }6576 }6577}65786579C_regparm C_word C_fcall6580C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)6581{6582 if ((x & y) & C_FIXNUM_BIT) {6583 return C_u_fixnum_and(x, y);6584 } else if (!C_truep(C_i_exact_integerp(x))) {6585 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", x);6586 } else if (!C_truep(C_i_exact_integerp(y))) {6587 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", y);6588 } else {6589 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6590 C_uword *scanr, *endr, *scans1, *ends1, *scans2;65916592 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6593 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);65946595 negp = C_mk_bool(C_bignum_negativep(x) && C_bignum_negativep(y));6596 /* Allow negative 1-bits to propagate */6597 if (C_bignum_negativep(x) || C_bignum_negativep(y))6598 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6599 else6600 size = nmin(C_bignum_size(x), C_bignum_size(y));66016602 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6603 scanr = C_bignum_digits(res);6604 endr = scanr + C_bignum_size(res);66056606 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6607 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;66086609 if (C_bignum_size(x) < C_bignum_size(y)) {6610 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6611 scans2 = C_bignum_digits(y);6612 } else {6613 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6614 scans2 = C_bignum_digits(x);6615 }66166617 while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;6618 C_memset(scanr, 0, C_wordstobytes(endr - scanr));66196620 if (C_truep(nx)) free_tmp_bignum(nx);6621 if (C_truep(ny)) free_tmp_bignum(ny);6622 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);66236624 return C_bignum_simplify(res);6625 }6626}66276628void C_ccall C_bitwise_and(C_word c, C_word *av)6629{6630 /* C_word closure = av[ 0 ]; */6631 C_word k = av[ 1 ];6632 C_word next_val, result, prev_result;6633 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;66346635 c -= 2;6636 av += 2;66376638 if (c == 0) C_kontinue(k, C_fix(-1));66396640 prev_result = result = *(av++);66416642 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6643 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", result);66446645 while (c--) {6646 next_val = *(av++);6647 a = ab[c&1]; /* One may hold last iteration result, the other is unused */6648 result = C_s_a_i_bitwise_and(&a, 2, result, next_val);6649 result = move_buffer_object(&a, ab[(c+1)&1], result);6650 clear_buffer_object(ab[(c+1)&1], prev_result);6651 prev_result = result;6652 }66536654 C_kontinue(k, result);6655}66566657C_regparm C_word C_fcall6658C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)6659{6660 if ((x & y) & C_FIXNUM_BIT) {6661 return C_u_fixnum_or(x, y);6662 } else if (!C_truep(C_i_exact_integerp(x))) {6663 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", x);6664 } else if (!C_truep(C_i_exact_integerp(y))) {6665 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", y);6666 } else {6667 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6668 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;66696670 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6671 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);66726673 negp = C_mk_bool(C_bignum_negativep(x) || C_bignum_negativep(y));6674 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6675 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6676 scanr = C_bignum_digits(res);6677 endr = scanr + C_bignum_size(res);66786679 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6680 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;66816682 if (C_bignum_size(x) < C_bignum_size(y)) {6683 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6684 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6685 } else {6686 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6687 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6688 }66896690 while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;6691 while (scans2 < ends2) *scanr++ = *scans2++;6692 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6693 assert(scanr == endr);66946695 if (C_truep(nx)) free_tmp_bignum(nx);6696 if (C_truep(ny)) free_tmp_bignum(ny);6697 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);66986699 return C_bignum_simplify(res);6700 }6701}67026703void C_ccall C_bitwise_ior(C_word c, C_word *av)6704{6705 /* C_word closure = av[ 0 ]; */6706 C_word k = av[ 1 ];6707 C_word next_val, result, prev_result;6708 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;67096710 c -= 2;6711 av += 2;67126713 if (c == 0) C_kontinue(k, C_fix(0));67146715 prev_result = result = *(av++);67166717 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6718 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", result);67196720 while (c--) {6721 next_val = *(av++);6722 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6723 result = C_s_a_i_bitwise_ior(&a, 2, result, next_val);6724 result = move_buffer_object(&a, ab[(c+1)&1], result);6725 clear_buffer_object(ab[(c+1)&1], prev_result);6726 prev_result = result;6727 }67286729 C_kontinue(k, result);6730}67316732C_regparm C_word C_fcall6733C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)6734{6735 if ((x & y) & C_FIXNUM_BIT) {6736 return C_fixnum_xor(x, y);6737 } else if (!C_truep(C_i_exact_integerp(x))) {6738 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", x);6739 } else if (!C_truep(C_i_exact_integerp(y))) {6740 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", y);6741 } else {6742 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;6743 C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;67446745 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);6746 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);67476748 size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;6749 negp = C_mk_bool(C_bignum_negativep(x) != C_bignum_negativep(y));6750 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);6751 scanr = C_bignum_digits(res);6752 endr = scanr + C_bignum_size(res);67536754 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;6755 if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;67566757 if (C_bignum_size(x) < C_bignum_size(y)) {6758 scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);6759 scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);6760 } else {6761 scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);6762 scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);6763 }67646765 while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;6766 while (scans2 < ends2) *scanr++ = *scans2++;6767 if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */6768 assert(scanr == endr);67696770 if (C_truep(nx)) free_tmp_bignum(nx);6771 if (C_truep(ny)) free_tmp_bignum(ny);6772 if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);67736774 return C_bignum_simplify(res);6775 }6776}67776778void C_ccall C_bitwise_xor(C_word c, C_word *av)6779{6780 /* C_word closure = av[ 0 ]; */6781 C_word k = av[ 1 ];6782 C_word next_val, result, prev_result;6783 C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;67846785 c -= 2;6786 av += 2;67876788 if (c == 0) C_kontinue(k, C_fix(0));67896790 prev_result = result = *(av++);67916792 if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))6793 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", result);67946795 while (c--) {6796 next_val = *(av++);6797 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */6798 result = C_s_a_i_bitwise_xor(&a, 2, result, next_val);6799 result = move_buffer_object(&a, ab[(c+1)&1], result);6800 clear_buffer_object(ab[(c+1)&1], prev_result);6801 prev_result = result;6802 }68036804 C_kontinue(k, result);6805}68066807C_regparm C_word C_fcall6808C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)6809{6810 if (!C_truep(C_i_exact_integerp(x))) {6811 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-not", x);6812 } else {6813 return C_s_a_u_i_integer_minus(ptr, 2, C_fix(-1), x);6814 }6815}68166817C_regparm C_word C_fcall6818C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)6819{6820 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, size, negp, res,6821 digit_offset, bit_offset;68226823 if (!(y & C_FIXNUM_BIT))6824 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", y);68256826 y = C_unfix(y);6827 if (y == 0 || x == C_fix(0)) { /* Done (no shift) */6828 return x;6829 } else if (x & C_FIXNUM_BIT) {6830 if (y < 0) {6831 /* Don't shift more than a word's length (that's undefined in C!) */6832 if (-y < C_WORD_SIZE) {6833 return C_fix(C_unfix(x) >> -y);6834 } else {6835 return (x < 0) ? C_fix(-1) : C_fix(0);6836 }6837 } else if (y > 0 && y < C_WORD_SIZE-2 &&6838 /* After shifting, the length still fits a fixnum */6839 (C_ilen(C_unfix(x)) + y) < C_WORD_SIZE-2) {6840 return C_fix((C_uword)C_unfix(x) << y);6841 } else {6842 x = C_a_u_i_fix_to_big(&a, x);6843 }6844 } else if (!C_truep(C_i_bignump(x))) {6845 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "arithmetic-shift", x);6846 }68476848 negp = C_mk_bool(C_bignum_negativep(x));68496850 if (y > 0) { /* Shift left */6851 C_uword *startr, *startx, *endx, *endr;68526853 digit_offset = y / C_BIGNUM_DIGIT_LENGTH;6854 bit_offset = y % C_BIGNUM_DIGIT_LENGTH;68556856 size = C_fix(C_bignum_size(x) + digit_offset + 1);6857 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);68586859 startr = C_bignum_digits(res);6860 endr = startr + C_bignum_size(res);68616862 startx = C_bignum_digits(x);6863 endx = startx + C_bignum_size(x);68646865 /* Initialize only the lower digits we're skipping and the MSD */6866 C_memset(startr, 0, C_wordstobytes(digit_offset));6867 *(endr-1) = 0;6868 startr += digit_offset;6869 /* Can't use bignum_digits_destructive_copy because it assumes6870 * we want to copy from the start.6871 */6872 C_memcpy(startr, startx, C_wordstobytes(endx-startx));6873 if(bit_offset > 0)6874 bignum_digits_destructive_shift_left(startr, endr, bit_offset);68756876 return C_bignum_simplify(res);6877 } else if (-y >= C_bignum_size(x) * (C_word)C_BIGNUM_DIGIT_LENGTH) {6878 /* All bits are shifted out, just return 0 or -1 */6879 return C_truep(negp) ? C_fix(-1) : C_fix(0);6880 } else { /* Shift right */6881 C_uword *startr, *startx, *endr;6882 C_word nx;68836884 digit_offset = -y / C_BIGNUM_DIGIT_LENGTH;6885 bit_offset = -y % C_BIGNUM_DIGIT_LENGTH;68866887 size = C_fix(C_bignum_size(x) - digit_offset);6888 res = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);68896890 startr = C_bignum_digits(res);6891 endr = startr + C_bignum_size(res);68926893 size = C_bignum_size(x) + 1;6894 if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) {6895 startx = C_bignum_digits(nx) + digit_offset;6896 } else {6897 startx = C_bignum_digits(x) + digit_offset;6898 }6899 /* Can't use bignum_digits_destructive_copy because that assumes6900 * target is at least as big as source.6901 */6902 C_memcpy(startr, startx, C_wordstobytes(endr-startr));6903 if(bit_offset > 0)6904 bignum_digits_destructive_shift_right(startr,endr,bit_offset,C_truep(nx));69056906 if (C_truep(nx)) {6907 free_tmp_bignum(nx);6908 bignum_digits_destructive_negate(res);6909 }6910 return C_bignum_simplify(res);6911 }6912}691369146915C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)6916{6917 double f;69186919 C_check_real(n, "exp", f);6920 return C_flonum(a, C_exp(f));6921}692269236924C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)6925{6926 double f;69276928 C_check_real(n, "log", f);6929 return C_flonum(a, C_log(f));6930}693169326933C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)6934{6935 double f;69366937 C_check_real(n, "sin", f);6938 return C_flonum(a, C_sin(f));6939}694069416942C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)6943{6944 double f;69456946 C_check_real(n, "cos", f);6947 return C_flonum(a, C_cos(f));6948}694969506951C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)6952{6953 double f;69546955 C_check_real(n, "tan", f);6956 return C_flonum(a, C_tan(f));6957}695869596960C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)6961{6962 double f;69636964 C_check_real(n, "asin", f);6965 return C_flonum(a, C_asin(f));6966}696769686969C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)6970{6971 double f;69726973 C_check_real(n, "acos", f);6974 return C_flonum(a, C_acos(f));6975}697669776978C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)6979{6980 double f;69816982 C_check_real(n, "atan", f);6983 return C_flonum(a, C_atan(f));6984}698569866987C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)6988{6989 double f1, f2;69906991 C_check_real(n1, "atan", f1);6992 C_check_real(n2, "atan", f2);6993 return C_flonum(a, C_atan2(f1, f2));6994}699569966997C_regparm C_word C_fcall C_a_i_sinh(C_word **a, int c, C_word n)6998{6999 double f;70007001 C_check_real(n, "sinh", f);7002 return C_flonum(a, C_sinh(f));7003}700470057006C_regparm C_word C_fcall C_a_i_cosh(C_word **a, int c, C_word n)7007{7008 double f;70097010 C_check_real(n, "cosh", f);7011 return C_flonum(a, C_cosh(f));7012}701370147015C_regparm C_word C_fcall C_a_i_tanh(C_word **a, int c, C_word n)7016{7017 double f;70187019 C_check_real(n, "tanh", f);7020 return C_flonum(a, C_tanh(f));7021}702270237024C_regparm C_word C_fcall C_a_i_asinh(C_word **a, int c, C_word n)7025{7026 double f;70277028 C_check_real(n, "asinh", f);7029 return C_flonum(a, C_asinh(f));7030}703170327033C_regparm C_word C_fcall C_a_i_acosh(C_word **a, int c, C_word n)7034{7035 double f;70367037 C_check_real(n, "acosh", f);7038 return C_flonum(a, C_acosh(f));7039}704070417042C_regparm C_word C_fcall C_a_i_atanh(C_word **a, int c, C_word n)7043{7044 double f;70457046 C_check_real(n, "atanh", f);7047 return C_flonum(a, C_atanh(f));7048}704970507051C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)7052{7053 double f;70547055 C_check_real(n, "sqrt", f);7056 return C_flonum(a, C_sqrt(f));7057}705870597060C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)7061{7062 C_word a;70637064 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7065 a = C_u_i_car(lst);70667067 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7068 if(C_u_i_car(a) == x) return a;7069 }7070 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);70717072 lst = C_u_i_cdr(lst);7073 }70747075 if(lst!=C_SCHEME_END_OF_LIST)7076 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", lst);70777078 return C_SCHEME_FALSE;7079}708070817082C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)7083{7084 C_word a;70857086 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7087 a = C_u_i_car(lst);70887089 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7090 if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;7091 }7092 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);70937094 lst = C_u_i_cdr(lst);7095 }70967097 if(lst!=C_SCHEME_END_OF_LIST)7098 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", lst);70997100 return C_SCHEME_FALSE;7101}710271037104C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)7105{7106 C_word a;71077108 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7109 a = C_u_i_car(lst);71107111 if(!C_immediatep(a) && C_header_type(a) == C_PAIR_TYPE) {7112 if(C_equalp(C_u_i_car(a), x)) return a;7113 }7114 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);71157116 lst = C_u_i_cdr(lst);7117 }71187119 if(lst!=C_SCHEME_END_OF_LIST)7120 barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", lst);71217122 return C_SCHEME_FALSE;7123}712471257126C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)7127{7128 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7129 if(C_u_i_car(lst) == x) return lst;7130 else lst = C_u_i_cdr(lst);7131 }71327133 if(lst!=C_SCHEME_END_OF_LIST)7134 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memq", lst);71357136 return C_SCHEME_FALSE;7137}713871397140C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)7141{7142 while(!C_immediatep(lst)) {7143 if(C_u_i_car(lst) == x) return lst;7144 else lst = C_u_i_cdr(lst);7145 }71467147 return C_SCHEME_FALSE;7148}714971507151C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)7152{7153 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7154 if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;7155 else lst = C_u_i_cdr(lst);7156 }71577158 if(lst!=C_SCHEME_END_OF_LIST)7159 barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);71607161 return C_SCHEME_FALSE;7162}716371647165C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)7166{7167 while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {7168 if(C_equalp(C_u_i_car(lst), x)) return lst;7169 else lst = C_u_i_cdr(lst);7170 }71717172 if(lst!=C_SCHEME_END_OF_LIST)7173 barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", lst);71747175 return C_SCHEME_FALSE;7176}717771787179/* Inline routines for extended bindings: */71807181C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)7182{7183 if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {7184 error_location = loc;7185 barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);7186 }71877188 return C_SCHEME_UNDEFINED;7189}71907191C_regparm C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc)7192{7193 if(!(x & C_FIXNUM_BIT)) {7194 error_location = loc;7195 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);7196 }71977198 return C_SCHEME_UNDEFINED;7199}72007201/* DEPRECATED */7202C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)7203{7204 if(C_u_i_exactp(x) == C_SCHEME_FALSE) {7205 error_location = loc;7206 barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR, NULL, x);7207 }72087209 return C_SCHEME_UNDEFINED;7210}721172127213C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)7214{7215 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {7216 error_location = loc;7217 barf(C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR, NULL, x);7218 }72197220 return C_SCHEME_UNDEFINED;7221}722272237224C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)7225{7226 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7227 error_location = loc;7228 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7229 }72307231 return C_SCHEME_UNDEFINED;7232}723372347235C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)7236{7237 if (C_i_numberp(x) == C_SCHEME_FALSE) {7238 error_location = loc;7239 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);7240 }72417242 return C_SCHEME_UNDEFINED;7243}724472457246C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)7247{7248 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {7249 error_location = loc;7250 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);7251 }72527253 return C_SCHEME_UNDEFINED;7254}725572567257C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)7258{7259 if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {7260 error_location = loc;7261 barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);7262 }72637264 return C_SCHEME_UNDEFINED;7265}726672677268C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)7269{7270 if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {7271 error_location = loc;7272 barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);7273 }72747275 return C_SCHEME_UNDEFINED;7276}727772787279C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)7280{7281 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x,0) != st) {7282 error_location = loc;7283 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);7284 }72857286 return C_SCHEME_UNDEFINED;7287}728872897290C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)7291{7292 if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {7293 error_location = loc;7294 barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);7295 }72967297 return C_SCHEME_UNDEFINED;7298}729973007301C_regparm C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc)7302{7303 if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {7304 error_location = loc;7305 barf(C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR, NULL, x);7306 }73077308 return C_SCHEME_UNDEFINED;7309}731073117312C_regparm C_word C_fcall C_i_check_locative_2(C_word x, C_word loc)7313{7314 if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {7315 error_location = loc;7316 barf(C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR, NULL, x);7317 }73187319 return C_SCHEME_UNDEFINED;7320}732173227323C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)7324{7325 if(!C_truep(C_i_symbolp(x))) {7326 error_location = loc;7327 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);7328 }73297330 return C_SCHEME_UNDEFINED;7331}733273337334C_regparm C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc)7335{7336 if(!C_truep(C_i_keywordp(x))) {7337 error_location = loc;7338 barf(C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR, NULL, x);7339 }73407341 return C_SCHEME_UNDEFINED;7342}73437344C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)7345{7346 if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)) {7347 error_location = loc;7348 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);7349 }73507351 return C_SCHEME_UNDEFINED;7352}735373547355C_regparm C_word C_fcall C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)7356{73577358 if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {7359 error_location = loc;7360 barf(C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR, NULL, x);7361 }73627363 if((C_block_item(x, 1) & dir) != dir) { /* slot #1: I/O direction mask */7364 error_location = loc;7365 switch (dir) {7366 case C_fix(1):7367 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR, NULL, x);7368 case C_fix(2):7369 barf(C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR, NULL, x);7370 default:7371 barf(C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR, NULL, x);7372 }7373 }73747375 if(open == C_SCHEME_TRUE) {7376 if(C_block_item(x, 8) == C_FIXNUM_BIT) { /* slot #8: closed mask */7377 error_location = loc;7378 barf(C_PORT_CLOSED_ERROR, NULL, x);7379 }7380 }73817382 return C_SCHEME_UNDEFINED;7383}738473857386/*XXX these are not correctly named */7387C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)7388{7389 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)7390 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);73917392 return x;7393}739473957396C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)7397{7398 if((x & C_FIXNUM_BIT) == 0)7399 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);74007401 return x;7402}740374047405C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)7406{7407 if((x & C_FIXNUM_BIT) != 0) return x;74087409 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)7410 barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);74117412 return x;7413}741474157416C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)7417{7418 if(C_immediatep(x))7419 barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);74207421 return x;7422}742374247425C_regparm C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)7426{7427 if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)7428 barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, t, x);74297430 return x;7431}743274337434C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)7435{7436 if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)7437 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);74387439 return x;7440}744174427443C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)7444{7445 if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)7446 barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);74477448 return x;7449}745074517452C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)7453{7454 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7455 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);74567457 return x;7458}745974607461/* TODO: Is this used? */7462C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)7463{7464 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)7465 barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);74667467 return x;7468}746974707471C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)7472{7473 if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 07474 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))7475 barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);74767477 return x;7478}74797480C_regparm C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)7481{7482 if((x & C_FIXNUM_BIT) != 0) {7483 if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;7484 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7485 } else if (C_truep(C_i_bignump(x))) {7486 if (C_truep(C_fixnum_lessp(C_i_integer_length(x), bits))) return x;7487 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7488 } else {7489 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);7490 }7491}74927493C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)7494{7495 if((x & C_FIXNUM_BIT) != 0) {7496 if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7497 else if(C_ilen(C_unfix(x)) <= C_unfix(bits)) return x;7498 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7499 } else if(C_truep(C_i_bignump(x))) {7500 if(C_bignum_negativep(x)) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7501 else if(integer_length_abs(x) <= C_unfix(bits)) return x;7502 else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);7503 } else {7504 barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);7505 }7506}75077508/* I */7509C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)7510{7511 return C_mk_bool(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE);7512}751375147515C_regparm C_word C_fcall C_i_null_list_p(C_word x)7516{7517 if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;7518 else if(!C_immediatep(x) && C_header_type(x) == C_PAIR_TYPE) return C_SCHEME_FALSE;7519 else {7520 barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);7521 return C_SCHEME_FALSE;7522 }7523}752475257526C_regparm C_word C_fcall C_i_string_null_p(C_word x)7527{7528 if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)7529 return C_zero_length_p(x);7530 else {7531 barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);7532 return C_SCHEME_FALSE;7533 }7534}753575367537C_regparm C_word C_fcall C_i_null_pointerp(C_word x)7538{7539 if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)7540 return C_null_pointerp(x);75417542 barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);7543 return C_SCHEME_FALSE;7544}75457546/* only used here for char comparators below: */7547static C_word C_fcall check_char_internal(C_word x, C_char *loc)7548{7549 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {7550 error_location = intern0(loc);7551 barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);7552 }75537554 return C_SCHEME_UNDEFINED;7555}75567557C_regparm C_word C_i_char_equalp(C_word x, C_word y)7558{7559 check_char_internal(x, "char=?");7560 check_char_internal(y, "char=?");7561 return C_u_i_char_equalp(x, y);7562}75637564C_regparm C_word C_i_char_greaterp(C_word x, C_word y)7565{7566 check_char_internal(x, "char>?");7567 check_char_internal(y, "char>?");7568 return C_u_i_char_greaterp(x, y);7569}75707571C_regparm C_word C_i_char_lessp(C_word x, C_word y)7572{7573 check_char_internal(x, "char<?");7574 check_char_internal(y, "char<?");7575 return C_u_i_char_lessp(x, y);7576}75777578C_regparm C_word C_i_char_greater_or_equal_p(C_word x, C_word y)7579{7580 check_char_internal(x, "char>=?");7581 check_char_internal(y, "char>=?");7582 return C_u_i_char_greater_or_equal_p(x, y);7583}75847585C_regparm C_word C_i_char_less_or_equal_p(C_word x, C_word y)7586{7587 check_char_internal(x, "char<=?");7588 check_char_internal(y, "char<=?");7589 return C_u_i_char_less_or_equal_p(x, y);7590}759175927593/* Primitives: */75947595void C_ccall C_apply(C_word c, C_word *av)7596{7597 C_word7598 /* closure = av[ 0 ] */7599 k = av[ 1 ],7600 fn = av[ 2 ];7601 int av2_size, i, n = c - 3;7602 int non_list_args = n - 1;7603 C_word lst, len, *ptr, *av2;76047605 if(c < 4) C_bad_min_argc(c, 4);76067607 if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE)7608 barf(C_NOT_A_CLOSURE_ERROR, "apply", fn);76097610 lst = av[ c - 1 ];7611 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7612 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);76137614 len = C_unfix(C_u_i_length(lst));7615 av2_size = 2 + non_list_args + len;76167617 if(C_demand(av2_size))7618 stack_check_demand = 0;7619 else if(stack_check_demand)7620 C_stack_overflow("apply");7621 else {7622 stack_check_demand = av2_size;7623 C_save_and_reclaim((void *)C_apply, c, av);7624 }76257626 av2 = ptr = C_alloc(av2_size);7627 *(ptr++) = fn;7628 *(ptr++) = k;76297630 if(non_list_args > 0) {7631 C_memcpy(ptr, av + 3, non_list_args * sizeof(C_word));7632 ptr += non_list_args;7633 }76347635 while(len--) {7636 *(ptr++) = C_u_i_car(lst);7637 lst = C_u_i_cdr(lst);7638 }76397640 assert((ptr - av2) == av2_size);76417642 ((C_proc)(void *)C_block_item(fn, 0))(av2_size, av2);7643}764476457646void C_ccall C_call_cc(C_word c, C_word *av)7647{7648 C_word7649 /* closure = av[ 0 ] */7650 k = av[ 1 ],7651 cont = av[ 2 ],7652 *a = C_alloc(C_SIZEOF_CLOSURE(2)),7653 wrapper;7654 void *pr = (void *)C_block_item(cont,0);7655 C_word av2[ 3 ];76567657 if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)7658 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);76597660 /* Check for values-continuation: */7661 if(C_block_item(k, 0) == (C_word)values_continuation)7662 wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);7663 else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);76647665 av2[ 0 ] = cont;7666 av2[ 1 ] = k;7667 av2[ 2 ] = wrapper;7668 ((C_proc)pr)(3, av2);7669}767076717672void C_ccall call_cc_wrapper(C_word c, C_word *av)7673{7674 C_word7675 closure = av[ 0 ],7676 /* av[ 1 ] is current k and ignored */7677 result,7678 k = C_block_item(closure, 1);76797680 if(c != 3) C_bad_argc(c, 3);76817682 result = av[ 2 ];7683 C_kontinue(k, result);7684}768576867687void C_ccall call_cc_values_wrapper(C_word c, C_word *av)7688{7689 C_word7690 closure = av[ 0 ],7691 /* av[ 1 ] is current k and ignored */7692 k = C_block_item(closure, 1),7693 x1,7694 n = c;76957696 av[ 0 ] = k; /* reuse av */7697 C_memmove(av + 1, av + 2, (n - 1) * sizeof(C_word));7698 C_do_apply(n - 1, av);7699}770077017702void C_ccall C_continuation_graft(C_word c, C_word *av)7703{7704 C_word7705 /* self = av[ 0 ] */7706 /* k = av[ 1 ] */7707 kk = av[ 2 ],7708 proc = av[ 3 ];77097710 av[ 0 ] = proc; /* reuse av */7711 av[ 1 ] = C_block_item(kk, 1);7712 ((C_proc)C_fast_retrieve_proc(proc))(2, av);7713}771477157716void C_ccall C_values(C_word c, C_word *av)7717{7718 C_word7719 /* closure = av[ 0 ] */7720 k = av[ 1 ],7721 n = c;77227723 if(c < 2) C_bad_min_argc(c, 2);77247725 /* Check continuation whether it receives multiple values: */7726 if(C_block_item(k, 0) == (C_word)values_continuation) {7727 av[ 0 ] = k; /* reuse av */7728 C_memmove(av + 1, av + 2, (c - 2) * sizeof(C_word));7729 C_do_apply(c - 1, av);7730 }77317732 if(c != 3) {7733#ifdef RELAX_MULTIVAL_CHECK7734 if(c == 2) n = C_SCHEME_UNDEFINED;7735 else n = av[ 2 ];7736#else7737 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7738#endif7739 }7740 else n = av[ 2 ];77417742 C_kontinue(k, n);7743}774477457746void C_ccall C_apply_values(C_word c, C_word *av)7747{7748 C_word7749 /* closure = av[ 0 ] */7750 k = av[ 1 ],7751 lst, len, n;77527753 if(c != 3) C_bad_argc(c, 3);77547755 lst = av[ 2 ];77567757 if(lst != C_SCHEME_END_OF_LIST && (C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))7758 barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);77597760 /* Check whether continuation receives multiple values: */7761 if(C_block_item(k, 0) == (C_word)values_continuation) {7762 C_word *av2, *ptr;77637764 len = C_unfix(C_u_i_length(lst));7765 n = len + 1;77667767 if(C_demand(n))7768 stack_check_demand = 0;7769 else if(stack_check_demand)7770 C_stack_overflow("apply");7771 else {7772 stack_check_demand = n;7773 C_save_and_reclaim((void *)C_apply_values, c, av);7774 }77757776 av2 = C_alloc(n);7777 av2[ 0 ] = k;7778 ptr = av2 + 1;7779 while(len--) {7780 *(ptr++) = C_u_i_car(lst);7781 lst = C_u_i_cdr(lst);7782 }77837784 C_do_apply(n, av2);7785 }77867787 if(C_immediatep(lst)) {7788#ifdef RELAX_MULTIVAL_CHECK7789 n = C_SCHEME_UNDEFINED;7790#else7791 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7792#endif7793 }7794 else if(C_header_type(lst) == C_PAIR_TYPE) {7795 if(C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)7796 n = C_u_i_car(lst);7797 else {7798#ifdef RELAX_MULTIVAL_CHECK7799 n = C_u_i_car(lst);7800#else7801 barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);7802#endif7803 }7804 }7805 else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);78067807 C_kontinue(k, n);7808}780978107811void C_ccall C_call_with_values(C_word c, C_word *av)7812{7813 C_word7814 /* closure = av[ 0 ] */7815 k = av[ 1 ],7816 thunk,7817 kont,7818 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7819 kk;78207821 if(c != 4) C_bad_argc(c, 4);78227823 thunk = av[ 2 ];7824 kont = av[ 3 ];78257826 if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)7827 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);78287829 if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)7830 barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);78317832 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7833 av[ 0 ] = thunk; /* reuse av */7834 av[ 1 ] = kk;7835 C_do_apply(2, av);7836}783778387839void C_ccall C_u_call_with_values(C_word c, C_word *av)7840{7841 C_word7842 /* closure = av[ 0 ] */7843 k = av[ 1 ],7844 thunk = av[ 2 ],7845 kont = av[ 3 ],7846 *a = C_alloc(C_SIZEOF_CLOSURE(3)),7847 kk;78487849 kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);7850 av[ 0 ] = thunk; /* reuse av */7851 av[ 1 ] = kk;7852 C_do_apply(2, av);7853}785478557856void C_ccall values_continuation(C_word c, C_word *av)7857{7858 C_word7859 closure = av[ 0 ],7860 kont = C_block_item(closure, 1),7861 k = C_block_item(closure, 2),7862 *av2 = C_alloc(c + 1);78637864 av2[ 0 ] = kont;7865 av2[ 1 ] = k;7866 C_memcpy(av2 + 2, av + 1, (c - 1) * sizeof(C_word));7867 C_do_apply(c + 1, av2);7868}78697870static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i)7871{7872 C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab, num, denom, gcd, a_div_g;78737874 switch (i) {7875 case C_fix(0): return C_fix(0);7876 case C_fix(1): return rat;7877 case C_fix(-1):7878 num = C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(rat));7879 return C_ratnum(ptr, num , C_u_i_ratnum_denom(rat));7880 /* default: CONTINUE BELOW */7881 }78827883 num = C_u_i_ratnum_num(rat);7884 denom = C_u_i_ratnum_denom(rat);78857886 /* a/b * c/d = a*c / b*d [with b = 1] */7887 /* = ((a / g) * c) / (d / g) */7888 /* With g = gcd(a, d) and a = x [Knuth, 4.5.1] */7889 gcd = C_s_a_u_i_integer_gcd(&a, 2, i, denom);78907891 /* Calculate a/g (= i/gcd), which will later be multiplied by y */7892 a_div_g = C_s_a_u_i_integer_quotient(&a, 2, i, gcd);7893 if (a_div_g == C_fix(0)) {7894 clear_buffer_object(ab, gcd);7895 return C_fix(0); /* Save some work */7896 }78977898 /* Final numerator = a/g * c (= a_div_g * num) */7899 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g, num);79007901 /* Final denominator = d/g (= denom/gcd) */7902 denom = C_s_a_u_i_integer_quotient(ptr, 2, denom, gcd);79037904 num = move_buffer_object(ptr, ab, num);7905 denom = move_buffer_object(ptr, ab, denom);79067907 clear_buffer_object(ab, gcd);7908 clear_buffer_object(ab, a_div_g);79097910 if (denom == C_fix(1)) return num;7911 else return C_ratnum(ptr, num, denom);7912}79137914static C_word rat_times_rat(C_word **ptr, C_word x, C_word y)7915{7916 C_word ab[C_SIZEOF_FIX_BIGNUM * 6], *a = ab,7917 num, denom, xnum, xdenom, ynum, ydenom,7918 g1, g2, a_div_g1, b_div_g2, c_div_g2, d_div_g1;79197920 xnum = C_u_i_ratnum_num(x);7921 xdenom = C_u_i_ratnum_denom(x);7922 ynum = C_u_i_ratnum_num(y);7923 ydenom = C_u_i_ratnum_denom(y);79247925 /* a/b * c/d = a*c / b*d [generic] */7926 /* = ((a / g1) * (c / g2)) / ((b / g2) * (d / g1)) */7927 /* With g1 = gcd(a, d) and g2 = gcd(b, c) [Knuth, 4.5.1] */7928 g1 = C_s_a_u_i_integer_gcd(&a, 2, xnum, ydenom);7929 g2 = C_s_a_u_i_integer_gcd(&a, 2, ynum, xdenom);79307931 /* Calculate a/g1 (= xnum/g1), which will later be multiplied by c/g2 */7932 a_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, xnum, g1);79337934 /* Calculate c/g2 (= ynum/g2), which will later be multiplied by a/g1 */7935 c_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, ynum, g2);79367937 /* Final numerator = a/g1 * c/g2 */7938 num = C_s_a_u_i_integer_times(ptr, 2, a_div_g1, c_div_g2);79397940 /* Now, do the same for the denominator.... */79417942 /* Calculate b/g2 (= xdenom/g2), which will later be multiplied by d/g1 */7943 b_div_g2 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g2);79447945 /* Calculate d/g1 (= ydenom/g1), which will later be multiplied by b/g2 */7946 d_div_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);79477948 /* Final denominator = b/g2 * d/g1 */7949 denom = C_s_a_u_i_integer_times(ptr, 2, b_div_g2, d_div_g1);79507951 num = move_buffer_object(ptr, ab, num);7952 denom = move_buffer_object(ptr, ab, denom);79537954 clear_buffer_object(ab, g1);7955 clear_buffer_object(ab, g2);7956 clear_buffer_object(ab, a_div_g1);7957 clear_buffer_object(ab, b_div_g2);7958 clear_buffer_object(ab, c_div_g2);7959 clear_buffer_object(ab, d_div_g1);79607961 if (denom == C_fix(1)) return num;7962 else return C_ratnum(ptr, num, denom);7963}79647965static C_word7966cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)7967{7968 /* Allocation here is kind of tricky: Each intermediate result can7969 * be at most a ratnum consisting of two bignums (2 digits), so7970 * C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2) = 9 words7971 */7972 C_word ab[(C_SIZEOF_RATNUM + C_SIZEOF_BIGNUM(2))*6], *a = ab,7973 r1, r2, i1, i2, r, i;79747975 /* a+bi * c+di = (a*c - b*d) + (a*d + b*c)i */7976 /* We call these: r1 = a*c, r2 = b*d, i1 = a*d, i2 = b*c */7977 r1 = C_s_a_i_times(&a, 2, rx, ry);7978 r2 = C_s_a_i_times(&a, 2, ix, iy);7979 i1 = C_s_a_i_times(&a, 2, rx, iy);7980 i2 = C_s_a_i_times(&a, 2, ix, ry);79817982 r = C_s_a_i_minus(ptr, 2, r1, r2);7983 i = C_s_a_i_plus(ptr, 2, i1, i2);79847985 r = move_buffer_object(ptr, ab, r);7986 i = move_buffer_object(ptr, ab, i);79877988 clear_buffer_object(ab, r1);7989 clear_buffer_object(ab, r2);7990 clear_buffer_object(ab, i1);7991 clear_buffer_object(ab, i2);79927993 if (C_truep(C_u_i_zerop2(i))) return r;7994 else return C_cplxnum(ptr, r, i);7995}79967997/* The maximum size this needs is that required to store a complex7998 * number result, where both real and imag parts consist of ratnums.7999 * The maximum size of those ratnums is if they consist of two bignums8000 * from a fixnum multiplication (2 digits each), so we're looking at8001 * C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words!8002 */8003C_regparm C_word C_fcall8004C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)8005{8006 if (x & C_FIXNUM_BIT) {8007 if (y & C_FIXNUM_BIT) {8008 return C_a_i_fixnum_times(ptr, 2, x, y);8009 } else if (C_immediatep(y)) {8010 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8011 } else if (C_block_header(y) == C_FLONUM_TAG) {8012 return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y));8013 } else if (C_truep(C_bignump(y))) {8014 return C_s_a_u_i_integer_times(ptr, 2, x, y);8015 } else if (C_block_header(y) == C_RATNUM_TAG) {8016 return rat_times_integer(ptr, y, x);8017 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8018 return cplx_times(ptr, x, C_fix(0),8019 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8020 } else {8021 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8022 }8023 } else if (C_immediatep(x)) {8024 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8025 } else if (C_block_header(x) == C_FLONUM_TAG) {8026 if (y & C_FIXNUM_BIT) {8027 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y));8028 } else if (C_immediatep(y)) {8029 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8030 } else if (C_block_header(y) == C_FLONUM_TAG) {8031 return C_a_i_flonum_times(ptr, 2, x, y);8032 } else if (C_truep(C_bignump(y))) {8033 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y));8034 } else if (C_block_header(y) == C_RATNUM_TAG) {8035 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8036 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8037 C_word ab[C_SIZEOF_FLONUM], *a = ab;8038 return cplx_times(ptr, x, C_flonum(&a, 0.0),8039 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8040 } else {8041 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8042 }8043 } else if (C_truep(C_bignump(x))) {8044 if (y & C_FIXNUM_BIT) {8045 return C_s_a_u_i_integer_times(ptr, 2, x, y);8046 } else if (C_immediatep(y)) {8047 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8048 } else if (C_block_header(y) == C_FLONUM_TAG) {8049 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y));8050 } else if (C_truep(C_bignump(y))) {8051 return C_s_a_u_i_integer_times(ptr, 2, x, y);8052 } else if (C_block_header(y) == C_RATNUM_TAG) {8053 return rat_times_integer(ptr, y, x);8054 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8055 return cplx_times(ptr, x, C_fix(0),8056 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8057 } else {8058 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8059 }8060 } else if (C_block_header(x) == C_RATNUM_TAG) {8061 if (y & C_FIXNUM_BIT) {8062 return rat_times_integer(ptr, x, y);8063 } else if (C_immediatep(y)) {8064 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8065 } else if (C_block_header(y) == C_FLONUM_TAG) {8066 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8067 } else if (C_truep(C_bignump(y))) {8068 return rat_times_integer(ptr, x, y);8069 } else if (C_block_header(y) == C_RATNUM_TAG) {8070 return rat_times_rat(ptr, x, y);8071 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8072 return cplx_times(ptr, x, C_fix(0),8073 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8074 } else {8075 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);8076 }8077 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8078 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8079 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x),8080 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y));8081 } else {8082 C_word ab[C_SIZEOF_FLONUM], *a = ab, yi;8083 yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0);8084 return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi);8085 }8086 } else {8087 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x);8088 }8089}809080918092C_regparm C_word C_fcall8093C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)8094{8095 if (x & C_FIXNUM_BIT) {8096 if (y & C_FIXNUM_BIT) {8097 return C_a_i_fixnum_times(ptr, 2, x, y);8098 } else {8099 C_word tmp = x; /* swap to ensure x is a bignum and y a fixnum */8100 x = y;8101 y = tmp;8102 }8103 }8104 /* Here, we know for sure that X is a bignum */8105 if (y == C_fix(0)) {8106 return C_fix(0);8107 } else if (y == C_fix(1)) {8108 return x;8109 } else if (y == C_fix(-1)) {8110 return C_s_a_u_i_integer_negate(ptr, 1, x);8111 } else if (y & C_FIXNUM_BIT) { /* Any other fixnum */8112 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y),8113 negp = C_mk_bool((y & C_INT_SIGN_BIT) ?8114 !C_bignum_negativep(x) :8115 C_bignum_negativep(x));81168117 if (C_fitsinbignumhalfdigitp(absy) ||8118 (((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {8119 C_word size, res;8120 C_uword *startr, *endr;8121 int shift;8122 size = C_bignum_size(x) + 1; /* Needs _at most_ one more digit */8123 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);81248125 bignum_digits_destructive_copy(res, x);81268127 startr = C_bignum_digits(res);8128 endr = startr + size - 1;8129 /* Scale up, and sanitise the result. */8130 shift = C_ilen(absy) - 1;8131 if (((C_uword)1 << shift) == absy) { /* Power of two? */8132 *endr = bignum_digits_destructive_shift_left(startr, endr, shift);8133 } else {8134 *endr = bignum_digits_destructive_scale_up_with_carry(startr, endr,8135 absy, 0);8136 }8137 return C_bignum_simplify(res);8138 } else {8139 C_word *a = C_alloc(C_SIZEOF_FIX_BIGNUM);8140 y = C_a_u_i_fix_to_big(&a, y);8141 return bignum_times_bignum_unsigned(ptr, x, y, negp);8142 }8143 } else {8144 C_word negp = C_bignum_negativep(x) ?8145 !C_bignum_negativep(y) :8146 C_bignum_negativep(y);8147 return bignum_times_bignum_unsigned(ptr, x, y, C_mk_bool(negp));8148 }8149}81508151static C_regparm C_word8152bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8153{8154 C_word size, res = C_SCHEME_FALSE;8155 if (C_bignum_size(y) < C_bignum_size(x)) { /* Ensure size(x) <= size(y) */8156 C_word z = x;8157 x = y;8158 y = z;8159 }81608161 if (C_bignum_size(x) >= C_KARATSUBA_THRESHOLD)8162 res = bignum_times_bignum_karatsuba(ptr, x, y, negp);81638164 if (!C_truep(res)) {8165 size = C_bignum_size(x) + C_bignum_size(y);8166 res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_TRUE);8167 bignum_digits_multiply(x, y, res);8168 res = C_bignum_simplify(res);8169 }8170 return res;8171}81728173/* Karatsuba multiplication: invoked when the two numbers are large8174 * enough to make it worthwhile, and we still have enough stack left.8175 * Complexity is O(n^log2(3)), where n is max(len(x), len(y)). The8176 * description in [Knuth, 4.3.3] leaves a lot to be desired. [MCA,8177 * 1.3.2] and [MpNT, 3.2] are a bit easier to understand. We assume8178 * that length(x) <= length(y).8179 */8180static C_regparm C_word8181bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)8182{8183 C_word kab[C_SIZEOF_FIX_BIGNUM*15+C_SIZEOF_BIGNUM(2)*3], *ka = kab, o[18],8184 xhi, xlo, xmid, yhi, ylo, ymid, a, b, c, n, bits;8185 int i = 0;81868187 /* Ran out of stack? Fall back to non-recursive multiplication */8188 C_stack_check1(return C_SCHEME_FALSE);81898190 /* Split |x| in half: <xhi,xlo> and |y|: <yhi,ylo> with len(ylo)=len(xlo) */8191 x = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, x);8192 y = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, y);8193 n = C_fix(C_bignum_size(y) >> 1);8194 xhi = o[i++] = bignum_extract_digits(&ka, 3, x, n, C_SCHEME_FALSE);8195 xlo = o[i++] = bignum_extract_digits(&ka, 3, x, C_fix(0), n);8196 yhi = o[i++] = bignum_extract_digits(&ka, 3, y, n, C_SCHEME_FALSE);8197 ylo = o[i++] = bignum_extract_digits(&ka, 3, y, C_fix(0), n);81988199 /* a = xhi * yhi, b = xlo * ylo, c = (xhi - xlo) * (yhi - ylo) */8200 a = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xhi, yhi);8201 b = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xlo, ylo);8202 xmid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, xhi, xlo);8203 ymid = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, yhi, ylo);8204 c = o[i++] = C_s_a_u_i_integer_times(&ka, 2, xmid, ymid);82058206 /* top(x) = a << (bits - 1) and bottom(y) = ((b + (a - c)) << bits) + b */8207 bits = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;8208 x = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, a, C_fix((C_uword)bits << 1));8209 c = o[i++] = C_s_a_u_i_integer_minus(&ka, 2, a, c);8210 c = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, b, c);8211 c = o[i++] = C_s_a_i_arithmetic_shift(&ka, 2, c, C_fix(bits));8212 y = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, c, b);8213 /* Finally, return top + bottom, and correct for negative */8214 n = o[i++] = C_s_a_u_i_integer_plus(&ka, 2, x, y);8215 if (C_truep(negp)) n = o[i++] = C_s_a_u_i_integer_negate(&ka, 1, n);82168217 n = move_buffer_object(ptr, kab, n);8218 while(i--) clear_buffer_object(kab, o[i]);8219 return n;8220}82218222void C_ccall C_times(C_word c, C_word *av)8223{8224 /* C_word closure = av[ 0 ]; */8225 C_word k = av[ 1 ];8226 C_word next_val,8227 result = C_fix(1),8228 prev_result = result;8229 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a;82308231 c -= 2;8232 av += 2;82338234 while (c--) {8235 next_val = *(av++);8236 a = ab[c&1]; /* One may hold prev iteration result, the other is unused */8237 result = C_s_a_i_times(&a, 2, result, next_val);8238 result = move_buffer_object(&a, ab[(c+1)&1], result);8239 clear_buffer_object(ab[(c+1)&1], prev_result);8240 prev_result = result;8241 }82428243 C_kontinue(k, result);8244}824582468247static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp)8248{8249 C_word size, result;8250 C_uword sum, digit, *scan_y, *end_y, *scan_r, *end_r;8251 int carry = 0;82528253 if (C_bignum_size(y) > C_bignum_size(x)) { /* Ensure size(y) <= size(x) */8254 C_word z = x;8255 x = y;8256 y = z;8257 }82588259 size = C_fix(C_bignum_size(x) + 1); /* One more digit, for possible carry. */8260 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);82618262 scan_y = C_bignum_digits(y);8263 end_y = scan_y + C_bignum_size(y);8264 scan_r = C_bignum_digits(result);8265 end_r = scan_r + C_bignum_size(result);82668267 /* Copy x into r so we can operate on two pointers, which is faster8268 * than three, and we can stop earlier after adding y. It's slower8269 * if x and y have equal length. On average it's slightly faster.8270 */8271 bignum_digits_destructive_copy(result, x);8272 *(end_r-1) = 0; /* Ensure most significant digit is initialised */82738274 /* Move over x and y simultaneously, destructively adding digits w/ carry. */8275 while (scan_y < end_y) {8276 digit = *scan_r;8277 if (carry) {8278 sum = digit + *scan_y++ + 1;8279 carry = sum <= digit;8280 } else {8281 sum = digit + *scan_y++;8282 carry = sum < digit;8283 }8284 (*scan_r++) = sum;8285 }82868287 /* The end of y, the smaller number. Propagate carry into the rest of x. */8288 while (carry) {8289 sum = (*scan_r) + 1;8290 carry = (sum == 0);8291 (*scan_r++) = sum;8292 }8293 assert(scan_r <= end_r);82948295 return C_bignum_simplify(result);8296}82978298static C_word rat_plusmin_integer(C_word **ptr, C_word rat, C_word i, integer_plusmin_op plusmin_op)8299{8300 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8301 num, denom, tmp, res;83028303 if (i == C_fix(0)) return rat;83048305 num = C_u_i_ratnum_num(rat);8306 denom = C_u_i_ratnum_denom(rat);83078308 /* a/b [+-] c/d = (a*d [+-] b*c)/(b*d) | d = 1: (num + denom * i) / denom */8309 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8310 res = plusmin_op(&a, 2, num, tmp);8311 res = move_buffer_object(ptr, ab, res);8312 clear_buffer_object(ab, tmp);8313 return C_ratnum(ptr, res, denom);8314}83158316/* This is needed only for minus: plus is commutative but minus isn't. */8317static C_word integer_minus_rat(C_word **ptr, C_word i, C_word rat)8318{8319 C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_BIGNUM(2)], *a = ab,8320 num, denom, tmp, res;83218322 num = C_u_i_ratnum_num(rat);8323 denom = C_u_i_ratnum_denom(rat);83248325 if (i == C_fix(0))8326 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, num), denom);83278328 /* a/b - c/d = (a*d - b*c)/(b*d) | b = 1: (denom * i - num) / denom */8329 tmp = C_s_a_u_i_integer_times(&a, 2, denom, i);8330 res = C_s_a_u_i_integer_minus(&a, 2, tmp, num);8331 res = move_buffer_object(ptr, ab, res);8332 clear_buffer_object(ab, tmp);8333 return C_ratnum(ptr, res, denom);8334}83358336/* This is pretty braindead and ugly */8337static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_op plusmin_op)8338{8339 C_word ab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)*2], *a = ab,8340 xnum = C_u_i_ratnum_num(x), ynum = C_u_i_ratnum_num(y),8341 xdenom = C_u_i_ratnum_denom(x), ydenom = C_u_i_ratnum_denom(y),8342 xnorm, ynorm, tmp_r, g1, ydenom_g1, xdenom_g1, norm_sum, g2, len,8343 res_num, res_denom;83448345 /* Knuth, 4.5.1. Start with g1 = gcd(xdenom, ydenom) */8346 g1 = C_s_a_u_i_integer_gcd(&a, 2, xdenom, ydenom);83478348 /* xnorm = xnum * (ydenom/g1) */8349 ydenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g1);8350 xnorm = C_s_a_u_i_integer_times(&a, 2, xnum, ydenom_g1);83518352 /* ynorm = ynum * (xdenom/g1) */8353 xdenom_g1 = C_s_a_u_i_integer_quotient(&a, 2, xdenom, g1);8354 ynorm = C_s_a_u_i_integer_times(&a, 2, ynum, xdenom_g1);83558356 /* norm_sum = xnorm [+-] ynorm */8357 norm_sum = plusmin_op(&a, 2, xnorm, ynorm);83588359 /* g2 = gcd(norm_sum, g1) */8360 g2 = C_s_a_u_i_integer_gcd(&a, 2, norm_sum, g1);83618362 /* res_num = norm_sum / g2 */8363 res_num = C_s_a_u_i_integer_quotient(ptr, 2, norm_sum, g2);8364 if (res_num == C_fix(0)) {8365 res_denom = C_fix(0); /* No need to calculate denom: we'll return 0 */8366 } else {8367 /* res_denom = xdenom_g1 * (ydenom / g2) */8368 C_word res_tmp_denom = C_s_a_u_i_integer_quotient(&a, 2, ydenom, g2);8369 res_denom = C_s_a_u_i_integer_times(ptr, 2, xdenom_g1, res_tmp_denom);83708371 /* Ensure they're allocated in the correct place */8372 res_num = move_buffer_object(ptr, ab, res_num);8373 res_denom = move_buffer_object(ptr, ab, res_denom);8374 clear_buffer_object(ab, res_tmp_denom);8375 }83768377 clear_buffer_object(ab, xdenom_g1);8378 clear_buffer_object(ab, ydenom_g1);8379 clear_buffer_object(ab, xnorm);8380 clear_buffer_object(ab, ynorm);8381 clear_buffer_object(ab, norm_sum);8382 clear_buffer_object(ab, g1);8383 clear_buffer_object(ab, g2);83848385 switch (res_denom) {8386 case C_fix(0): return C_fix(0);8387 case C_fix(1): return res_num;8388 default: return C_ratnum(ptr, res_num, res_denom);8389 }8390}83918392/* The maximum size this needs is that required to store a complex8393 * number result, where both real and imag parts consist of ratnums.8394 * The maximum size of those ratnums is if they consist of two "fix8395 * bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM *8396 * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!8397 */8398C_regparm C_word C_fcall8399C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)8400{8401 if (x & C_FIXNUM_BIT) {8402 if (y & C_FIXNUM_BIT) {8403 return C_a_i_fixnum_plus(ptr, 2, x, y);8404 } else if (C_immediatep(y)) {8405 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8406 } else if (C_block_header(y) == C_FLONUM_TAG) {8407 return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y));8408 } else if (C_truep(C_bignump(y))) {8409 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8410 } else if (C_block_header(y) == C_RATNUM_TAG) {8411 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8412 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8413 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8414 imag = C_u_i_cplxnum_imag(y);8415 if (C_truep(C_u_i_inexactp(real_sum)))8416 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8417 return C_cplxnum(ptr, real_sum, imag);8418 } else {8419 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8420 }8421 } else if (C_immediatep(x)) {8422 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8423 } else if (C_block_header(x) == C_FLONUM_TAG) {8424 if (y & C_FIXNUM_BIT) {8425 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y));8426 } else if (C_immediatep(y)) {8427 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8428 } else if (C_block_header(y) == C_FLONUM_TAG) {8429 return C_a_i_flonum_plus(ptr, 2, x, y);8430 } else if (C_truep(C_bignump(y))) {8431 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y));8432 } else if (C_block_header(y) == C_RATNUM_TAG) {8433 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8434 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8435 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8436 imag = C_u_i_cplxnum_imag(y);8437 if (C_truep(C_u_i_inexactp(real_sum)))8438 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8439 return C_cplxnum(ptr, real_sum, imag);8440 } else {8441 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8442 }8443 } else if (C_truep(C_bignump(x))) {8444 if (y & C_FIXNUM_BIT) {8445 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8446 } else if (C_immediatep(y)) {8447 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8448 } else if (C_block_header(y) == C_FLONUM_TAG) {8449 return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y));8450 } else if (C_truep(C_bignump(y))) {8451 return C_s_a_u_i_integer_plus(ptr, 2, x, y);8452 } else if (C_block_header(y) == C_RATNUM_TAG) {8453 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus);8454 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8455 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8456 imag = C_u_i_cplxnum_imag(y);8457 if (C_truep(C_u_i_inexactp(real_sum)))8458 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8459 return C_cplxnum(ptr, real_sum, imag);8460 } else {8461 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8462 }8463 } else if (C_block_header(x) == C_RATNUM_TAG) {8464 if (y & C_FIXNUM_BIT) {8465 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8466 } else if (C_immediatep(y)) {8467 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8468 } else if (C_block_header(y) == C_FLONUM_TAG) {8469 return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8470 } else if (C_truep(C_bignump(y))) {8471 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus);8472 } else if (C_block_header(y) == C_RATNUM_TAG) {8473 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus);8474 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8475 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)),8476 imag = C_u_i_cplxnum_imag(y);8477 if (C_truep(C_u_i_inexactp(real_sum)))8478 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8479 return C_cplxnum(ptr, real_sum, imag);8480 } else {8481 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8482 }8483 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8484 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8485 C_word real_sum, imag_sum;8486 real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y));8487 imag_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y));8488 if (C_truep(C_u_i_zerop2(imag_sum))) return real_sum;8489 else return C_cplxnum(ptr, real_sum, imag_sum);8490 } else {8491 C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y),8492 imag = C_u_i_cplxnum_imag(x);8493 if (C_truep(C_u_i_inexactp(real_sum)))8494 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8495 return C_cplxnum(ptr, real_sum, imag);8496 }8497 } else {8498 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x);8499 }8500}85018502C_regparm C_word C_fcall8503C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y)8504{8505 if ((x & y) & C_FIXNUM_BIT) {8506 return C_a_i_fixnum_plus(ptr, 2, x, y);8507 } else {8508 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8509 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8510 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);85118512 if (C_bignum_negativep(x)) {8513 if (C_bignum_negativep(y)) {8514 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8515 } else {8516 return bignum_minus_unsigned(ptr, y, x);8517 }8518 } else {8519 if (C_bignum_negativep(y)) {8520 return bignum_minus_unsigned(ptr, x, y);8521 } else {8522 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8523 }8524 }8525 }8526}85278528void C_ccall C_plus(C_word c, C_word *av)8529{8530 /* C_word closure = av[ 0 ]; */8531 C_word k = av[ 1 ];8532 C_word next_val,8533 result = C_fix(0),8534 prev_result = result;8535 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;85368537 c -= 2;8538 av += 2;85398540 while (c--) {8541 next_val = *(av++);8542 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8543 result = C_s_a_i_plus(&a, 2, result, next_val);8544 result = move_buffer_object(&a, ab[(c+1)&1], result);8545 clear_buffer_object(ab[(c+1)&1], prev_result);8546 prev_result = result;8547 }85488549 C_kontinue(k, result);8550}85518552static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)8553{8554 C_word res, size;8555 C_uword *scan_r, *end_r, *scan_y, *end_y, difference, digit;8556 int borrow = 0;85578558 switch(bignum_cmp_unsigned(x, y)) {8559 case 0: /* x = y, return 0 */8560 return C_fix(0);8561 case -1: /* abs(x) < abs(y), return -(abs(y) - abs(x)) */8562 size = C_fix(C_bignum_size(y)); /* Maximum size of result is length of y. */8563 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_TRUE, C_SCHEME_FALSE);8564 size = y;8565 y = x;8566 x = size;8567 break;8568 case 1: /* abs(x) > abs(y), return abs(x) - abs(y) */8569 default:8570 size = C_fix(C_bignum_size(x)); /* Maximum size of result is length of x. */8571 res = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);8572 break;8573 }85748575 scan_r = C_bignum_digits(res);8576 end_r = scan_r + C_bignum_size(res);8577 scan_y = C_bignum_digits(y);8578 end_y = scan_y + C_bignum_size(y);85798580 bignum_digits_destructive_copy(res, x); /* See bignum_plus_unsigned */85818582 /* Destructively subtract y's digits w/ borrow from and back into r. */8583 while (scan_y < end_y) {8584 digit = *scan_r;8585 if (borrow) {8586 difference = digit - *scan_y++ - 1;8587 borrow = difference >= digit;8588 } else {8589 difference = digit - *scan_y++;8590 borrow = difference > digit;8591 }8592 (*scan_r++) = difference;8593 }85948595 /* The end of y, the smaller number. Propagate borrow into the rest of x. */8596 while (borrow) {8597 digit = *scan_r;8598 difference = digit - borrow;8599 borrow = difference >= digit;8600 (*scan_r++) = difference;8601 }86028603 assert(scan_r <= end_r);86048605 return C_bignum_simplify(res);8606}86078608/* Like C_s_a_i_plus, this needs at most 29 words */8609C_regparm C_word C_fcall8610C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)8611{8612 if (x & C_FIXNUM_BIT) {8613 if (y & C_FIXNUM_BIT) {8614 return C_a_i_fixnum_difference(ptr, 2, x, y);8615 } else if (C_immediatep(y)) {8616 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8617 } else if (C_block_header(y) == C_FLONUM_TAG) {8618 return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y));8619 } else if (C_truep(C_bignump(y))) {8620 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8621 } else if (C_block_header(y) == C_RATNUM_TAG) {8622 return integer_minus_rat(ptr, x, y);8623 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8624 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8625 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8626 if (C_truep(C_u_i_inexactp(real_diff)))8627 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8628 return C_cplxnum(ptr, real_diff, imag);8629 } else {8630 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8631 }8632 } else if (C_immediatep(x)) {8633 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8634 } else if (C_block_header(x) == C_FLONUM_TAG) {8635 if (y & C_FIXNUM_BIT) {8636 return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y));8637 } else if (C_immediatep(y)) {8638 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8639 } else if (C_block_header(y) == C_FLONUM_TAG) {8640 return C_a_i_flonum_difference(ptr, 2, x, y);8641 } else if (C_truep(C_bignump(y))) {8642 return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y));8643 } else if (C_block_header(y) == C_RATNUM_TAG) {8644 return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y));8645 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8646 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8647 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8648 if (C_truep(C_u_i_inexactp(real_diff)))8649 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8650 return C_cplxnum(ptr, real_diff, imag);8651 } else {8652 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8653 }8654 } else if (C_truep(C_bignump(x))) {8655 if (y & C_FIXNUM_BIT) {8656 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8657 } else if (C_immediatep(y)) {8658 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8659 } else if (C_block_header(y) == C_FLONUM_TAG) {8660 return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y));8661 } else if (C_truep(C_bignump(y))) {8662 return C_s_a_u_i_integer_minus(ptr, 2, x, y);8663 } else if (C_block_header(y) == C_RATNUM_TAG) {8664 return integer_minus_rat(ptr, x, y);8665 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8666 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8667 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8668 if (C_truep(C_u_i_inexactp(real_diff)))8669 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8670 return C_cplxnum(ptr, real_diff, imag);8671 } else {8672 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8673 }8674 } else if (C_block_header(x) == C_RATNUM_TAG) {8675 if (y & C_FIXNUM_BIT) {8676 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8677 } else if (C_immediatep(y)) {8678 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8679 } else if (C_block_header(y) == C_FLONUM_TAG) {8680 return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y);8681 } else if (C_truep(C_bignump(y))) {8682 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus);8683 } else if (C_block_header(y) == C_RATNUM_TAG) {8684 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus);8685 } else if (C_block_header(y) == C_CPLXNUM_TAG) {8686 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)),8687 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y));8688 if (C_truep(C_u_i_inexactp(real_diff)))8689 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8690 return C_cplxnum(ptr, real_diff, imag);8691 } else {8692 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);8693 }8694 } else if (C_block_header(x) == C_CPLXNUM_TAG) {8695 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) {8696 C_word real_diff, imag_diff;8697 real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y));8698 imag_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_imag(x),C_u_i_cplxnum_imag(y));8699 if (C_truep(C_u_i_zerop2(imag_diff))) return real_diff;8700 else return C_cplxnum(ptr, real_diff, imag_diff);8701 } else {8702 C_word real_diff = C_s_a_i_minus(ptr, 2, C_u_i_cplxnum_real(x), y),8703 imag = C_u_i_cplxnum_imag(x);8704 if (C_truep(C_u_i_inexactp(real_diff)))8705 imag = C_a_i_exact_to_inexact(ptr, 1, imag);8706 return C_cplxnum(ptr, real_diff, imag);8707 }8708 } else {8709 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8710 }8711}87128713C_regparm C_word C_fcall8714C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y)8715{8716 if ((x & y) & C_FIXNUM_BIT) {8717 return C_a_i_fixnum_difference(ptr, 2, x, y);8718 } else {8719 C_word ab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_BIGNUM_WRAPPER], *a = ab;8720 if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);8721 if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);87228723 if (C_bignum_negativep(x)) {8724 if (C_bignum_negativep(y)) {8725 return bignum_minus_unsigned(ptr, y, x);8726 } else {8727 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_TRUE);8728 }8729 } else {8730 if (C_bignum_negativep(y)) {8731 return bignum_plus_unsigned(ptr, x, y, C_SCHEME_FALSE);8732 } else {8733 return bignum_minus_unsigned(ptr, x, y);8734 }8735 }8736 }8737}87388739void C_ccall C_minus(C_word c, C_word *av)8740{8741 /* C_word closure = av[ 0 ]; */8742 C_word k = av[ 1 ];8743 C_word next_val, result, prev_result;8744 C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;87458746 if (c < 3) {8747 C_bad_min_argc(c, 3);8748 } else if (c == 3) {8749 a = ab[0];8750 C_kontinue(k, C_s_a_i_negate(&a, 1, av[ 2 ]));8751 } else {8752 prev_result = result = av[ 2 ];8753 c -= 3;8754 av += 3;87558756 while (c--) {8757 next_val = *(av++);8758 a = ab[c&1]; /* One may hold last iteration result, the other is unused */8759 result = C_s_a_i_minus(&a, 2, result, next_val);8760 result = move_buffer_object(&a, ab[(c+1)&1], result);8761 clear_buffer_object(ab[(c+1)&1], prev_result);8762 prev_result = result;8763 }87648765 C_kontinue(k, result);8766 }8767}876887698770static C_regparm void8771integer_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8772{8773 if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */8774 if (x & C_FIXNUM_BIT) {8775 /* abs(x) < abs(y), so it will always be [0, x] except for this case: */8776 if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&8777 C_bignum_negated_fitsinfixnump(y)) {8778 if (q != NULL) *q = C_fix(-1);8779 if (r != NULL) *r = C_fix(0);8780 } else {8781 if (q != NULL) *q = C_fix(0);8782 if (r != NULL) *r = x;8783 }8784 } else {8785 bignum_divrem(ptr, x, y, q, r);8786 }8787 } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */8788 if (q != NULL) *q = C_a_i_fixnum_quotient_checked(ptr, 2, x, y);8789 if (r != NULL) *r = C_i_fixnum_remainder_checked(x, y);8790 } else { /* x is bignum, y is fixnum. */8791 C_word absy = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);87928793 if (y == C_fix(1)) {8794 if (q != NULL) *q = x;8795 if (r != NULL) *r = C_fix(0);8796 } else if (y == C_fix(-1)) {8797 if (q != NULL) *q = C_s_a_u_i_integer_negate(ptr, 1, x);8798 if (r != NULL) *r = C_fix(0);8799 } else if (C_fitsinbignumhalfdigitp(absy) ||8800 ((((C_uword)1 << (C_ilen(absy)-1)) == absy) &&8801 C_fitsinfixnump(absy))) {8802 assert(y != C_fix(0)); /* _must_ be checked by caller */8803 if (q != NULL) {8804 bignum_destructive_divide_unsigned_small(ptr, x, y, q, r);8805 } else { /* We assume r isn't NULL here (that makes no sense) */8806 C_word rem;8807 C_uword next_power = (C_uword)1 << (C_ilen(absy)-1);88088809 if (next_power == absy) { /* Is absy a power of two? */8810 rem = *(C_bignum_digits(x)) & (next_power - 1);8811 } else { /* Too bad, we have to do some real work */8812 rem = bignum_remainder_unsigned_halfdigit(x, absy);8813 }8814 *r = C_bignum_negativep(x) ? C_fix(-rem) : C_fix(rem);8815 }8816 } else { /* Just divide it as two bignums */8817 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;8818 bignum_divrem(ptr, x, C_a_u_i_fix_to_big(&a, y), q, r);8819 if (q != NULL) *q = move_buffer_object(ptr, ab, *q);8820 if (r != NULL) *r = move_buffer_object(ptr, ab, *r);8821 }8822 }8823}88248825/* This _always_ needs two bignum wrappers in ptr! */8826static C_regparm void8827bignum_divrem(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8828{8829 C_word q_negp = C_mk_bool(C_bignum_negativep(y) != C_bignum_negativep(x)),8830 r_negp = C_mk_bool(C_bignum_negativep(x)), res, size;88318832 switch(bignum_cmp_unsigned(x, y)) {8833 case 0:8834 if (q != NULL) *q = C_truep(q_negp) ? C_fix(-1) : C_fix(1);8835 if (r != NULL) *r = C_fix(0);8836 break;8837 case -1:8838 if (q != NULL) *q = C_fix(0);8839 if (r != NULL) *r = x;8840 break;8841 case 1:8842 default:8843 res = C_SCHEME_FALSE;8844 size = C_bignum_size(x) - C_bignum_size(y);8845 if (C_bignum_size(y) > C_BURNIKEL_ZIEGLER_THRESHOLD &&8846 size > C_BURNIKEL_ZIEGLER_THRESHOLD) {8847 res = bignum_divide_burnikel_ziegler(ptr, x, y, q, r);8848 }88498850 if (!C_truep(res)) {8851 bignum_divide_unsigned(ptr, x, y, q, q_negp, r, r_negp);8852 if (q != NULL) *q = C_bignum_simplify(*q);8853 if (r != NULL) *r = C_bignum_simplify(*r);8854 }8855 break;8856 }8857}88588859/* Burnikel-Ziegler recursive division: Split high number (x) in three8860 * or four parts and divide by the lowest number (y), split in two8861 * parts. There are descriptions in [MpNT, 4.2], [MCA, 1.4.3] and the8862 * paper "Fast Recursive Division" by Christoph Burnikel & Joachim8863 * Ziegler is freely available. There is also a description in Karl8864 * Hasselstrom's thesis "Fast Division of Integers".8865 *8866 * The complexity of this is supposedly O(r*s^{log(3)-1} + r*log(s)),8867 * where s is the length of x, and r is the length of y (in digits).8868 *8869 * TODO: See if it's worthwhile to implement "division without remainder"8870 * from the Burnikel-Ziegler paper.8871 */8872static C_regparm C_word8873bignum_divide_burnikel_ziegler(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)8874{8875 C_word ab[C_SIZEOF_FIX_BIGNUM*9], *a = ab,8876 lab[2][C_SIZEOF_FIX_BIGNUM*10], *la,8877 q_negp = (C_bignum_negativep(y) ? C_mk_nbool(C_bignum_negativep(x)) :8878 C_mk_bool(C_bignum_negativep(x))),8879 r_negp = C_mk_bool(C_bignum_negativep(x)), s, m, n, i, j, l, shift,8880 yhi, ylo, zi, zi_orig, newx, newy, quot, qi, ri;88818882 /* Ran out of stack? Fall back to non-recursive division */8883 C_stack_check1(return C_SCHEME_FALSE);88848885 x = C_s_a_u_i_integer_abs(&a, 1, x);8886 y = C_s_a_u_i_integer_abs(&a, 1, y);88878888 /* Define m as min{2^k|(2^k)*BURNIKEL_ZIEGLER_DIFF_THRESHOLD > s}8889 * This ensures we shift as little as possible (less pressure8890 * on the GC) while maintaining a power of two until we drop8891 * below the threshold, so we can always split N in half.8892 */8893 s = C_bignum_size(y);8894 m = 1 << C_ilen(s / C_BURNIKEL_ZIEGLER_THRESHOLD);8895 j = (s+m-1) / m; /* j = s/m, rounded up */8896 n = j * m;88978898 shift = (C_BIGNUM_DIGIT_LENGTH * n) - integer_length_abs(y);8899 newx = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(shift));8900 newy = C_s_a_i_arithmetic_shift(&a, 2, y, C_fix(shift));8901 if (shift != 0) {8902 clear_buffer_object(ab, x);8903 clear_buffer_object(ab, y);8904 }8905 x = newx;8906 y = newy;89078908 /* l needs to be the smallest value so that a < base^{l*n}/2 */8909 l = (C_bignum_size(x) + n) / n;8910 if ((C_BIGNUM_DIGIT_LENGTH * l) == integer_length_abs(x)) l++;8911 l = nmax(l, 2);89128913 yhi = bignum_extract_digits(&a, 3, y, C_fix(n >> 1), C_SCHEME_FALSE);8914 ylo = bignum_extract_digits(&a, 3, y, C_fix(0), C_fix(n >> 1));89158916 s = (l - 2) * n * C_BIGNUM_DIGIT_LENGTH;8917 zi_orig = zi = C_s_a_i_arithmetic_shift(&a, 2, x, C_fix(-s));8918 quot = C_fix(0);89198920 for(i = l - 2; i >= 0; --i) {8921 la = lab[i&1];89228923 burnikel_ziegler_2n_div_1n(&la, zi, y, yhi, ylo, C_fix(n), &qi, &ri);89248925 newx = C_s_a_i_arithmetic_shift(&la, 2, quot, C_fix(n*C_BIGNUM_DIGIT_LENGTH));8926 clear_buffer_object(lab, quot);8927 quot = C_s_a_u_i_integer_plus(&la, 2, newx, qi);8928 move_buffer_object(&la, lab[(i+1)&1], quot);8929 clear_buffer_object(lab, newx);8930 clear_buffer_object(lab, qi);89318932 if (i > 0) { /* Set z_{i-1} = [r{i}, x{i-1}] */8933 newx = bignum_extract_digits(&la, 3, x, C_fix(n * (i-1)), C_fix(n * i));8934 newy = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(n*C_BIGNUM_DIGIT_LENGTH));8935 clear_buffer_object(lab, zi);8936 zi = C_s_a_u_i_integer_plus(&la, 2, newx, newy);8937 move_buffer_object(&la, lab[(i+1)&1], zi);8938 move_buffer_object(&la, lab[(i+1)&1], quot);8939 clear_buffer_object(lab, newx);8940 clear_buffer_object(lab, newy);8941 clear_buffer_object(lab, ri);8942 }8943 }8944 clear_buffer_object(ab, x);8945 clear_buffer_object(ab, y);8946 clear_buffer_object(ab, yhi);8947 clear_buffer_object(ab, ylo);8948 clear_buffer_object(ab, zi_orig);8949 clear_buffer_object(lab, zi);89508951 if (q != NULL) {8952 if (C_truep(q_negp)) {8953 newx = C_s_a_u_i_integer_negate(&la, 1, quot);8954 clear_buffer_object(lab, quot);8955 quot = newx;8956 }8957 *q = move_buffer_object(ptr, lab, quot);8958 }8959 clear_buffer_object(lab, quot);89608961 if (r != NULL) {8962 newx = C_s_a_i_arithmetic_shift(&la, 2, ri, C_fix(-shift));8963 if (C_truep(r_negp)) {8964 newy = C_s_a_u_i_integer_negate(ptr, 1, newx);8965 clear_buffer_object(lab, newx);8966 newx = newy;8967 }8968 *r = move_buffer_object(ptr, lab, newx);8969 }8970 clear_buffer_object(lab, ri);89718972 return C_SCHEME_TRUE;8973}89748975static C_regparm void8976burnikel_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)8977{8978 C_word kab[C_SIZEOF_FIX_BIGNUM*6 + C_SIZEOF_BIGNUM(2)], *ka = kab,8979 lab[2][C_SIZEOF_FIX_BIGNUM*4], *la,8980 size, tmp, less, qhat, rhat, r1, r1a3, i = 0;89818982 size = C_unfix(n) * C_BIGNUM_DIGIT_LENGTH;8983 tmp = C_s_a_i_arithmetic_shift(&ka, 2, a12, C_fix(-size));8984 less = C_i_integer_lessp(tmp, b1); /* a1 < b1 ? */8985 clear_buffer_object(kab, tmp);89868987 if (C_truep(less)) {8988 C_word atmpb[C_SIZEOF_FIX_BIGNUM*2], *atmp = atmpb, b11, b12, halfn;89898990 halfn = C_fix(C_unfix(n) >> 1);8991 b11 = bignum_extract_digits(&atmp, 3, b1, halfn, C_SCHEME_FALSE);8992 b12 = bignum_extract_digits(&atmp, 3, b1, C_fix(0), halfn);89938994 burnikel_ziegler_2n_div_1n(&ka, a12, b1, b11, b12, n, &qhat, &r1);8995 qhat = move_buffer_object(&ka, atmpb, qhat);8996 r1 = move_buffer_object(&ka, atmpb, r1);89978998 clear_buffer_object(atmpb, b11);8999 clear_buffer_object(atmpb, b12);9000 } else {9001 C_word atmpb[C_SIZEOF_FIX_BIGNUM*5], *atmp = atmpb, tmp2;90029003 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, C_fix(1), C_fix(size));9004 qhat = C_s_a_u_i_integer_minus(&ka, 2, tmp, C_fix(1)); /* B^n - 1 */9005 qhat = move_buffer_object(&ka, atmpb, qhat);9006 clear_buffer_object(atmpb, tmp);90079008 /* r1 = (a12 - b1*B^n) + b1 */9009 tmp = C_s_a_i_arithmetic_shift(&atmp, 2, b1, C_fix(size));9010 tmp2 = C_s_a_u_i_integer_minus(&atmp, 2, a12, tmp);9011 r1 = C_s_a_u_i_integer_plus(&ka, 2, tmp2, b1);9012 r1 = move_buffer_object(&ka, atmpb, r1);9013 clear_buffer_object(atmpb, tmp);9014 clear_buffer_object(atmpb, tmp2);9015 }90169017 tmp = C_s_a_i_arithmetic_shift(&ka, 2, r1, C_fix(size));9018 clear_buffer_object(kab, r1);9019 r1a3 = C_s_a_u_i_integer_plus(&ka, 2, tmp, a3);9020 b2 = C_s_a_u_i_integer_times(&ka, 2, qhat, b2);90219022 la = lab[0];9023 rhat = C_s_a_u_i_integer_minus(&la, 2, r1a3, b2);9024 rhat = move_buffer_object(&la, kab, rhat);9025 qhat = move_buffer_object(&la, kab, qhat);90269027 clear_buffer_object(kab, tmp);9028 clear_buffer_object(kab, r1a3);9029 clear_buffer_object(kab, b2);90309031 while(C_truep(C_i_negativep(rhat))) {9032 la = lab[(++i)&1];9033 /* rhat += b */9034 r1 = C_s_a_u_i_integer_plus(&la, 2, rhat, b);9035 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9036 clear_buffer_object(lab[(i-1)&1], r1);9037 clear_buffer_object(lab[(i-1)&1], rhat);9038 clear_buffer_object(kab, rhat);9039 rhat = tmp;90409041 /* qhat -= 1 */9042 r1 = C_s_a_u_i_integer_minus(&la, 2, qhat, C_fix(1));9043 tmp = move_buffer_object(&la, lab[(i-1)&1], r1);9044 clear_buffer_object(lab[(i-1)&1], r1);9045 clear_buffer_object(lab[(i-1)&1], qhat);9046 clear_buffer_object(kab, qhat);9047 qhat = tmp;9048 }90499050 if (q != NULL) *q = move_buffer_object(ptr, lab, qhat);9051 if (r != NULL) *r = move_buffer_object(ptr, lab, rhat);9052 clear_buffer_object(lab, qhat);9053 clear_buffer_object(lab, rhat);9054}90559056static C_regparm void9057burnikel_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)9058{9059 C_word kab[2][C_SIZEOF_FIX_BIGNUM*7], *ka, a12, a3, a4,9060 q1 = C_fix(0), r1, q2 = C_fix(0), r2, *qp;9061 int stack_full = 0;90629063 C_stack_check1(stack_full = 1);90649065 n = C_unfix(n);9066 if (stack_full || (n & 1) || (n < C_BURNIKEL_ZIEGLER_THRESHOLD)) {9067 integer_divrem(ptr, a, b, q, r);9068 } else {9069 ka = kab[0];9070 a12 = bignum_extract_digits(&ka, 3, a, C_fix(n), C_SCHEME_FALSE);9071 a3 = bignum_extract_digits(&ka, 3, a, C_fix(n >> 1), C_fix(n));90729073 qp = (q == NULL) ? NULL : &q1;9074 ka = kab[1];9075 burnikel_ziegler_3n_div_2n(&ka, a12, a3, b, b1, b2, C_fix(n >> 1), qp, &r1);9076 q1 = move_buffer_object(&ka, kab[0], q1);9077 r1 = move_buffer_object(&ka, kab[0], r1);9078 clear_buffer_object(kab[0], a12);9079 clear_buffer_object(kab[0], a3);90809081 a4 = bignum_extract_digits(&ka, 3, a, C_fix(0), C_fix(n >> 1));90829083 qp = (q == NULL) ? NULL : &q2;9084 ka = kab[0];9085 burnikel_ziegler_3n_div_2n(&ka, r1, a4, b, b1, b2, C_fix(n >> 1), qp, r);9086 if (r != NULL) *r = move_buffer_object(ptr, kab[0], *r);9087 clear_buffer_object(kab[1], r1);90889089 if (q != NULL) {9090 C_word halfn_bits = (n >> 1) * C_BIGNUM_DIGIT_LENGTH;9091 r1 = C_s_a_i_arithmetic_shift(&ka, 2, q1, C_fix(halfn_bits));9092 *q = C_s_a_i_plus(ptr, 2, r1, q2); /* q = [q1, q2] */9093 *q = move_buffer_object(ptr, kab[0], *q);9094 clear_buffer_object(kab[0], r1);9095 clear_buffer_object(kab[1], q1);9096 clear_buffer_object(kab[0], q2);9097 }9098 clear_buffer_object(kab[1], a4);9099 }9100}910191029103static C_regparm C_word bignum_remainder_unsigned_halfdigit(C_word x, C_word y)9104{9105 C_uword *start = C_bignum_digits(x),9106 *scan = start + C_bignum_size(x),9107 rem = 0, two_digits;91089109 assert((y > 1) && (C_fitsinbignumhalfdigitp(y)));9110 while (start < scan) {9111 two_digits = (*--scan);9112 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_HI_HALF(two_digits)) % y;9113 rem = C_BIGNUM_DIGIT_COMBINE(rem, C_BIGNUM_DIGIT_LO_HALF(two_digits)) % y;9114 }9115 return rem;9116}91179118/* There doesn't seem to be a way to return two values from inline functions */9119void C_ccall C_quotient_and_remainder(C_word c, C_word *av)9120{9121 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab,9122 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE,9123 q, r, k, x, y;91249125 if (c != 4) C_bad_argc_2(c, 4, av[ 0 ]);91269127 k = av[ 1 ];9128 x = av[ 2 ];9129 y = av[ 3 ];91309131 if (!C_truep(C_i_integerp(x)))9132 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", x);9133 if (!C_truep(C_i_integerp(y)))9134 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient&remainder", y);9135 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient&remainder");91369137 if (C_truep(C_i_flonump(x))) {9138 if C_truep(C_i_flonump(y)) {9139 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;91409141 C_modf(dx / dy, &tmp);9142 q = C_flonum(&a, tmp);9143 r = C_flonum(&a, dx - tmp * dy);9144 /* reuse av */9145 av[ 0 ] = C_SCHEME_UNDEFINED;9146 /* av[ 1 ] = k; */ /* stays the same */9147 av[ 2 ] = q;9148 av[ 3 ] = r;9149 C_values(4, av);9150 }9151 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9152 }9153 if (C_truep(C_i_flonump(y))) {9154 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9155 }91569157 integer_divrem(&a, x, y, &q, &r);91589159 if (C_truep(nx) || C_truep(ny)) {9160 C_word newq, newr;9161 newq = C_a_i_exact_to_inexact(&a, 1, q);9162 newr = C_a_i_exact_to_inexact(&a, 1, r);9163 clear_buffer_object(ab, q);9164 clear_buffer_object(ab, r);9165 q = newq;9166 r = newr;91679168 clear_buffer_object(ab, nx);9169 clear_buffer_object(ab, ny);9170 }9171 /* reuse av */9172 av[ 0 ] = C_SCHEME_UNDEFINED;9173 /* av[ 1 ] = k; */ /* stays the same */9174 av[ 2 ] = q;9175 av[ 3 ] = r;9176 C_values(4, av);9177}91789179void C_ccall C_u_integer_quotient_and_remainder(C_word c, C_word *av)9180{9181 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q, r;91829183 if (av[ 3 ] == C_fix(0)) C_div_by_zero_error("quotient&remainder");91849185 integer_divrem(&a, av[ 2 ], av[ 3 ], &q, &r);91869187 /* reuse av */9188 av[ 0 ] = C_SCHEME_UNDEFINED;9189 /* av[ 1 ] = k; */ /* stays the same */9190 av[ 2 ] = q;9191 av[ 3 ] = r;9192 C_values(4, av);9193}91949195C_regparm C_word C_fcall9196C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)9197{9198 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, r,9199 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;92009201 if (!C_truep(C_i_integerp(x)))9202 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", x);9203 if (!C_truep(C_i_integerp(y)))9204 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "remainder", y);9205 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("remainder");92069207 if (C_truep(C_i_flonump(x))) {9208 if C_truep(C_i_flonump(y)) {9209 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;92109211 C_modf(dx / dy, &tmp);9212 return C_flonum(ptr, dx - tmp * dy);9213 }9214 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9215 }9216 if (C_truep(C_i_flonump(y))) {9217 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9218 }92199220 integer_divrem(&a, x, y, NULL, &r);92219222 if (C_truep(nx) || C_truep(ny)) {9223 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9224 clear_buffer_object(ab, r);9225 r = newr;92269227 clear_buffer_object(ab, nx);9228 clear_buffer_object(ab, ny);9229 }9230 return move_buffer_object(ptr, ab, r);9231}92329233C_regparm C_word C_fcall9234C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)9235{9236 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, r;9237 if (y == C_fix(0)) C_div_by_zero_error("remainder");9238 integer_divrem(&a, x, y, NULL, &r);9239 return move_buffer_object(ptr, ab, r);9240}92419242/* Modulo's sign follows y (whereas remainder's sign follows x) */9243C_regparm C_word C_fcall9244C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)9245{9246 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r,9247 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;92489249 if (!C_truep(C_i_integerp(x)))9250 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", x);9251 if (!C_truep(C_i_integerp(y)))9252 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "modulo", y);9253 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("modulo");92549255 if (C_truep(C_i_flonump(x))) {9256 if C_truep(C_i_flonump(y)) {9257 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;92589259 C_modf(dx / dy, &tmp);9260 tmp = dx - tmp * dy;9261 if ((dx > 0.0) != (dy > 0.0) && tmp != 0.0) {9262 return C_flonum(ptr, tmp + dy);9263 } else {9264 return C_flonum(ptr, tmp);9265 }9266 }9267 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9268 }9269 if (C_truep(C_i_flonump(y))) {9270 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9271 }92729273 integer_divrem(&a, x, y, NULL, &r);9274 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9275 C_word m = C_s_a_i_plus(ptr, 2, r, y);9276 m = move_buffer_object(ptr, ab, m);9277 clear_buffer_object(ab, r);9278 r = m;9279 }92809281 if (C_truep(nx) || C_truep(ny)) {9282 C_word newr = C_a_i_exact_to_inexact(ptr, 1, r);9283 clear_buffer_object(ab, r);9284 r = newr;92859286 clear_buffer_object(ab, nx);9287 clear_buffer_object(ab, ny);9288 }92899290 return move_buffer_object(ptr, ab, r);9291}92929293C_regparm C_word C_fcall9294C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)9295{9296 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;9297 if (y == C_fix(0)) C_div_by_zero_error("modulo");92989299 integer_divrem(&a, x, y, NULL, &r);9300 if (C_i_positivep(y) != C_i_positivep(r) && r != C_fix(0)) {9301 C_word m = C_s_a_u_i_integer_plus(ptr, 2, r, y);9302 m = move_buffer_object(ptr, ab, m);9303 clear_buffer_object(ab, r);9304 r = m;9305 }9306 return move_buffer_object(ptr, ab, r);9307}93089309C_regparm C_word C_fcall9310C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)9311{9312 C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, q,9313 nx = C_SCHEME_FALSE, ny = C_SCHEME_FALSE;93149315 if (!C_truep(C_i_integerp(x)))9316 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", x);9317 if (!C_truep(C_i_integerp(y)))9318 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "quotient", y);9319 if (C_truep(C_i_zerop(y))) C_div_by_zero_error("quotient");93209321 if (C_truep(C_i_flonump(x))) {9322 if C_truep(C_i_flonump(y)) {9323 double dx = C_flonum_magnitude(x), dy = C_flonum_magnitude(y), tmp;93249325 C_modf(dx / dy, &tmp);9326 return C_flonum(ptr, tmp);9327 }9328 x = nx = C_s_a_u_i_flo_to_int(&a, 1, x);9329 }9330 if (C_truep(C_i_flonump(y))) {9331 y = ny = C_s_a_u_i_flo_to_int(&a, 1, y);9332 }93339334 integer_divrem(&a, x, y, &q, NULL);93359336 if (C_truep(nx) || C_truep(ny)) {9337 C_word newq = C_a_i_exact_to_inexact(ptr, 1, q);9338 clear_buffer_object(ab, q);9339 q = newq;93409341 clear_buffer_object(ab, nx);9342 clear_buffer_object(ab, ny);9343 }9344 return move_buffer_object(ptr, ab, q);9345}93469347C_regparm C_word C_fcall9348C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y)9349{9350 C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q;9351 if (y == C_fix(0)) C_div_by_zero_error("quotient");9352 integer_divrem(&a, x, y, &q, NULL);9353 return move_buffer_object(ptr, ab, q);9354}935593569357/* For help understanding this algorithm, see:9358 Knuth, Donald E., "The Art of Computer Programming",9359 volume 2, "Seminumerical Algorithms"9360 section 4.3.1, "Multiple-Precision Arithmetic".93619362 [Yeah, that's a nice book but that particular section is not9363 helpful at all, which is also pointed out by P. Brinch Hansen's9364 "Multiple-Length Division Revisited: A Tour Of The Minefield".9365 That's a more down-to-earth step-by-step explanation of the9366 algorithm. Add to this the C implementation in Hacker's Delight9367 (section 9-2, p141--142) and you may be able to grok this...9368 ...barely, if you're as math-challenged as I am -- sjamaan]93699370 This assumes that numerator >= denominator!9371*/9372static void9373bignum_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)9374{9375 C_word quotient = C_SCHEME_UNDEFINED, remainder = C_SCHEME_UNDEFINED,9376 return_rem = C_mk_nbool(r == NULL), size;93779378 if (q != NULL) {9379 size = C_fix(C_bignum_size(num) + 1 - C_bignum_size(denom));9380 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);9381 }93829383 /* An object is always required to receive the remainder */9384 size = C_fix(C_bignum_size(num) + 1);9385 remainder = C_allocate_scratch_bignum(ptr, size, r_negp, C_SCHEME_FALSE);9386 bignum_destructive_divide_full(num, denom, quotient, remainder, return_rem);93879388 /* Simplification must be done by the caller, for consistency */9389 if (q != NULL) *q = quotient;9390 if (r == NULL) {9391 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(remainder));9392 } else {9393 *r = remainder;9394 }9395}93969397/* Compare two numbers as ratnums. Either may be rat-, fix- or bignums */9398static C_word rat_cmp(C_word x, C_word y)9399{9400 C_word ab[C_SIZEOF_FIX_BIGNUM*4], *a = ab, x1, x2, y1, y2,9401 s, t, ssize, tsize, result, negp;9402 C_uword *scan;94039404 /* Check for 1 or 0; if x or y is this, the other must be the ratnum */9405 if (x == C_fix(0)) { /* Only the sign of y1 matters */9406 return basic_cmp(x, C_u_i_ratnum_num(y), "ratcmp", 0);9407 } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */9408 return basic_cmp(C_u_i_ratnum_denom(y), C_u_i_ratnum_num(y), "ratcmp", 0);9409 } else if (y == C_fix(0)) { /* Only the sign of x1 matters */9410 return basic_cmp(C_u_i_ratnum_num(x), y, "ratcmp", 0);9411 } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */9412 return basic_cmp(C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), "ratcmp", 0);9413 }94149415 /* Extract components x=x1/x2 and y=y1/y2 */9416 if (x & C_FIXNUM_BIT || C_truep(C_bignump(x))) {9417 x1 = x;9418 x2 = C_fix(1);9419 } else {9420 x1 = C_u_i_ratnum_num(x);9421 x2 = C_u_i_ratnum_denom(x);9422 }94239424 if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) {9425 y1 = y;9426 y2 = C_fix(1);9427 } else {9428 y1 = C_u_i_ratnum_num(y);9429 y2 = C_u_i_ratnum_denom(y);9430 }94319432 /* We only want to deal with bignums (this is tricky enough) */9433 if (x1 & C_FIXNUM_BIT) x1 = C_a_u_i_fix_to_big(&a, x1);9434 if (x2 & C_FIXNUM_BIT) x2 = C_a_u_i_fix_to_big(&a, x2);9435 if (y1 & C_FIXNUM_BIT) y1 = C_a_u_i_fix_to_big(&a, y1);9436 if (y2 & C_FIXNUM_BIT) y2 = C_a_u_i_fix_to_big(&a, y2);94379438 /* We multiply using schoolbook method, so this will be very slow in9439 * extreme cases. This is a tradeoff we make so that comparisons9440 * are inlineable, which makes a big difference for the common case.9441 */9442 ssize = C_bignum_size(x1) + C_bignum_size(y2);9443 negp = C_mk_bool(C_bignum_negativep(x1));9444 s = allocate_tmp_bignum(C_fix(ssize), negp, C_SCHEME_TRUE);9445 bignum_digits_multiply(x1, y2, s); /* Swap args if x1 < y2? */94469447 tsize = C_bignum_size(y1) + C_bignum_size(x2);9448 negp = C_mk_bool(C_bignum_negativep(y1));9449 t = allocate_tmp_bignum(C_fix(tsize), negp, C_SCHEME_TRUE);9450 bignum_digits_multiply(y1, x2, t); /* Swap args if y1 < x2? */94519452 /* Shorten the numbers if needed */9453 for (scan = C_bignum_digits(s)+ssize-1; *scan == 0; scan--) ssize--;9454 C_bignum_mutate_size(s, ssize);9455 for (scan = C_bignum_digits(t)+tsize-1; *scan == 0; scan--) tsize--;9456 C_bignum_mutate_size(t, tsize);94579458 result = C_i_bignum_cmp(s, t);94599460 free_tmp_bignum(t);9461 free_tmp_bignum(s);9462 return result;9463}94649465C_regparm double C_fcall C_bignum_to_double(C_word bignum)9466{9467 double accumulator = 0;9468 C_uword *start = C_bignum_digits(bignum),9469 *scan = start + C_bignum_size(bignum);9470 while (start < scan) {9471 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9472 accumulator *= (C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH;9473 accumulator += (*--scan);9474 }9475 return(C_bignum_negativep(bignum) ? -accumulator : accumulator);9476}94779478C_regparm C_word C_fcall9479C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x)9480{9481 int exponent;9482 double significand = frexp(C_flonum_magnitude(x), &exponent);94839484 assert(C_truep(C_u_i_fpintegerp(x)));94859486 if (exponent <= 0) {9487 return C_fix(0);9488 } else if (exponent == 1) { /* TODO: check significand * 2^exp fits fixnum? */9489 return significand < 0.0 ? C_fix(-1) : C_fix(1);9490 } else {9491 C_word size, negp = C_mk_bool(C_flonum_magnitude(x) < 0.0), result;9492 C_uword *start, *end;94939494 size = C_fix(C_BIGNUM_BITS_TO_DIGITS(exponent));9495 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);94969497 start = C_bignum_digits(result);9498 end = start + C_bignum_size(result);94999500 fabs_frexp_to_digits(exponent, fabs(significand), start, end);9501 return C_bignum_simplify(result);9502 }9503}95049505static void9506fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)9507{9508 C_uword digit, odd_bits = exp % C_BIGNUM_DIGIT_LENGTH;95099510 assert(C_isfinite(sign));9511 assert(0.5 <= sign && sign < 1); /* Guaranteed by frexp() and fabs() */9512 assert((scan - start) == C_BIGNUM_BITS_TO_DIGITS(exp));95139514 if (odd_bits > 0) { /* Handle most significant digit first */9515 sign *= (C_uword)1 << odd_bits;9516 digit = (C_uword)sign;9517 (*--scan) = digit;9518 sign -= (double)digit;9519 }95209521 while (start < scan && sign > 0) {9522 sign *= pow(2.0, C_BIGNUM_DIGIT_LENGTH);9523 digit = (C_uword)sign;9524 (*--scan) = digit;9525 sign -= (double)digit;9526 }95279528 /* Finish up by clearing any remaining, lower, digits */9529 while (start < scan)9530 (*--scan) = 0;9531}95329533/* This is a bit weird: We have to compare flonums as bignums due to9534 * precision loss on 64-bit platforms. For simplicity, we convert9535 * fixnums to bignums here.9536 */9537static C_word int_flo_cmp(C_word intnum, C_word flonum)9538{9539 C_word ab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_FLONUM], *a = ab, flo_int, res;9540 double i, f;95419542 f = C_flonum_magnitude(flonum);95439544 if (C_isnan(f)) {9545 return C_SCHEME_FALSE; /* "mu" */9546 } else if (C_isinf(f)) {9547 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9548 } else {9549 f = modf(f, &i);95509551 flo_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));95529553 res = basic_cmp(intnum, flo_int, "int_flo_cmp", 0);9554 clear_buffer_object(ab, flo_int);95559556 if (res == C_fix(0)) /* Use fraction to break tie. If f > 0, x is smaller */9557 return C_fix((f > 0.0) ? -1 : ((f < 0.0) ? 1 : 0));9558 else9559 return res;9560 }9561}95629563/* For convenience (ie, to reduce the degree of mindfuck) */9564static C_word flo_int_cmp(C_word flonum, C_word intnum)9565{9566 C_word res = int_flo_cmp(intnum, flonum);9567 switch(res) {9568 case C_fix(1): return C_fix(-1);9569 case C_fix(-1): return C_fix(1);9570 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9571 }9572}95739574/* This code is a bit tedious, but it makes inline comparisons possible! */9575static C_word rat_flo_cmp(C_word ratnum, C_word flonum)9576{9577 C_word ab[C_SIZEOF_FIX_BIGNUM * 4 + C_SIZEOF_FLONUM], *a = ab,9578 num, denom, i_int, res, nscaled, iscaled, negp, shift_amount;9579 C_uword *scan;9580 double i, f;95819582 f = C_flonum_magnitude(flonum);95839584 if (C_isnan(f)) {9585 return C_SCHEME_FALSE; /* "mu" */9586 } else if (C_isinf(f)) {9587 return C_fix((f > 0.0) ? -1 : 1); /* x is smaller if f is +inf.0 */9588 } else {9589 /* Scale up the floating-point number to become a whole integer,9590 * and remember power of two (# of bits) to shift the numerator.9591 */9592 shift_amount = 0;95939594 /* TODO: This doesn't work for denormalized flonums! */9595 while (modf(f, &i) != 0.0) {9596 f = ldexp(f, 1);9597 shift_amount++;9598 }95999600 i = f; /* TODO: split i and f so it'll work for denormalized flonums */96019602 num = C_u_i_ratnum_num(ratnum);9603 negp = C_i_negativep(num);96049605 if (C_truep(negp) && i >= 0.0) { /* Save some time if signs differ */9606 return C_fix(-1);9607 } else if (!C_truep(negp) && i <= 0.0) { /* num is never 0 */9608 return C_fix(1);9609 } else {9610 denom = C_u_i_ratnum_denom(ratnum);9611 i_int = C_s_a_u_i_flo_to_int(&a, 1, C_flonum(&a, i));96129613 /* Multiply the scaled flonum integer by the denominator, and9614 * shift the numerator so that they may be directly compared. */9615 iscaled = C_s_a_u_i_integer_times(&a, 2, i_int, denom);9616 nscaled = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));96179618 /* Finally, we're ready to compare them! */9619 res = basic_cmp(nscaled, iscaled, "rat_flo_cmp", 0);9620 clear_buffer_object(ab, nscaled);9621 clear_buffer_object(ab, iscaled);9622 clear_buffer_object(ab, i_int);96239624 return res;9625 }9626 }9627}96289629static C_word flo_rat_cmp(C_word flonum, C_word ratnum)9630{9631 C_word res = rat_flo_cmp(ratnum, flonum);9632 switch(res) {9633 case C_fix(1): return C_fix(-1);9634 case C_fix(-1): return C_fix(1);9635 default: return res; /* Can be either C_fix(0) or C_SCHEME_FALSE(!) */9636 }9637}96389639/* The primitive comparison operator. eqp should be 1 if we're only9640 * interested in equality testing (can speed things up and in case of9641 * compnums, equality checking is the only available operation). This9642 * may return #f, in case there is no answer (for NaNs) or as a quick9643 * and dirty non-zero answer when eqp is true. Ugly but effective :)9644 */9645static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)9646{9647 if (x & C_FIXNUM_BIT) {9648 if (y & C_FIXNUM_BIT) {9649 return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0));9650 } else if (C_immediatep(y)) {9651 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9652 } else if (C_block_header(y) == C_FLONUM_TAG) {9653 return int_flo_cmp(x, y);9654 } else if (C_truep(C_bignump(y))) {9655 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9656 return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);9657 } else if (C_block_header(y) == C_RATNUM_TAG) {9658 if (eqp) return C_SCHEME_FALSE;9659 else return rat_cmp(x, y);9660 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9661 if (eqp) return C_SCHEME_FALSE;9662 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9663 } else {9664 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9665 }9666 } else if (C_immediatep(x)) {9667 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9668 } else if (C_block_header(x) == C_FLONUM_TAG) {9669 if (y & C_FIXNUM_BIT) {9670 return flo_int_cmp(x, y);9671 } else if (C_immediatep(y)) {9672 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9673 } else if (C_block_header(y) == C_FLONUM_TAG) {9674 double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);9675 if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */9676 else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));9677 } else if (C_truep(C_bignump(y))) {9678 return flo_int_cmp(x, y);9679 } else if (C_block_header(y) == C_RATNUM_TAG) {9680 return flo_rat_cmp(x, y);9681 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9682 if (eqp) return C_SCHEME_FALSE;9683 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9684 } else {9685 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9686 }9687 } else if (C_truep(C_bignump(x))) {9688 if (y & C_FIXNUM_BIT) {9689 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;9690 return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));9691 } else if (C_immediatep(y)) {9692 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9693 } else if (C_block_header(y) == C_FLONUM_TAG) {9694 return int_flo_cmp(x, y);9695 } else if (C_truep(C_bignump(y))) {9696 return C_i_bignum_cmp(x, y);9697 } else if (C_block_header(y) == C_RATNUM_TAG) {9698 if (eqp) return C_SCHEME_FALSE;9699 else return rat_cmp(x, y);9700 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9701 if (eqp) return C_SCHEME_FALSE;9702 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9703 } else {9704 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9705 }9706 } else if (C_block_header(x) == C_RATNUM_TAG) {9707 if (y & C_FIXNUM_BIT) {9708 if (eqp) return C_SCHEME_FALSE;9709 else return rat_cmp(x, y);9710 } else if (C_immediatep(y)) {9711 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9712 } else if (C_block_header(y) == C_FLONUM_TAG) {9713 return rat_flo_cmp(x, y);9714 } else if (C_truep(C_bignump(y))) {9715 if (eqp) return C_SCHEME_FALSE;9716 else return rat_cmp(x, y);9717 } else if (C_block_header(y) == C_RATNUM_TAG) {9718 if (eqp) {9719 return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x),9720 C_u_i_ratnum_num(y)),9721 C_i_integer_equalp(C_u_i_ratnum_denom(x),9722 C_u_i_ratnum_denom(y))),9723 C_fix(0));9724 } else {9725 return rat_cmp(x, y);9726 }9727 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9728 if (eqp) return C_SCHEME_FALSE;9729 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);9730 } else {9731 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9732 }9733 } else if (C_block_header(x) == C_CPLXNUM_TAG) {9734 if (!eqp) {9735 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x);9736 } else if (y & C_FIXNUM_BIT) {9737 return C_SCHEME_FALSE;9738 } else if (C_immediatep(y)) {9739 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9740 } else if (C_block_header(y) == C_FLONUM_TAG ||9741 C_truep(C_bignump(x)) ||9742 C_block_header(y) == C_RATNUM_TAG) {9743 return C_SCHEME_FALSE;9744 } else if (C_block_header(y) == C_CPLXNUM_TAG) {9745 return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)),9746 C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))),9747 C_fix(0));9748 } else {9749 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9750 }9751 } else {9752 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9753 }9754}97559756static int bignum_cmp_unsigned(C_word x, C_word y)9757{9758 C_word xlen = C_bignum_size(x), ylen = C_bignum_size(y);97599760 if (xlen < ylen) {9761 return -1;9762 } else if (xlen > ylen) {9763 return 1;9764 } else if (x == y) {9765 return 0;9766 } else {9767 C_uword *startx = C_bignum_digits(x),9768 *scanx = startx + xlen,9769 *scany = C_bignum_digits(y) + ylen;97709771 while (startx < scanx) {9772 C_uword xdigit = (*--scanx), ydigit = (*--scany);9773 if (xdigit < ydigit)9774 return -1;9775 if (xdigit > ydigit)9776 return 1;9777 }9778 return 0;9779 }9780}97819782C_regparm C_word C_fcall C_i_bignum_cmp(C_word x, C_word y)9783{9784 if (C_bignum_negativep(x)) {9785 if (C_bignum_negativep(y)) { /* Largest negative number is smallest */9786 return C_fix(bignum_cmp_unsigned(y, x));9787 } else {9788 return C_fix(-1);9789 }9790 } else {9791 if (C_bignum_negativep(y)) {9792 return C_fix(1);9793 } else {9794 return C_fix(bignum_cmp_unsigned(x, y));9795 }9796 }9797}97989799void C_ccall C_nequalp(C_word c, C_word *av)9800{9801 /* C_word closure = av[ 0 ]; */9802 C_word k = av[ 1 ];9803 C_word x, y, result = C_SCHEME_TRUE;98049805 c -= 2;9806 av += 2;9807 if (c == 0) C_kontinue(k, result);9808 x = *(av++);98099810 if (c == 1 && !C_truep(C_i_numberp(x)))9811 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);98129813 while(--c) {9814 y = *(av++);9815 result = C_i_nequalp(x, y);9816 if (result == C_SCHEME_FALSE) break;9817 }98189819 C_kontinue(k, result);9820}98219822C_regparm C_word C_fcall C_i_nequalp(C_word x, C_word y)9823{9824 return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));9825}98269827C_regparm C_word C_fcall C_i_integer_equalp(C_word x, C_word y)9828{9829 if (x & C_FIXNUM_BIT)9830 return C_mk_bool(x == y);9831 else if (y & C_FIXNUM_BIT)9832 return C_SCHEME_FALSE;9833 else9834 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(0));9835}983698379838void C_ccall C_greaterp(C_word c, C_word *av)9839{9840 C_word x, y,9841 /* closure = av[ 0 ] */9842 k = av[ 1 ],9843 result = C_SCHEME_TRUE;98449845 c -= 2;9846 av += 2;9847 if (c == 0) C_kontinue(k, result);98489849 x = *(av++);98509851 if (c == 1 && !C_truep(C_i_numberp(x)))9852 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">", x);98539854 while(--c) {9855 y = *(av++);9856 result = C_i_greaterp(x, y);9857 if (result == C_SCHEME_FALSE) break;9858 x = y;9859 }98609861 C_kontinue(k, result);9862}986398649865C_regparm C_word C_fcall C_i_greaterp(C_word x, C_word y)9866{9867 return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));9868}98699870C_regparm C_word C_fcall C_i_integer_greaterp(C_word x, C_word y)9871{9872 if (x & C_FIXNUM_BIT) {9873 if (y & C_FIXNUM_BIT) {9874 return C_mk_bool(C_unfix(x) > C_unfix(y));9875 } else {9876 return C_mk_bool(C_bignum_negativep(y));9877 }9878 } else if (y & C_FIXNUM_BIT) {9879 return C_mk_nbool(C_bignum_negativep(x));9880 } else {9881 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(1));9882 }9883}98849885void C_ccall C_lessp(C_word c, C_word *av)9886{9887 C_word x, y,9888 /* closure = av[ 0 ] */9889 k = av[ 1 ],9890 result = C_SCHEME_TRUE;98919892 c -= 2;9893 av += 2;9894 if (c == 0) C_kontinue(k, result);98959896 x = *(av++);98979898 if (c == 1 && !C_truep(C_i_numberp(x)))9899 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<", x);99009901 while(--c) {9902 y = *(av++);9903 result = C_i_lessp(x, y);9904 if (result == C_SCHEME_FALSE) break;9905 x = y;9906 }99079908 C_kontinue(k, result);9909}991099119912C_regparm C_word C_fcall C_i_lessp(C_word x, C_word y)9913{9914 return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));9915}99169917C_regparm C_word C_fcall C_i_integer_lessp(C_word x, C_word y)9918{9919 if (x & C_FIXNUM_BIT) {9920 if (y & C_FIXNUM_BIT) {9921 return C_mk_bool(C_unfix(x) < C_unfix(y));9922 } else {9923 return C_mk_nbool(C_bignum_negativep(y));9924 }9925 } else if (y & C_FIXNUM_BIT) {9926 return C_mk_bool(C_bignum_negativep(x));9927 } else {9928 return C_mk_bool(C_i_bignum_cmp(x, y) == C_fix(-1));9929 }9930}99319932void C_ccall C_greater_or_equal_p(C_word c, C_word *av)9933{9934 C_word x, y,9935 /* closure = av[ 0 ] */9936 k = av[ 1 ],9937 result = C_SCHEME_TRUE;99389939 c -= 2;9940 av += 2;9941 if (c == 0) C_kontinue(k, result);99429943 x = *(av++);99449945 if (c == 1 && !C_truep(C_i_numberp(x)))9946 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, ">=", x);99479948 while(--c) {9949 y = *(av++);9950 result = C_i_greater_or_equalp(x, y);9951 if (result == C_SCHEME_FALSE) break;9952 x = y;9953 }99549955 C_kontinue(k, result);9956}995799589959C_regparm C_word C_fcall C_i_greater_or_equalp(C_word x, C_word y)9960{9961 C_word res = basic_cmp(x, y, ">=", 0);9962 return C_mk_bool(res == C_fix(0) || res == C_fix(1));9963}99649965C_regparm C_word C_fcall C_i_integer_greater_or_equalp(C_word x, C_word y)9966{9967 if (x & C_FIXNUM_BIT) {9968 if (y & C_FIXNUM_BIT) {9969 return C_mk_bool(C_unfix(x) >= C_unfix(y));9970 } else {9971 return C_mk_bool(C_bignum_negativep(y));9972 }9973 } else if (y & C_FIXNUM_BIT) {9974 return C_mk_nbool(C_bignum_negativep(x));9975 } else {9976 C_word res = C_i_bignum_cmp(x, y);9977 return C_mk_bool(res == C_fix(0) || res == C_fix(1));9978 }9979}99809981void C_ccall C_less_or_equal_p(C_word c, C_word *av)9982{9983 C_word x, y,9984 /* closure = av[ 0 ] */9985 k = av[ 1 ],9986 result = C_SCHEME_TRUE;99879988 c -= 2;9989 av += 2;9990 if (c == 0) C_kontinue(k, result);99919992 x = *(av++);99939994 if (c == 1 && !C_truep(C_i_numberp(x)))9995 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "<=", x);99969997 while(--c) {9998 y = *(av++);9999 result = C_i_less_or_equalp(x, y);10000 if (result == C_SCHEME_FALSE) break;10001 x = y;10002 }1000310004 C_kontinue(k, result);10005}100061000710008C_regparm C_word C_fcall C_i_less_or_equalp(C_word x, C_word y)10009{10010 C_word res = basic_cmp(x, y, "<=", 0);10011 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10012}100131001410015C_regparm C_word C_fcall C_i_integer_less_or_equalp(C_word x, C_word y)10016{10017 if (x & C_FIXNUM_BIT) {10018 if (y & C_FIXNUM_BIT) {10019 return C_mk_bool(C_unfix(x) <= C_unfix(y));10020 } else {10021 return C_mk_nbool(C_bignum_negativep(y));10022 }10023 } else if (y & C_FIXNUM_BIT) {10024 return C_mk_bool(C_bignum_negativep(x));10025 } else {10026 C_word res = C_i_bignum_cmp(x, y);10027 return C_mk_bool(res == C_fix(0) || res == C_fix(-1));10028 }10029}100301003110032void C_ccall C_gc(C_word c, C_word *av)10033{10034 C_word10035 /* closure = av[ 0 ] */10036 k = av[ 1 ];10037 int f;10038 C_word10039 arg, *p,10040 size = 0;1004110042 if(c == 3) {10043 arg = av[ 2 ];10044 f = C_truep(arg);10045 }10046 else if(c != 2) C_bad_min_argc(c, 2);10047 else f = 1;1004810049 C_save(k);10050 p = C_temporary_stack;1005110052 if(c == 3) {10053 if((arg & C_FIXNUM_BIT) != 0) size = C_unfix(arg);10054 else if(arg == C_SCHEME_END_OF_LIST) size = percentage(heap_size, C_heap_growth);10055 }1005610057 if(size && !C_heap_size_is_fixed) {10058 C_rereclaim2(size, 0);10059 C_temporary_stack = C_temporary_stack_bottom;10060 gc_2(0, p);10061 }10062 else if(f) C_fromspace_top = C_fromspace_limit;1006310064 C_reclaim((void *)gc_2, 1);10065}100661006710068void C_ccall gc_2(C_word c, C_word *av)10069{10070 C_word k = av[ 0 ];10071 C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));10072}100731007410075void C_ccall C_open_file_port(C_word c, C_word *av)10076{10077 C_word10078 /* closure = av[ 0 ] */10079 k = av[ 1 ],10080 port = av[ 2 ],10081 channel = av[ 3 ],10082 mode = av[ 4 ];10083 C_FILEPTR fp = (C_FILEPTR)NULL;10084 C_char fmode[ 4 ];10085 C_word n;10086 char *buf;1008710088 switch(channel) {10089 case C_fix(0): fp = C_stdin; break;10090 case C_fix(1): fp = C_stdout; break;10091 case C_fix(2): fp = C_stderr; break;10092 default:10093 n = C_header_size(channel);10094 buf = buffer;1009510096 if(n >= STRING_BUFFER_SIZE) {10097 if((buf = (char *)C_malloc(n + 1)) == NULL)10098 barf(C_OUT_OF_MEMORY_ERROR, "open");10099 }1010010101 C_strncpy(buf, C_c_string(channel), n);10102 buf[ n ] = '\0';10103 if (n != strlen(buf))10104 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", channel);10105 n = C_header_size(mode);10106 if (n >= sizeof(fmode)) n = sizeof(fmode) - 1;10107 C_strncpy(fmode, C_c_string(mode), n);10108 fmode[ n ] = '\0';10109 if (n != strlen(fmode)) /* Shouldn't happen, but never hurts */10110 barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", mode);10111 fp = C_fopen(buf, fmode);1011210113 if(buf != buffer) C_free(buf);10114 }1011510116 C_set_block_item(port, 0, (C_word)fp);10117 C_kontinue(k, C_mk_bool(fp != NULL));10118}101191012010121void C_ccall C_allocate_vector(C_word c, C_word *av)10122{10123 C_word10124 /* closure = av[ 0 ] */10125 k = av[ 1 ],10126 size, bvecf, init, align8,10127 bytes,10128 n, *p;1012910130 if(c != 6) C_bad_argc(c, 6);1013110132 size = av[ 2 ];10133 bvecf = av[ 3 ];10134 init = av[ 4 ];10135 align8 = av[ 5 ];10136 n = C_unfix(size);1013710138 if(n > C_HEADER_SIZE_MASK || n < 0)10139 barf(C_OUT_OF_RANGE_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));1014010141 if(!C_truep(bvecf)) bytes = C_wordstobytes(n) + sizeof(C_word);10142 else bytes = n + sizeof(C_word);1014310144 if(C_truep(align8)) bytes += sizeof(C_word);1014510146 C_save(k);10147 C_save(size);10148 C_save(init);10149 C_save(bvecf);10150 C_save(align8);10151 C_save(C_fix(bytes));1015210153 if(!C_demand(C_bytestowords(bytes))) {10154 /* Allocate on heap: */10155 if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))10156 C_fromspace_top = C_fromspace_limit; /* trigger major GC */1015710158 C_save(C_SCHEME_TRUE);10159 /* We explicitly pass 7 here, that's the number of things saved.10160 * That's the arguments, plus one additional thing: the mode.10161 */10162 C_reclaim((void *)allocate_vector_2, 7);10163 }1016410165 C_save(C_SCHEME_FALSE);10166 p = C_temporary_stack;10167 C_temporary_stack = C_temporary_stack_bottom;10168 allocate_vector_2(0, p);10169}101701017110172void C_ccall allocate_vector_2(C_word c, C_word *av)10173{10174 C_word10175 mode = av[ 0 ],10176 bytes = C_unfix(av[ 1 ]),10177 align8 = av[ 2 ],10178 bvecf = av[ 3 ],10179 init = av[ 4 ],10180 size = C_unfix(av[ 5 ]),10181 k = av[ 6 ],10182 *v0, v;1018310184 if(C_truep(mode)) {10185 while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {10186 if(C_heap_size_is_fixed)10187 panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));1018810189 C_save(init);10190 C_save(k);10191 C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);10192 k = C_restore;10193 init = C_restore;10194 }1019510196 v0 = (C_word *)C_align((C_word)C_fromspace_top);10197 C_fromspace_top += C_align(bytes);10198 }10199 else v0 = C_alloc(C_bytestowords(bytes));1020010201#ifndef C_SIXTY_FOUR10202 if(C_truep(align8) && C_aligned8(v0)) ++v0;10203#endif1020410205 v = (C_word)v0;1020610207 if(!C_truep(bvecf)) {10208 *(v0++) = C_VECTOR_TYPE | size | (C_truep(align8) ? C_8ALIGN_BIT : 0);1020910210 while(size--) *(v0++) = init;10211 }10212 else {10213 *(v0++) = C_STRING_TYPE | size;1021410215 if(C_truep(init))10216 C_memset(v0, C_character_code(init), size);10217 }1021810219 C_kontinue(k, v);10220}1022110222static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)10223{10224 C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),10225 bigvec = (C_word)(mem + C_SIZEOF_BIGNUM_WRAPPER);10226 if (mem == NULL) abort(); /* TODO: panic */1022710228 C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));10229 C_set_block_item(bigvec, 0, C_truep(negp));1023010231 if (C_truep(initp)) {10232 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10233 0, C_wordstobytes(C_unfix(size)));10234 }1023510236 return C_a_i_bignum_wrapper(&mem, bigvec);10237}1023810239C_regparm C_word C_fcall10240C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)10241{10242 C_word big, bigvec = C_scratch_alloc(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));1024310244 C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));10245 C_set_block_item(bigvec, 0, C_truep(negp));1024610247 if (C_truep(initp)) {10248 C_memset(((C_uword *)C_data_pointer(bigvec))+1,10249 0, C_wordstobytes(C_unfix(size)));10250 }1025110252 big = C_a_i_bignum_wrapper(ptr, bigvec);10253 C_mutate_scratch_slot(&C_internal_bignum_vector(big), bigvec);10254 return big;10255}1025610257/* Simplification: scan trailing zeroes, then return a fixnum if the10258 * value fits, or trim the bignum's length. If the bignum was stored10259 * in scratch space, we mark it as reclaimable. This means any10260 * references to the original bignum are invalid after simplification!10261 */10262C_regparm C_word C_fcall C_bignum_simplify(C_word big)10263{10264 C_uword *start = C_bignum_digits(big),10265 *last_digit = start + C_bignum_size(big) - 1,10266 *scan = last_digit, tmp;10267 int length;1026810269 while (scan >= start && *scan == 0)10270 scan--;10271 length = scan - start + 1;1027210273 switch(length) {10274 case 0:10275 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10276 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10277 return C_fix(0);10278 case 1:10279 tmp = *start;10280 if (C_bignum_negativep(big) ?10281 !(tmp & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)tmp) :10282 C_ufitsinfixnump(tmp)) {10283 if (C_in_scratchspacep(C_internal_bignum_vector(big)))10284 C_mutate_scratch_slot(NULL, C_internal_bignum_vector(big));10285 return C_bignum_negativep(big) ? C_fix(-(C_word)tmp) : C_fix(tmp);10286 }10287 /* FALLTHROUGH */10288 default:10289 if (scan < last_digit) C_bignum_mutate_size(big, length);10290 return big;10291 }10292}1029310294static void bignum_digits_destructive_negate(C_word result)10295{10296 C_uword *scan, *end, digit, sum;1029710298 scan = C_bignum_digits(result);10299 end = scan + C_bignum_size(result);1030010301 do {10302 digit = ~*scan;10303 sum = digit + 1;10304 *scan++ = sum;10305 } while (sum == 0 && scan < end);1030610307 for (; scan < end; scan++) {10308 *scan = ~*scan;10309 }10310}1031110312static C_uword10313bignum_digits_destructive_scale_up_with_carry(C_uword *start, C_uword *end, C_uword factor, C_uword carry)10314{10315 C_uword digit, p;1031610317 assert(C_fitsinbignumhalfdigitp(carry));10318 assert(C_fitsinbignumhalfdigitp(factor));1031910320 /* See fixnum_times. Substitute xlo = factor, xhi = 0, y = digit10321 * and simplify the result to reduce variable usage.10322 */10323 while (start < end) {10324 digit = (*start);1032510326 p = factor * C_BIGNUM_DIGIT_LO_HALF(digit) + carry;10327 carry = C_BIGNUM_DIGIT_LO_HALF(p);1032810329 p = factor * C_BIGNUM_DIGIT_HI_HALF(digit) + C_BIGNUM_DIGIT_HI_HALF(p);10330 (*start++) = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), carry);10331 carry = C_BIGNUM_DIGIT_HI_HALF(p);10332 }10333 return carry;10334}1033510336static C_uword10337bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denominator)10338{10339 C_uword digit, k = 0;10340 C_uhword q_j_hi, q_j_lo;1034110342 /* Single digit divisor case from Hacker's Delight, Figure 9-1,10343 * adapted to modify u[] in-place instead of writing to q[].10344 */10345 while (start < end) {10346 digit = (*--end);1034710348 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_HI_HALF(digit)); /* j */10349 q_j_hi = k / denominator;10350 k -= q_j_hi * denominator;1035110352 k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */10353 q_j_lo = k / denominator;10354 k -= q_j_lo * denominator;1035510356 *end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);10357 }10358 return k;10359}1036010361static C_uword10362bignum_digits_destructive_shift_right(C_uword *start, C_uword *end, int shift_right, int negp)10363{10364 int shift_left = C_BIGNUM_DIGIT_LENGTH - shift_right;10365 C_uword digit, carry = negp ? ((~(C_uword)0) << shift_left) : 0;1036610367 assert(shift_right < C_BIGNUM_DIGIT_LENGTH);1036810369 while (start < end) {10370 digit = *(--end);10371 *end = (digit >> shift_right) | carry;10372 carry = digit << shift_left;10373 }10374 return carry >> shift_left; /* The bits that were shifted out to the right */10375}1037610377static C_uword10378bignum_digits_destructive_shift_left(C_uword *start, C_uword *end, int shift_left)10379{10380 C_uword carry = 0, digit;10381 int shift_right = C_BIGNUM_DIGIT_LENGTH - shift_left;1038210383 assert(shift_left < C_BIGNUM_DIGIT_LENGTH);1038410385 while (start < end) {10386 digit = *start;10387 (*start++) = (digit << shift_left) | carry;10388 carry = digit >> shift_right;10389 }10390 return carry; /* This would end up as most significant digit if it fit */10391}1039210393static C_regparm void10394bignum_digits_multiply(C_word x, C_word y, C_word result)10395{10396 C_uword product,10397 *xd = C_bignum_digits(x),10398 *yd = C_bignum_digits(y),10399 *rd = C_bignum_digits(result);10400 C_uhword carry, yj;10401 /* Lengths in halfwords */10402 int i, j, length_x = C_bignum_size(x) * 2, length_y = C_bignum_size(y) * 2;1040310404 /* From Hacker's Delight, Figure 8-1 (top part) */10405 for (j = 0; j < length_y; ++j) {10406 yj = C_uhword_ref(yd, j);10407 if (yj == 0) continue;10408 carry = 0;10409 for (i = 0; i < length_x; ++i) {10410 product = (C_uword)C_uhword_ref(xd, i) * yj +10411 (C_uword)C_uhword_ref(rd, i + j) + carry;10412 C_uhword_set(rd, i + j, product);10413 carry = C_BIGNUM_DIGIT_HI_HALF(product);10414 }10415 C_uhword_set(rd, j + length_x, carry);10416 }10417}104181041910420/* "small" is either a number that fits a halfdigit, or a power of two */10421static C_regparm void10422bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_word *q, C_word *r)10423{10424 C_word size, quotient, q_negp = C_mk_bool((y & C_INT_SIGN_BIT) ?10425 !(C_bignum_negativep(x)) :10426 C_bignum_negativep(x)),10427 r_negp = C_mk_bool(C_bignum_negativep(x));10428 C_uword *start, *end, remainder;10429 int shift_amount;1043010431 size = C_fix(C_bignum_size(x));10432 quotient = C_allocate_scratch_bignum(ptr, size, q_negp, C_SCHEME_FALSE);10433 bignum_digits_destructive_copy(quotient, x);1043410435 start = C_bignum_digits(quotient);10436 end = start + C_bignum_size(quotient);1043710438 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);1043910440 shift_amount = C_ilen(y) - 1;10441 if (((C_uword)1 << shift_amount) == y) { /* Power of two? Shift! */10442 remainder = bignum_digits_destructive_shift_right(start,end,shift_amount,0);10443 assert(C_ufitsinfixnump(remainder));10444 } else {10445 remainder = bignum_digits_destructive_scale_down(start, end, y);10446 assert(C_fitsinbignumhalfdigitp(remainder));10447 }1044810449 if (r != NULL) *r = C_truep(r_negp) ? C_fix(-remainder) : C_fix(remainder);10450 /* Calling this function only makes sense if quotient is needed */10451 *q = C_bignum_simplify(quotient);10452}1045310454static C_regparm void10455bignum_destructive_divide_full(C_word numerator, C_word denominator, C_word quotient, C_word remainder, C_word return_remainder)10456{10457 C_word length = C_bignum_size(denominator);10458 C_uword d1 = *(C_bignum_digits(denominator) + length - 1),10459 *startr = C_bignum_digits(remainder),10460 *endr = startr + C_bignum_size(remainder);10461 int shift;1046210463 shift = C_BIGNUM_DIGIT_LENGTH - C_ilen(d1); /* nlz */1046410465 /* We have to work on halfdigits, so we shift out only the necessary10466 * amount in order fill out that halfdigit (base is halved).10467 * This trick is shamelessly stolen from Gauche :)10468 * See below for part 2 of the trick.10469 */10470 if (shift >= C_BIGNUM_HALF_DIGIT_LENGTH)10471 shift -= C_BIGNUM_HALF_DIGIT_LENGTH;1047210473 /* Code below won't always set high halfdigit of quotient, so do it here. */10474 if (quotient != C_SCHEME_UNDEFINED)10475 C_bignum_digits(quotient)[C_bignum_size(quotient)-1] = 0;1047610477 bignum_digits_destructive_copy(remainder, numerator);10478 *(endr-1) = 0; /* Ensure most significant digit is initialised */10479 if (shift == 0) { /* Already normalized */10480 bignum_destructive_divide_normalized(remainder, denominator, quotient);10481 } else { /* Requires normalisation; allocate scratch denominator for this */10482 C_uword *startnd;10483 C_word ndenom;1048410485 bignum_digits_destructive_shift_left(startr, endr, shift);1048610487 ndenom = allocate_tmp_bignum(C_fix(length), C_SCHEME_FALSE, C_SCHEME_FALSE);10488 startnd = C_bignum_digits(ndenom);10489 bignum_digits_destructive_copy(ndenom, denominator);10490 bignum_digits_destructive_shift_left(startnd, startnd+length, shift);1049110492 bignum_destructive_divide_normalized(remainder, ndenom, quotient);10493 if (C_truep(return_remainder)) /* Otherwise, don't bother shifting back */10494 bignum_digits_destructive_shift_right(startr, endr, shift, 0);1049510496 free_tmp_bignum(ndenom);10497 }10498}1049910500static C_regparm void10501bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)10502{10503 C_uword *v = C_bignum_digits(big_v),10504 *u = C_bignum_digits(big_u),10505 *q = big_q == C_SCHEME_UNDEFINED ? NULL : C_bignum_digits(big_q),10506 p, /* product of estimated quotient & "denominator" */10507 hat, qhat, rhat, /* estimated quotient and remainder digit */10508 vn_1, vn_2; /* "cached" values v[n-1], v[n-2] */10509 C_word t, k; /* Two helpers: temp/final remainder and "borrow" */10510 /* We use plain ints here, which theoretically may not be enough on10511 * 64-bit for an insanely huge number, but it is a _lot_ faster.10512 */10513 int n = C_bignum_size(big_v) * 2, /* in halfwords */10514 m = (C_bignum_size(big_u) * 2) - 2; /* Correct for extra digit */10515 int i, j; /* loop vars */1051610517 /* Part 2 of Gauche's aforementioned trick: */10518 if (C_uhword_ref(v, n-1) == 0) n--;1051910520 /* These won't change during the loop, but are used in every step. */10521 vn_1 = C_uhword_ref(v, n-1);10522 vn_2 = C_uhword_ref(v, n-2);1052310524 /* See also Hacker's Delight, Figure 9-1. This is almost exactly that. */10525 for (j = m - n; j >= 0; j--) {10526 hat = C_BIGNUM_DIGIT_COMBINE(C_uhword_ref(u, j+n), C_uhword_ref(u, j+n-1));10527 if (hat == 0) {10528 if (q != NULL) C_uhword_set(q, j, 0);10529 continue;10530 }10531 qhat = hat / vn_1;10532 rhat = hat % vn_1;1053310534 /* Two whiles is faster than one big check with an OR. Thanks, Gauche! */10535 while(qhat >= ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) { qhat--; rhat += vn_1; }10536 while(qhat * vn_2 > C_BIGNUM_DIGIT_COMBINE(rhat, C_uhword_ref(u, j+n-2))10537 && rhat < ((C_uword)1 << C_BIGNUM_HALF_DIGIT_LENGTH)) {10538 qhat--;10539 rhat += vn_1;10540 }1054110542 /* Multiply and subtract */10543 k = 0;10544 for (i = 0; i < n; i++) {10545 p = qhat * C_uhword_ref(v, i);10546 t = C_uhword_ref(u, i+j) - k - C_BIGNUM_DIGIT_LO_HALF(p);10547 C_uhword_set(u, i+j, t);10548 k = C_BIGNUM_DIGIT_HI_HALF(p) - (t >> C_BIGNUM_HALF_DIGIT_LENGTH);10549 }10550 t = C_uhword_ref(u,j+n) - k;10551 C_uhword_set(u, j+n, t);1055210553 if (t < 0) { /* Subtracted too much? */10554 qhat--;10555 k = 0;10556 for (i = 0; i < n; i++) {10557 t = (C_uword)C_uhword_ref(u, i+j) + C_uhword_ref(v, i) + k;10558 C_uhword_set(u, i+j, t);10559 k = t >> C_BIGNUM_HALF_DIGIT_LENGTH;10560 }10561 C_uhword_set(u, j+n, (C_uhword_ref(u, j+n) + k));10562 }10563 if (q != NULL) C_uhword_set(q, j, qhat);10564 } /* end j */10565}105661056710568void C_ccall C_string_to_symbol(C_word c, C_word *av)10569{10570 C_word10571 /* closure = av[ 0 ] */10572 k = av[ 1 ],10573 string;10574 int len, key;10575 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);10576 C_char *name;1057710578 if(c != 3) C_bad_argc(c, 3);1057910580 string = av[ 2 ];1058110582 if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)10583 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->symbol", string);1058410585 len = C_header_size(string);10586 name = (C_char *)C_data_pointer(string);1058710588 key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);10589 if(!C_truep(s = lookup(key, len, name, symbol_table)))10590 s = add_symbol(&a, key, string, symbol_table);1059110592 C_kontinue(k, s);10593}1059410595void C_ccall C_string_to_keyword(C_word c, C_word *av)10596{10597 C_word10598 /* closure = av[ 0 ] */10599 k = av[ 1 ],10600 string;10601 int len, key;10602 C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);10603 C_char *name;1060410605 if(c != 3) C_bad_argc(c, 3);1060610607 string = av[ 2 ];1060810609 if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)10610 barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->keyword", string);1061110612 len = C_header_size(string);10613 name = (C_char *)C_data_pointer(string);10614 key = hash_string(len, name, keyword_table->size, keyword_table->rand, 0);1061510616 if(!C_truep(s = lookup(key, len, name, keyword_table))) {10617 s = add_symbol(&a, key, string, keyword_table);10618 C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */10619 C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */10620 }10621 C_kontinue(k, s);10622}1062310624/* This will usually return a flonum, but it may also return a cplxnum10625 * consisting of two flonums, making for a total of 11 words.10626 */10627C_regparm C_word C_fcall10628C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)10629{10630 if (n & C_FIXNUM_BIT) {10631 return C_flonum(ptr, (double)C_unfix(n));10632 } else if (C_immediatep(n)) {10633 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10634 } else if (C_block_header(n) == C_FLONUM_TAG) {10635 return n;10636 } else if (C_truep(C_bignump(n))) {10637 return C_a_u_i_big_to_flo(ptr, c, n);10638 } else if (C_block_header(n) == C_CPLXNUM_TAG) {10639 return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)),10640 C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n)));10641 /* The horribly painful case: ratnums */10642 } else if (C_block_header(n) == C_RATNUM_TAG) {10643 /* This tries to keep the numbers within representable ranges and10644 * tries to drop as few significant digits as possible by bringing10645 * the two numbers to within the same powers of two. See10646 * algorithms M & N in Knuth, 4.2.1.10647 */10648 C_word num = C_u_i_ratnum_num(n), denom = C_u_i_ratnum_denom(n),10649 /* e = approx. distance between the numbers in powers of 2.10650 * ie, 2^e-1 < n/d < 2^e+1 (e is the *un*biased value of10651 * e_w in M2. TODO: What if b!=2 (ie, flonum-radix isn't 2)?10652 */10653 e = integer_length_abs(num) - integer_length_abs(denom),10654 ab[C_SIZEOF_FIX_BIGNUM*5+C_SIZEOF_FLONUM], *a = ab, tmp, q, r, len,10655 shift_amount, negp = C_i_integer_negativep(num);10656 C_uword *d;10657 double res, fraction;1065810659 /* Align by shifting the smaller to the size of the larger */10660 if (e < 0) num = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(-e));10661 else if (e > 0) denom = C_s_a_i_arithmetic_shift(&a, 2, denom, C_fix(e));1066210663 /* Here, 1/2 <= n/d < 2 [N3] */10664 if (C_truep(C_i_integer_lessp(num, denom))) { /* n/d < 1? */10665 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(1));10666 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10667 num = tmp;10668 e--;10669 }1067010671 /* Here, 1 <= n/d < 2 (normalized) [N5] */10672 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));1067310674 tmp = C_s_a_i_arithmetic_shift(&a, 2, num, C_fix(shift_amount));10675 clear_buffer_object(ab, num); /* "knows" shift creates fresh numbers */10676 num = tmp;1067710678 /* Now, calculate round(num/denom). We start with a quotient&remainder */10679 integer_divrem(&a, num, denom, &q, &r);1068010681 /* We multiply the remainder by two to simulate adding 1/2 for10682 * round. However, we don't do it if num = denom (q=1,r=0) */10683 if (!((q == C_fix(1) || q == C_fix(-1)) && r == C_fix(0))) {10684 tmp = C_s_a_i_arithmetic_shift(&a, 2, r, C_fix(1));10685 clear_buffer_object(ab, r); /* "knows" shift creates fresh numbers */10686 r = tmp;10687 }1068810689 /* Now q is the quotient, but to "round" result we need to10690 * adjust. This follows the semantics of the "round" procedure:10691 * Round away from zero on positive numbers (ignoring sign). In10692 * case of exactly halfway, we round up if odd.10693 */10694 tmp = C_a_i_exact_to_inexact(&a, 1, q);10695 fraction = fabs(C_flonum_magnitude(tmp));10696 switch (basic_cmp(r, denom, "", 0)) {10697 case C_fix(0):10698 if (C_truep(C_i_oddp(q))) fraction += 1.0;10699 break;10700 case C_fix(1):10701 fraction += 1.0;10702 break;10703 default: /* if r <= denom, we're done */ break;10704 }1070510706 clear_buffer_object(ab, num);10707 clear_buffer_object(ab, denom);10708 clear_buffer_object(ab, q);10709 clear_buffer_object(ab, r);1071010711 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG));10712 res = ldexp(fraction, e - shift_amount);10713 return C_flonum(ptr, C_truep(negp) ? -res : res);10714 } else {10715 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n);10716 }10717}107181071910720/* this is different from C_a_i_flonum_round, for R5RS compatibility */10721C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)10722{10723 double fn, i, f, i2, r;1072410725 fn = C_flonum_magnitude(n);10726 if(fn < 0.0) {10727 f = modf(-fn, &i);10728 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10729 r = -i;10730 else10731 r = -(i + 1.0);10732 }10733 else if(fn == 0.0/* || fn == -0.0*/)10734 r = fn;10735 else {10736 f = modf(fn, &i);10737 if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))10738 r = i;10739 else10740 r = i + 1.0;10741 }1074210743 return C_flonum(ptr, r);10744}1074510746C_regparm C_word C_fcall10747C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)10748{10749 double xub, yub, r;1075010751 if (!C_truep(C_u_i_fpintegerp(x)))10752 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", x);10753 if (!C_truep(C_u_i_fpintegerp(y)))10754 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "gcd", y);1075510756 xub = C_flonum_magnitude(x);10757 yub = C_flonum_magnitude(y);1075810759 if (xub < 0.0) xub = -xub;10760 if (yub < 0.0) yub = -yub;1076110762 while(yub != 0.0) {10763 r = fmod(xub, yub);10764 xub = yub;10765 yub = r;10766 }10767 return C_flonum(p, xub);10768}1076910770/* This is Lehmer's GCD algorithm with Jebelean's quotient test, as10771 * it is presented in the paper "An Analysis of Lehmer’s Euclidean10772 * GCD Algorithm", by J. Sorenson. Fuck the ACM and their goddamn10773 * paywall; you can currently find the paper here:10774 * http://www.csie.nuk.edu.tw/~cychen/gcd/An%20analysis%20of%20Lehmer%27s%20Euclidean%20GCD%20algorithm.pdf10775 * If that URI fails, it's also explained in [MpNT, 5.2]10776 *10777 * The basic idea is to avoid divisions which yield only small10778 * quotients, in which the remainder won't reduce the numbers by10779 * much. This can be detected by dividing only the leading k bits.10780 * In our case, k = C_WORD_SIZE - 2.10781 */10782inline static void lehmer_gcd(C_word **ptr, C_word u, C_word v, C_word *x, C_word *y)10783{10784 int i_even = 1, done = 0;10785 C_word shift_amount = integer_length_abs(u) - (C_WORD_SIZE - 2),10786 ab[C_SIZEOF_BIGNUM(2)*2+C_SIZEOF_FIX_BIGNUM*2], *a = ab,10787 uhat, vhat, qhat, xnext, ynext,10788 xprev = 1, yprev = 0, xcurr = 0, ycurr = 1;1078910790 uhat = C_s_a_i_arithmetic_shift(&a, 2, u, C_fix(-shift_amount));10791 vhat = C_s_a_i_arithmetic_shift(&a, 2, v, C_fix(-shift_amount));10792 assert(uhat & C_FIXNUM_BIT); uhat = C_unfix(uhat);10793 assert(vhat & C_FIXNUM_BIT); vhat = C_unfix(vhat);1079410795 do {10796 qhat = uhat / vhat; /* Estimated quotient for this step */10797 xnext = xprev - qhat * xcurr;10798 ynext = yprev - qhat * ycurr;1079910800 /* Euclidean GCD swap on uhat and vhat (shift_amount is not needed): */10801 shift_amount = vhat;10802 vhat = uhat - qhat * vhat;10803 uhat = shift_amount;1080410805 i_even = !i_even;10806 if (i_even)10807 done = (vhat < -xnext) || ((uhat - vhat) < (ynext - ycurr));10808 else10809 done = (vhat < -ynext) || ((uhat - vhat) < (xnext - xcurr));1081010811 if (!done) {10812 xprev = xcurr; yprev = ycurr;10813 xcurr = xnext; ycurr = ynext;10814 }10815 } while (!done);1081610817 /* x = xprev * u + yprev * v */10818 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xprev), u);10819 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(yprev), v);10820 *x = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10821 *x = move_buffer_object(ptr, ab, *x);10822 clear_buffer_object(ab, uhat);10823 clear_buffer_object(ab, vhat);1082410825 /* y = xcurr * u + ycurr * v */10826 uhat = C_s_a_u_i_integer_times(&a, 2, C_fix(xcurr), u);10827 vhat = C_s_a_u_i_integer_times(&a, 2, C_fix(ycurr), v);10828 *y = C_s_a_u_i_integer_plus(ptr, 2, uhat, vhat);10829 *y = move_buffer_object(ptr, ab, *y);10830 clear_buffer_object(ab, uhat);10831 clear_buffer_object(ab, vhat);10832}1083310834/* Because this must be inlineable (due to + and - using this for10835 * ratnums), we can't use burnikel-ziegler division here, until we10836 * have a C implementation that doesn't consume stack. However,10837 * we *can* use Lehmer's GCD.10838 */10839C_regparm C_word C_fcall10840C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)10841{10842 C_word ab[2][C_SIZEOF_BIGNUM(2) * 2], *a, newx, newy, size, i = 0;1084310844 if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1084510846 a = ab[i++];10847 x = C_s_a_u_i_integer_abs(&a, 1, x);10848 y = C_s_a_u_i_integer_abs(&a, 1, y);1084910850 if (!C_truep(C_i_integer_greaterp(x, y))) {10851 newx = y; y = x; x = newx; /* Ensure loop invariant: abs(x) >= abs(y) */10852 }1085310854 while(y != C_fix(0)) {10855 assert(integer_length_abs(x) >= integer_length_abs(y));10856 /* x and y are stored in the same buffer, as well as a result */10857 a = ab[i++];10858 if (i == 2) i = 0;1085910860 if (x & C_FIXNUM_BIT) return C_i_fixnum_gcd(x, y);1086110862 /* First, see if we should run a Lehmer step */10863 if ((integer_length_abs(x) - integer_length_abs(y)) < C_HALF_WORD_SIZE) {10864 lehmer_gcd(&a, x, y, &newx, &newy);10865 newx = move_buffer_object(&a, ab[i], newx);10866 newy = move_buffer_object(&a, ab[i], newy);10867 clear_buffer_object(ab[i], x);10868 clear_buffer_object(ab[i], y);10869 x = newx;10870 y = newy;10871 a = ab[i++]; /* Ensure x and y get cleared correctly below */10872 if (i == 2) i = 0;10873 }1087410875 newy = C_s_a_u_i_integer_remainder(&a, 2, x, y);10876 newy = move_buffer_object(&a, ab[i], newy);10877 newx = move_buffer_object(&a, ab[i], y);10878 clear_buffer_object(ab[i], x);10879 clear_buffer_object(ab[i], y);10880 x = newx;10881 y = newy;10882 }1088310884 newx = C_s_a_u_i_integer_abs(ptr, 1, x);10885 newx = move_buffer_object(ptr, ab, newx);10886 clear_buffer_object(ab, x);10887 clear_buffer_object(ab, y);10888 return newx;10889}108901089110892C_regparm C_word C_fcall10893C_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)10894{10895 if (start == end) {10896 return C_SCHEME_FALSE;10897 } else {10898 size_t nbits;10899 char *s = C_c_string(str);10900 C_word result, size;10901 end = C_unfix(end);10902 start = C_unfix(start);10903 radix = C_unfix(radix);1090410905 assert((radix > 1) && C_fitsinbignumhalfdigitp(radix));1090610907 nbits = (end - start) * C_ilen(radix - 1);10908 size = C_BIGNUM_BITS_TO_DIGITS(nbits);10909 if (size == 1) {10910 result = C_bignum1(ptr, C_truep(negp), 0);10911 } else if (size == 2) {10912 result = C_bignum2(ptr, C_truep(negp), 0, 0);10913 } else {10914 size = C_fix(size);10915 result = C_allocate_scratch_bignum(ptr, size, negp, C_SCHEME_FALSE);10916 }1091710918 return str_to_bignum(result, s + start, s + end, radix);10919 }10920}1092110922inline static int hex_char_to_digit(int ch)10923{10924 if (ch == (int)'#') return 0; /* Hash characters in numbers are mapped to 0 */10925 else if (ch >= (int)'a') return ch - (int)'a' + 10; /* lower hex */10926 else if (ch >= (int)'A') return ch - (int)'A' + 10; /* upper hex */10927 else return ch - (int)'0'; /* decimal (OR INVALID; handled elsewhere) */10928}1092910930/* Write from digit character stream to bignum. Bignum does not need10931 * to be initialised. Returns the bignum, or a fixnum. Assumes the10932 * string contains only digits that fit within radix (checked by10933 * string->number).10934 */10935static C_regparm C_word10936str_to_bignum(C_word bignum, char *str, char *str_end, int radix)10937{10938 int radix_shift, str_digit;10939 C_uword *digits = C_bignum_digits(bignum),10940 *end_digits = digits + C_bignum_size(bignum), big_digit = 0;1094110942 /* Below, we try to save up as much as possible in big_digit, and10943 * only when it exceeds what we would be able to multiply easily, we10944 * scale up the bignum and add what we saved up.10945 */10946 radix_shift = C_ilen(radix) - 1;10947 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */10948 int n = 0; /* Number of bits read so far into current big digit */1094910950 /* Read from least to most significant digit to avoid shifting or scaling */10951 while (str_end > str) {10952 str_digit = hex_char_to_digit((int)*--str_end);1095310954 big_digit |= (C_uword)str_digit << n;10955 n += radix_shift;1095610957 if (n >= C_BIGNUM_DIGIT_LENGTH) {10958 n -= C_BIGNUM_DIGIT_LENGTH;10959 *digits++ = big_digit;10960 big_digit = str_digit >> (radix_shift - n);10961 }10962 }10963 assert(n < C_BIGNUM_DIGIT_LENGTH);10964 /* If radix isn't an exact divisor of digit length, write final digit */10965 if (n > 0) *digits++ = big_digit;10966 assert(digits == end_digits);10967 } else { /* Not a power of two */10968 C_uword *last_digit = digits, factor; /* bignum starts as zero */1096910970 do {10971 factor = radix;10972 while (str < str_end && C_fitsinbignumhalfdigitp(factor)) {10973 str_digit = hex_char_to_digit((int)*str++);10974 factor *= radix;10975 big_digit = radix * big_digit + str_digit;10976 }1097710978 big_digit = bignum_digits_destructive_scale_up_with_carry(10979 digits, last_digit, factor / radix, big_digit);1098010981 if (big_digit) {10982 (*last_digit++) = big_digit; /* Move end */10983 big_digit = 0;10984 }10985 } while (str < str_end);1098610987 /* Set remaining digits to zero so bignum_simplify can do its work */10988 assert(last_digit <= end_digits);10989 while (last_digit < end_digits) *last_digit++ = 0;10990 }1099110992 return C_bignum_simplify(bignum);10993}109941099510996static C_regparm double C_fcall decode_flonum_literal(C_char *str)10997{10998 C_char *eptr;10999 double flo;11000 int len = C_strlen(str);1100111002 /* We only need to be able to parse what C_flonum_to_string() emits,11003 * so we avoid too much error checking.11004 */11005 if (len == 6) { /* Only perform comparisons when necessary */11006 if (!C_strcmp(str, "-inf.0")) return -1.0 / 0.0;11007 if (!C_strcmp(str, "+inf.0")) return 1.0 / 0.0;11008 if (!C_strcmp(str, "+nan.0")) return 0.0 / 0.0;11009 }1101011011 errno = 0;11012 flo = C_strtod(str, &eptr);1101311014 if((flo == HUGE_VAL && errno != 0) ||11015 (flo == -HUGE_VAL && errno != 0) ||11016 (*eptr != '\0' && C_strcmp(eptr, ".0") != 0)) {11017 panic(C_text("could not decode flonum literal"));11018 }1101911020 return flo;11021}110221102311024static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum)11025{11026 static char *digits = "0123456789abcdef";11027 char *p;11028 C_uword shift = C_ilen(base) - 1;11029 int mask = (1 << shift) - 1;11030 if (as_flonum) {11031 buffer[68] = '\0';11032 buffer[67] = '0';11033 buffer[66] = '.';11034 } else {11035 buffer[66] = '\0';11036 }11037 p = buffer + 66;11038 if (mask == base - 1) {11039 do {11040 *(--p) = digits [ num & mask ];11041 num >>= shift;11042 } while (num);11043 } else {11044 do {11045 *(--p) = digits [ num % base ];11046 num /= base;11047 } while (num);11048 }11049 if (negp) *(--p) = '-';11050 return p;11051}110521105311054void C_ccall C_number_to_string(C_word c, C_word *av)11055{11056 C_word radix, num;1105711058 if(c == 3) {11059 radix = C_fix(10);11060 } else if(c == 4) {11061 radix = av[ 3 ];11062 if(!(radix & C_FIXNUM_BIT))11063 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", radix);11064 } else {11065 C_bad_argc(c, 3);11066 }1106711068 num = av[ 2 ];1106911070 if(num & C_FIXNUM_BIT) {11071 C_fixnum_to_string(c, av); /* reuse av */11072 } else if (C_immediatep(num)) {11073 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);11074 } else if(C_block_header(num) == C_FLONUM_TAG) {11075 C_flonum_to_string(c, av); /* reuse av */11076 } else if (C_truep(C_bignump(num))) {11077 C_integer_to_string(c, av); /* reuse av */11078 } else {11079 C_word k = av[ 1 ];11080 try_extended_number("##sys#extended-number->string", 3, k, num, radix);11081 }11082}1108311084void C_ccall C_fixnum_to_string(C_word c, C_word *av)11085{11086 C_char *p;11087 C_word *a,11088 /* self = av[ 0 ] */11089 k = av[ 1 ],11090 num = av[ 2 ],11091 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ])),11092 neg = ((num & C_INT_SIGN_BIT) ? 1 : 0);1109311094 if (radix < 2 || radix > 16) {11095 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11096 }1109711098 num = neg ? -C_unfix(num) : C_unfix(num);11099 p = to_n_nary(num, radix, neg, 0);1110011101 num = C_strlen(p);11102 a = C_alloc((C_bytestowords(num) + 1));11103 C_kontinue(k, C_string(&a, num, p));11104}1110511106void C_ccall C_flonum_to_string(C_word c, C_word *av)11107{11108 C_char *p;11109 double f, fa, m;11110 C_word *a,11111 /* self = av[ 0 ] */11112 k = av[ 1 ],11113 num = av[ 2 ],11114 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1111511116 f = C_flonum_magnitude(num);11117 fa = fabs(f);1111811119 /* XXX TODO: Should inexacts be printable in other bases than 10?11120 * Perhaps output a string starting with #i?11121 * Right now something like (number->string 1e40 16) results in11122 * a string that can't be read back using string->number.11123 */11124 if((radix < 2) || (radix > 16)){11125 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11126 }1112711128 if(f == 0.0 || (C_modf(f, &m) == 0.0 && log2(fa) < C_WORD_SIZE)) { /* Use fast int code */11129 if(signbit(f)) {11130 p = to_n_nary((C_uword)-f, radix, 1, 1);11131 } else {11132 p = to_n_nary((C_uword)f, radix, 0, 1);11133 }11134 } else if(C_isnan(f)) {11135 p = "+nan.0";11136 } else if(C_isinf(f)) {11137 p = f > 0 ? "+inf.0" : "-inf.0";11138 } else { /* Doesn't fit an unsigned int and not "special"; use system libc */11139 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("%.*g"),11140 /* XXX: flonum_print_precision */11141 (int)C_unfix(C_get_print_precision()), f);11142 buffer[STRING_BUFFER_SIZE-1] = '\0';1114311144 if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {11145 /* Already checked for these, so shouldn't happen */11146 assert(*buffer != 'i'); /* "inf" */11147 assert(*buffer != 'n'); /* "nan" */11148 /* Ensure integral flonums w/o expt are always terminated by .0 */11149#if defined(HAVE_STRLCAT) || !defined(C_strcat)11150 C_strlcat(buffer, C_text(".0"), sizeof(buffer));11151#else11152 C_strcat(buffer, C_text(".0"));11153#endif11154 }11155 p = buffer;11156 }1115711158 radix = C_strlen(p);11159 a = C_alloc((C_bytestowords(radix) + 1));11160 radix = C_string(&a, radix, p);11161 C_kontinue(k, radix);11162}1116311164void C_ccall C_integer_to_string(C_word c, C_word *av)11165{11166 C_word11167 /* self = av[ 0 ] */11168 k = av[ 1 ],11169 num = av[ 2 ],11170 radix = ((c == 3) ? 10 : C_unfix(av[ 3 ]));1117111172 if (num & C_FIXNUM_BIT) {11173 C_fixnum_to_string(4, av); /* reuse av */11174 } else {11175 int len, radix_shift;11176 size_t nbits;1117711178 if ((radix < 2) || (radix > 16)) {11179 barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "number->string", C_fix(radix));11180 }1118111182 /* Approximation of the number of radix digits we'll need. We try11183 * to be as precise as possible to avoid memmove overhead at the end11184 * of the non-powers of two part of the conversion procedure, which11185 * we may need to do because we write strings back-to-front, and11186 * pointers must be aligned (even for byte blocks).11187 */11188 len = C_bignum_size(num)-1;1118911190 nbits = (size_t)len * C_BIGNUM_DIGIT_LENGTH;11191 nbits += C_ilen(C_bignum_digits(num)[len]);1119211193 len = C_ilen(radix)-1;11194 len = (nbits + len - 1) / len;11195 len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */1119611197 radix_shift = C_ilen(radix) - 1;11198 if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&11199 /* The power of two fast path is much faster than recursion */11200 ((C_uword)1 << radix_shift) != radix) {11201 try_extended_number("##sys#integer->string/recursive",11202 4, k, num, C_fix(radix), C_fix(len));11203 } else {11204 C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[6];1120511206 kav[ 0 ] = (C_word)NULL; /* No "self" closure */11207 kav[ 1 ] = C_closure(&ka, 4, (C_word)bignum_to_str_2,11208 k, num, C_fix(radix));11209 kav[ 2 ] = C_fix(len);11210 kav[ 3 ] = C_SCHEME_TRUE; /* Byte vector */11211 kav[ 4 ] = C_SCHEME_FALSE; /* No initialization */11212 kav[ 5 ] = C_SCHEME_FALSE; /* Don't align at 8 bytes */11213 C_allocate_vector(6, kav);11214 }11215 }11216}1121711218static void bignum_to_str_2(C_word c, C_word *av)11219{11220 static char *characters = "0123456789abcdef";11221 C_word11222 self = av[ 0 ],11223 string = av[ 1 ],11224 k = C_block_item(self, 1),11225 bignum = C_block_item(self, 2),11226 radix = C_unfix(C_block_item(self, 3));11227 char11228 *buf = C_c_string(string),11229 *index = buf + C_header_size(string) - 1;11230 int radix_shift,11231 negp = (C_bignum_negativep(bignum) ? 1 : 0);1123211233 radix_shift = C_ilen(radix) - 1;11234 if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */11235 int radix_mask = radix - 1, big_digit_len = 0, radix_digit;11236 C_uword *scan, *end, big_digit = 0;1123711238 scan = C_bignum_digits(bignum);11239 end = scan + C_bignum_size(bignum);1124011241 while (scan < end) {11242 /* If radix isn't an exact divisor of digit length, handle overlap */11243 if (big_digit_len == 0) {11244 big_digit = *scan++;11245 big_digit_len = C_BIGNUM_DIGIT_LENGTH;11246 } else {11247 assert(index >= buf);11248 radix_digit = big_digit;11249 big_digit = *scan++;11250 radix_digit |= ((unsigned int)big_digit << big_digit_len) & radix_mask;11251 *index-- = characters[radix_digit];11252 big_digit >>= (radix_shift - big_digit_len);11253 big_digit_len = C_BIGNUM_DIGIT_LENGTH - (radix_shift - big_digit_len);11254 }1125511256 while(big_digit_len >= radix_shift && index >= buf) {11257 radix_digit = big_digit & radix_mask;11258 *index-- = characters[radix_digit];11259 big_digit >>= radix_shift;11260 big_digit_len -= radix_shift;11261 }11262 }1126311264 assert(big_digit < radix);1126511266 /* Final digit (like overlap at start of while loop) */11267 if (big_digit) *index-- = characters[big_digit];1126811269 if (negp) {11270 /* Loop above might've overwritten sign position with a zero */11271 if (*(index+1) == '0') *(index+1) = '-';11272 else *index-- = '-';11273 }1127411275 /* Length calculation is always precise for radix powers of two. */11276 assert(index == buf-1);11277 } else {11278 C_uword base, *start, *scan, big_digit;11279 C_word working_copy;11280 int steps, i;1128111282 working_copy = allocate_tmp_bignum(C_fix(C_bignum_size(bignum)),11283 C_mk_bool(negp), C_SCHEME_FALSE);11284 bignum_digits_destructive_copy(working_copy, bignum);1128511286 start = C_bignum_digits(working_copy);1128711288 scan = start + C_bignum_size(bignum);11289 /* Calculate the largest power of radix that fits a halfdigit:11290 * steps = log10(2^halfdigit_bits), base = 10^steps11291 */11292 for(steps = 0, base = radix; C_fitsinbignumhalfdigitp(base); base *= radix)11293 steps++;1129411295 base /= radix; /* Back down: we overshot in the loop */1129611297 while (scan > start) {11298 big_digit = bignum_digits_destructive_scale_down(start, scan, base);1129911300 if (*(scan-1) == 0) scan--; /* Adjust if we exhausted the highest digit */1130111302 for(i = 0; i < steps && index >= buf; ++i) {11303 C_word tmp = big_digit / radix;11304 *index-- = characters[big_digit - (tmp*radix)]; /* big_digit % radix */11305 big_digit = tmp;11306 }11307 }11308 assert(index >= buf-1);11309 free_tmp_bignum(working_copy);1131011311 /* Move index onto first nonzero digit. We're writing a bignum11312 here: it can't consist of only zeroes. */11313 while(*++index == '0');1131411315 if (negp) *--index = '-';1131611317 /* Shorten with distance between start and index. */11318 if (buf != index) {11319 i = C_header_size(string) - (index - buf);11320 C_memmove(buf, index, i); /* Move start of number to beginning. */11321 C_block_header(string) = C_STRING_TYPE | i; /* Mutate strlength. */11322 }11323 }1132411325 C_kontinue(k, string);11326}113271132811329void C_ccall C_make_structure(C_word c, C_word *av)11330{11331 C_word11332 /* closure = av[ 0 ] */11333 k = av[ 1 ],11334 type = av[ 2 ],11335 size = c - 3,11336 *s, s0;1133711338 if(!C_demand(size + 2))11339 C_save_and_reclaim((void *)C_make_structure, c, av);1134011341 s = C_alloc(C_SIZEOF_STRUCTURE(size + 1)),11342 s0 = (C_word)s;11343 *(s++) = C_STRUCTURE_TYPE | (size + 1);11344 *(s++) = type;11345 av += 3;1134611347 while(size--)11348 *(s++) = *(av++);1134911350 C_kontinue(k, s0);11351}113521135311354void C_ccall C_make_symbol(C_word c, C_word *av)11355{11356 C_word11357 /* closure = av[ 0 ] */11358 k = av[ 1 ],11359 name = av[ 2 ],11360 ab[ C_SIZEOF_SYMBOL ],11361 *a = ab,11362 s0 = (C_word)a;1136311364 *(a++) = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);11365 *(a++) = C_SCHEME_UNBOUND;11366 *(a++) = name;11367 *a = C_SCHEME_END_OF_LIST;11368 C_kontinue(k, s0);11369}113701137111372void C_ccall C_make_pointer(C_word c, C_word *av)11373{11374 C_word11375 /* closure = av[ 0 ] */11376 k = av[ 1 ],11377 ab[ 2 ],11378 *a = ab,11379 p;1138011381 p = C_mpointer(&a, NULL);11382 C_kontinue(k, p);11383}113841138511386void C_ccall C_make_tagged_pointer(C_word c, C_word *av)11387{11388 C_word11389 /* closure = av[ 0 ] */11390 k = av[ 1 ],11391 tag = av[ 2 ],11392 ab[ 3 ],11393 *a = ab,11394 p;1139511396 p = C_taggedmpointer(&a, tag, NULL);11397 C_kontinue(k, p);11398}113991140011401void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)11402{11403 C_word11404 /* closure = av[ 0 ] */11405 k = av[ 1 ],11406 n = av[ 2 ],11407 *p;1140811409 C_save(k);1141011411 if(!C_demand(C_bytestowords(C_unfix(n))))11412 C_reclaim((void *)generic_trampoline, 1);1141311414 p = C_temporary_stack;11415 C_temporary_stack = C_temporary_stack_bottom;11416 generic_trampoline(0, p);11417}114181141911420void C_ccall generic_trampoline(C_word c, C_word *av)11421{11422 C_word k = av[ 0 ];1142311424 C_kontinue(k, C_SCHEME_UNDEFINED);11425}114261142711428void C_ccall C_return_to_host(C_word c, C_word *av)11429{11430 C_word11431 /* closure = av[ 0 ] */11432 k = av[ 1 ];1143311434 return_to_host = 1;11435 C_save(k);11436 C_reclaim((void *)generic_trampoline, 1);11437}114381143911440void C_ccall C_get_symbol_table_info(C_word c, C_word *av)11441{11442 C_word11443 /* closure = av[ 0 ] */11444 k = av[ 1 ];11445 double d1, d2;11446 int n = 0, total;11447 C_SYMBOL_TABLE *stp;11448 C_word11449 x, y,11450 ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_VECTOR(4) ],11451 *a = ab;1145211453 for(stp = symbol_table_list; stp != NULL; stp = stp->next)11454 ++n;1145511456 d1 = compute_symbol_table_load(&d2, &total);11457 x = C_flonum(&a, d1); /* load */11458 y = C_flonum(&a, d2); /* avg bucket length */11459 C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));11460}114611146211463void C_ccall C_get_memory_info(C_word c, C_word *av)11464{11465 C_word11466 /* closure = av[ 0 ] */11467 k = av[ 1 ],11468 ab[ C_SIZEOF_VECTOR(2) ],11469 *a = ab;1147011471 C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));11472}114731147411475void C_ccall C_context_switch(C_word c, C_word *av)11476{11477 C_word11478 /* closure = av[ 0 ] */11479 state = av[ 2 ],11480 n = C_header_size(state) - 1,11481 adrs = C_block_item(state, 0),11482 *av2;11483 C_proc tp = (C_proc)C_block_item(adrs,0);1148411485 /* Copy argvector because it may be mutated in-place. The state11486 * vector should not be re-invoked(?), but it can be kept alive11487 * during GC, so the mutated argvector/state slots may turn stale.11488 */11489 av2 = C_alloc(n);11490 C_memcpy(av2, (C_word *)state + 2, n * sizeof(C_word));11491 tp(n, av2);11492}114931149411495void C_ccall C_peek_signed_integer(C_word c, C_word *av)11496{11497 C_word11498 /* closure = av[ 0 ] */11499 k = av[ 1 ],11500 v = av[ 2 ],11501 index = av[ 3 ],11502 x = C_block_item(v, C_unfix(index)),11503 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1150411505 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1150611507 C_kontinue(k, C_int_to_num(&a, num));11508}115091151011511void C_ccall C_peek_unsigned_integer(C_word c, C_word *av)11512{11513 C_word11514 /* closure = av[ 0 ] */11515 k = av[ 1 ],11516 v = av[ 2 ],11517 index = av[ 3 ],11518 x = C_block_item(v, C_unfix(index)),11519 ab[C_SIZEOF_BIGNUM(1)], *a = ab;1152011521 C_uword num = ((C_word *)C_data_pointer(v))[ C_unfix(index) ];1152211523 C_kontinue(k, C_unsigned_int_to_num(&a, num));11524}1152511526void C_ccall C_peek_int64(C_word c, C_word *av)11527{11528 C_word11529 /* closure = av[ 0 ] */11530 k = av[ 1 ],11531 v = av[ 2 ],11532 index = av[ 3 ],11533 x = C_block_item(v, C_unfix(index)),11534 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1153511536 C_s64 num = ((C_s64 *)C_data_pointer(v))[ C_unfix(index) ];1153711538 C_kontinue(k, C_int64_to_num(&a, num));11539}115401154111542void C_ccall C_peek_uint64(C_word c, C_word *av)11543{11544 C_word11545 /* closure = av[ 0 ] */11546 k = av[ 1 ],11547 v = av[ 2 ],11548 index = av[ 3 ],11549 x = C_block_item(v, C_unfix(index)),11550 ab[C_SIZEOF_BIGNUM(2)], *a = ab;1155111552 C_u64 num = ((C_u64 *)C_data_pointer(v))[ C_unfix(index) ];1155311554 C_kontinue(k, C_uint64_to_num(&a, num));11555}115561155711558void C_ccall C_decode_seconds(C_word c, C_word *av)11559{11560 C_word11561 /* closure = av[ 0 ] */11562 k = av[ 1 ],11563 secs = av[ 2 ],11564 mode = av[ 3 ];11565 time_t tsecs;11566 struct tm *tmt;11567 C_word11568 ab[ C_SIZEOF_VECTOR(10) ],11569 *a = ab,11570 info;1157111572 tsecs = (time_t)C_num_to_int64(secs);1157311574 if(mode == C_SCHEME_FALSE) tmt = C_localtime(&tsecs);11575 else tmt = C_gmtime(&tsecs);1157611577 if(tmt == NULL)11578 C_kontinue(k, C_SCHEME_FALSE);1157911580 info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),11581 C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),11582 C_fix(tmt->tm_wday), C_fix(tmt->tm_yday),11583 tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,11584#ifdef C_GNU_ENV11585 /* negative for west of UTC, but we want positive */11586 C_fix(-tmt->tm_gmtoff)11587#elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)11588 C_fix(mode == C_SCHEME_FALSE ? _timezone : 0) /* does not account for DST */11589#else11590 C_fix(mode == C_SCHEME_FALSE ? timezone : 0) /* does not account for DST */11591#endif11592 );11593 C_kontinue(k, info);11594}115951159611597void C_ccall C_machine_byte_order(C_word c, C_word *av)11598{11599 C_word11600 /* closure = av[ 0 ] */11601 k = av[ 1 ];11602 char *str;11603 C_word *a, s;1160411605 if(c != 2) C_bad_argc(c, 2);1160611607#if defined(C_MACHINE_BYTE_ORDER)11608 str = C_MACHINE_BYTE_ORDER;11609#else11610 C_cblock11611 static C_word one_two_three = 123;11612 str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";11613 C_cblockend;11614#endif1161511616 a = C_alloc(2 + C_bytestowords(strlen(str)));11617 s = C_string2(&a, str);1161811619 C_kontinue(k, s);11620}116211162211623void C_ccall C_machine_type(C_word c, C_word *av)11624{11625 C_word11626 /* closure = av[ 0 ] */11627 k = av[ 1 ],11628 *a, s;1162911630 if(c != 2) C_bad_argc(c, 2);1163111632 a = C_alloc(2 + C_bytestowords(strlen(C_MACHINE_TYPE)));11633 s = C_string2(&a, C_MACHINE_TYPE);1163411635 C_kontinue(k, s);11636}116371163811639void C_ccall C_software_type(C_word c, C_word *av)11640{11641 C_word11642 /* closure = av[ 0 ] */11643 k = av[ 1 ],11644 *a, s;1164511646 if(c != 2) C_bad_argc(c, 2);1164711648 a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_TYPE)));11649 s = C_string2(&a, C_SOFTWARE_TYPE);1165011651 C_kontinue(k, s);11652}116531165411655void C_ccall C_build_platform(C_word c, C_word *av)11656{11657 C_word11658 /* closure = av[ 0 ] */11659 k = av[ 1 ],11660 *a, s;1166111662 if(c != 2) C_bad_argc(c, 2);1166311664 a = C_alloc(2 + C_bytestowords(strlen(C_BUILD_PLATFORM)));11665 s = C_string2(&a, C_BUILD_PLATFORM);1166611667 C_kontinue(k, s);11668}116691167011671void C_ccall C_software_version(C_word c, C_word *av)11672{11673 C_word11674 /* closure = av[ 0 ] */11675 k = av[ 1 ],11676 *a, s;1167711678 if(c != 2) C_bad_argc(c, 2);1167911680 a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_VERSION)));11681 s = C_string2(&a, C_SOFTWARE_VERSION);1168211683 C_kontinue(k, s);11684}116851168611687/* Register finalizer: */1168811689void C_ccall C_register_finalizer(C_word c, C_word *av)11690{11691 C_word11692 /* closure = av[ 0 ]) */11693 k = av[ 1 ],11694 x = av[ 2 ],11695 proc = av[ 3 ];1169611697 if(C_immediatep(x) ||11698 (!C_in_stackp(x) && !C_in_heapp(x) && !C_in_scratchspacep(x)))11699 C_kontinue(k, x); /* not GCable */1170011701 C_do_register_finalizer(x, proc);11702 C_kontinue(k, x);11703}117041170511706/*XXX could this be made static? is it used in eggs somewhere?11707 if not, declare as fcall/regparm (and static, remove from chicken.h)11708 */11709void C_ccall C_do_register_finalizer(C_word x, C_word proc)11710{11711 C_word *ptr;11712 int n, i;11713 FINALIZER_NODE *flist;1171411715 if(finalizer_free_list == NULL) {11716 if((flist = (FINALIZER_NODE *)C_malloc(sizeof(FINALIZER_NODE))) == NULL)11717 panic(C_text("out of memory - cannot allocate finalizer node"));1171811719 ++allocated_finalizer_count;11720 }11721 else {11722 flist = finalizer_free_list;11723 finalizer_free_list = flist->next;11724 }1172511726 if(finalizer_list != NULL) finalizer_list->previous = flist;1172711728 flist->previous = NULL;11729 flist->next = finalizer_list;11730 finalizer_list = flist;1173111732 if(C_in_stackp(x)) C_mutate_slot(&flist->item, x);11733 else flist->item = x;1173411735 if(C_in_stackp(proc)) C_mutate_slot(&flist->finalizer, proc);11736 else flist->finalizer = proc;1173711738 ++live_finalizer_count;11739}117401174111742/*XXX same here */11743int C_do_unregister_finalizer(C_word x)11744{11745 int n;11746 FINALIZER_NODE *flist;1174711748 for(flist = finalizer_list; flist != NULL; flist = flist->next) {11749 if(flist->item == x) {11750 if(flist->previous == NULL) finalizer_list = flist->next;11751 else flist->previous->next = flist->next;1175211753 return 1;11754 }11755 }1175611757 return 0;11758}117591176011761/* Dynamic loading of shared objects: */1176211763void C_ccall C_set_dlopen_flags(C_word c, C_word *av)11764{11765 C_word11766 /* closure = av[ 0 ] */11767 k = av[ 1 ],11768 now = av[ 2 ],11769 global = av[ 3 ];1177011771#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)11772 dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);11773#endif11774 C_kontinue(k, C_SCHEME_UNDEFINED);11775}117761177711778void C_ccall C_dload(C_word c, C_word *av)11779{11780 C_word11781 /* closure = av[ 0 ] */11782 k = av[ 1 ],11783 name = av[ 2 ],11784 entry = av[ 3 ];1178511786#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))11787 /* Force minor GC: otherwise the lf may contain pointers to stack-data11788 (stack allocated interned symbols, for example) */11789 C_save_and_reclaim_args((void *)dload_2, 3, k, name, entry);11790#endif1179111792 C_kontinue(k, C_SCHEME_FALSE);11793}117941179511796#ifdef DLOAD_2_DEFINED11797# undef DLOAD_2_DEFINED11798#endif1179911800#if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)11801# ifdef __hpux__11802# define DLOAD_2_DEFINED11803void C_ccall dload_2(C_word c, C_word *av0)11804{11805 void *handle, *p;11806 C_word11807 entry = av0[ 0 ],11808 name = av0[ 1 ],11809 k = av0[ 2 ],,11810 av[ 2 ];11811 C_char *mname = (C_char *)C_data_pointer(name);1181211813 /*11814 * C_fprintf(C_stderr,11815 * "shl_loading %s : %s\n",11816 * (char *) C_data_pointer(name),11817 * (char *) C_data_pointer(entry));11818 */1181911820 if ((handle = (void *) shl_load(mname,11821 BIND_IMMEDIATE | DYNAMIC_PATH,11822 0L)) != NULL) {11823 shl_t shl_handle = (shl_t) handle;1182411825 /*** This version does not check for C_dynamic_and_unsafe. Fix it. */11826 if (shl_findsym(&shl_handle, (char *) C_data_pointer(entry), TYPE_PROCEDURE, &p) == 0) {11827 current_module_name = C_strdup(mname);11828 current_module_handle = handle;1182911830 if(debug_mode) {11831 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11832 current_module_name, (C_uword)current_module_handle);11833 }1183411835 av[ 0 ] = C_SCHEME_UNDEFINED;11836 av[ 1 ] = k;11837 ((C_proc)p)(2, av); /* doesn't return */11838 } else {11839 C_dlerror = (char *) C_strerror(errno);11840 shl_unload(shl_handle);11841 }11842 } else {11843 C_dlerror = (char *) C_strerror(errno);11844 }1184511846 C_kontinue(k, C_SCHEME_FALSE);11847}11848# endif11849#endif118501185111852#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)11853# ifndef __hpux__11854# define DLOAD_2_DEFINED11855void C_ccall dload_2(C_word c, C_word *av0)11856{11857 void *handle, *p, *p2;11858 C_word11859 entry = av0[ 0 ],11860 name = av0[ 1 ],11861 k = av0[ 2 ],11862 av[ 2 ];11863 C_char *topname = (C_char *)C_data_pointer(entry);11864 C_char *mname = (C_char *)C_data_pointer(name);11865 C_char *tmp;11866 int tmp_len = 0;1186711868 if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {11869 if((p = C_dlsym(handle, topname)) == NULL) {11870 tmp_len = C_strlen(topname) + 2;11871 tmp = (C_char *)C_malloc(tmp_len);1187211873 if(tmp == NULL)11874 panic(C_text("out of memory - cannot allocate toplevel name string"));1187511876 C_strlcpy(tmp, C_text("_"), tmp_len);11877 C_strlcat(tmp, topname, tmp_len);11878 p = C_dlsym(handle, tmp);11879 C_free(tmp);11880 }1188111882 if(p != NULL) {11883 current_module_name = C_strdup(mname);11884 current_module_handle = handle;1188511886 if(debug_mode) {11887 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11888 current_module_name, (C_uword)current_module_handle);11889 }1189011891 av[ 0 ] = C_SCHEME_UNDEFINED;11892 av[ 1 ] = k;11893 ((C_proc)p)(2, av); /* doesn't return */11894 }1189511896 C_dlclose(handle);11897 }1189811899 C_dlerror = (char *)dlerror();11900 C_kontinue(k, C_SCHEME_FALSE);11901}11902# endif11903#endif119041190511906#if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)11907# define DLOAD_2_DEFINED11908void C_ccall dload_2(C_word c, C_word *av0)11909{11910 HINSTANCE handle;11911 FARPROC p = NULL, p2;11912 C_word11913 entry = av0[ 0 ],11914 name = av0[ 1 ],11915 k = av0[ 2 ],11916 av[ 2 ];11917 C_char *topname = (C_char *)C_data_pointer(entry);11918 C_char *mname = (C_char *)C_data_pointer(name);1191911920 /* cannot use LoadLibrary on non-DLLs, so we use extension checking */11921 if (C_header_size(name) >= 5) {11922 char *n = (char*) C_data_pointer(name);11923 int l = C_header_size(name);11924 if (C_strncasecmp(".dll", n+l-5, 4) &&11925 C_strncasecmp(".so", n+l-4, 3))11926 C_kontinue(k, C_SCHEME_FALSE);11927 }1192811929 if((handle = LoadLibrary(mname)) != NULL) {11930 if ((p = GetProcAddress(handle, topname)) != NULL) {11931 current_module_name = C_strdup(mname);11932 current_module_handle = handle;1193311934 if(debug_mode) {11935 C_dbg(C_text("debug"), C_text("loading compiled library %s (" UWORD_FORMAT_STRING ")\n"),11936 current_module_name, (C_uword)current_module_handle);11937 }1193811939 av[ 0 ] = C_SCHEME_UNDEFINED;11940 av[ 1 ] = k;11941 ((C_proc)p)(2, av); /* doesn't return */11942 }11943 else FreeLibrary(handle);11944 }1194511946 C_dlerror = (char *) C_strerror(errno);11947 C_kontinue(k, C_SCHEME_FALSE);11948}11949#endif119501195111952void C_ccall C_become(C_word c, C_word *av)11953{11954 C_word11955 /* closure = av[ 0 ] */11956 k = av[ 1 ],11957 table = av[ 2 ],11958 tp, x, old, neu, i, *p;1195911960 i = forwarding_table_size;11961 p = forwarding_table;1196211963 for(tp = table; tp != C_SCHEME_END_OF_LIST; tp = C_u_i_cdr(tp)) {11964 x = C_u_i_car(tp);11965 old = C_u_i_car(x);11966 neu = C_u_i_cdr(x);1196711968 if(i == 0) {11969 if((forwarding_table = (C_word *)realloc(forwarding_table, (forwarding_table_size + 1) * 4 * sizeof(C_word))) == NULL)11970 panic(C_text("out of memory - cannot re-allocate forwarding table"));1197111972 i = forwarding_table_size;11973 p = forwarding_table + forwarding_table_size * 2;11974 forwarding_table_size *= 2;11975 }1197611977 *(p++) = old;11978 *(p++) = neu;11979 --i;11980 }1198111982 *p = 0;11983 C_fromspace_top = C_fromspace_limit;11984 C_save_and_reclaim_args((void *)become_2, 1, k);11985}119861198711988void C_ccall become_2(C_word c, C_word *av)11989{11990 C_word k = av[ 0 ];1199111992 *forwarding_table = 0;11993 C_kontinue(k, C_SCHEME_UNDEFINED);11994}119951199611997C_regparm C_word C_fcall11998C_a_i_cpu_time(C_word **a, int c, C_word buf)11999{12000 C_word u, s = C_fix(0);1200112002#if defined(C_NONUNIX) || defined(__CYGWIN__)12003 if(CLOCKS_PER_SEC == 1000) u = clock();12004 else u = C_uint64_to_num(a, ((C_u64)clock() / CLOCKS_PER_SEC) * 1000);12005#else12006 struct rusage ru;1200712008 if(C_getrusage(RUSAGE_SELF, &ru) == -1) u = 0;12009 else {12010 u = C_uint64_to_num(a, (C_u64)ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000);12011 s = C_uint64_to_num(a, (C_u64)ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000);12012 }12013#endif1201412015 /* buf must not be in nursery */12016 C_set_block_item(buf, 0, u);12017 C_set_block_item(buf, 1, s);12018 return buf;12019}120201202112022C_regparm C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak)12023{12024 C_word *loc = *a;12025 int offset, i, in = C_unfix(index);12026 *a = loc + C_SIZEOF_LOCATIVE;1202712028 loc[ 0 ] = C_LOCATIVE_TAG;1202912030 switch(C_unfix(type)) {12031 case C_SLOT_LOCATIVE: in *= sizeof(C_word); break;12032 case C_U16_LOCATIVE:12033 case C_S16_LOCATIVE: in *= 2; break;12034 case C_U32_LOCATIVE:12035 case C_F32_LOCATIVE:12036 case C_S32_LOCATIVE: in *= 4; break;12037 case C_U64_LOCATIVE:12038 case C_S64_LOCATIVE:12039 case C_F64_LOCATIVE: in *= 8; break;12040 }1204112042 offset = in + sizeof(C_header);12043 loc[ 1 ] = object + offset;12044 loc[ 2 ] = C_fix(offset);12045 loc[ 3 ] = type;12046 loc[ 4 ] = C_truep(weak) ? C_SCHEME_FALSE : object;1204712048 return (C_word)loc;12049}1205012051C_regparm C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc)12052{12053 C_word *ptr;1205412055 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12056 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);1205712058 ptr = (C_word *)C_block_item(loc, 0);1205912060 if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);1206112062 switch(C_unfix(C_block_item(loc, 2))) {12063 case C_SLOT_LOCATIVE: return *ptr;12064 case C_CHAR_LOCATIVE: return C_make_character(*((char *)ptr));12065 case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));12066 case C_S8_LOCATIVE: return C_fix(*((char *)ptr));12067 case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));12068 case C_S16_LOCATIVE: return C_fix(*((short *)ptr));12069 case C_U32_LOCATIVE: return C_unsigned_int_to_num(a, *((C_u32 *)ptr));12070 case C_S32_LOCATIVE: return C_int_to_num(a, *((C_s32 *)ptr));12071 case C_U64_LOCATIVE: return C_uint64_to_num(a, *((C_u64 *)ptr));12072 case C_S64_LOCATIVE: return C_int64_to_num(a, *((C_s64 *)ptr));12073 case C_F32_LOCATIVE: return C_flonum(a, *((float *)ptr));12074 case C_F64_LOCATIVE: return C_flonum(a, *((double *)ptr));12075 default: panic(C_text("bad locative type"));12076 }12077}1207812079C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)12080{12081 C_word *ptr, val;1208212083 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12084 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);1208512086 ptr = (C_word *)C_block_item(loc, 0);1208712088 if(ptr == NULL)12089 barf(C_LOST_LOCATIVE_ERROR, "locative-set!", loc);1209012091 switch(C_unfix(C_block_item(loc, 2))) {12092 case C_SLOT_LOCATIVE: C_mutate(ptr, x); break;1209312094 case C_CHAR_LOCATIVE:12095 if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)12096 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1209712098 *((char *)ptr) = C_character_code(x);12099 break;1210012101 case C_U8_LOCATIVE:12102 if((x & C_FIXNUM_BIT) == 0)12103 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1210412105 *((unsigned char *)ptr) = C_unfix(x);12106 break;1210712108 case C_S8_LOCATIVE:12109 if((x & C_FIXNUM_BIT) == 0)12110 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1211112112 *((char *)ptr) = C_unfix(x);12113 break;1211412115 case C_U16_LOCATIVE:12116 if((x & C_FIXNUM_BIT) == 0)12117 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1211812119 *((unsigned short *)ptr) = C_unfix(x);12120 break;1212112122 case C_S16_LOCATIVE:12123 if((x & C_FIXNUM_BIT) == 0)12124 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1212512126 *((short *)ptr) = C_unfix(x);12127 break;1212812129 case C_U32_LOCATIVE:12130 if(!C_truep(C_i_exact_integerp(x)))12131 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1213212133 *((C_u32 *)ptr) = C_num_to_unsigned_int(x);12134 break;1213512136 case C_S32_LOCATIVE:12137 if(!C_truep(C_i_exact_integerp(x)))12138 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1213912140 *((C_s32 *)ptr) = C_num_to_int(x);12141 break;1214212143 case C_U64_LOCATIVE:12144 if(!C_truep(C_i_exact_integerp(x)))12145 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1214612147 *((C_u64 *)ptr) = C_num_to_uint64(x);12148 break;1214912150 case C_S64_LOCATIVE:12151 if(!C_truep(C_i_exact_integerp(x)))12152 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1215312154 *((C_s64 *)ptr) = C_num_to_int64(x);12155 break;1215612157 case C_F32_LOCATIVE:12158 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12159 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1216012161 *((float *)ptr) = C_flonum_magnitude(x);12162 break;1216312164 case C_F64_LOCATIVE:12165 if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)12166 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);1216712168 *((double *)ptr) = C_flonum_magnitude(x);12169 break;1217012171 default: panic(C_text("bad locative type"));12172 }1217312174 return C_SCHEME_UNDEFINED;12175}121761217712178C_regparm C_word C_fcall C_i_locative_to_object(C_word loc)12179{12180 C_word *ptr;1218112182 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12183 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative->object", loc);1218412185 ptr = (C_word *)C_block_item(loc, 0);1218612187 if(ptr == NULL) return C_SCHEME_FALSE;12188 else return (C_word)ptr - C_unfix(C_block_item(loc, 1));12189}121901219112192C_regparm C_word C_fcall C_i_locative_index(C_word loc)12193{12194 int bytes;1219512196 if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)12197 barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-index", loc);1219812199 bytes = C_unfix(C_block_item(loc, 1)) - sizeof(C_header);1220012201 switch(C_unfix(C_block_item(loc, 2))) {12202 case C_SLOT_LOCATIVE: return C_fix(bytes/sizeof(C_word)); break;1220312204 case C_CHAR_LOCATIVE:12205 case C_U8_LOCATIVE:12206 case C_S8_LOCATIVE: return C_fix(bytes); break;1220712208 case C_U16_LOCATIVE:12209 case C_S16_LOCATIVE: return C_fix(bytes/2); break;1221012211 case C_U32_LOCATIVE:12212 case C_S32_LOCATIVE:12213 case C_F32_LOCATIVE: return C_fix(bytes/4); break;1221412215 case C_U64_LOCATIVE:12216 case C_S64_LOCATIVE:12217 case C_F64_LOCATIVE: return C_fix(bytes/8); break;1221812219 default: panic(C_text("bad locative type"));12220 }12221}122221222312224/* GC protection of user-variables: */1222512226C_regparm void C_fcall C_gc_protect(C_word **addr, int n)12227{12228 int k;1222912230 if(collectibles_top + n >= collectibles_limit) {12231 k = collectibles_limit - collectibles;12232 collectibles = (C_word **)C_realloc(collectibles, sizeof(C_word *) * k * 2);1223312234 if(collectibles == NULL)12235 panic(C_text("out of memory - cannot allocate GC protection vector"));1223612237 collectibles_top = collectibles + k;12238 collectibles_limit = collectibles + k * 2;12239 }1224012241 C_memcpy(collectibles_top, addr, n * sizeof(C_word *));12242 collectibles_top += n;12243}122441224512246C_regparm void C_fcall C_gc_unprotect(int n)12247{12248 collectibles_top -= n;12249}122501225112252/* Map procedure-ptr to id or id to ptr: */1225312254C_char *C_lookup_procedure_id(void *ptr)12255{12256 LF_LIST *lfl;12257 C_PTABLE_ENTRY *pt;1225812259 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12260 pt = lfl->ptable;1226112262 if(pt != NULL) {12263 while(pt->id != NULL) {12264 if(pt->ptr == ptr) return pt->id;12265 else ++pt;12266 }12267 }12268 }1226912270 return NULL;12271}122721227312274void *C_lookup_procedure_ptr(C_char *id)12275{12276 LF_LIST *lfl;12277 C_PTABLE_ENTRY *pt;1227812279 for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {12280 pt = lfl->ptable;1228112282 if(pt != NULL) {12283 while(pt->id != NULL) {12284 if(!C_strcmp(id, pt->id)) return pt->ptr;12285 else ++pt;12286 }12287 }12288 }1228912290 return NULL;12291}122921229312294void C_ccall C_copy_closure(C_word c, C_word *av)12295{12296 C_word12297 /* closure = av[ 0 ] */12298 k = av[ 1 ],12299 proc = av[ 2 ],12300 *p;12301 int n = C_header_size(proc);1230212303 if(!C_demand(n + 1))12304 C_save_and_reclaim_args((void *)copy_closure_2, 2, proc, k);12305 else {12306 C_save(proc);12307 C_save(k);12308 p = C_temporary_stack;12309 C_temporary_stack = C_temporary_stack_bottom;12310 copy_closure_2(0, p);12311 }12312}123131231412315static void C_ccall copy_closure_2(C_word c, C_word *av)12316{12317 C_word12318 k = av[ 0 ],12319 proc = av[ 1 ];12320 int cells = C_header_size(proc);12321 C_word12322 *ptr = C_alloc(C_SIZEOF_CLOSURE(cells)),12323 *p = ptr;1232412325 *(p++) = C_CLOSURE_TYPE | cells;12326 /* this is only allowed because the storage is freshly allocated: */12327 C_memcpy_slots(p, C_data_pointer(proc), cells);12328 C_kontinue(k, (C_word)ptr);12329}123301233112332/* Ph'nglui mglw'nafh Cthulhu R'lyeh wgah'nagl fhtagn */1233312334void C_ccall C_call_with_cthulhu(C_word c, C_word *av)12335{12336 C_word12337 proc = av[ 2 ],12338 *a = C_alloc(C_SIZEOF_CLOSURE(1)),12339 av2[ 2 ];1234012341 av2[ 0 ] = proc;12342 av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */12343 C_do_apply(2, av2);12344}123451234612347/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)12348 These routines return #f if the operation failed due to overflow.12349 */1235012351C_regparm C_word C_fcall C_i_o_fixnum_plus(C_word n1, C_word n2)12352{12353 C_word x1, x2, s;1235412355 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1235612357 x1 = C_unfix(n1);12358 x2 = C_unfix(n2);12359 s = x1 + x2;1236012361#ifdef C_SIXTY_FOUR12362 if((((s ^ x1) & (s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12363#else12364 if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12365#endif12366 else return C_fix(s);12367}123681236912370C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)12371{12372 C_word x1, x2, s;1237312374 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1237512376 x1 = C_unfix(n1);12377 x2 = C_unfix(n2);12378 s = x1 - x2;1237912380#ifdef C_SIXTY_FOUR12381 if((((s ^ x1) & ~(s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;12382#else12383 if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;12384#endif12385 else return C_fix(s);12386}123871238812389C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)12390{12391 C_word x1, x2;12392 C_uword x1u, x2u;12393#ifdef C_SIXTY_FOUR12394# ifdef C_LLP12395 C_uword c = 1ULL<<63ULL;12396# else12397 C_uword c = 1UL<<63UL;12398# endif12399#else12400 C_uword c = 1UL<<31UL;12401#endif1240212403 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1240412405 if((n1 & C_INT_SIGN_BIT) == (n2 & C_INT_SIGN_BIT)) --c;1240612407 x1 = C_unfix(n1);12408 x2 = C_unfix(n2);12409 x1u = x1 < 0 ? -x1 : x1;12410 x2u = x2 < 0 ? -x2 : x2;1241112412 if(x2u != 0 && x1u > (c / x2u)) return C_SCHEME_FALSE;1241312414 x1 = x1 * x2;1241512416 if(C_fitsinfixnump(x1)) return C_fix(x1);12417 else return C_SCHEME_FALSE;12418}124191242012421C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, C_word n2)12422{12423 C_word x1, x2;1242412425 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1242612427 x1 = C_unfix(n1);12428 x2 = C_unfix(n2);1242912430 if(x2 == 0)12431 barf(C_DIVISION_BY_ZERO_ERROR, "fx/?");1243212433#ifdef C_SIXTY_FOUR12434 if(x1 == 0x8000000000000000L && x2 == -1) return C_SCHEME_FALSE;12435#else12436 if(x1 == 0x80000000L && x2 == -1) return C_SCHEME_FALSE;12437#endif1243812439 x1 = x1 / x2;1244012441 if(C_fitsinfixnump(x1)) return C_fix(x1);12442 else return C_SCHEME_FALSE;12443}124441244512446C_regparm C_word C_fcall C_i_o_fixnum_and(C_word n1, C_word n2)12447{12448 C_uword x1, x2, r;1244912450 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1245112452 x1 = C_unfix(n1);12453 x2 = C_unfix(n2);12454 r = x1 & x2;1245512456 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12457 else return C_fix(r);12458}124591246012461C_regparm C_word C_fcall C_i_o_fixnum_ior(C_word n1, C_word n2)12462{12463 C_uword x1, x2, r;1246412465 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1246612467 x1 = C_unfix(n1);12468 x2 = C_unfix(n2);12469 r = x1 | x2;1247012471 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12472 else return C_fix(r);12473}124741247512476C_regparm C_word C_fcall C_i_o_fixnum_xor(C_word n1, C_word n2)12477{12478 C_uword x1, x2, r;1247912480 if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;1248112482 x1 = C_unfix(n1);12483 x2 = C_unfix(n2);12484 r = x1 ^ x2;1248512486 if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;12487 else return C_fix(r);12488}124891249012491/* decoding of literals in compressed format */1249212493static C_regparm C_uword C_fcall decode_size(C_char **str)12494{12495 C_uchar **ustr = (C_uchar **)str;12496 C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */1249712498 size |= (*((*ustr)++) & 0xff) << 8;12499 size |= (*((*ustr)++) & 0xff);12500 return size;12501}125021250312504static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,12505 C_word *dest)12506{12507 C_ulong bits = *((*str)++) & 0xff;12508 C_word *data, *dptr, val;12509 C_uword size;1251012511 /* vvv this can be taken out at a later stage (once it works reliably) vvv */12512 if(bits != 0xfe)12513 panic(C_text("invalid encoded literal format"));1251412515 bits = *((*str)++) & 0xff;12516 /* ^^^ */1251712518#ifdef C_SIXTY_FOUR12519 bits <<= 24 + 32;12520#else12521 bits <<= 24;12522#endif1252312524 if(bits == C_HEADER_BITS_MASK) { /* special/immediate */12525 switch(0xff & *((*str)++)) {12526 case C_BOOLEAN_BITS:12527 return C_mk_bool(*((*str)++));1252812529 case C_CHARACTER_BITS:12530 return C_make_character(decode_size(str));1253112532 case C_SCHEME_END_OF_LIST:12533 case C_SCHEME_UNDEFINED:12534 case C_SCHEME_END_OF_FILE:12535 case C_SCHEME_BROKEN_WEAK_PTR:12536 return (C_word)(*(*str - 1));1253712538 case C_FIXNUM_BIT:12539 val = (C_uword)(signed char)*((*str)++) << 24; /* always big endian */12540 val |= ((C_uword)*((*str)++) & 0xff) << 16;12541 val |= ((C_uword)*((*str)++) & 0xff) << 8;12542 val |= ((C_uword)*((*str)++) & 0xff);12543 return C_fix(val);1254412545#ifdef C_SIXTY_FOUR12546 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:12547#else12548 case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:12549#endif12550 bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);12551 break;1255212553 default:12554 panic(C_text("invalid encoded special literal"));12555 }12556 }1255712558#ifndef C_SIXTY_FOUR12559 if((bits & C_8ALIGN_BIT) != 0) {12560 /* Align _data_ on 8-byte boundary: */12561 if(C_aligned8(*ptr)) ++(*ptr);12562 }12563#endif1256412565 val = (C_word)(*ptr);1256612567 if((bits & C_SPECIALBLOCK_BIT) != 0)12568 panic(C_text("literals with special bit cannot be decoded"));1256912570 if(bits == C_FLONUM_TYPE) {12571 val = C_flonum(ptr, decode_flonum_literal(*str));12572 while(*((*str)++) != '\0'); /* skip terminating '\0' */12573 return val;12574 }1257512576 size = decode_size(str);1257712578 switch(bits) {12579 /* This cannot be encoded as a blob due to endianness differences */12580 case (C_STRING_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */12581 /* bignums are also allocated statically */12582 val = C_static_bignum(ptr, size, *str);12583 *str += size;12584 break;1258512586 case C_STRING_TYPE:12587 /* strings are always allocated statically */12588 val = C_static_string(ptr, size, *str);12589 *str += size;12590 break;1259112592 case C_BYTEVECTOR_TYPE:12593 /* ... as are bytevectors (blobs) */12594 val = C_static_bytevector(ptr, size, *str);12595 *str += size;12596 break;1259712598 case C_SYMBOL_TYPE:12599 if(dest == NULL)12600 panic(C_text("invalid literal symbol destination"));1260112602 if (**str == '\1') {12603 val = C_h_intern(dest, size, ++*str);12604 } else if (**str == '\2') {12605 val = C_h_intern_kw(dest, size, ++*str);12606 } else {12607 C_snprintf(buffer, sizeof(buffer), C_text("Unknown symbol subtype: %d"), (int)**str);12608 panic(buffer);12609 }12610 *str += size;12611 break;1261212613 case C_LAMBDA_INFO_TYPE:12614 /* lambda infos are always allocated statically */12615 val = C_static_lambda_info(ptr, size, *str);12616 *str += size;12617 break;1261812619 default:12620 *((*ptr)++) = C_make_header(bits, size);12621 data = *ptr;1262212623 if((bits & C_BYTEBLOCK_BIT) != 0) {12624 C_memcpy(data, *str, size);12625 size = C_align(size);12626 *str += size;12627 *ptr = (C_word *)C_align((C_word)(*ptr) + size);12628 }12629 else {12630 C_word *dptr = *ptr;12631 *ptr += size;1263212633 while(size--) {12634 *dptr = decode_literal2(ptr, str, dptr);12635 ++dptr;12636 }12637 }12638 }1263912640 return val;12641}126421264312644C_regparm C_word C_fcall12645C_decode_literal(C_word **ptr, C_char *str)12646{12647 return decode_literal2(ptr, &str, NULL);12648}126491265012651void12652C_use_private_repository(C_char *path)12653{12654 private_repository = path;12655}126561265712658C_char *12659C_private_repository_path()12660{12661 return private_repository;12662}1266312664C_char *12665C_executable_pathname() {12666#ifdef SEARCH_EXE_PATH12667 return C_main_exe == NULL ? NULL : C_strdup(C_main_exe);12668#else12669 return C_resolve_executable_pathname(NULL);12670#endif12671}1267212673C_char *12674C_executable_dirname() {12675 int len;12676 C_char *path;1267712678 if((path = C_executable_pathname()) == NULL)12679 return NULL;1268012681#if defined(_WIN32) && !defined(__CYGWIN__)12682 for(len = C_strlen(path); len >= 0 && path[len] != '\\'; len--);12683#else12684 for(len = C_strlen(path); len >= 0 && path[len] != '/'; len--);12685#endif1268612687 path[len] = '\0';12688 return path;12689}1269012691C_char *12692C_resolve_executable_pathname(C_char *fname)12693{12694 int n;12695 C_char *buffer = (C_char *) C_malloc(C_MAX_PATH);1269612697 if(buffer == NULL) return NULL;1269812699#if defined(__linux__) || defined(__sun)12700 C_char linkname[64]; /* /proc/<pid>/exe */12701 pid_t pid = C_getpid();1270212703# ifdef __linux__12704 C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);12705# else12706 C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */12707# endif1270812709 n = C_readlink(linkname, buffer, C_MAX_PATH);12710 if(n < 0 || n >= C_MAX_PATH)12711 goto error;1271212713 buffer[n] = '\0';12714 return buffer;12715#elif defined(_WIN32) && !defined(__CYGWIN__)12716 n = GetModuleFileName(NULL, buffer, C_MAX_PATH);12717 if(n == 0 || n >= C_MAX_PATH)12718 goto error;1271912720 return buffer;12721#elif defined(C_MACOSX)12722 C_char buf[C_MAX_PATH];12723 C_u32 size = C_MAX_PATH;1272412725 if(_NSGetExecutablePath(buf, &size) != 0)12726 goto error;1272712728 if(C_realpath(buf, buffer) == NULL)12729 goto error;1273012731 return buffer;12732#elif defined(__HAIKU__)12733{12734 image_info info;12735 int32 cookie = 0;1273612737 while (get_next_image_info(0, &cookie, &info) == B_OK) {12738 if (info.type == B_APP_IMAGE) {12739 C_strlcpy(buffer, info.name, C_MAX_PATH);12740 return buffer;12741 }12742 }12743}12744#elif defined(SEARCH_EXE_PATH)12745 int len;12746 C_char *path, buf[C_MAX_PATH];1274712748 /* no name given (execve) */12749 if(fname == NULL)12750 goto error;1275112752 /* absolute pathname */12753 if(fname[0] == '/') {12754 if(C_realpath(fname, buffer) == NULL)12755 goto error;12756 else12757 return buffer;12758 }1275912760 /* current directory */12761 if(C_strchr(fname, '/') != NULL) {12762 if(C_getcwd(buffer, C_MAX_PATH) == NULL)12763 goto error;1276412765 n = C_snprintf(buf, C_MAX_PATH, "%s/%s", buffer, fname);12766 if(n < 0 || n >= C_MAX_PATH)12767 goto error;1276812769 if(C_access(buf, X_OK) == 0) {12770 if(C_realpath(buf, buffer) == NULL)12771 goto error;12772 else12773 return buffer;12774 }12775 }1277612777 /* walk PATH */12778 if((path = C_getenv("PATH")) == NULL)12779 goto error;1278012781 do {12782 /* check PATH entry length */12783 len = C_strcspn(path, ":");12784 if(len == 0 || len >= C_MAX_PATH)12785 continue;1278612787 /* "<path>/<fname>" to buf */12788 C_strncpy(buf, path, len);12789 n = C_snprintf(buf + len, C_MAX_PATH - len, "/%s", fname);12790 if(n < 0 || n + len >= C_MAX_PATH)12791 continue;1279212793 if(C_access(buf, X_OK) != 0)12794 continue;1279512796 /* fname found, resolve links */12797 if(C_realpath(buf, buffer) != NULL)12798 return buffer;1279912800 /* seek next entry, skip colon */12801 } while (path += len, *path++);12802#else12803# error "Please either define SEARCH_EXE_PATH in Makefile.<platform> or implement C_resolve_executable_pathname for your platform!"12804#endif1280512806error:12807 C_free(buffer);12808 return NULL;12809}1281012811C_regparm C_word C_fcall12812C_i_getprop(C_word sym, C_word prop, C_word def)12813{12814 C_word pl = C_symbol_plist(sym);1281512816 while(pl != C_SCHEME_END_OF_LIST) {12817 if(C_block_item(pl, 0) == prop)12818 return C_u_i_car(C_u_i_cdr(pl));12819 else pl = C_u_i_cdr(C_u_i_cdr(pl));12820 }1282112822 return def;12823}128241282512826C_regparm C_word C_fcall12827C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)12828{12829 C_word pl = C_symbol_plist(sym);1283012831 /* Newly added plist? Ensure the symbol stays! */12832 if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym);1283312834 while(pl != C_SCHEME_END_OF_LIST) {12835 if(C_block_item(pl, 0) == prop) {12836 C_mutate(&C_u_i_car(C_u_i_cdr(pl)), val);12837 return val;12838 }12839 else pl = C_u_i_cdr(C_u_i_cdr(pl));12840 }1284112842 pl = C_a_pair(ptr, val, C_symbol_plist(sym));12843 pl = C_a_pair(ptr, prop, pl);12844 C_mutate_slot(&C_symbol_plist(sym), pl);12845 return val;12846}128471284812849C_regparm C_word C_fcall12850C_i_get_keyword(C_word kw, C_word args, C_word def)12851{12852 while(!C_immediatep(args)) {12853 if(C_header_type(args) == C_PAIR_TYPE) {12854 if(kw == C_u_i_car(args)) {12855 args = C_u_i_cdr(args);1285612857 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)12858 return def;12859 else return C_u_i_car(args);12860 }12861 else {12862 args = C_u_i_cdr(args);1286312864 if(C_immediatep(args) || C_header_type(args) != C_PAIR_TYPE)12865 return def;12866 else args = C_u_i_cdr(args);12867 }12868 }12869 }1287012871 return def;12872}1287312874C_word C_i_dump_statistical_profile()12875{12876 PROFILE_BUCKET *b, *b2, **bp;12877 FILE *fp;12878 C_char *k1, *k2 = NULL;12879 int n;12880 double ms;1288112882 assert(profiling);12883 assert(profile_table != NULL);1288412885 set_profile_timer(0);1288612887 profiling = 0; /* In case a SIGPROF is delivered late */12888 bp = profile_table;1288912890 C_snprintf(buffer, STRING_BUFFER_SIZE, C_text("PROFILE.%d"), C_getpid());1289112892 if(debug_mode)12893 C_dbg(C_text("debug"), C_text("dumping statistical profile to `%s'...\n"), buffer);1289412895 fp = C_fopen(buffer, "w");12896 if (fp == NULL)12897 panic(C_text("could not write profile!"));1289812899 C_fputs(C_text("statistical\n"), fp);12900 for(n = 0; n < PROFILE_TABLE_SIZE; ++n) {12901 for(b = bp[ n ]; b != NULL; b = b2) {12902 b2 = b->next;1290312904 k1 = b->key;12905 C_fputs(C_text("(|"), fp);12906 /* Dump raw C string as if it were a symbol */12907 while((k2 = C_strpbrk(k1, C_text("\\|"))) != NULL) {12908 C_fwrite(k1, 1, k2-k1, fp);12909 C_fputc('\\', fp);12910 C_fputc(*k2, fp);12911 k1 = k2+1;12912 }12913 C_fputs(k1, fp);12914 ms = (double)b->sample_count * (double)profile_frequency / 1000.0;12915 C_fprintf(fp, C_text("| " UWORD_COUNT_FORMAT_STRING " %lf)\n"),12916 b->call_count, ms);12917 C_free(b);12918 }12919 }1292012921 C_fclose(fp);12922 C_free(profile_table);12923 profile_table = NULL;1292412925 return C_SCHEME_UNDEFINED;12926}1292712928void C_ccall C_dump_heap_state(C_word c, C_word *av)12929{12930 C_word12931 /* closure = av[ 0 ] */12932 k = av[ 1 ];1293312934 /* make sure heap is compacted */12935 C_save(k);12936 C_fromspace_top = C_fromspace_limit; /* force major GC */12937 C_reclaim((void *)dump_heap_state_2, 1);12938}129391294012941static C_ulong12942hdump_hash(C_word key)12943{12944 return (C_ulong)key % HDUMP_TABLE_SIZE;12945}129461294712948static void12949hdump_count(C_word key, int n, int t)12950{12951 HDUMP_BUCKET **bp = hdump_table + hdump_hash(key);12952 HDUMP_BUCKET *b = *bp;1295312954 while(b != NULL) {12955 if(b->key == key) {12956 b->count += n;12957 b->total += t;12958 return;12959 }12960 else b = b->next;12961 }1296212963 b = (HDUMP_BUCKET *)C_malloc(sizeof(HDUMP_BUCKET));1296412965 if(b == 0)12966 panic(C_text("out of memory - can not allocate heap-dump table-bucket"));1296712968 b->next = *bp;12969 b->key = key;12970 *bp = b;12971 b->count = n;12972 b->total = t;12973}129741297512976static void C_ccall dump_heap_state_2(C_word c, C_word *av)12977{12978 C_word k = av[ 0 ];12979 HDUMP_BUCKET *b, *b2, **bp;12980 int n, bytes;12981 C_byte *scan;12982 C_SCHEME_BLOCK *sbp;12983 C_header h;12984 C_word x, key, *p;12985 int imm = 0, blk = 0;1298612987 hdump_table = (HDUMP_BUCKET **)C_malloc(HDUMP_TABLE_SIZE * sizeof(HDUMP_BUCKET *));1298812989 if(hdump_table == NULL)12990 panic(C_text("out of memory - can not allocate heap-dump table"));1299112992 C_memset(hdump_table, 0, sizeof(HDUMP_BUCKET *) * HDUMP_TABLE_SIZE);1299312994 scan = fromspace_start;1299512996 while(scan < C_fromspace_top) {12997 ++blk;12998 sbp = (C_SCHEME_BLOCK *)scan;1299913000 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13001 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1300213003 n = C_header_size(sbp);13004 h = sbp->header;13005 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13006 key = (C_word)(h & C_HEADER_BITS_MASK);13007 p = sbp->data;1300813009 if(key == C_STRUCTURE_TYPE) key = *p;1301013011 hdump_count(key, 1, bytes);1301213013 if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {13014 if((h & C_SPECIALBLOCK_BIT) != 0) {13015 --n;13016 ++p;13017 }1301813019 while(n--) {13020 x = *(p++);1302113022 if(C_immediatep(x)) {13023 ++imm;1302413025 if((x & C_FIXNUM_BIT) != 0) key = C_fix(1);13026 else {13027 switch(x & C_IMMEDIATE_TYPE_BITS) {13028 case C_BOOLEAN_BITS: key = C_SCHEME_TRUE; break;13029 case C_CHARACTER_BITS: key = C_make_character('A'); break;13030 default: key = x;13031 }13032 }1303313034 hdump_count(key, 1, 0);13035 }13036 }13037 }1303813039 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13040 }1304113042 bp = hdump_table;13043 /* HACK */13044#define C_WEAK_PAIR_TYPE (C_PAIR_TYPE | C_SPECIALBLOCK_BIT)1304513046 for(n = 0; n < HDUMP_TABLE_SIZE; ++n) {13047 for(b = bp[ n ]; b != NULL; b = b2) {13048 b2 = b->next;1304913050 switch(b->key) {13051 case C_fix(1): C_fprintf(C_stderr, C_text("fixnum ")); break;13052 case C_SCHEME_TRUE: C_fprintf(C_stderr, C_text("boolean ")); break;13053 case C_SCHEME_END_OF_LIST: C_fprintf(C_stderr, C_text("null ")); break;13054 case C_SCHEME_UNDEFINED : C_fprintf(C_stderr, C_text("void ")); break;13055 case C_SCHEME_BROKEN_WEAK_PTR: C_fprintf(C_stderr, C_text("broken weak ptr")); break;13056 case C_make_character('A'): C_fprintf(C_stderr, C_text("character ")); break;13057 case C_SCHEME_END_OF_FILE: C_fprintf(C_stderr, C_text("eof ")); break;13058 case C_SCHEME_UNBOUND: C_fprintf(C_stderr, C_text("unbound ")); break;13059 case C_SYMBOL_TYPE: C_fprintf(C_stderr, C_text("symbol ")); break;13060 case C_STRING_TYPE: C_fprintf(C_stderr, C_text("string ")); break;13061 case C_PAIR_TYPE: C_fprintf(C_stderr, C_text("pair ")); break;13062 case C_CLOSURE_TYPE: C_fprintf(C_stderr, C_text("closure ")); break;13063 case C_FLONUM_TYPE: C_fprintf(C_stderr, C_text("flonum ")); break;13064 case C_PORT_TYPE: C_fprintf(C_stderr, C_text("port ")); break;13065 case C_POINTER_TYPE: C_fprintf(C_stderr, C_text("pointer ")); break;13066 case C_LOCATIVE_TYPE: C_fprintf(C_stderr, C_text("locative ")); break;13067 case C_TAGGED_POINTER_TYPE: C_fprintf(C_stderr, C_text("tagged pointer ")); break;13068 case C_LAMBDA_INFO_TYPE: C_fprintf(C_stderr, C_text("lambda info ")); break;13069 case C_WEAK_PAIR_TYPE: C_fprintf(C_stderr, C_text("weak pair ")); break;13070 case C_VECTOR_TYPE: C_fprintf(C_stderr, C_text("vector ")); break;13071 case C_BYTEVECTOR_TYPE: C_fprintf(C_stderr, C_text("bytevector ")); break;13072 case C_BIGNUM_TYPE: C_fprintf(C_stderr, C_text("bignum ")); break;13073 case C_CPLXNUM_TYPE: C_fprintf(C_stderr, C_text("cplxnum ")); break;13074 case C_RATNUM_TYPE: C_fprintf(C_stderr, C_text("ratnum ")); break;13075 /* XXX this is sort of funny: */13076 case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("blob ")); break;13077 default:13078 x = b->key;1307913080 if(!C_immediatep(x) && C_header_bits(x) == C_SYMBOL_TYPE) {13081 x = C_block_item(x, 1);13082 C_fprintf(C_stderr, C_text("`%.*s'"), (int)C_header_size(x), C_c_string(x));13083 }13084 else C_fprintf(C_stderr, C_text("unknown key " UWORD_FORMAT_STRING), (C_uword)b->key);13085 }1308613087 C_fprintf(C_stderr, C_text("\t%d"), b->count);1308813089 if(b->total > 0)13090 C_fprintf(C_stderr, C_text("\t%d bytes"), b->total);1309113092 C_fputc('\n', C_stderr);13093 C_free(b);13094 }13095 }1309613097 C_fprintf(C_stderr, C_text("\ntotal number of blocks: %d, immediates: %d\n"),13098 blk, imm);13099 C_free(hdump_table);13100 C_kontinue(k, C_SCHEME_UNDEFINED);13101}131021310313104static void C_ccall filter_heap_objects_2(C_word c, C_word *av)13105{13106 void *func = C_pointer_address(av[ 0 ]);13107 C_word13108 userarg = av[ 1 ],13109 vector = av[ 2 ],13110 k = av[ 3 ];13111 int n, bytes;13112 C_byte *scan;13113 C_SCHEME_BLOCK *sbp;13114 C_header h;13115 C_word *p;13116 int vecsize = C_header_size(vector);13117 typedef int (*filterfunc)(C_word x, C_word userarg);13118 filterfunc ff = (filterfunc)func;13119 int vcount = 0;1312013121 scan = fromspace_start;1312213123 while(scan < C_fromspace_top) {13124 sbp = (C_SCHEME_BLOCK *)scan;1312513126 if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)13127 sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);1312813129 n = C_header_size(sbp);13130 h = sbp->header;13131 bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);13132 p = sbp->data;1313313134 if(ff((C_word)sbp, userarg)) {13135 if(vcount < vecsize) {13136 C_set_block_item(vector, vcount, (C_word)sbp);13137 ++vcount;13138 }13139 else {13140 C_kontinue(k, C_fix(-1));13141 }13142 }1314313144 scan = (C_byte *)sbp + C_align(bytes) + sizeof(C_word);13145 }1314613147 C_kontinue(k, C_fix(vcount));13148}131491315013151void C_ccall C_filter_heap_objects(C_word c, C_word *av)13152{13153 C_word13154 /* closure = av[ 0 ] */13155 k = av[ 1 ],13156 func = av[ 2 ],13157 vector = av[ 3 ],13158 userarg = av[ 4 ];1315913160 /* make sure heap is compacted */13161 C_save(k);13162 C_save(vector);13163 C_save(userarg);13164 C_save(func);13165 C_fromspace_top = C_fromspace_limit; /* force major GC */13166 C_reclaim((void *)filter_heap_objects_2, 4);13167}1316813169C_regparm C_word C_fcall C_i_process_sleep(C_word n)13170{13171#if defined(_WIN32) && !defined(__CYGWIN__)13172 Sleep(C_unfix(n) * 1000);13173 return C_fix(0);13174#else13175 return C_fix(sleep(C_unfix(n)));13176#endif13177}1317813179C_regparm C_word C_fcall13180C_i_file_exists_p(C_word name, C_word file, C_word dir)13181{13182 struct stat buf;13183 int res;1318413185 res = C_stat(C_c_string(name), &buf);1318613187 if(res != 0) {13188 switch(errno) {13189 case ENOENT: return C_SCHEME_FALSE;13190 case EOVERFLOW: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13191 case ENOTDIR: return C_SCHEME_FALSE;13192 default: return C_fix(res);13193 }13194 }1319513196 switch(buf.st_mode & S_IFMT) {13197 case S_IFDIR: return C_truep(file) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13198 default: return C_truep(dir) ? C_SCHEME_FALSE : C_SCHEME_TRUE;13199 }13200}132011320213203C_regparm C_word C_fcall13204C_i_pending_interrupt(C_word dummy)13205{13206 if(pending_interrupts_count > 0) {13207 handling_interrupts = 1; /* Lock out further forced GCs until we're done */13208 return C_fix(pending_interrupts[ --pending_interrupts_count ]);13209 } else {13210 handling_interrupts = 0; /* OK, can go on */13211 return C_SCHEME_FALSE;13212 }13213}132141321513216/* random numbers, mostly lifted from13217 https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c13218*/1321913220#ifdef __linux__13221# include <sys/syscall.h>13222#endif132231322413225#if !defined(_WIN32)13226static C_word random_urandom(C_word buf, int count)13227{13228 static int fd = -1;13229 int off = 0, r;1323013231 if(fd == -1) {13232 fd = open("/dev/urandom", O_RDONLY);1323313234 if(fd == -1) return C_SCHEME_FALSE;13235 }1323613237 while(count > 0) {13238 r = read(fd, C_data_pointer(buf) + off, count);1323913240 if(r == -1) {13241 if(errno != EINTR && errno != EAGAIN) return C_SCHEME_FALSE;13242 else r = 0;13243 }1324413245 count -= r;13246 off += r;13247 }1324813249 return C_SCHEME_TRUE;13250}13251#endif132521325313254C_word C_random_bytes(C_word buf, C_word size)13255{13256 int count = C_unfix(size);13257 int r = 0;13258 int off = 0;1325913260#if defined(__OpenBSD__) || defined(__FreeBSD__)13261 arc4random_buf(C_data_pointer(buf), count);13262#elif defined(SYS_getrandom) && defined(__NR_getrandom)13263 static int use_urandom = 0;1326413265 if(use_urandom) return random_urandom(buf, count);1326613267 while(count > 0) {13268 /* GRND_NONBLOCK = 0x0001 */13269 r = syscall(SYS_getrandom, C_data_pointer(buf) + off, count, 1);1327013271 if(r == -1) {13272 if(errno == ENOSYS) {13273 use_urandom = 1;13274 return random_urandom(buf, count);13275 }13276 else if(errno != EINTR) return C_SCHEME_FALSE;13277 else r = 0;13278 }1327913280 count -= r;13281 off += r;13282 }13283#elif defined(_WIN32) && !defined(__CYGWIN__)13284 typedef BOOLEAN (*func)(PVOID, ULONG);13285 static func RtlGenRandom = NULL;1328613287 if(RtlGenRandom == NULL) {13288 HMODULE mod = LoadLibrary("advapi32.dll");1328913290 if(mod == NULL) return C_SCHEME_FALSE;1329113292 if((RtlGenRandom = (func)GetProcAddress(mod, "SystemFunction036")) == NULL)13293 return C_SCHEME_FALSE;13294 }1329513296 if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))13297 return C_SCHEME_FALSE;13298#else13299 return random_urandom(buf, count);13300#endif1330113302 return C_SCHEME_TRUE;13303}133041330513306/* WELL512 pseudo random number generator, see also:13307 https://en.wikipedia.org/wiki/Well_equidistributed_long-period_linear13308 http://lomont.org/Math/Papers/2008/Lomont_PRNG_2008.pdf13309*/1331013311static C_uword random_word(void)13312{13313 C_uword a, b, c, d, r;13314 a = random_state[random_state_index];13315 c = random_state[(random_state_index+13)&15];13316 b = a^c^(a<<16)^(c<<15);13317 c = random_state[(random_state_index+9)&15];13318 c ^= (c>>11);13319 a = random_state[random_state_index] = b^c;13320 d = a^((a<<5)&0xDA442D24UL);13321 random_state_index = (random_state_index + 15)&15;13322 a = random_state[random_state_index];13323 random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);13324 r = random_state[random_state_index];13325 return r;13326}133271332813329static C_uword random_uniform(C_uword bound)13330{13331 C_uword r, min;1333213333 if (bound < 2) return 0;1333413335 min = (1U + ~bound) % bound; /* = 2**<wordsize> mod bound */1333613337 do r = random_word(); while (r < min);1333813339 /* r is now clamped to a set whose size mod upper_bound == 013340 * the worst case (2**<wordsize-1>+1) requires ~ 2 attempts */1334113342 return r % bound;13343}133441334513346C_regparm C_word C_random_fixnum(C_word n)13347{13348 C_word nf;1334913350 if (!(n & C_FIXNUM_BIT))13351 barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "pseudo-random-integer", n);1335213353 nf = C_unfix(n);1335413355 if(nf < 0)13356 barf(C_OUT_OF_RANGE_ERROR, "pseudo-random-integer", n, C_fix(0));1335713358 return C_fix(random_uniform(nf));13359}133601336113362C_regparm C_word C_fcall13363C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)13364{13365 C_uword *start, *end;1336613367 if(C_bignum_negativep(rn))13368 barf(C_OUT_OF_RANGE_ERROR, "pseudo-random-integer", rn, C_fix(0));1336913370 int len = integer_length_abs(rn);13371 C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));13372 C_word result = C_allocate_scratch_bignum(ptr, size, C_SCHEME_FALSE, C_SCHEME_FALSE);13373 C_uword *p;13374 C_uword highest_word = C_bignum_digits(rn)[C_bignum_size(rn)-1];13375 start = C_bignum_digits(result);13376 end = start + C_bignum_size(result);1337713378 for(p = start; p < (end - 1); ++p) {13379 *p = random_word();13380 len -= sizeof(C_uword);13381 }1338213383 *p = random_uniform(highest_word);13384 return C_bignum_simplify(result);13385}1338613387/*13388 * C_a_i_random_real: Generate a stream of bits uniformly at random and13389 * interpret it as the fractional part of the binary expansion of a13390 * number in [0, 1], 0.00001010011111010100...; then round it.13391 * More information on https://mumble.net/~campbell/2014/04/28/uniform-random-float13392 */1339313394static inline C_u64 random64() {13395#ifdef C_SIXTY_FOUR13396 return random_word();13397#else13398 C_u64 v = 0;13399 v |= ((C_u64) random_word()) << 32;13400 v |= (C_u64) random_word();13401 return v;13402#endif13403}1340413405#if defined(__GNUC__) && !defined(__TINYC__)13406# define clz64 __builtin_clzll13407#else13408/* https://en.wikipedia.org/wiki/Find_first_set#CLZ */13409static const C_uchar clz_table_4bit[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 };1341013411int clz32(C_u32 x)13412{13413 int n;13414 if ((x & 0xFFFF0000) == 0) {n = 16; x <<= 16;} else {n = 0;}13415 if ((x & 0xFF000000) == 0) {n += 8; x <<= 8;}13416 if ((x & 0xF0000000) == 0) {n += 4; x <<= 4;}13417 n += (int)clz_table_4bit[x >> (32-4)];13418 return n;13419}1342013421int clz64(C_u64 x)13422{13423 int y = clz32(x >> 32);1342413425 if(y == 32) return y + clz32(x);1342613427 return y;13428}13429#endif1343013431C_regparm C_word C_fcall13432C_a_i_random_real(C_word **ptr, C_word n) {13433 int exponent = -64;13434 uint64_t significand;13435 unsigned shift;1343613437 while (C_unlikely((significand = random64()) == 0)) {13438 exponent -= 64;13439 if (C_unlikely(exponent < -1074))13440 return 0;13441 }1344213443 shift = clz64(significand);13444 if (shift != 0) {13445 exponent -= shift;13446 significand <<= shift;13447 significand |= (random64() >> (64 - shift));13448 }1344913450 significand |= 1;13451 return C_flonum(ptr, ldexp((double)significand, exponent));13452}1345313454C_word C_set_random_seed(C_word buf, C_word n)13455{13456 int i, nsu = C_unfix(n) / sizeof(C_uword);13457 int off = 0;1345813459 for(i = 0; i < (C_RANDOM_STATE_SIZE / sizeof(C_uword)); ++i) {13460 if(off >= nsu) off = 0;1346113462 random_state[ i ] = *((C_uword *)C_data_pointer(buf) + off);13463 ++off;13464 }1346513466 random_state_index = 0;13467 return C_SCHEME_FALSE;13468}