diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 91a8da1a6..830c3ba9b 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -78,6 +78,10 @@ STREAM_OBJS = stream.o file.o streams/strm_os.o streams/strm_clos.o FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o +THREAD_OBJS = @THREAD_OBJS@ + +UNICODE_OBJS = @UNICODE_OBJS@ + OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o error.o \ string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ @@ -85,7 +89,7 @@ OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ load.o unixfsys.o unixsys.o serialize.o sse2.o atomic.o process.o \ $(BOOT_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(STREAM_OBJS) \ - $(CLOS_OBJS) $(FFI_OBJS) @EXTRA_OBJS@ + $(CLOS_OBJS) $(FFI_OBJS) $(THREAD_OBJS) $(UNICODE_OBJS) @EXTRA_OBJS@ .PHONY: all diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 57f945305..54a821ee4 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -54,13 +54,13 @@ _ecl_set_max_heap_size(size_t new_size) { const cl_env_ptr the_env = ecl_process_env(); ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size = new_size); + GC_set_max_heap_size(ecl_core.max_heap_size = new_size); if (new_size == 0) { cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - GC_FREE(cl_core.safety_region); - cl_core.safety_region = 0; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + GC_FREE(ecl_core.safety_region); + ecl_core.safety_region = 0; } ecl_enable_interrupts_env(the_env); } @@ -96,7 +96,7 @@ out_of_memory(size_t requested_bytes) /* The out of memory condition may happen in more than one thread */ /* But then we have to ensure the error has not been solved */ #ifdef ECL_THREADS - ecl_mutex_lock(&cl_core.error_lock); + ecl_mutex_lock(&ecl_core.error_lock); ECL_UNWIND_PROTECT_BEGIN(the_env) #endif { @@ -111,23 +111,23 @@ out_of_memory(size_t requested_bytes) goto OUTPUT; } } - if (cl_core.max_heap_size == 0) { + if (ecl_core.max_heap_size == 0) { /* We did not set any limit in the amount of memory, * yet we failed, or we had some limits but we have * not reached them. */ - if (cl_core.safety_region) { + if (ecl_core.safety_region) { /* We can free some memory and try handling the error */ - GC_FREE(cl_core.safety_region); + GC_FREE(ecl_core.safety_region); the_env->string_pool = ECL_NIL; - cl_core.safety_region = 0; + ecl_core.safety_region = 0; method = 0; } else { /* No possibility of continuing */ method = 2; } } else { - cl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - GC_set_max_heap_size(cl_core.max_heap_size); + ecl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + GC_set_max_heap_size(ecl_core.max_heap_size); method = 1; } OUTPUT: @@ -135,7 +135,7 @@ out_of_memory(size_t requested_bytes) } #ifdef ECL_THREADS ECL_UNWIND_PROTECT_EXIT { - ecl_mutex_unlock(&cl_core.error_lock); + ecl_mutex_unlock(&ecl_core.error_lock); } ECL_UNWIND_PROTECT_END; #endif ecl_bds_unwind1(the_env); @@ -154,8 +154,8 @@ out_of_memory(size_t requested_bytes) } if (!interrupts) ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size += - cl_core.max_heap_size / 2); + ecl_core.max_heap_size += (ecl_core.max_heap_size / 2); + GC_set_max_heap_size(ecl_core.max_heap_size); /* Default allocation. Note that we do not allocate atomic. */ return GC_MALLOC(requested_bytes); } @@ -393,6 +393,7 @@ ecl_alloc_instance(cl_index slots) i = ecl_alloc_object(t_instance); i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots); i->instance.length = slots; + i->instance.isgf = ECL_NOT_FUNCALLABLE; i->instance.entry = FEnot_funcallable_vararg; i->instance.slotds = ECL_UNBOUND; return i; @@ -793,14 +794,14 @@ init_alloc(int pass) FALSE, TRUE); # endif #endif /* !GBC_BOEHM_PRECISE */ - - GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); + ecl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]; + GC_set_max_heap_size(ecl_core.max_heap_size); /* Save some memory for the case we get tight. */ - if (cl_core.max_heap_size == 0) { + if (ecl_core.max_heap_size == 0) { cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - cl_core.safety_region = 0; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + ecl_core.safety_region = 0; } init_type_info(); @@ -890,7 +891,7 @@ standard_finalizer(cl_object o) } case t_symbol: { if (o->symbol.binding != ECL_MISSING_SPECIAL_BINDING) { - ecl_atomic_push(&cl_core.reused_indices, ecl_make_fixnum(o->symbol.binding)); + ecl_atomic_push(&ecl_core.reused_indices, ecl_make_fixnum(o->symbol.binding)); o->symbol.binding = ECL_MISSING_SPECIAL_BINDING; } } @@ -1067,33 +1068,33 @@ si_gc_stats(cl_object enable) cl_object old_status; cl_object size1; cl_object size2; - if (cl_core.gc_stats == 0) { + if (ecl_core.gc_stats == 0) { old_status = ECL_NIL; } else if (GC_print_stats) { old_status = @':full'; } else { old_status = ECL_T; } - if (cl_core.bytes_consed == ECL_NIL) { - cl_core.bytes_consed = ecl_alloc_object(t_bignum); - mpz_init2(ecl_bignum(cl_core.bytes_consed), 128); - cl_core.gc_counter = ecl_alloc_object(t_bignum); - mpz_init2(ecl_bignum(cl_core.gc_counter), 128); + if (ecl_core.bytes_consed == ECL_NIL) { + ecl_core.bytes_consed = ecl_alloc_object(t_bignum); + mpz_init2(ecl_bignum(ecl_core.bytes_consed), 128); + ecl_core.gc_counter = ecl_alloc_object(t_bignum); + mpz_init2(ecl_bignum(ecl_core.gc_counter), 128); } update_bytes_consed(); /* We need fresh copies of the bignums */ - size1 = _ecl_big_register_copy(cl_core.bytes_consed); - size2 = _ecl_big_register_copy(cl_core.gc_counter); + size1 = _ecl_big_register_copy(ecl_core.bytes_consed); + size2 = _ecl_big_register_copy(ecl_core.gc_counter); if (enable == ECL_NIL) { GC_print_stats = 0; - cl_core.gc_stats = 0; + ecl_core.gc_stats = 0; } else if (enable == ecl_make_fixnum(0)) { - mpz_set_ui(ecl_bignum(cl_core.bytes_consed), 0); - mpz_set_ui(ecl_bignum(cl_core.gc_counter), 0); + mpz_set_ui(ecl_bignum(ecl_core.bytes_consed), 0); + mpz_set_ui(ecl_bignum(ecl_core.gc_counter), 0); } else { - cl_core.gc_stats = 1; + ecl_core.gc_stats = 1; GC_print_stats = (enable == @':full'); } @(return size1 size2 old_status); @@ -1106,10 +1107,10 @@ static void gather_statistics() { /* GC stats rely on bignums */ - if (cl_core.gc_stats) { + if (ecl_core.gc_stats) { update_bytes_consed(); - mpz_add_ui(ecl_bignum(cl_core.gc_counter), - ecl_bignum(cl_core.gc_counter), + mpz_add_ui(ecl_bignum(ecl_core.gc_counter), + ecl_bignum(ecl_core.gc_counter), 1); } if (GC_old_start_callback) @@ -1119,8 +1120,8 @@ gather_statistics() static void update_bytes_consed () { #if GBC_BOEHM == 0 - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), GC_get_bytes_since_gc()); #else /* This is not accurate and may wrap around. We try to detect this @@ -1131,15 +1132,15 @@ update_bytes_consed () { if (bytes > new_bytes) { cl_index wrapped; wrapped = ~((cl_index)0) - bytes; - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), wrapped); - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), new_bytes); } else { - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), new_bytes - bytes); } bytes = new_bytes; @@ -1171,7 +1172,7 @@ ecl_mark_env(struct cl_env_struct *env) static void stacks_scanner() { - cl_object l = cl_core.libraries; + cl_object l = ecl_core.libraries; loop_for_on_unsafe(l) { cl_object dll = ECL_CONS_CAR(l); if (dll->cblock.locked) { @@ -1179,18 +1180,19 @@ stacks_scanner() GC_set_mark_bit((void *)dll); } } end_loop_for_on_unsafe(l); + GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1)); GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); - ecl_mark_env(cl_core.first_env); + ecl_mark_env(ecl_core.first_env); #ifdef ECL_THREADS - l = cl_core.processes; + l = ecl_core.processes; if (l != OBJNULL) { cl_index i, size; for (i = 0, size = l->vector.dim; i < size; i++) { cl_object process = l->vector.self.t[i]; if (!Null(process)) { cl_env_ptr env = process->process.env; - if (env && (env != cl_core.first_env)) ecl_mark_env(env); + if (env && (env != ecl_core.first_env)) ecl_mark_env(env); } } } diff --git a/src/c/apply.d b/src/c/apply.d index 12a27e74e..6851c95b8 100644 --- a/src/c/apply.d +++ b/src/c/apply.d @@ -12,7 +12,135 @@ */ #include +#include #include +#include +#include + +cl_objectfn +ecl_function_dispatch(cl_env_ptr env, cl_object x) +{ + cl_object fun = x; + if (ecl_unlikely(fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; + case t_instance: + env->function = fun; + return fun->instance.entry; + case t_symbol: + fun = ECL_SYM_FUN(fun); + env->function = fun; + return fun->cfun.entry; + case t_bytecodes: + env->function = fun; + return fun->bytecodes.entry; + case t_bclosure: + env->function = fun; + return fun->bclosure.entry; + default: + FEinvalid_function(x); + } + _ecl_unexpected_return(); +} + +/* Calling conventions: + * Compiled C code calls lisp function supplying #args, and args. + * + * Linking function performs check_args, gets jmp_buf with _setjmp, then + * + * if cfun then stores C code address into function link location and transfers + * to jmp_buf at cf_self + + * if cclosure then replaces #args with cc_env and calls cc_self otherwise, it + * emulates funcall. + */ + +cl_object +ecl_apply_from_stack_frame(cl_object frame, cl_object x) +{ + cl_object *sp = ECL_STACK_FRAME_PTR(frame); + cl_index narg = frame->frame.size; + cl_object fun = x; + cl_object ret; + frame->frame.env->stack_frame = frame; + AGAIN: + frame->frame.env->function = fun; + if (ecl_unlikely(fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) + FEwrong_num_arguments(fun); + ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); + break; + case t_cfun: + ret = APPLY(narg, fun->cfun.entry, sp); + break; + case t_cclosure: + ret = APPLY(narg, fun->cclosure.entry, sp); + break; + case t_instance: + switch (fun->instance.isgf) { + case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: + ret = _ecl_standard_dispatch(frame, fun); + break; + case ECL_USER_DISPATCH: + fun = fun->instance.slots[fun->instance.length - 1]; + goto AGAIN; + case ECL_READER_DISPATCH: + case ECL_WRITER_DISPATCH: + ret = APPLY(narg, fun->instance.entry, sp); + break; + default: + FEinvalid_function(fun); + } + break; + case t_symbol: + if (ecl_unlikely(!ECL_FBOUNDP(fun))) + FEundefined_function(fun); + fun = ECL_SYM_FUN(fun); + goto AGAIN; + case t_bytecodes: + ret = ecl_interpret(frame, ECL_NIL, fun); + break; + case t_bclosure: + ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); + break; + default: + FEinvalid_function(x); + } + frame->frame.env->stack_frame = NULL; /* for gc's sake */ + return ret; +} + +cl_object +cl_funcall(cl_narg narg, cl_object function, ...) +{ + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; +} + +cl_object * +_ecl_va_sp(cl_narg narg) +{ + return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; +} #if !(ECL_C_ARGUMENTS_LIMIT == 63) #error "Please adjust code to the constant!" @@ -658,4 +786,5 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) default: FEprogram_error("Too many arguments", 0); } + _ecl_unexpected_return(); } diff --git a/src/c/character.d b/src/c/character.d index 3b6699fab..549466744 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -14,9 +14,20 @@ #include #include +#include #include "char_ctype.d" +static void +assert_type_radix(cl_object fun, cl_narg narg, cl_object radix) +{ + unlikely_if (!ECL_FIXNUMP(radix) + || ecl_fixnum(radix) < 2 + || ecl_fixnum(radix) > 36) { + FEwrong_type_nth_arg(fun, narg, radix, @[si::radix]); + } +} + ecl_character ecl_char_code(cl_object c) { @@ -96,48 +107,10 @@ cl_both_case_p(cl_object c) @(return (ecl_both_case_p(ecl_char_code(c))? ECL_T : ECL_NIL)); } -int -ecl_string_case(cl_object s) -{ - /* Returns 1 if string is all uppercase, -1 if all lowercase, and 0 if mixed case */ - int upcase; - cl_index i; - - switch (ecl_t_of(s)) { -#ifdef ECL_UNICODE - case t_string: -#endif - case t_base_string: - for (i = 0, upcase = 0; i < s->base_string.dim; i++) { - ecl_character c = ecl_char(s, i); - - if (ecl_upper_case_p(c)) { - if (upcase < 0) - return 0; - upcase = +1; - } else if (ecl_lower_case_p(c)) { - if (upcase > 0) - return 0; - upcase = -1; - } - } - break; - default: - FEwrong_type_argument(@[string], s); - } - return upcase; -} - @(defun digit_char_p (c &optional (radix ecl_make_fixnum(10))) @ { cl_fixnum basis, value; - if (ecl_unlikely(!ECL_FIXNUMP(radix) || - ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || - ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { - FEwrong_type_nth_arg(@[digit-char-p], 2, radix, - ecl_make_integer_type(ecl_make_fixnum(2), - ecl_make_fixnum(36))); - } + assert_type_radix(@[digit-char-p], 2, radix); basis = ecl_fixnum(radix); value = ecl_digitp(ecl_char_code(c), basis); @(return ((value < 0)? ECL_NIL: ecl_make_fixnum(value))); @@ -373,11 +346,11 @@ cl_character(cl_object x) x = ECL_CODE_CHAR(x->base_string.self[0]); break; } - default: ERROR: - FEwrong_type_nth_arg - (@[character], - 1, x, - ecl_read_from_cstring("(OR CHARACTER SYMBOL (ARRAY CHARACTER (1)) (ARRAY BASE-CHAR (1)))")); + default: +#ifdef ECL_UNICODE + ERROR: +#endif + FEwrong_type_only_arg(@[character], x, @[character]); } @(return x); } @@ -430,13 +403,7 @@ cl_char_downcase(cl_object c) @ { cl_fixnum basis; cl_object output = ECL_NIL; - if (ecl_unlikely(!ECL_FIXNUMP(radix) || - ecl_fixnum_lower(radix, ecl_make_fixnum(2)) || - ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) { - FEwrong_type_nth_arg(@[digit-char], 2, radix, - ecl_make_integer_type(ecl_make_fixnum(2), - ecl_make_fixnum(36))); - } + assert_type_radix(@[digit-char], 2, radix); basis = ecl_fixnum(radix); switch (ecl_t_of(weight)) { case t_fixnum: { @@ -476,78 +443,3 @@ cl_char_int(cl_object c) ecl_return1(the_env, ecl_make_fixnum(ecl_char_code(c))); } -/* here we give every character an implicit name of the form 'u#' where # is a hexadecimal number, - corresponding to a unicode code point. - #\u14ea should work, for example -*/ - -cl_object -cl_char_name(cl_object c) -{ - ecl_character code = ecl_char_code(c); - cl_object output; - if (code <= 127) { - output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL); -#ifdef ECL_UNICODE - } else if (!Null(output = _ecl_ucd_code_to_name(code))) { - (void)0; -#endif - } else { - ecl_base_char name[8]; - ecl_base_char *start; - name[7] = 0; - name[6] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[5] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[4] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[3] = ecl_digit_char(code & 0xF, 16); code >>= 4; - if (code == 0) { - start = name + 2; - } else { - name[2] = ecl_digit_char(code & 0xF, 16); code >>= 4; - name[1] = ecl_digit_char(code & 0xF, 16); - start = name; - } - start[0] = 'U'; - output = ecl_make_simple_base_string((const char*)start,-1); - } - @(return output); -} - -cl_object -cl_name_char(cl_object name) -{ - const cl_env_ptr the_env = ecl_process_env(); - cl_object c; - cl_index l; - name = cl_string(name); - c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL); - if (c != ECL_NIL) { - ecl_return1(the_env, ECL_CODE_CHAR(ecl_fixnum(c))); - } -#ifdef ECL_UNICODE - c = _ecl_ucd_name_to_code(name); - if (c != ECL_NIL) { - ecl_return1(the_env, cl_code_char(c)); - } -#endif - if (ecl_stringp(name) && (l = ecl_length(name))) { - c = cl_char(name, ecl_make_fixnum(0)); - if (l == 1) { - (void)0; - } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) { - c = ECL_NIL; - } else { - cl_index used_l; - cl_index end = name->base_string.fillp; - cl_index real_end = end; - c = ecl_parse_integer(name, 1, end, &real_end, 16); - used_l = real_end; - if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) { - c = ECL_NIL; - } else { - c = ECL_CODE_CHAR(ecl_fixnum(c)); - } - } - } - ecl_return1(the_env, c); -} diff --git a/src/c/compiler.d b/src/c/compiler.d index 23b4930b0..07029b43f 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -3107,10 +3107,11 @@ c_cons_cdr(cl_env_ptr env, cl_object args, int flags) cl_object si_need_to_make_load_form_p(cl_object object) { - cl_object load_form_cache = cl__make_hash_table(@'eq', - ecl_make_fixnum(16), - cl_core.rehash_size, - cl_core.rehash_threshold); + cl_object load_form_cache = + cl__make_hash_table(@'eq', + ecl_make_fixnum(16), + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); cl_object waiting_objects = ecl_list1(object); cl_type type = t_start; @@ -3803,8 +3804,8 @@ init_compiler() cl_object dispatch_table = cl_core.compiler_dispatch = cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); int i; for (i = 0; database[i].symbol; i++) { ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); diff --git a/src/c/eval.d b/src/c/eval.d index 97fb81668..a7e246d07 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -16,127 +16,6 @@ #include #include -cl_object * -_ecl_va_sp(cl_narg narg) -{ - return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; -} - -/* Calling conventions: - * Compiled C code calls lisp function supplying #args, and args. - * Linking function performs check_args, gets jmp_buf with _setjmp, then - * if cfun then stores C code address into function link location - * and transfers to jmp_buf at cf_self - * if cclosure then replaces #args with cc_env and calls cc_self - * otherwise, it emulates funcall. - */ - -cl_object -ecl_apply_from_stack_frame(cl_object frame, cl_object x) -{ - cl_object *sp = ECL_STACK_FRAME_PTR(frame); - cl_index narg = frame->frame.size; - cl_object fun = x; - cl_object ret; - frame->frame.env->stack_frame = frame; - AGAIN: - frame->frame.env->function = fun; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - break; - case t_cfun: - ret = APPLY(narg, fun->cfun.entry, sp); - break; - case t_cclosure: - ret = APPLY(narg, fun->cclosure.entry, sp); - break; - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - ret = _ecl_standard_dispatch(frame, fun); - break; - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - ret = APPLY(narg, fun->instance.entry, sp); - break; - default: - FEinvalid_function(fun); - } - break; - case t_symbol: - if (ecl_unlikely(!ECL_FBOUNDP(fun))) - FEundefined_function(fun); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - ret = ecl_interpret(frame, ECL_NIL, fun); - break; - case t_bclosure: - ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - break; - default: - FEinvalid_function(x); - } - frame->frame.env->stack_frame = NULL; /* for gc's sake */ - return ret; -} - -cl_objectfn -ecl_function_dispatch(cl_env_ptr env, cl_object x) -{ - cl_object fun = x; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; - case t_instance: - env->function = fun; - return fun->instance.entry; - case t_symbol: - fun = ECL_SYM_FUN(fun); - env->function = fun; - return fun->cfun.entry; - case t_bytecodes: - env->function = fun; - return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; - return fun->bclosure.entry; - default: - FEinvalid_function(x); - } -} - -cl_object -cl_funcall(cl_narg narg, cl_object function, ...) -{ - cl_object output; - --narg; - { - ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); - output = ecl_apply_from_stack_frame(frame, function); - ECL_STACK_FRAME_VARARGS_END(frame); - } - return output; -} - @(defun apply (fun lastarg &rest args) @ { if (narg == 2 && ecl_t_of(lastarg) == t_frame) { diff --git a/src/c/ffi/libraries.d b/src/c/ffi/libraries.d index 098cd483d..21441dfc0 100644 --- a/src/c/ffi/libraries.d +++ b/src/c/ffi/libraries.d @@ -221,7 +221,7 @@ static cl_object ecl_library_find_by_name(cl_object filename) { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object other = ECL_CONS_CAR(l); cl_object name = other->cblock.name; if (!Null(name) && ecl_string_eq(name, filename)) { @@ -235,7 +235,7 @@ static cl_object ecl_library_find_by_handle(void *handle) { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object other = ECL_CONS_CAR(l); if (handle == other->cblock.handle) { return other; @@ -268,7 +268,7 @@ ecl_library_open_inner(cl_object filename, bool self_destruct) block->cblock.refs = ecl_one_plus(block->cblock.refs); } else { si_set_finalizer(block, ECL_T); - cl_core.libraries = CONS(block, cl_core.libraries); + ecl_core.libraries = CONS(block, ecl_core.libraries); } } ecl_enable_interrupts(); @@ -341,7 +341,7 @@ ecl_library_symbol(cl_object block, const char *symbol, bool lock) { void *p; if (block == @':default') { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object block = ECL_CONS_CAR(l); p = ecl_library_symbol(block, symbol, lock); if (p) return p; @@ -426,7 +426,7 @@ ecl_library_close(cl_object block) { block = ECL_NIL; } else if (block->cblock.handle != NULL) { success = GC_call_with_alloc_lock(dlclose_wrapper, block); - cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); + ecl_core.libraries = ecl_remove_eq(block, ecl_core.libraries); } else { /* block not loaded */ success = FALSE; } @@ -443,8 +443,8 @@ ecl_library_close(cl_object block) { void ecl_library_close_all(void) { - while (cl_core.libraries != ECL_NIL) { - ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + while (ecl_core.libraries != ECL_NIL) { + ecl_library_close(ECL_CONS_CAR(ecl_core.libraries)); } } diff --git a/src/c/hash.d b/src/c/hash.d index d9c3320b4..580f16894 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -943,8 +943,8 @@ ecl_extend_hashtable(cl_object hashtable) (weakness ECL_NIL) (synchronized ECL_NIL) (size ecl_make_fixnum(1024)) - (rehash_size cl_core.rehash_size) - (rehash_threshold cl_core.rehash_threshold)) + (rehash_size ecl_ct_default_rehash_size) + (rehash_threshold ecl_ct_default_rehash_threshold)) @ { cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); if (hash->hash.test == ecl_htt_generic) { diff --git a/src/c/main.d b/src/c/main.d index 7f06fe6a7..78807f74a 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -35,6 +35,7 @@ # define MAP_FAILED -1 # endif #endif +#include #include #include #include @@ -49,8 +50,90 @@ /******************************* EXPORTS ******************************/ const char *ecl_self; + +/* -- core runtime ---------------------------------------------------------- */ + +/* The root environment is a default execution context. */ static struct cl_env_struct first_env; +struct ecl_core_struct ecl_core = { + .first_env = &first_env, + /* processes */ +#ifdef ECL_THREADS + .processes = ECL_NIL, + .last_var_index = 0, + .reused_indices = ECL_NIL, +#endif + /* signals */ + .default_sigmask_bytes = 0, + .known_signals = ECL_NIL, + /* allocation */ + .max_heap_size = 0, + .bytes_consed = ECL_NIL, + .gc_counter = ECL_NIL, + .gc_stats = 0, + .safety_region = NULL, + /* pathnames */ + .path_max = 0, + .pathname_translations = ECL_NIL, + /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers + thanks to the magic in the garbage collector. */ + .libraries = ECL_NIL, + .library_pathname = ECL_NIL +}; + +/* note that this function does not create any environment */ +int +ecl_boot(void) +{ + int i; + + i = ecl_option_values[ECL_OPT_BOOTED]; + if (i) { + if (i < 0) { + /* We have called cl_shutdown and want to use ECL again. */ + ecl_set_option(ECL_OPT_BOOTED, 1); + } + return 1; + } + + init_process(); + /* init_unixint(); */ + /* init_garbage(); */ + + ecl_core.path_max = MAXPATHLEN; + + return 0; +} + +/* -- constants ----------------------------------------------------- */ + +const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); + +ecl_def_ct_base_string(ecl_ct_null_string,"",0,,const); + +ecl_def_ct_single_float(ecl_ct_default_rehash_size,1.5f,,const); +ecl_def_ct_single_float(ecl_ct_default_rehash_threshold,0.75f,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_zero,0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_zero,0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_zero,0,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_minus_zero,-0.0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_minus_zero,-0.0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); + +ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); +ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); + +/* These two tags have a special meaning for the frame stack. */ + +ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); +ecl_def_ct_base_string(ecl_ct_dtag_string,"DUMMY-TAG",9,static,const); + +ecl_def_ct_symbol(ecl_ct_protect_tag,ecl_stp_constant,ecl_ct_ptag_string,ECL_NIL,,const); +ecl_def_ct_symbol(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL,,const); + /************************ GLOBAL INITIALIZATION ***********************/ @@ -192,7 +275,7 @@ init_env_aux(cl_env_ptr env) void ecl_init_first_env(cl_env_ptr env) { - env->default_sigmask = cl_core.default_sigmask; + env->default_sigmask = ecl_core.first_env->default_sigmask; #ifdef ECL_THREADS init_threads(); #else @@ -246,7 +329,7 @@ _ecl_alloc_env(cl_env_ptr parent) * Note that at this point we are not allocating any other memory * which is stored via a pointer in the environment. If we would do * that, an unlucky interrupt by the gc before the allocated - * environment is registered in cl_core.processes could lead to + * environment is registered in ecl_core.processes could lead to * memory being freed because the gc is not aware of the pointer to * the allocated memory in the environment. */ @@ -268,14 +351,14 @@ _ecl_alloc_env(cl_env_ptr parent) # endif #endif { - size_t bytes = cl_core.default_sigmask_bytes; + size_t bytes = ecl_core.default_sigmask_bytes; if (bytes == 0) { output->default_sigmask = 0; } else if (parent) { output->default_sigmask = ecl_alloc_atomic(bytes); memcpy(output->default_sigmask, parent->default_sigmask, bytes); } else { - output->default_sigmask = cl_core.default_sigmask; + output->default_sigmask = ecl_core.first_env->default_sigmask; } } for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { @@ -313,8 +396,6 @@ cl_shutdown(void) ecl_set_option(ECL_OPT_BOOTED, -1); } -ecl_def_ct_single_float(default_rehash_size,1.5f,static,const); -ecl_def_ct_single_float(default_rehash_threshold,0.75f,static,const); ecl_def_ct_base_string(str_common_lisp,"COMMON-LISP",11,static,const); ecl_def_ct_base_string(str_common_lisp_user,"COMMON-LISP-USER",16,static,const); ecl_def_ct_base_string(str_cl,"CL",2,static,const); @@ -337,7 +418,6 @@ ecl_def_ct_base_string(str_gray,"GRAY",4,static,const); #endif ecl_def_ct_base_string(str_star_dot_star,"*.*",3,static,const); ecl_def_ct_base_string(str_rel_star_dot_star,"./*.*",5,static,const); -ecl_def_ct_base_string(str_empty,"",0,static,const); ecl_def_ct_base_string(str_G,"G",1,static,const); ecl_def_ct_base_string(str_T,"T",1,static,const); #ifdef ENABLE_DLOPEN @@ -352,22 +432,6 @@ ecl_def_ct_base_string(str_lsp,"lsp",3,static,const); ecl_def_ct_base_string(str_LSP,"LSP",3,static,const); ecl_def_ct_base_string(str_lisp,"lisp",4,static,const); ecl_def_ct_base_string(str_NIL,"NIL",3,static,const); -ecl_def_ct_base_string(str_slash,"/",1,static,const); - -ecl_def_ct_single_float(flt_zero,0,static,const); -ecl_def_ct_single_float(flt_zero_neg,-0.0,static,const); -ecl_def_ct_double_float(dbl_zero,0,static,const); -ecl_def_ct_double_float(dbl_zero_neg,-0.0,static,const); -ecl_def_ct_long_float(ldbl_zero,0,static,const); -ecl_def_ct_long_float(ldbl_zero_neg,-0.0l,static,const); -ecl_def_ct_ratio(plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),static,const); -ecl_def_ct_ratio(minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),static,const); -ecl_def_ct_single_float(flt_one,1,static,const); -ecl_def_ct_single_float(flt_one_neg,-1,static,const); -ecl_def_ct_single_float(flt_two,2,static,const); -ecl_def_ct_complex(flt_imag_unit,&flt_zero_data,&flt_one_data,static,const); -ecl_def_ct_complex(flt_imag_unit_neg,&flt_zero_data,&flt_one_neg_data,static,const); -ecl_def_ct_complex(flt_imag_two,&flt_zero_data,&flt_two_data,static,const); struct cl_core_struct cl_core = { .packages = ECL_NIL, @@ -384,9 +448,6 @@ struct cl_core_struct cl_core = { .c_package = ECL_NIL, .ffi_package = ECL_NIL, - .pathname_translations = ECL_NIL, - .library_pathname = ECL_NIL, - .terminal_io = ECL_NIL, .null_stream = ECL_NIL, .standard_input = ECL_NIL, @@ -397,61 +458,13 @@ struct cl_core_struct cl_core = { .compiler_readtable = ECL_NIL, .char_names = ECL_NIL, - .null_string = (cl_object)&str_empty_data, - .plus_half = (cl_object)&plus_half_data, - .minus_half = (cl_object)&minus_half_data, - .imag_unit = (cl_object)&flt_imag_unit_data, - .minus_imag_unit = (cl_object)&flt_imag_unit_neg_data, - .imag_two = (cl_object)&flt_imag_two_data, - .singlefloat_zero = (cl_object)&flt_zero_data, - .doublefloat_zero = (cl_object)&dbl_zero_data, - .singlefloat_minus_zero = (cl_object)&flt_zero_neg_data, - .doublefloat_minus_zero = (cl_object)&dbl_zero_neg_data, - .longfloat_zero = (cl_object)&ldbl_zero_data, - .longfloat_minus_zero = (cl_object)&ldbl_zero_neg_data, - - .gensym_prefix = (cl_object)&str_G_data, - .gentemp_prefix = (cl_object)&str_T_data, + .gensym_prefix = ECL_NIL, + .gentemp_prefix = ECL_NIL, .gentemp_counter = ecl_make_fixnum(0), - .Jan1st1970UT = ECL_NIL, - .system_properties = ECL_NIL, - - .first_env = &first_env, -#ifdef ECL_THREADS - .processes = ECL_NIL, -#endif - /* LIBRARIES is an adjustable vector of objects. It behaves as - a vector of weak pointers thanks to the magic in - gbc.d/alloc_2.d */ - .libraries = ECL_NIL, - - .max_heap_size = 0, - .bytes_consed = ECL_NIL, - .gc_counter = ECL_NIL, - .gc_stats = 0, - .path_max = 0, -#ifdef GBC_BOEHM - .safety_region = NULL, -#endif - - .default_sigmask = NULL, - .default_sigmask_bytes = 0, - -#ifdef ECL_THREADS - .last_var_index = 0, - .reused_indices = ECL_NIL, -#endif - .slash = (cl_object)&str_slash_data, - .compiler_dispatch = ECL_NIL, - - .rehash_size = (cl_object)&default_rehash_size_data, - .rehash_threshold = (cl_object)&default_rehash_threshold_data, - - .known_signals = ECL_NIL }; #if !defined(ECL_MS_WINDOWS_HOST) @@ -483,22 +496,8 @@ cl_boot(int argc, char **argv) int i; cl_env_ptr env; - i = ecl_option_values[ECL_OPT_BOOTED]; - if (i) { - if (i < 0) { - /* We have called cl_shutdown and want to use ECL again. */ - ecl_set_option(ECL_OPT_BOOTED, 1); - } - return 1; - } - - /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ - -#if !defined(GBC_BOEHM) - setbuf(stdin, stdin_buf); - setbuf(stdout, stdout_buf); -#endif - init_process(); + i = ecl_boot(); + if (i==1) return 1; ARGC = argc; ARGV = argv; @@ -514,7 +513,7 @@ cl_boot(int argc, char **argv) * ext::*interrupts-enabled* while creating packages. */ - env = cl_core.first_env; + env = ecl_core.first_env; ecl_init_first_env(env); /* @@ -553,11 +552,8 @@ cl_boot(int argc, char **argv) #endif cl_num_symbols_in_core=2; -#ifdef NO_PATH_MAX - cl_core.path_max = sysconf(_PC_PATH_MAX); -#else - cl_core.path_max = MAXPATHLEN; -#endif + cl_core.gensym_prefix = (cl_object)&str_G_data; + cl_core.gentemp_prefix = (cl_object)&str_T_data; cl_core.lisp_package = ecl_make_package(str_common_lisp, @@ -648,8 +644,8 @@ cl_boot(int argc, char **argv) */ cl_core.char_names = aux = cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); for (i = 0; char_names[i].elt.self; i++) { cl_object name = (cl_object)(char_names + i); cl_object code = ecl_make_fixnum(i); @@ -675,8 +671,8 @@ cl_boot(int argc, char **argv) */ cl_core.system_properties = cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); @@ -742,8 +738,8 @@ cl_boot(int argc, char **argv) */ ECL_SET(@'si::*class-name-hash-table*', cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold)); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold)); /* * Features. diff --git a/src/c/num_co.d b/src/c/num_co.d index 1a88fc970..d347b3552 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -431,21 +431,21 @@ cl_imagpart(cl_object x) break; case t_singlefloat: if (signbit(ecl_single_float(x))) - x = cl_core.singlefloat_minus_zero; + x = ecl_ct_singlefloat_minus_zero; else - x = cl_core.singlefloat_zero; + x = ecl_ct_singlefloat_zero; break; case t_doublefloat: if (signbit(ecl_double_float(x))) - x = cl_core.doublefloat_minus_zero; + x = ecl_ct_doublefloat_minus_zero; else - x = cl_core.doublefloat_zero; + x = ecl_ct_doublefloat_zero; break; case t_longfloat: if (signbit(ecl_long_float(x))) - x = cl_core.longfloat_minus_zero; + x = ecl_ct_longfloat_minus_zero; else - x = cl_core.longfloat_zero; + x = ecl_ct_longfloat_zero; break; case t_complex: x = x->gencomplex.imag; diff --git a/src/c/number.d b/src/c/number.d index 62fc3abd8..ad580a458 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -501,9 +501,9 @@ ecl_make_single_float(float f) if (f == (float)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.singlefloat_minus_zero; + return ecl_ct_singlefloat_minus_zero; #endif - return cl_core.singlefloat_zero; + return ecl_ct_singlefloat_zero; } x = ecl_alloc_object(t_singlefloat); ecl_single_float(x) = f; @@ -519,9 +519,9 @@ ecl_make_double_float(double f) if (f == (double)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.doublefloat_minus_zero; + return ecl_ct_doublefloat_minus_zero; #endif - return cl_core.doublefloat_zero; + return ecl_ct_doublefloat_zero; } x = ecl_alloc_object(t_doublefloat); ecl_double_float(x) = f; @@ -537,9 +537,9 @@ ecl_make_long_float(long double f) if (f == (long double)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.longfloat_minus_zero; + return ecl_ct_longfloat_minus_zero; #endif - return cl_core.longfloat_zero; + return ecl_ct_longfloat_zero; } x = ecl_alloc_object(t_longfloat); x->longfloat.value = f; diff --git a/src/c/numbers/atan.d b/src/c/numbers/atan.d index e63bc8a5e..af55f7c9c 100644 --- a/src/c/numbers/atan.d +++ b/src/c/numbers/atan.d @@ -15,11 +15,19 @@ #define ECL_INCLUDE_MATH_H #include +#include #include #include #pragma STDC FENV_ACCESS ON +ecl_def_ct_single_float(ecl_ct_flt_zero,0,static,const); +ecl_def_ct_single_float(ecl_ct_flt_one,1,static,const); +ecl_def_ct_single_float(ecl_ct_flt_one_neg,-1,static,const); + +ecl_def_ct_complex(ecl_ct_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one,static,const); +ecl_def_ct_complex(ecl_ct_minus_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one_neg,static,const); + cl_object ecl_atan2(cl_object y, cl_object x) { @@ -53,20 +61,20 @@ ecl_atan1(cl_object y) { if (ECL_COMPLEXP(y)) { #if 0 /* ANSI states it should be this first part */ - cl_object z = ecl_times(cl_core.imag_unit, y); + cl_object z = ecl_times(ecl_ct_imag_unit, y); z = ecl_plus(ecl_log1(ecl_one_plus(z)), ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), - cl_core.imag_unit)); + ecl_ct_imag_unit)); #else - cl_object z1, z = ecl_times(cl_core.imag_unit, y); + cl_object z1, z = ecl_times(ecl_ct_imag_unit, y); z = ecl_one_plus(z); z1 = ecl_times(y, y); z1 = ecl_one_plus(z1); z1 = ecl_sqrt(z1); z = ecl_divide(z, z1); z = ecl_log1(z); - z = ecl_times(cl_core.minus_imag_unit, z); + z = ecl_times(ecl_ct_minus_imag_unit, z); #endif /* ANSI */ return z; } else { diff --git a/src/c/numbers/round.d b/src/c/numbers/round.d index b1b97060f..4d5ffaa39 100644 --- a/src/c/numbers/round.d +++ b/src/c/numbers/round.d @@ -87,12 +87,12 @@ ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); cl_object r = ecl_minus(q, q1); if (ecl_minusp(r)) { - int c = ecl_number_compare(cl_core.minus_half, r); + int c = ecl_number_compare(ecl_ct_minus_half, r); if (c > 0 || (c == 0 && ecl_oddp(q1))) { q1 = ecl_one_minus(q1); } } else { - int c = ecl_number_compare(r, cl_core.plus_half); + int c = ecl_number_compare(r, ecl_ct_plus_half); if (c > 0 || (c == 0 && ecl_oddp(q1))) { q1 = ecl_one_plus(q1); } diff --git a/src/c/numbers/sqrt.d b/src/c/numbers/sqrt.d index a8af7cae3..a35ac725c 100644 --- a/src/c/numbers/sqrt.d +++ b/src/c/numbers/sqrt.d @@ -76,7 +76,7 @@ ecl_sqrt_long_float(cl_object x) static cl_object ecl_sqrt_complex(cl_object x) { - return ecl_expt(x, cl_core.plus_half); + return ecl_expt(x, ecl_ct_plus_half); } #ifdef ECL_COMPLEX_FLOAT diff --git a/src/c/package.d b/src/c/package.d index b7b6bd205..9729d5d71 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -23,8 +23,8 @@ * NOTE 1: we only need to use the package locks when reading/writing the hash * tables, or changing the fields of a package. We do not need the locks to * read lists from the packages (i.e. list of shadowing symbols, used - * packages, etc), or from the global environment (cl_core.packages_list) if - * we do not destructively modify them (For instance, use ecl_remove_eq + * packages, etc), or from the global environment (cl_core.packages_list) + * if we do not destructively modify them (For instance, use ecl_remove_eq * instead of ecl_delete_eq). */ /* @@ -114,8 +114,8 @@ make_package_hashtable() { return cl__make_hash_table(@'package', /* package hash table */ ecl_make_fixnum(128), /* initial size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); } static cl_object @@ -270,7 +270,7 @@ ecl_make_package(cl_object name, cl_object nicknames, nicknamed->pack.nicknamedby = CONS(x, nicknamed->pack.nicknamedby); } end_loop_for_in; /* Finally, add it to the list of packages */ - cl_core.packages = CONS(x, cl_core.packages); + cl_core.packages = ecl_cons(x, cl_core.packages); OUTPUT: (void)0; } ECL_WITH_GLOBAL_ENV_WRLOCK_END; diff --git a/src/c/pathname.d b/src/c/pathname.d index c9819f84a..79b12526f 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -461,7 +461,7 @@ parse_word(cl_object s, delim_fn delim, int flags, cl_index start, case 0: if (flags & WORD_EMPTY_IS_NIL) return ECL_NIL; - return cl_core.null_string; + return ecl_ct_null_string; case 1: if (ecl_char(s,j) == '*') return @':wild'; @@ -505,7 +505,7 @@ parse_directories(cl_object s, int flags, cl_index start, cl_index end, cl_object part = parse_word(s, delim, flags, j, end, &i); if (part == @':error' || part == ECL_NIL) break; - if (part == cl_core.null_string) { /* "/", ";" */ + if (part == ecl_ct_null_string) { /* "/", ";" */ if (j != start) { if (flags & WORD_LOGICAL) return @':error'; @@ -525,7 +525,7 @@ ecl_logical_hostname_p(cl_object host) { if (!ecl_stringp(host)) return FALSE; - return !Null(ecl_assqlp(host, cl_core.pathname_translations)); + return !Null(ecl_assqlp(host, ecl_core.pathname_translations)); } /* @@ -900,8 +900,8 @@ si_coerce_to_filename(cl_object pathname_orig) pathname_orig->pathname.type, pathname_orig->pathname.version); } - if (cl_core.path_max != -1 && - ecl_length(namestring) >= cl_core.path_max - 16) + if (ecl_core.path_max != -1 && + ecl_length(namestring) >= ecl_core.path_max - 16) FEerror("Too long filename: ~S.", 1, namestring); return namestring; } @@ -1318,7 +1318,7 @@ cl_host_namestring(cl_object pname) pname = cl_pathname(pname); pname = pname->pathname.host; if (Null(pname) || pname == @':wild') - pname = cl_core.null_string; + pname = ecl_ct_null_string; @(return pname); } @@ -1542,7 +1542,7 @@ coerce_to_from_pathname(cl_object x, cl_object host) FEerror("Wrong host syntax ~S", 1, host); } /* Find its translation list */ - pair = ecl_assqlp(host, cl_core.pathname_translations); + pair = ecl_assqlp(host, ecl_core.pathname_translations); if (set == OBJNULL) { @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); } @@ -1552,7 +1552,7 @@ coerce_to_from_pathname(cl_object x, cl_object host) } if (pair == ECL_NIL) { pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); - cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); + ecl_core.pathname_translations = CONS(pair, ecl_core.pathname_translations); } for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { cl_object item = CAR(l); diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index 1a8a0d614..e75a3814d 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -96,8 +96,8 @@ si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_funct cl_object hash = cl__make_hash_table(@'eq', ecl_make_fixnum(1024), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); ecl_bds_bind(env, @'si::*circle-stack*', hash); si_write_object_with_circle(x, cl_core.null_stream, print_function); diff --git a/src/c/process.d b/src/c/process.d index 9f9fffda4..e74b2c6ce 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -84,13 +84,13 @@ cl_env_ptr cl_env_p = NULL; void init_process(void) { - cl_env_ptr env = cl_core.first_env; + cl_env_ptr env = ecl_core.first_env; #ifdef ECL_THREADS ecl_process_key_create(cl_env_key); - ecl_mutex_init(&cl_core.processes_lock, 1); - ecl_mutex_init(&cl_core.global_lock, 1); - ecl_mutex_init(&cl_core.error_lock, 1); - ecl_rwlock_init(&cl_core.global_env_lock); + ecl_mutex_init(&ecl_core.processes_lock, 1); + ecl_mutex_init(&ecl_core.global_lock, 1); + ecl_mutex_init(&ecl_core.error_lock, 1); + ecl_rwlock_init(&ecl_core.global_env_lock); #endif ecl_set_process_env(env); env->default_sigmask = NULL; diff --git a/src/c/read.d b/src/c/read.d index 8296de713..1cf6bce10 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -1301,8 +1301,8 @@ patch_sharp(const cl_env_ptr the_env, cl_object x) } else { cl_object table = cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); do { cl_object pair = ECL_CONS_CAR(pairs); _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); @@ -1883,8 +1883,8 @@ ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, cl_object hash = readtable->readtable.hash; if (Null(hash)) { hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); readtable->readtable.hash = hash; } _ecl_sethash(ECL_CODE_CHAR(c), hash, @@ -1961,8 +1961,8 @@ ecl_invalid_character_p(int c) c = ecl_char_code(chr); cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_readtable_set(readtable, c, cat, table); @(return ECL_T); @) diff --git a/src/c/serialize.d b/src/c/serialize.d index 4cb169e0c..d5d79a8fb 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -349,8 +349,8 @@ init_pool(pool_t pool, cl_object root) ECL_NIL, ecl_make_fixnum(0)); pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); pool->queue = ecl_list1(root); pool->last = pool->queue; diff --git a/src/c/stacks.d b/src/c/stacks.d index ef52372c6..c62b83446 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -450,11 +450,11 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol) cl_object pool; cl_index new_index = symbol->symbol.binding; if (new_index == ECL_MISSING_SPECIAL_BINDING) { - pool = ecl_atomic_pop(&cl_core.reused_indices); + pool = ecl_atomic_pop(&ecl_core.reused_indices); if (!Null(pool)) { new_index = ecl_fixnum(ECL_CONS_CAR(pool)); } else { - new_index = ecl_atomic_index_incf(&cl_core.last_var_index); + new_index = ecl_atomic_index_incf(&ecl_core.last_var_index); } symbol->symbol.binding = new_index; } @@ -470,7 +470,7 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) } if (index >= env->bds_stack.tl_bindings_size) { cl_index osize = env->bds_stack.tl_bindings_size; - cl_index nsize = cl_core.last_var_index * 1.25; + cl_index nsize = ecl_core.last_var_index * 1.25; cl_object *old_vector = env->bds_stack.tl_bindings; cl_object *new_vector = ecl_realloc(old_vector, osize*sizeof(cl_object*), @@ -728,7 +728,7 @@ cl_object init_stacks(cl_env_ptr the_env) { #ifdef ECL_THREADS - if (the_env == cl_core.first_env) { + if (the_env == ecl_core.first_env) { cl_index idx; cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*)); for(idx=0; idx<1024; idx++) { @@ -1114,7 +1114,7 @@ si_get_limit(cl_object type) output = env->c_stack.limit_size; else if (type == @'ext::heap-size') { /* size_t can be larger than cl_index */ - ecl_return1(env, ecl_make_unsigned_integer(cl_core.max_heap_size)); + ecl_return1(env, ecl_make_unsigned_integer(ecl_core.max_heap_size)); } ecl_return1(env, ecl_make_unsigned_integer(output)); diff --git a/src/c/string.d b/src/c/string.d index 32093f8b8..e511b4ed7 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -293,6 +293,114 @@ si_coerce_to_extended_string(cl_object x) } #endif +cl_object +cl_name_char(cl_object name) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object c; + cl_index l; + name = cl_string(name); + c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL); + if (c != ECL_NIL) { + ecl_return1(the_env, ECL_CODE_CHAR(ecl_fixnum(c))); + } +#ifdef ECL_UNICODE + c = _ecl_ucd_name_to_code(name); + if (c != ECL_NIL) { + ecl_return1(the_env, cl_code_char(c)); + } +#endif + if (ecl_stringp(name) && (l = ecl_length(name))) { + c = cl_char(name, ecl_make_fixnum(0)); + if (l == 1) { + (void)0; + } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) { + c = ECL_NIL; + } else { + cl_index used_l; + cl_index end = name->base_string.fillp; + cl_index real_end = end; + c = ecl_parse_integer(name, 1, end, &real_end, 16); + used_l = real_end; + if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) { + c = ECL_NIL; + } else { + c = ECL_CODE_CHAR(ecl_fixnum(c)); + } + } + } + ecl_return1(the_env, c); +} + +/* here we give every character an implicit name of the form 'u#' where # is a hexadecimal number, + corresponding to a unicode code point. + #\u14ea should work, for example +*/ + +cl_object +cl_char_name(cl_object c) +{ + ecl_character code = ecl_char_code(c); + cl_object output; + if (code <= 127) { + output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL); +#ifdef ECL_UNICODE + } else if (!Null(output = _ecl_ucd_code_to_name(code))) { + (void)0; +#endif + } else { + ecl_base_char name[8]; + ecl_base_char *start; + name[7] = 0; + name[6] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[5] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[4] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[3] = ecl_digit_char(code & 0xF, 16); code >>= 4; + if (code == 0) { + start = name + 2; + } else { + name[2] = ecl_digit_char(code & 0xF, 16); code >>= 4; + name[1] = ecl_digit_char(code & 0xF, 16); + start = name; + } + start[0] = 'U'; + output = ecl_make_simple_base_string((const char*)start,-1); + } + @(return output); +} + +int +ecl_string_case(cl_object s) +{ + /* Returns 1 if string is all uppercase, -1 if all lowercase, and 0 if mixed case */ + int upcase; + cl_index i; + + switch (ecl_t_of(s)) { +#ifdef ECL_UNICODE + case t_string: +#endif + case t_base_string: + for (i = 0, upcase = 0; i < s->base_string.dim; i++) { + ecl_character c = ecl_char(s, i); + + if (ecl_upper_case_p(c)) { + if (upcase < 0) + return 0; + upcase = +1; + } else if (ecl_lower_case_p(c)) { + if (upcase > 0) + return 0; + upcase = -1; + } + } + break; + default: + FEwrong_type_argument(@[string], s); + } + return upcase; +} + cl_object cl_char(cl_object object, cl_object index) { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index ff77ac41c..dd2917304 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -104,8 +104,6 @@ cl_symbols[] = { {"NIL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)}, -{SYS_ "PROTECT-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "DUMMY-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, @@ -1238,6 +1236,7 @@ cl_symbols[] = { {SYS_ "MKDIR" ECL_FUN("si_mkdir", si_mkdir, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {EXT_ "MKSTEMP" ECL_FUN("si_mkstemp", si_mkstemp, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {SYS_ "NEED-TO-MAKE-LOAD-FORM-P" ECL_FUN("si_need_to_make_load_form_p", si_need_to_make_load_form_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "RADIX" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "RMDIR" ECL_FUN("si_rmdir", si_rmdir, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {EXT_ "MAKE-PIPE" ECL_FUN("si_make_pipe", si_make_pipe, 0) ECL_VAR(EXT_ORDINARY, OBJNULL)}, /* package extensions */ diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index cdb2c3333..fc5817b85 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -31,7 +31,7 @@ # include #endif -/* -- Macros -------------------------------------------------------- */ +/* -- Macros ---------------------------------------------------------------- */ #ifdef ECL_WINDOWS_THREADS # define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2)) @@ -56,18 +56,18 @@ static void extend_process_vector() { - cl_object v = cl_core.processes; + cl_object v = ecl_core.processes; cl_index new_size = v->vector.dim + v->vector.dim/2; cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object other = cl_core.processes; + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + cl_object other = ecl_core.processes; if (new_size > other->vector.dim) { cl_object new = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ecl_make_fixnum(other->vector.fillp), ECL_NIL, ECL_NIL, ECL_NIL); ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - cl_core.processes = new; + ecl_core.processes = new; } } ECL_WITH_NATIVE_LOCK_END; } @@ -78,8 +78,8 @@ ecl_list_process(cl_object process) cl_env_ptr the_env = ecl_process_env(); bool ok = 0; do { - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object vector = cl_core.processes; + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + cl_object vector = ecl_core.processes; cl_index size = vector->vector.dim; cl_index ndx = vector->vector.fillp; if (ndx < size) { @@ -98,8 +98,8 @@ ecl_list_process(cl_object process) static void ecl_unlist_process(cl_object process) { - ecl_mutex_lock(&cl_core.processes_lock); - cl_object vector = cl_core.processes; + ecl_mutex_lock(&ecl_core.processes_lock); + cl_object vector = ecl_core.processes; cl_index i; for (i = 0; i < vector->vector.fillp; i++) { if (vector->vector.self.t[i] == process) { @@ -111,7 +111,7 @@ ecl_unlist_process(cl_object process) break; } } - ecl_mutex_unlock(&cl_core.processes_lock); + ecl_mutex_unlock(&ecl_core.processes_lock); } static cl_object @@ -119,8 +119,8 @@ ecl_process_list() { cl_env_ptr the_env = ecl_process_env(); cl_object output = ECL_NIL; - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object vector = cl_core.processes; + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + cl_object vector = ecl_core.processes; cl_object *data = vector->vector.self.t; cl_index i; for (i = 0; i < vector->vector.fillp; i++) { @@ -344,7 +344,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings) } #endif { - cl_object processes = cl_core.processes; + cl_object processes = ecl_core.processes; cl_index i, size; for (i = 0, size = processes->vector.fillp; i < size; i++) { cl_object p = processes->vector.self.t[i]; @@ -628,8 +628,9 @@ mp_process_active_p(cl_object process) cl_object mp_process_whostate(cl_object process) { + const cl_env_ptr the_env = ecl_process_env(); assert_type_process(process); - @(return (cl_core.null_string)); + ecl_return1(the_env, ecl_ct_null_string); } cl_object @@ -782,6 +783,6 @@ init_threads() ECL_NIL, ECL_NIL, ECL_NIL); v->vector.self.t[0] = process; v->vector.fillp = 1; - cl_core.processes = v; + ecl_core.processes = v; } } diff --git a/src/c/time.d b/src/c/time.d index 166a2a7c3..82ac93ae8 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -221,18 +221,14 @@ cl_get_internal_real_time() cl_object cl_get_universal_time() { + cl_env_ptr env = ecl_process_env(); cl_object utc = ecl_make_integer(time(0)); - @(return ecl_plus(utc, cl_core.Jan1st1970UT)); + ecl_return1(env, ecl_plus(utc, ecl_ct_Jan1st1970UT)); } void init_unixtime(void) { ecl_get_internal_real_time(&beginning); - ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000000)); - - cl_core.Jan1st1970UT = - ecl_times(ecl_make_fixnum(24 * 60 * 60), - ecl_make_fixnum(17 + 365 * 70)); } diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 56a6e48ea..a25b04868 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -1085,7 +1085,7 @@ dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int f cl_object si_get_library_pathname(void) { - cl_object s = cl_core.library_pathname; + cl_object s = ecl_core.library_pathname; if (!Null(s)) { goto OUTPUT_UNCHANGED; } else { @@ -1100,11 +1100,11 @@ si_get_library_pathname(void) ecl_filename_char *buffer; HMODULE hnd; cl_index len, ep; - s = ecl_alloc_adjustable_filename(cl_core.path_max); + s = ecl_alloc_adjustable_filename(ecl_core.path_max); buffer = ecl_filename_self(s); ecl_disable_interrupts(); hnd = GetModuleHandle("ecl.dll"); - len = ecl_GetModuleFileName(hnd, buffer, cl_core.path_max-1); + len = ecl_GetModuleFileName(hnd, buffer, ecl_core.path_max-1); ecl_enable_interrupts(); if (len == 0) { FEerror("GetModuleFileName failed (last error = ~S)", @@ -1125,9 +1125,9 @@ si_get_library_pathname(void) s = current_dir(); } } - cl_core.library_pathname = ecl_decode_filename(s, ECL_NIL); + ecl_core.library_pathname = ecl_decode_filename(s, ECL_NIL); OUTPUT_UNCHANGED: - @(return cl_core.library_pathname); + @(return ecl_core.library_pathname); } @(defun ext::chdir (directory &optional (change_d_p_d ECL_T)) diff --git a/src/c/unixint.d b/src/c/unixint.d index 7d6ad09ad..f4c6e90d8 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -534,7 +534,7 @@ handler_fn_prototype(non_evil_signal_handler, int sig, siginfo_t *siginfo, void unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); handle_or_queue(the_env, signal_object, sig); errno = old_errno; @@ -552,7 +552,7 @@ handler_fn_prototype(evil_signal_handler, int sig, siginfo_t *siginfo, void *dat unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); handle_signal_now(signal_object); errno = old_errno; @@ -647,7 +647,7 @@ asynchronous_signal_servicing_thread() break; } signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); if (!Null(signal_code)) { mp_process_run_function(3, @'si::handle-signal', @@ -959,7 +959,7 @@ cl_object si_get_signal_handler(cl_object code) { const cl_env_ptr the_env = ecl_process_env(); - cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + cl_object handler = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL); unlikely_if (handler == OBJNULL) { illegal_signal_code(code); } @@ -970,11 +970,11 @@ cl_object si_set_signal_handler(cl_object code, cl_object handler) { const cl_env_ptr the_env = ecl_process_env(); - cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + cl_object action = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL); unlikely_if (action == OBJNULL) { illegal_signal_code(code); } - ecl_sethash(code, cl_core.known_signals, handler); + ecl_sethash(code, ecl_core.known_signals, handler); si_catch_signal(2, code, ECL_T); ecl_return0(the_env); } @@ -984,7 +984,7 @@ si_set_signal_handler(cl_object code, cl_object handler) { const cl_env_ptr the_env = ecl_process_env(); int code_int; - unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) { + unlikely_if (ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL) == OBJNULL) { illegal_signal_code(code); } code_int = ecl_fixnum(code); @@ -1312,8 +1312,8 @@ install_asynchronous_signal_handlers() # endif #endif #ifdef HAVE_SIGPROCMASK - sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask; - cl_core.default_sigmask_bytes = sizeof(sigset_t); + sigset_t *sigmask = ecl_core.first_env->default_sigmask = &main_thread_sigmask; + ecl_core.default_sigmask_bytes = sizeof(sigset_t); # ifdef ECL_THREADS pthread_sigmask(SIG_SETMASK, NULL, sigmask); # else @@ -1472,10 +1472,10 @@ static void create_signal_code_constants() { cl_object hash = - cl_core.known_signals = + ecl_core.known_signals = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); int i; for (i = 0; known_signals[i].code >= 0; i++) { add_one_signal(hash, known_signals[i].code, diff --git a/src/c/vector_push.d b/src/c/vector_push.d index dbb1ff7ac..0a480a74b 100644 --- a/src/c/vector_push.d +++ b/src/c/vector_push.d @@ -18,69 +18,69 @@ static cl_object extend_vector(cl_object v, cl_index amount) { - cl_object other; - cl_index new_length; - unlikely_if (!ECL_VECTORP(v)) { - FEwrong_type_nth_arg(@[vector-push-extend],1,v,@[vector]); - } - if (!ECL_ADJUSTABLE_ARRAY_P(v)) - FEerror("vector-push-extend: the array ~S is not adjustable.", - 1, v); - if (v->vector.dim >= ECL_ARRAY_DIMENSION_LIMIT) - FEerror("Can't extend the array.", 0); - if (amount == 0) - amount = v->vector.dim / 2 + 1; - new_length = v->vector.dim + amount; - if (new_length > ECL_ARRAY_DIMENSION_LIMIT) - new_length = ECL_ARRAY_DIMENSION_LIMIT; - other = si_make_vector(cl_array_element_type(v), - ecl_make_fixnum(new_length), ECL_T, - ecl_make_fixnum(v->vector.fillp), - ECL_NIL, ecl_make_fixnum(0)); - ecl_copy_subarray(other, 0, v, 0, v->vector.fillp); - return si_replace_array(v, other); + cl_object other; + cl_index new_length; + unlikely_if (!ECL_VECTORP(v)) { + FEwrong_type_nth_arg(@[vector-push-extend],1,v,@[vector]); + } + if (!ECL_ADJUSTABLE_ARRAY_P(v)) + FEerror("vector-push-extend: the array ~S is not adjustable.", + 1, v); + if (v->vector.dim >= ECL_ARRAY_DIMENSION_LIMIT) + FEerror("Can't extend the array.", 0); + if (amount == 0) + amount = v->vector.dim / 2 + 1; + new_length = v->vector.dim + amount; + if (new_length > ECL_ARRAY_DIMENSION_LIMIT) + new_length = ECL_ARRAY_DIMENSION_LIMIT; + other = si_make_vector(cl_array_element_type(v), + ecl_make_fixnum(new_length), ECL_T, + ecl_make_fixnum(v->vector.fillp), + ECL_NIL, ecl_make_fixnum(0)); + ecl_copy_subarray(other, 0, v, 0, v->vector.fillp); + return si_replace_array(v, other); } ecl_character ecl_string_push_extend(cl_object s, ecl_character c) { - switch(ecl_t_of(s)) { + switch(ecl_t_of(s)) { #ifdef ECL_UNICODE - case t_string: + case t_string: #endif - case t_base_string: - /* We use the fact that both string types are - byte-compatible except for the data. */ - if (s->base_string.fillp >= s->base_string.dim) { - s = extend_vector(s, 0); - } - ecl_char_set(s, s->base_string.fillp++, c); - return c; - default: - FEwrong_type_nth_arg(@[vector-push-extend],1,s,@[string]); - } + case t_base_string: + /* We use the fact that both string types are + byte-compatible except for the data. */ + if (s->base_string.fillp >= s->base_string.dim) { + s = extend_vector(s, 0); + } + ecl_char_set(s, s->base_string.fillp++, c); + return c; + default: + FEwrong_type_nth_arg(@[vector-push-extend],1,s,@[string]); + } } cl_object cl_vector_push(cl_object value, cl_object v) { - cl_index f = ecl_fixnum(cl_fill_pointer(v)); - if (f >= v->vector.dim) { - @(return ECL_NIL); - } else { - ecl_aset1(v, v->vector.fillp, value); - @(return ecl_make_fixnum(v->vector.fillp++)); - } + cl_index f = ecl_fixnum(cl_fill_pointer(v)); + if (f >= v->vector.dim) { + @(return ECL_NIL); + } else { + ecl_aset1(v, v->vector.fillp, value); + @(return ecl_make_fixnum(v->vector.fillp++)); + } } @(defun vector-push-extend (value v &optional (extent ecl_make_fixnum(0))) @ { - cl_index f = ecl_fixnum(cl_fill_pointer(v)); - if (f >= v->vector.dim) { - v = extend_vector(v, ecl_to_size(extent)); - } - ecl_aset1(v, v->vector.fillp, value); - @(return ecl_make_fixnum(v->vector.fillp++)); + cl_index f = ecl_fixnum(cl_fill_pointer(v)); + if (f >= v->vector.dim) { + v = extend_vector(v, ecl_to_size(extent)); + } + ecl_aset1(v, v->vector.fillp, value); + @(return ecl_make_fixnum(v->vector.fillp++)); } @) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp index 6516c7c40..107a1dc8d 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp @@ -42,12 +42,12 @@ '( ;; Order is important: on platforms where 0.0 and -0.0 are the same ;; the last one is prioritized. - (#.(coerce 0 'cl:single-float) "cl_core.singlefloat_zero") - (#.(coerce 0 'cl:double-float) "cl_core.doublefloat_zero") - (#.(coerce -0.0 'cl:single-float) "cl_core.singlefloat_minus_zero") - (#.(coerce -0.0 'cl:double-float) "cl_core.doublefloat_minus_zero") - (#.(coerce 0 'cl:long-float) "cl_core.longfloat_zero") - (#.(coerce -0.0 'cl:long-float) "cl_core.longfloat_minus_zero") + (#.(coerce 0 'cl:single-float) "ecl_ct_singlefloat_zero") + (#.(coerce 0 'cl:double-float) "ecl_ct_doublefloat_zero") + (#.(coerce -0.0 'cl:single-float) "ecl_ct_singlefloat_minus_zero") + (#.(coerce -0.0 'cl:double-float) "ecl_ct_doublefloat_minus_zero") + (#.(coerce 0 'cl:long-float) "ecl_ct_longfloat_zero") + (#.(coerce -0.0 'cl:long-float) "ecl_ct_longfloat_minus_zero") ;; We temporarily remove this constant, because the bytecodes compiler ;; does not know how to externalize it. diff --git a/src/configure b/src/configure index dc0be976a..1023cf53f 100755 --- a/src/configure +++ b/src/configure @@ -737,6 +737,8 @@ LIBRARIES SUBDIRS TARGETS EXTRA_OBJS +THREAD_OBJS +UNICODE_OBJS PROGRAM_LDFLAGS BUNDLE_LDFLAGS SHARED_LDFLAGS @@ -7254,7 +7256,7 @@ fi boehm_configure_flags="${boehm_configure_flags} ${THREAD_GC_FLAGS}" - for k in $THREAD_OBJ; do EXTRA_OBJS="$EXTRA_OBJS ${k}.${OBJEXT}"; done + for k in $THREAD_OBJ; do THREAD_OBJS="$THREAD_OBJS ${k}.${OBJEXT}"; done { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for thread object files" >&5 printf %s "checking for thread object files... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${THREAD_OBJ}" >&5 @@ -11829,20 +11831,20 @@ printf "%s\n" "#define ECL_UNICODE 16" >>confdefs.h CHAR_CODE_LIMIT=65536 ECL_CHARACTER=$ECL_INT16_T - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd16.o unicode/ucd16-0000.o unicode/ucd16-0016.o unicode/ucd16-0032.o unicode/ucd16-0048.o unicode/ucd16-0064.o" + UNICODE_OBJS="unicode/ucd16.o unicode/ucd16-0000.o unicode/ucd16-0016.o unicode/ucd16-0032.o unicode/ucd16-0048.o unicode/ucd16-0064.o" else printf "%s\n" "#define ECL_UNICODE 21" >>confdefs.h CHAR_CODE_LIMIT=1114112 ECL_CHARACTER=$ECL_INT32_T - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd.o unicode/ucd-0000.o unicode/ucd-0016.o unicode/ucd-0032.o unicode/ucd-0048.o unicode/ucd-0064.o unicode/ucd-0080.o unicode/ucd-0096.o unicode/ucd-0112.o unicode/ucd-0128.o unicode/ucd-0144.o" + UNICODE_OBJS="unicode/ucd.o unicode/ucd-0000.o unicode/ucd-0016.o unicode/ucd-0032.o unicode/ucd-0048.o unicode/ucd-0064.o unicode/ucd-0080.o unicode/ucd-0096.o unicode/ucd-0112.o unicode/ucd-0128.o unicode/ucd-0144.o" fi printf "%s\n" "#define ECL_UNICODE_NAMES 1" >>confdefs.h - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd_names_char.o unicode/ucd_names_codes.o unicode/ucd_names_pair.o unicode/ucd_names_str.o" - ac_fn_c_check_header_compile "$LINENO" "wchar.h" "ac_cv_header_wchar_h" "$ac_includes_default" + UNICODE_OBJS="$UNICODE_OBJS unicode/ucd_names_char.o unicode/ucd_names_codes.o unicode/ucd_names_pair.o unicode/ucd_names_str.o" + ac_fn_c_check_header_compile "$LINENO" "wchar.h" "ac_cv_header_wchar_h" "$ac_includes_default" if test "x$ac_cv_header_wchar_h" = xyes then : printf "%s\n" "#define HAVE_WCHAR_H 1" >>confdefs.h diff --git a/src/configure.ac b/src/configure.ac index 5eff9a037..30f7e09a7 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -318,6 +318,8 @@ AC_SUBST(CORE_LIBS, []) dnl Locally compiled libs to link into AC_SUBST(SHARED_LDFLAGS) dnl Flags for shared libraries linker AC_SUBST(BUNDLE_LDFLAGS) dnl Flags for FASL files linker AC_SUBST(PROGRAM_LDFLAGS) dnl Flags for executable program linker +AC_SUBST(UNICODE_OBJS) dnl Unicode *.o files to be compiled into libecl.a +AC_SUBST(THREAD_OBJS) dnl Threads *.o files to be compiled into libecl.a AC_SUBST(EXTRA_OBJS) dnl Extra *.o files to be compiled into libecl.a AC_SUBST(TARGETS, ['bin/ecl$(EXE)'])dnl Versions of ECL to be built AC_SUBST(SUBDIRS, ['c doc']) dnl Subdirectories that make should process @@ -588,7 +590,7 @@ if test "${enable_threads}" = "yes" ; then CFLAGS="${CFLAGS} ${THREAD_CFLAGS}" ECL_PTHREAD_EXTENSIONS boehm_configure_flags="${boehm_configure_flags} ${THREAD_GC_FLAGS}" - for k in $THREAD_OBJ; do EXTRA_OBJS="$EXTRA_OBJS ${k}.${OBJEXT}"; done + for k in $THREAD_OBJ; do THREAD_OBJS="$THREAD_OBJS ${k}.${OBJEXT}"; done AC_MSG_CHECKING([for thread object files]) AC_MSG_RESULT([${THREAD_OBJ}]) AC_DEFINE( [ECL_THREADS], [1], [Userland threads?]) @@ -913,16 +915,16 @@ if test "x${enable_unicode}" != "xno"; then AC_DEFINE([ECL_UNICODE], [16], [Support for Unicode]) CHAR_CODE_LIMIT=65536 ECL_CHARACTER=$ECL_INT16_T - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd16.o unicode/ucd16-0000.o unicode/ucd16-0016.o unicode/ucd16-0032.o unicode/ucd16-0048.o unicode/ucd16-0064.o" + UNICODE_OBJS="unicode/ucd16.o unicode/ucd16-0000.o unicode/ucd16-0016.o unicode/ucd16-0032.o unicode/ucd16-0048.o unicode/ucd16-0064.o" else AC_DEFINE([ECL_UNICODE], [21], [Support for Unicode]) CHAR_CODE_LIMIT=1114112 ECL_CHARACTER=$ECL_INT32_T - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd.o unicode/ucd-0000.o unicode/ucd-0016.o unicode/ucd-0032.o unicode/ucd-0048.o unicode/ucd-0064.o unicode/ucd-0080.o unicode/ucd-0096.o unicode/ucd-0112.o unicode/ucd-0128.o unicode/ucd-0144.o" + UNICODE_OBJS="unicode/ucd.o unicode/ucd-0000.o unicode/ucd-0016.o unicode/ucd-0032.o unicode/ucd-0048.o unicode/ucd-0064.o unicode/ucd-0080.o unicode/ucd-0096.o unicode/ucd-0112.o unicode/ucd-0128.o unicode/ucd-0144.o" fi AC_DEFINE([ECL_UNICODE_NAMES], [1], [Link in the database of Unicode names]) - EXTRA_OBJS="$EXTRA_OBJS unicode/ucd_names_char.o unicode/ucd_names_codes.o unicode/ucd_names_pair.o unicode/ucd_names_str.o" - AC_CHECK_HEADERS([wchar.h]) + UNICODE_OBJS="$UNICODE_OBJS unicode/ucd_names_char.o unicode/ucd_names_codes.o unicode/ucd_names_pair.o unicode/ucd_names_str.o" + AC_CHECK_HEADERS([wchar.h]) ECL_ADD_FEATURE(unicode) else CHAR_CODE_LIMIT=256 diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index c12bf0821..4e25735fb 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -129,35 +129,52 @@ #define ecl_cast_ptr(type,n) ((type)(n)) #endif +#ifdef ECL_THREADS +#define ecl_def_ct_symbol(name,stype,sname,value,static,const) \ + static const struct ecl_symbol name ## _data = { \ + (int8_t)t_symbol, 0, stype, 0, \ + value, ECL_NIL, NULL /*ecl_undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL, \ + ECL_MISSING_SPECIAL_BINDING }; \ + static const cl_object name = (cl_object)(& name ## _data) +#else +#define ecl_def_ct_symbol(name,stype,sname,value,static,const) \ + static const struct ecl_symbol name ## _data = { \ + (int8_t)t_symbol, 0, stype, 0, \ + value, ECL_NIL, NULL /*ecl_undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL }; \ + static const cl_object name = (cl_object)(& name ## _data) +#endif + #define ecl_def_string_array(name,static,const) \ static const union { \ struct ecl_base_string elt; \ cl_fixnum padding[(sizeof(struct ecl_base_string)+3)/4*4]; \ } name[] -#define ecl_def_string_array_elt(chars) { { \ - (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ - ECL_NIL, (cl_index)(sizeof(chars))-1, \ - (cl_index)(sizeof(chars))-1, \ +#define ecl_def_string_array_elt(chars) { { \ + (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ + ECL_NIL, (cl_index)(sizeof(chars))-1, \ + (cl_index)(sizeof(chars))-1, \ (ecl_base_char*)(chars) } } -#define ecl_def_ct_base_string(name,chars,len,static,const) \ - static const struct ecl_base_string name ## _data = { \ +#define ecl_def_ct_base_string(name,chars,len,static,const) \ + static const struct ecl_base_string name ## _data = { \ (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ - ECL_NIL, (cl_index)(len), (cl_index)(len), \ - (ecl_base_char*)(chars) }; \ + ECL_NIL, (cl_index)(len), (cl_index)(len), \ + (ecl_base_char*)(chars) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_single_float(name,f,static,const) \ - static const struct ecl_singlefloat name ## _data = { \ - (int8_t)t_singlefloat, 0, 0, 0, \ - (float)(f) }; \ +#define ecl_def_ct_single_float(name,f,static,const) \ + static const struct ecl_singlefloat name ## _data = { \ + (int8_t)t_singlefloat, 0, 0, 0, \ + (float)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_double_float(name,f,static,const) \ - static const struct ecl_doublefloat name ## _data = { \ - (int8_t)t_doublefloat, 0, 0, 0, \ - (double)(f) }; \ +#define ecl_def_ct_double_float(name,f,static,const) \ + static const struct ecl_doublefloat name ## _data = { \ + (int8_t)t_doublefloat, 0, 0, 0, \ + (double)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) #define ecl_def_ct_long_float(name,f,static,const) \ diff --git a/src/h/external.h b/src/h/external.h index c4be0e7ad..c92947a3f 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -170,9 +170,36 @@ struct ecl_interrupt_struct { extern ECL_API cl_env_ptr cl_env_p; #endif -/* - * Per-process data. Modify main.d accordingly. - */ +/* Core environment. */ + +struct ecl_core_struct { + cl_env_ptr first_env; +#ifdef ECL_THREADS + cl_object processes; + ecl_mutex_t processes_lock; + ecl_mutex_t global_lock; + ecl_mutex_t error_lock; + ecl_rwlock_t global_env_lock; + cl_index last_var_index; + cl_object reused_indices; +#endif + size_t max_heap_size; + cl_object bytes_consed; + cl_object gc_counter; + bool gc_stats; + char *safety_region; + + cl_index default_sigmask_bytes; + cl_object known_signals; + + int path_max; + cl_object pathname_translations; + + cl_object libraries; + cl_object library_pathname; +}; + +/* Per-process data. Modify main.d accordingly. */ struct cl_core_struct { cl_object packages; @@ -189,9 +216,6 @@ struct cl_core_struct { cl_object c_package; cl_object ffi_package; - cl_object pathname_translations; - cl_object library_pathname; - cl_object terminal_io; cl_object null_stream; cl_object standard_input; @@ -202,63 +226,16 @@ struct cl_core_struct { cl_object compiler_readtable; cl_object char_names; - cl_object null_string; - - cl_object plus_half; - cl_object minus_half; - cl_object imag_unit; - cl_object minus_imag_unit; - cl_object imag_two; - cl_object singlefloat_zero; - cl_object doublefloat_zero; - cl_object singlefloat_minus_zero; - cl_object doublefloat_minus_zero; - cl_object longfloat_zero; - cl_object longfloat_minus_zero; cl_object gensym_prefix; cl_object gentemp_prefix; cl_object gentemp_counter; - cl_object Jan1st1970UT; - cl_object system_properties; - - cl_env_ptr first_env; -#ifdef ECL_THREADS - cl_object processes; - ecl_mutex_t processes_lock; - ecl_mutex_t global_lock; - ecl_mutex_t error_lock; - ecl_rwlock_t global_env_lock; -#endif - cl_object libraries; - - size_t max_heap_size; - cl_object bytes_consed; - cl_object gc_counter; - bool gc_stats; - int path_max; -#ifdef GBC_BOEHM - char *safety_region; -#endif - void *default_sigmask; - cl_index default_sigmask_bytes; - -#ifdef ECL_THREADS - cl_index last_var_index; - cl_object reused_indices; -#endif - cl_object slash; - cl_object compiler_dispatch; - - cl_object rehash_size; - cl_object rehash_threshold; - - cl_object known_signals; }; +extern ECL_API struct ecl_core_struct ecl_core; extern ECL_API struct cl_core_struct cl_core; /* memory.c */ @@ -268,6 +245,29 @@ extern ECL_API void ecl_free(void *ptr); extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx); #define ecl_free_unsafe(x) ecl_free(x); +/* cold_boot.c */ +extern ECL_API int ecl_boot(void); + +extern ECL_API const cl_object ecl_ct_Jan1st1970UT; +extern ECL_API const cl_object ecl_ct_null_string; + +extern ECL_API const cl_object ecl_ct_default_rehash_size; +extern ECL_API const cl_object ecl_ct_default_rehash_threshold; + +extern ECL_API const cl_object ecl_ct_singlefloat_zero; +extern ECL_API const cl_object ecl_ct_doublefloat_zero; +extern ECL_API const cl_object ecl_ct_longfloat_zero; + +extern ECL_API const cl_object ecl_ct_singlefloat_minus_zero; +extern ECL_API const cl_object ecl_ct_doublefloat_minus_zero; +extern ECL_API const cl_object ecl_ct_longfloat_minus_zero; + +extern ECL_API const cl_object ecl_ct_plus_half; +extern ECL_API const cl_object ecl_ct_minus_half; + +extern ECL_API const cl_object ecl_ct_protect_tag; +extern ECL_API const cl_object ecl_ct_dummy_tag; + /* alloc.c / alloc_2.c */ extern ECL_API cl_object ecl_alloc_object(cl_type t); diff --git a/src/h/internal.h b/src/h/internal.h index 421916000..62cfeac56 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -713,7 +713,7 @@ extern void ecl_get_internal_real_time(struct ecl_timeval *time); extern void ecl_get_internal_run_time(struct ecl_timeval *time); extern void ecl_musleep(double time); -#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),cl_core.Jan1st1970UT) +#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),ecl_ct_Jan1st1970UT) extern cl_fixnum ecl_runtime(void); /* unixfsys.d */ @@ -870,8 +870,8 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); #include #ifdef ECL_THREADS -# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.global_lock) +# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.global_lock) # define ECL_WITH_GLOBAL_LOCK_END \ ECL_WITH_NATIVE_LOCK_END # define ECL_WITH_LOCK_BEGIN(the_env,lock) { \ @@ -896,21 +896,21 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT { \ ecl_mutex_unlock(__ecl_the_lock); \ } ECL_UNWIND_PROTECT_THREAD_SAFE_END; } -# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \ - const cl_env_ptr __ecl_pack_env = the_env; \ +# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \ + const cl_env_ptr __ecl_pack_env = the_env; \ ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \ - ecl_rwlock_lock_read(&cl_core.global_env_lock); -# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \ - ecl_rwlock_unlock_read(&cl_core.global_env_lock); \ - ecl_bds_unwind1(__ecl_pack_env); \ + ecl_rwlock_lock_read(&ecl_core.global_env_lock); +# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \ + ecl_rwlock_unlock_read(&ecl_core.global_env_lock); \ + ecl_bds_unwind1(__ecl_pack_env); \ ecl_check_pending_interrupts(__ecl_pack_env); } # define ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { \ const cl_env_ptr __ecl_pack_env = the_env; \ ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \ - ecl_rwlock_lock_write(&cl_core.global_env_lock); -# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \ - ecl_rwlock_unlock_write(&cl_core.global_env_lock); \ - ecl_bds_unwind1(__ecl_pack_env); \ + ecl_rwlock_lock_write(&ecl_core.global_env_lock); +# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \ + ecl_rwlock_unlock_write(&ecl_core.global_env_lock); \ + ecl_bds_unwind1(__ecl_pack_env); \ ecl_check_pending_interrupts(__ecl_pack_env); } #else # define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) diff --git a/src/h/object.h b/src/h/object.h index 11d353d20..383490f3d 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -258,14 +258,15 @@ enum ecl_stype { /* symbol type */ }; #define ECL_NIL ((cl_object)t_list) +#define ECL_PROTECT_TAG ecl_ct_protect_tag +#define ECL_DUMMY_TAG ecl_ct_dummy_tag + #define ECL_NIL_SYMBOL ((cl_object)cl_symbols) #define ECL_T ((cl_object)(cl_symbols+1)) #define ECL_UNBOUND ((cl_object)(cl_symbols+2)) -#define ECL_PROTECT_TAG ((cl_object)(cl_symbols+3)) -#define ECL_DUMMY_TAG ((cl_object)(cl_symbols+4)) -#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+5)) -#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+6)) -#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+7)) +#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+3)) +#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+4)) +#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+5)) #define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) struct ecl_symbol { diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index ac2b2c550..85094ff5f 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -130,10 +130,15 @@ retrieved by (documentation 'NAME 'type)." (deftype index () '(INTEGER 0 #.array-dimension-limit)) +(deftype radix () + "A RADIX is an integer between 2 and 36, that is supported integer base." + '(INTEGER 2 36)) + (deftype fixnum () "A FIXNUM is an integer between MOST-NEGATIVE-FIXNUM and MOST-POSITIVE-FIXNUM inclusive. Other integers are bignums." '(INTEGER #.most-negative-fixnum #.most-positive-fixnum)) + (deftype bignum () '(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *))) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index d425602c6..d5a7263db 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -192,7 +192,7 @@ ;;; Fixed: 10/10/2006 ;;; Description: ;;; -;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized +;;; Nested calls to queue_finalizer trashed the value of ecl_core.to_be_finalized ;;; The following code tests that at least three objects are finalized. ;;; ;;; Note: this test fails in multithreaded mode. GC takes too long!