mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-04-06 11:01:01 -07:00
Merge branch 'ecl_core' into 'develop'
introduce a new structure ecl_core that is separate from cl_core See merge request embeddable-common-lisp/ecl!368
This commit is contained in:
Daniel Kochmański
commit
736e3eb447
37 changed files with 702 additions and 660 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
100
src/c/alloc_2.d
100
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);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
129
src/c/apply.d
129
src/c/apply.d
|
|
@ -12,7 +12,135 @@
|
|||
*/
|
||||
|
||||
#include <ecl/ecl.h>
|
||||
#include <ecl/ecl-inl.h>
|
||||
#include <ecl/internal.h>
|
||||
#include <ecl/external.h>
|
||||
#include <ecl/nucleus.h>
|
||||
|
||||
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();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -14,9 +14,20 @@
|
|||
|
||||
#include <stdio.h>
|
||||
#include <ecl/ecl.h>
|
||||
#include <ecl/internal.h>
|
||||
|
||||
#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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
121
src/c/eval.d
121
src/c/eval.d
|
|
@ -16,127 +16,6 @@
|
|||
#include <ecl/ecl-inl.h>
|
||||
#include <ecl/internal.h>
|
||||
|
||||
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) {
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
|
|
|
|||
204
src/c/main.d
204
src/c/main.d
|
|
@ -35,6 +35,7 @@
|
|||
# define MAP_FAILED -1
|
||||
# endif
|
||||
#endif
|
||||
#include <limits.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -15,11 +15,19 @@
|
|||
|
||||
#define ECL_INCLUDE_MATH_H
|
||||
#include <ecl/ecl.h>
|
||||
#include <ecl/ecl-inl.h>
|
||||
#include <ecl/internal.h>
|
||||
#include <ecl/impl/math_fenv.h>
|
||||
|
||||
#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 {
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
12
src/c/read.d
12
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);
|
||||
@)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
108
src/c/string.d
108
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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@
|
|||
# include <sched.h>
|
||||
#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;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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++));
|
||||
}
|
||||
@)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
12
src/configure
vendored
12
src/configure
vendored
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) \
|
||||
|
|
|
|||
108
src/h/external.h
108
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);
|
||||
|
|
|
|||
|
|
@ -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 <ecl/threads.h>
|
||||
|
||||
#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)
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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) *)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue