mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-04 16:30:48 -08:00
Code Issues Projects Releases Packages Wiki Activity

Implemented locking on hash tables and packages. Fixed several floating point contagion bugs in +, -, /, *, and ROUND.

Browse source
This commit is contained in:
jjgarcia 2003-11-24 11:27:28 +00:00
parent eb8f202478
commit cdff225681
31 changed files with 751 additions and 576 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/CHANGELOG
View file

@ -1708,6 +1708,9 @@ ECL 0.9d
permits combining (and repeating) the options -load, -eval, -shell
in a number of ways.
- SI:FILE-COLUMN now always returns a number, which may be 0 for
streams that do not have that information.
TODO:
=====

16
src/aclocal.m4 vendored
View file

@ -302,16 +302,28 @@ int main() {
int_type="int";
for (bits=1; ((t << 1) >> 1) == t; bits++, t <<= 1);
l = (~l) << (bits - 3);
#if 1
fprintf(f,"CL_FIXNUM_MIN='%d';",l);
fprintf(f,"CL_FIXNUM_MAX='%d';",-(l+1));
#else
l++;
fprintf(f,"CL_FIXNUM_MIN='%d';",l);
fprintf(f,"CL_FIXNUM_MAX='%d';",-l);
#endif
} else if (sizeof(long) >= sizeof(void*)) {
unsigned long int t = 1;
signed long int l = 0;
int_type="long int";
for (bits=1; ((t << 1) >> 1) == t; bits++, t <<= 1);
l = (~l) << (bits - 3);
fprintf(f,"CL_FIXNUM_MIN='%ld';",l);
fprintf(f,"CL_FIXNUM_MAX='%ld';",-(l+1));
#if 1
fprintf(f,"CL_FIXNUM_MIN='%d';",l);
fprintf(f,"CL_FIXNUM_MAX='%d';",-(l+1));
#else
l++;
fprintf(f,"CL_FIXNUM_MIN='%d';",l);
fprintf(f,"CL_FIXNUM_MAX='%d';",-l);
#endif
} else
exit(1);
fprintf(f,"CL_FIXNUM_TYPE='%s';",int_type);

49
src/c/all_symbols.d
View file

@ -2,15 +2,26 @@
#include "ecl.h"
#include "internal.h"
#define CL_ORDINARY 0
#define CL_SPECIAL 1
#define CL_CONSTANT 2
#define SI_ORDINARY 4
#define SI_SPECIAL 5
#define KEYWORD 10
#define FORM_ORDINARY 16
#define MP_ORDINARY 12
#define MP_SPECIAL 13
#define CL_PACKAGE 0
#define SI_PACKAGE 4
#define KEYWORD_PACKAGE 8
#define MP_PACKAGE 12
#define ORDINARY_SYMBOL 0
#define CONSTANT_SYMBOL 1
#define SPECIAL_SYMBOL 2
#define FORM_SYMBOL 3
#define CL_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL
#define CL_SPECIAL CL_PACKAGE | SPECIAL_SYMBOL
#define CL_CONSTANT CL_PACKAGE | CONSTANT_SYMBOL
#define SI_ORDINARY SI_PACKAGE | ORDINARY_SYMBOL
#define SI_SPECIAL SI_PACKAGE | SPECIAL_SYMBOL
#define SI_CONSTANT SI_PACKAGE | CONSTANT_SYMBOL
#define MP_ORDINARY MP_PACKAGE | ORDINARY_SYMBOL
#define MP_SPECIAL MP_PACKAGE | SPECIAL_SYMBOL
#define MP_CONSTANT MP_PACKAGE | CONSTANT_SYMBOL
#define KEYWORD KEYWORD_PACKAGE | CONSTANT_SYMBOL
#define FORM_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL
#include "symbols_list.h"
@ -143,18 +154,20 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
{
enum ecl_stype stp;
cl_object package;
bool form = 0;
switch (code & 3) {
case 0: stp = stp_ordinary; break;
case 1: stp = stp_special; break;
case 2: stp = stp_constant; break;
case ORDINARY_SYMBOL: stp = stp_ordinary; break;
case SPECIAL_SYMBOL: stp = stp_special; break;
case CONSTANT_SYMBOL: stp = stp_constant; break;
case FORM_SYMBOL: form = 1;
}
switch (code & 12) {
case 0: package = cl_core.lisp_package; break;
case 4: package = cl_core.system_package; break;
case 8: package = cl_core.keyword_package; break;
case CL_PACKAGE: package = cl_core.lisp_package; break;
case SI_PACKAGE: package = cl_core.system_package; break;
case KEYWORD_PACKAGE: package = cl_core.keyword_package; break;
#ifdef ECL_THREADS
case 12: package = cl_core.mp_package; break;
case MP_PACKAGE: package = cl_core.mp_package; break;
#endif
}
s->symbol.t = t_symbol;
@ -177,9 +190,7 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
cl_import2(s, package);
cl_export2(s, package);
}
if (code == FORM_ORDINARY)
s->symbol.isform = TRUE;
else if (fun != NULL) {
if (!(s->symbol.isform = form) && fun) {
cl_object f = cl_make_cfun_va(fun, s, NULL);
SYM_FUN(s) = f;
f->cfun.narg = narg;

23
src/c/alloc.d
View file

@ -225,14 +225,6 @@ cl_alloc_object(cl_type t)
start_critical_section();
tm = tm_of(t);
ONCE_MORE:
if (interrupt_flag) {
interrupt_flag = FALSE;
#ifdef HAVE_ALARM
alarm(0);
#endif
terminal_interrupt(TRUE);
}
obj = tm->tm_free;
if (obj == OBJNULL) {
cl_index available = available_pages();
@ -437,13 +429,6 @@ make_cons(cl_object a, cl_object d)
start_critical_section();
ONCE_MORE:
if (interrupt_flag) {
interrupt_flag = FALSE;
#ifdef HAVE_ALARM
alarm(0);
#endif
terminal_interrupt(TRUE);
}
obj = tm->tm_free;
if (obj == OBJNULL) {
if (tm->tm_npage >= tm->tm_maxpage)
@ -515,15 +500,7 @@ cl_alloc(cl_index n)
n = round_up(n);
start_critical_section();
ONCE_MORE:
if (interrupt_flag) {
interrupt_flag = FALSE;
gg = g;
terminal_interrupt(TRUE);
g = gg;
}
/* Use extra indirection so that cb_pointer can be updated */
for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link)
if ((*cbpp)->cb_size >= n) {

3
src/c/alloc_2.d
View file

@ -56,8 +56,7 @@ finalize(cl_object o, cl_object data)
break;
#ifdef ECL_THREADS
case t_lock:
if (o->lock.mutex != NULL)
pthread_mutex_destroy(o->lock.mutex);
pthread_mutex_destroy(&o->lock.mutex);
break;
#endif
default:}

6
src/c/error.d
View file

@ -58,12 +58,6 @@ internal_error(const char *s)
/* Support for Lisp Error Handler */
/*****************************************************************************/
void
terminal_interrupt(bool correctable)
{
funcall(2, @'si::terminal-interrupt', correctable? Ct : Cnil);
}
void
FEerror(char *s, int narg, ...)
{

25
src/c/file.d
View file

@ -1348,8 +1348,7 @@ BEGIN:
cl_object si_file_column(cl_object strm)
{
int c = file_column(strm);
@(return (c < 0? Cnil : MAKE_FIXNUM(c)))
@(return MAKE_FIXNUM(file_column(strm)))
}
int
@ -1359,14 +1358,14 @@ file_column(cl_object strm)
BEGIN:
#ifdef ECL_CLOS_STREAMS
if (type_of(strm) == t_instance)
return -1;
return 0;
#endif
if (type_of(strm) != t_stream)
FEtype_error_stream(strm);
switch ((enum ecl_smmode)strm->stream.mode) {
case smm_closed:
FEclosed_stream(strm);
return(-1);
return 0;
case smm_output:
case smm_io:
@ -1385,26 +1384,14 @@ BEGIN:
case smm_input:
case smm_probe:
case smm_string_input:
return(-1);
return 0;
case smm_concatenated:
case smm_broadcast:
if (endp(strm->stream.object0))
return(-1);
return 0;
strm = CAR(strm->stream.object0);
goto BEGIN;
case smm_broadcast:
{
int i;
cl_object x;
for (x = strm->stream.object0; !endp(x); x = CDR(x)) {
i = file_column(CAR(x));
if (i >= 0)
return(i);
}
return(-1);
}
default:
error("illegal stream mode");
}

8
src/c/gbc.d
View file

@ -701,6 +701,7 @@ ecl_gc(cl_type new_name)
{
int tm;
int gc_start = runtime();
cl_object old_interrupt_enable;
start_critical_section();
t = new_name;
@ -713,6 +714,7 @@ ecl_gc(cl_type t)
int i, j;
int tm;
int gc_start = runtime();
cl_object old_interrupt_enable;
#endif /* THREADS */
if (!GC_enabled())
@ -763,7 +765,7 @@ ecl_gc(cl_type t)
if (GC_enter_hook != NULL)
(*GC_enter_hook)();
interrupt_enable = FALSE;
old_interrupt_enable = ecl_enable_interrupt(Cnil);
collect_blocks = t > t_end;
if (collect_blocks)
@ -850,7 +852,7 @@ ecl_gc(cl_type t)
fflush(stdout);
}
interrupt_enable = TRUE;
ecl_enable_interrupt(old_enable_interrupt);
if (GC_exit_hook != NULL)
(*GC_exit_hook)();
@ -888,7 +890,7 @@ ecl_gc(cl_type t)
fflush(stdout);
}
if (interrupt_flag) sigint();
if (cl_env.interrupts_pending) si_check_pending_interrupts();
end_critical_section();
}

2
src/c/gfun.d
View file

@ -91,7 +91,7 @@ set_meth_hash(cl_object *keys, int argno, cl_object hashtable, cl_object value)
else
FEerror("internal error, corrupted hashtable ~S", 1, hashtable);
if (over)
extend_hashtable(hashtable);
ecl_extend_hashtable(hashtable);
keylist = Cnil;
for (p = keys + argno; p > keys; p--) keylist = CONS(p[-1], keylist);
e = get_meth_hash(keys, argno, hashtable);

102
src/c/hash.d
View file

@ -16,6 +16,7 @@
#include "ecl.h"
#include <stdlib.h>
#include "internal.h"
/*******************
* CRC-32 ROUTINES *
@ -229,7 +230,6 @@ ecl_search_hash(cl_object key, cl_object hashtable)
int htest;
bool b;
assert_type_hash_table(hashtable);
htest = hashtable->hash.test;
hsize = hashtable->hash.size;
j = hsize;
@ -279,8 +279,13 @@ ecl_search_hash(cl_object key, cl_object hashtable)
cl_object
gethash(cl_object key, cl_object hashtable)
{
/* INV: ecl_search_hash() checks the type of hashtable */
return ecl_search_hash(key, hashtable)->value;
cl_object output;
assert_type_hash_table(hashtable);
HASH_TABLE_LOCK(hashtable);
output = ecl_search_hash(key, hashtable)->value;
HASH_TABLE_UNLOCK(hashtable);
return output;
}
cl_object
@ -288,12 +293,13 @@ gethash_safe(cl_object key, cl_object hashtable, cl_object def)
{
struct ecl_hashtable_entry *e;
/* INV: ecl_search_hash() checks the type of hashtable */
assert_type_hash_table(hashtable);
HASH_TABLE_LOCK(hashtable);
e = ecl_search_hash(key, hashtable);
if (e->key == OBJNULL)
return def;
else
return e->value;
if (e->key != OBJNULL)
def = e->value;
HASH_TABLE_UNLOCK(hashtable);
return def;
}
static void
@ -336,11 +342,12 @@ sethash(cl_object key, cl_object hashtable, cl_object value)
bool over;
struct ecl_hashtable_entry *e;
/* INV: ecl_search_hash() checks the type of hashtable */
assert_type_hash_table(hashtable);
HASH_TABLE_LOCK(hashtable);
e = ecl_search_hash(key, hashtable);
if (e->key != OBJNULL) {
e->value = value;
return;
goto OUTPUT;
}
i = hashtable->hash.entries + 1;
if (i >= hashtable->hash.size)
@ -351,15 +358,19 @@ sethash(cl_object key, cl_object hashtable, cl_object value)
over = i >= hashtable->hash.size * sf(hashtable->hash.threshold);
else if (type_of(hashtable->hash.threshold) == t_longfloat)
over = i >= hashtable->hash.size * lf(hashtable->hash.threshold);
else
else {
HASH_TABLE_UNLOCK(hashtable);
corrupted_hash(hashtable);
}
if (over)
extend_hashtable(hashtable);
ecl_extend_hashtable(hashtable);
add_new_to_hash(key, hashtable, value);
OUTPUT:
HASH_TABLE_UNLOCK(hashtable);
}
void
extend_hashtable(cl_object hashtable)
ecl_extend_hashtable(cl_object hashtable)
{
cl_object old, key;
cl_index old_size, new_size, i;
@ -402,14 +413,16 @@ extend_hashtable(cl_object hashtable)
@(defun make_hash_table (&key (test @'eql')
(size MAKE_FIXNUM(1024))
(rehash_size make_shortfloat(1.5))
(rehash_threshold make_shortfloat(0.7)))
(rehash_threshold make_shortfloat(0.7))
(lockable Cnil))
@
@(return cl__make_hash_table(test, size, rehash_size, rehash_threshold))
@(return cl__make_hash_table(test, size, rehash_size, rehash_threshold,
lockable))
@)
cl_object
cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size,
cl_object rehash_threshold)
cl_object rehash_threshold, cl_object lockable)
{
int htt;
cl_index hsize;
@ -455,6 +468,11 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size,
h->hash.data = NULL; /* for GC sake */
h->hash.data = (struct ecl_hashtable_entry *)
cl_alloc(hsize * sizeof(struct ecl_hashtable_entry));
h->hash.lockable = !Null(lockable);
#ifdef ECL_THREADS
if (h->hash.lockable)
pthread_mutex_init(&h->hash.lock, NULL);
#endif
return cl_clrhash(h);
}
@ -465,12 +483,14 @@ cl_hash_table_p(cl_object ht)
}
@(defun gethash (key ht &optional (no_value Cnil))
struct ecl_hashtable_entry *e;
struct ecl_hashtable_entry e;
@
/* INV: ecl_search_hash() checks the type of hashtable */
e = ecl_search_hash(key, ht);
if (e->key != OBJNULL)
@(return e->value Ct)
assert_type_hash_table(ht);
HASH_TABLE_LOCK(ht);
e = *ecl_search_hash(key, ht);
HASH_TABLE_UNLOCK(ht);
if (e.key != OBJNULL)
@(return e.value Ct)
else
@(return no_value Cnil)
@)
@ -487,16 +507,21 @@ bool
remhash(cl_object key, cl_object hashtable)
{
struct ecl_hashtable_entry *e;
bool output;
/* INV: ecl_search_hash() checks the type of hashtable */
assert_type_hash_table(hashtable);
HASH_TABLE_LOCK(hashtable);
e = ecl_search_hash(key, hashtable);
if (e->key != OBJNULL) {
if (e->key == OBJNULL) {
output = FALSE;
} else {
e->key = OBJNULL;
e->value = Cnil;
hashtable->hash.entries--;
return TRUE;
output = TRUE;
}
return FALSE;
HASH_TABLE_UNLOCK(hashtable);
return output;
}
cl_object
@ -512,11 +537,13 @@ cl_clrhash(cl_object ht)
cl_index i;
assert_type_hash_table(ht);
HASH_TABLE_LOCK(ht);
for(i = 0; i < ht->hash.size; i++) {
ht->hash.data[i].key = OBJNULL;
ht->hash.data[i].value = OBJNULL;
}
ht->hash.entries = 0;
HASH_TABLE_UNLOCK(ht);
@(return ht)
}
@ -529,7 +556,8 @@ cl_hash_table_test(cl_object ht)
case htt_eql: output = @'eql'; break;
case htt_equal: output = @'equal'; break;
case htt_equalp: output = @'equalp'; break;
default: output = Cnil;
case htt_pack:
default: output = @'equal';
}
@(return output)
}
@ -557,12 +585,14 @@ si_hash_table_iterate(int narg, cl_object env)
i = fix(index);
if (i < 0)
i = -1;
for (; ++i < ht->hash.size; )
if (ht->hash.data[i].key != OBJNULL) {
for (; ++i < ht->hash.size; ) {
struct ecl_hashtable_entry e = ht->hash.data[i];
if (e.key != OBJNULL) {
@(return (CAR(env) = MAKE_FIXNUM(i))
ht->hash.data[i].key
ht->hash.data[i].value)
e.key
e.value)
}
}
CAR(env) = Cnil;
}
@(return Cnil)
@ -602,10 +632,9 @@ cl_maphash(cl_object fun, cl_object ht)
assert_type_hash_table(ht);
for (i = 0; i < ht->hash.size; i++) {
if(ht->hash.data[i].key != OBJNULL)
funcall(3, fun,
ht->hash.data[i].key,
ht->hash.data[i].value);
struct ecl_hashtable_entry e = ht->hash.data[i];
if(e.key != OBJNULL)
funcall(3, fun, e.key, e.value);
}
@(return Cnil)
}
@ -617,9 +646,12 @@ si_copy_hash_table(cl_object orig)
hash = cl__make_hash_table(cl_hash_table_test(orig),
cl_hash_table_size(orig),
cl_hash_table_rehash_size(orig),
cl_hash_table_rehash_threshold(orig));
cl_hash_table_rehash_threshold(orig),
orig->hash.lockable? Ct : Cnil);
HASH_TABLE_LOCK(hash);
memcpy(hash->hash.data, orig->hash.data,
orig->hash.size * sizeof(*orig->hash.data));
hash->hash.entries = orig->hash.entries;
HASH_TABLE_UNLOCK(hash);
@(return hash)
}

18
src/c/list.d
View file

@ -849,6 +849,24 @@ error: FEerror("The keys ~S and the data ~S are not of the same length",
@(return a_list)
@)
void
ecl_delete_eq(cl_object x, cl_object *lp)
{
for (; CONSP(*lp); lp = &CDR((*lp)))
if (CAR((*lp)) == x) {
*lp = CDR((*lp));
return;
}
}
cl_object
ecl_remove_eq(cl_object x, cl_object l)
{
l = cl_copy_list(l);
ecl_delete_eq(x, &l);
return l;
}
/* Added for use by the compiler, instead of open coding them. Beppe */
cl_object
assq(cl_object x, cl_object l)

27
src/c/load.d
View file

@ -105,6 +105,7 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print)
cl_object block;
cl_object basename;
cl_object prefix;
cl_object output;
/* A full garbage collection enables us to detect unused code
and leave space for the library to be loaded. */
@ -113,10 +114,19 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print)
/* We need the full pathname */
filename = coerce_to_filename(cl_truename(filename));
#ifdef ECL_THREADS
/* Loading binary code is not thread safe. When another thread tries
to load the same file, we may end up initializing twice the same
module. */
mp_get_lock(1, symbol_value(@'mp::+load-compile-lock+'));
CL_UNWIND_PROTECT_BEGIN {
#endif
/* Try to load shared object file */
block = ecl_library_open(filename);
if (block->cblock.handle == NULL)
@(return ecl_library_error(block))
if (block->cblock.handle == NULL) {
output = ecl_library_error(block);
goto OUTPUT;
}
/* Fist try to call "init_CODE()" */
block->cblock.entry = ecl_library_symbol(block, INIT_PREFIX "CODE");
@ -138,15 +148,22 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print)
block->cblock.entry = ecl_library_symbol(block, basename->string.self);
if (block->cblock.entry == NULL) {
cl_object output = ecl_library_error(block);
output = ecl_library_error(block);
ecl_library_close(block);
@(return output)
goto OUTPUT;
}
/* Finally, perform initialization */
GO_ON:
read_VV(block, block->cblock.entry);
@(return Cnil)
output = Cnil;
OUTPUT:
#ifdef ECL_THREADS
} CL_UNWIND_PROTECT_EXIT {
mp_giveup_lock(symbol_value(@'mp::+load-compile-lock+'));
} CL_UNWIND_PROTECT_END;
#endif
@(return output)
}
#endif /* ENABLE_DLOPEN */

18
src/c/main.d
View file

@ -82,7 +82,7 @@ ecl_init_env(struct cl_env_struct *env)
env->circle_counter = -2;
env->circle_stack = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024),
make_shortfloat(1.5),
make_shortfloat(0.7));
make_shortfloat(0.7), Cnil);
#ifndef ECL_CMU_FORMAT
env->fmt_aux_stream = make_string_output_stream(64);
#endif
@ -215,7 +215,8 @@ cl_boot(int argc, char **argv)
cl_core.system_properties =
cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */
make_shortfloat(1.5), /* rehash-size */
make_shortfloat(0.7)); /* rehash-threshold */
make_shortfloat(0.7), /* rehash-threshold */
Ct); /* thread-safe */
cl_core.gensym_prefix = make_simple_string("G");
cl_core.gentemp_prefix = make_simple_string("T");
@ -233,7 +234,9 @@ cl_boot(int argc, char **argv)
#ifdef ECL_THREADS
cl_env.bindings_hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024),
make_shortfloat(1.5),
make_shortfloat(0.7));
make_shortfloat(0.7),
Cnil); /* no locking */
ECL_SET(@'mp::*current-process*', cl_env.own_process);
#endif
/*
@ -254,6 +257,10 @@ cl_boot(int argc, char **argv)
/*
* 5) Set up hooks for LOAD, errors and macros.
*/
#ifdef ECL_THREADS
ECL_SET(@'mp::+load-compile-lock+',
mp_make_lock(2, @':name', @'mp::+load-compile-lock+'));
#endif
ECL_SET(@'si::*load-hooks*', cl_list(
#ifdef ENABLE_DLOPEN
4,CONS(make_simple_string("fas"), @'si::load-binary'),
@ -276,7 +283,8 @@ cl_boot(int argc, char **argv)
ECL_SET(@'si::*class-name-hash-table*',
cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */
make_shortfloat(1.5), /* rehash-size */
make_shortfloat(0.7))); /* rehash-threshold */
make_shortfloat(0.7), /* rehash-threshold */
Ct)); /* thread safe */
#endif
/*
@ -350,7 +358,7 @@ cl_boot(int argc, char **argv)
/* Jump to top level */
ECL_SET(@'*package*', cl_core.user_package);
enable_interrupt();
init_unixint();
si_catch_bad_signals();
}

30
src/c/num_arith.d
View file

@ -289,7 +289,7 @@ number_plus(cl_object x, cl_object y)
case t_shortfloat:
return make_shortfloat(number_to_double(x) + sf(y));
case t_longfloat:
return make_shortfloat(number_to_double(x) + lf(y));
return make_longfloat(number_to_double(x) + lf(y));
case t_complex:
goto COMPLEX;
default:
@ -387,7 +387,7 @@ number_minus(cl_object x, cl_object y)
case t_shortfloat:
return make_shortfloat(fix(x) - sf(y));
case t_longfloat:
return make_shortfloat(fix(x) - lf(y));
return make_longfloat(fix(x) - lf(y));
case t_complex:
goto COMPLEX;
default:
@ -524,11 +524,14 @@ number_negate(cl_object x)
switch (type_of(x)) {
case t_fixnum: {
cl_fixnum k = fix(x);
/* -MOST_NEGATIVE_FIXNUM > MOST_POSITIVE_FIXNUM */
if (k == MOST_NEGATIVE_FIXNUM)
if (-MOST_NEGATIVE_FIXNUM > MOST_POSITIVE_FIXNUM) {
if (k == MOST_NEGATIVE_FIXNUM)
return(bignum1(- MOST_NEGATIVE_FIXNUM));
else
else
return(MAKE_FIXNUM(-k));
} else {
return MAKE_FIXNUM(-k);
}
}
case t_bignum:
z = big_register0_get();
@ -695,8 +698,21 @@ integer_divide(cl_object x, cl_object y)
if (tx == t_fixnum) {
if (ty == t_fixnum)
return MAKE_FIXNUM(fix(x) / fix(y));
if (ty == t_bignum)
return MAKE_FIXNUM(0);
if (ty == t_bignum) {
/* The only number "x" which can be a bignum and be
* as large as "-x" is -MOST_NEGATIVE_FIXNUM. However
* in newer versions of ECL we will probably choose
* MOST_NEGATIVE_FIXNUM = - MOST_POSITIVE_FIXNUM.
*/
if (-MOST_NEGATIVE_FIXNUM > MOST_POSITIVE_FIXNUM) {
if (mpz_cmp_si(y->big.big_num, -fix(x)))
return MAKE_FIXNUM(0);
else
return MAKE_FIXNUM(-1);
} else {
return MAKE_FIXNUM(0);
}
}
FEtype_error_integer(y);
}
if (tx == t_bignum) {

33
src/c/num_co.d
View file

@ -102,11 +102,11 @@ number_remainder(cl_object x, cl_object y, cl_object q)
break;
}
case t_shortfloat:
if (t == t_longfloat)
if (y && t == t_longfloat)
x = make_longfloat(sf(x));
break;
case t_longfloat:
if (t == t_shortfloat)
if (y && t == t_shortfloat)
x = make_shortfloat(lf(x));
break;
default:
@ -634,34 +634,9 @@ round2(cl_object x, cl_object y)
VALUES(1) = number_remainder(x, y, q1);
break;
}
case t_shortfloat: {
float d = sf(q);
float aux = d + (d >= 0.0 ? 0.5 : -0.5);
cl_object q1 = float_to_integer(aux);
d -= aux;
if (d == 0.5 && number_oddp(q1))
q1 = one_plus(q1);
if (d == -0.5 && number_oddp(q1))
q1 = one_minus(q1);
VALUES(0) = q1;
VALUES(1) = number_remainder(x, y, q1);
break;
}
case t_longfloat: {
double d = lf(q);
double aux = d + (d >= 0.0 ? 0.5 : -0.5);
cl_object q1 = double_to_integer(aux);
d -= aux;
if (d == 0.5 && number_oddp(q1))
q1 = one_plus(q1);
if (d == -0.5 && number_oddp(q1))
q1 = one_minus(q1);
VALUES(0) = q1;
VALUES(1) = number_remainder(x, y, q1);
break;
}
default:
FEerror("Complex arguments to round2 (~S, ~S)", 2, x, y);
VALUES(0) = q = round1(q);
VALUES(1) = number_remainder(x, y, q);
}
NVALUES = 2;
return VALUES(0);

2
src/c/num_comp.d
View file

@ -77,7 +77,7 @@ number_equalp(cl_object x, cl_object y)
return 0;
case t_ratio:
return (number_equalp(x->ratio.num, y->ratio.num) &&
number_equalp(x->ratio.den, x->ratio.den));
number_equalp(x->ratio.den, y->ratio.den));
case t_shortfloat:
return sf(y) == number_to_double(x);
case t_longfloat:

362
src/c/package.d
View file

@ -14,11 +14,22 @@
See file '../Copyright' for full details.
*/
#include "ecl.h"
#include "internal.h"
/******************************* ------- ******************************/
/*
* 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
* instead of ecl_delete_eq).
*/
/*
* NOTE 2: Operations between locks must be guaranteed not fail, or, if
* they signal an error, they should undo all locks they had before.
*/
#define INTERNAL 1
#define EXTERNAL 2
@ -75,6 +86,7 @@ make_package_hashtable()
cl_index hsize = 128;
h = cl_alloc_object(t_hashtable);
h->hash.lockable = 0;
h->hash.test = htt_pack;
h->hash.size = hsize;
h->hash.rehash_size = make_shortfloat(1.5);
@ -94,6 +106,10 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list)
assert_type_proper_list(nicknames);
assert_type_proper_list(use_list);
/* 1) Find a similarly named package in the list of packages to be
* created and use it.
*/
PACKAGE_OP_LOCK();
if (cl_core.packages_to_be_created != OBJNULL) {
cl_object *p = &cl_core.packages_to_be_created;
for (x = *p; x != Cnil; ) {
@ -102,12 +118,16 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list)
x = CDAR(x);
goto INTERN;
}
/* FIXME! We should also check the nicknames */
p = &CDR(x);
x = *p;
}
}
if ((other = find_package(name)) != Cnil) {
ERROR: cl_cerror(8,
/* 2) Otherwise, try to build a new package */
if ((other = ecl_find_package_nolock(name)) != Cnil) {
ERROR: PACKAGE_OP_UNLOCK();
cl_cerror(8,
make_simple_string("Return existing package"),
@'si::simple-package-error',
@':format-control',
@ -120,6 +140,19 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list)
x->pack.internal = make_package_hashtable();
x->pack.external = make_package_hashtable();
x->pack.name = name;
#ifdef ECL_THREADS
#if 0
pthread_mutex_init(&x->pack.lock);
#else
{
pthread_mutexattr_t attr;
pthread_mutexattr_init(&attr);
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP);
pthread_mutex_init(&x->pack.lock, &attr);
pthread_mutexattr_destroy(&attr);
}
#endif
#endif
INTERN:
x->pack.nicknames = Cnil;
x->pack.shadowings = Cnil;
@ -128,7 +161,7 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list)
x->pack.locked = FALSE;
for (; !endp(nicknames); nicknames = CDR(nicknames)) {
cl_object nick = cl_string(CAR(nicknames));
if ((other = find_package(nick)) != Cnil) {
if ((other = ecl_find_package_nolock(nick)) != Cnil) {
name = nick;
goto ERROR;
}
@ -139,7 +172,10 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list)
x->pack.uses = CONS(y, x->pack.uses);
y->pack.usedby = CONS(x, y->pack.usedby);
}
/* 3) Finally, add it to the list of packages */
cl_core.packages = CONS(x, cl_core.packages);
PACKAGE_OP_UNLOCK();
return(x);
}
@ -148,20 +184,16 @@ rename_package(cl_object x, cl_object name, cl_object nicknames)
{
cl_object y;
/*
If we are trying to rename the package with either its name
or a nickname, then we are really trying to redefine the
package. Therefore, do not signal the error.
Marco Antoniotti 19951028
*/
name = cl_string(name);
x = si_coerce_to_package(x);
if (x->pack.locked)
CEpackage_error("Cannot rename locked package ~S.", x, 0);
name = cl_string(name);
y = find_package(name);
PACKAGE_OP_LOCK();
y = ecl_find_package_nolock(name);
if ((y != Cnil) && (y != x)) {
ERROR: FEpackage_error("A package with name ~S already exists.", x,
ERROR: PACKAGE_OP_UNLOCK();
FEpackage_error("A package with name ~S already exists.", x,
1, name);
}
@ -170,7 +202,7 @@ rename_package(cl_object x, cl_object name, cl_object nicknames)
assert_type_proper_list(nicknames);
for (; !endp(nicknames); nicknames = CDR(nicknames)) {
cl_object nick = CAR(nicknames);
y = find_package(nick);
y = ecl_find_package_nolock(nick);
if (x == y)
continue;
if (y != Cnil) {
@ -179,16 +211,23 @@ rename_package(cl_object x, cl_object name, cl_object nicknames)
}
x->pack.nicknames = CONS(cl_string(nick), x->pack.nicknames);
}
PACKAGE_OP_UNLOCK();
return(x);
}
/*
Find_package(n) seaches for a package with name n, where n is
ecl_find_package_nolock(n) seaches for a package with name n, where n is
a valid string designator, or simply outputs n if it is a
package.
This is not a locking routine and someone may replace the list of
packages while we are scanning it. Nevertheless, the list IS NOT
be destructively modified, which means that we are on the safe side.
Routines which need to ensure that the package list remains constant
should enforce a global lock with PACKAGE_OP_LOCK().
*/
cl_object
find_package(cl_object name)
ecl_find_package_nolock(cl_object name)
{
cl_object l, p;
@ -209,9 +248,9 @@ find_package(cl_object name)
cl_object
si_coerce_to_package(cl_object p)
{
/* INV: find_package() signals an error if "p" is neither a package
/* INV: ecl_find_package_nolock() signals an error if "p" is neither a package
nor a string */
cl_object pp = find_package(p);
cl_object pp = ecl_find_package_nolock(p);
if (Null(pp)) {
FEpackage_error("There exists no package with name ~S", p, 0);
}
@ -250,29 +289,34 @@ intern(cl_object name, cl_object p, int *intern_flag)
assert_type_string(name);
p = si_coerce_to_package(p);
TRY_AGAIN:
PACKAGE_LOCK(p);
s = gethash_safe(name, p->pack.external, OBJNULL);
if (s != OBJNULL) {
*intern_flag = EXTERNAL;
return s;
goto OUTPUT;
}
/* Keyword package has no intern section nor can it be used */
if (p == cl_core.keyword_package) goto INTERN;
s = gethash_safe(name, p->pack.internal, OBJNULL);
if (s != OBJNULL) {
*intern_flag = INTERNAL;
return s;
goto OUTPUT;
}
for (ul=p->pack.uses; CONSP(ul); ul = CDR(ul)) {
s = gethash_safe(name, CAR(ul)->pack.external, OBJNULL);
if (s != OBJNULL) {
*intern_flag = INHERITED;
return s;
goto OUTPUT;
}
}
INTERN:
if (p->pack.locked)
if (p->pack.locked) {
PACKAGE_UNLOCK(p);
CEpackage_error("Cannot intern symbol ~S in locked package ~S.",
p, 2, name, p);
goto TRY_AGAIN;
}
s = make_symbol(name);
s->symbol.hpack = p;
*intern_flag = 0;
@ -283,100 +327,112 @@ intern(cl_object name, cl_object p, int *intern_flag)
} else {
sethash(name, p->pack.internal, s);
}
OUTPUT:
PACKAGE_UNLOCK(p);
return s;
}
/*
Find_symbol(st, len, p) searches for string st of length len in package p.
ecl_find_symbol_nolock(st, len, p) searches for string st of length
len in package p.
*/
cl_object
find_symbol(cl_object name, cl_object p, int *intern_flag)
ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag)
{
cl_object s, ul;
name = cl_string(name);
p = si_coerce_to_package(p);
assert_type_string(name);
s = gethash_safe(name, p->pack.external, OBJNULL);
if (s != OBJNULL) {
*intern_flag = EXTERNAL;
return s;
goto OUTPUT;
}
if (p == cl_core.keyword_package) goto RETURN;
if (p == cl_core.keyword_package)
goto NOTHING;
s = gethash_safe(name, p->pack.internal, OBJNULL);
if (s != OBJNULL) {
*intern_flag = INTERNAL;
return s;
goto OUTPUT;
}
for (ul=p->pack.uses; CONSP(ul); ul = CDR(ul)) {
s = gethash_safe(name, CAR(ul)->pack.external, OBJNULL);
if (s != OBJNULL) {
*intern_flag = INHERITED;
return s;
goto OUTPUT;
}
}
RETURN:
NOTHING:
*intern_flag = 0;
return(Cnil);
s = Cnil;
OUTPUT:
return s;
}
static void
delete_eq(cl_object x, cl_object *lp)
#ifdef ECL_THREADS
cl_object
ecl_find_symbol(cl_object n, cl_object p, int *intern_flag)
{
for (; CONSP(*lp); lp = &CDR((*lp)))
if (CAR((*lp)) == x) {
*lp = CDR((*lp));
return;
}
n = cl_string(n);
p = si_coerce_to_package(p);
PACKAGE_LOCK(p);
n = ecl_find_symbol_nolock(n, p, intern_flag);
PACKAGE_UNLOCK(p);
return n;
}
#endif
bool
unintern(cl_object s, cl_object p)
{
cl_object x, y, l, hash;
bool output = FALSE;
assert_type_symbol(s);
p = si_coerce_to_package(p);
TRY_AGAIN:
PACKAGE_LOCK(p);
hash = p->pack.internal;
x = gethash_safe(s->symbol.name, hash, OBJNULL);
if (x == s) {
if (member_eq(s, p->pack.shadowings))
goto L;
if (x == s)
goto UNINTERN;
}
hash = p->pack.external;
x = gethash_safe(s->symbol.name, hash, OBJNULL);
if (x == s) {
if (member_eq(s, p->pack.shadowings))
goto L;
goto UNINTERN;
}
return(FALSE);
L:
if (p->pack.locked)
if (x != s)
goto OUTPUT;
UNINTERN:
if (p->pack.locked) {
PACKAGE_UNLOCK(p);
CEpackage_error("Cannot unintern symbol ~S from locked package ~S.",
p, 2, s, p);
goto TRY_AGAIN;
}
if (!member_eq(s, p->pack.shadowings))
goto NOT_SHADOW;
x = OBJNULL;
for (l = p->pack.uses; CONSP(l); l = CDR(l)) {
y = gethash_safe(s->symbol.name, CAR(l)->pack.external, OBJNULL);
if (y != OBJNULL) {
if (x == OBJNULL)
x = y;
else if (x != y)
FEpackage_error(
"Cannot unintern the shadowing symbol ~S~%\
from ~S,~%\
because ~S and ~S will cause~%\
a name conflict.", p, 4, s, p, x, y);
else if (x != y) {
PACKAGE_UNLOCK(p);
FEpackage_error("Cannot unintern the shadowing symbol ~S~%"
"from ~S,~%"
"because ~S and ~S will cause~%"
"a name conflict.", p, 4, s, p, x, y);
}
}
}
delete_eq(s, &p->pack.shadowings);
UNINTERN:
p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings);
NOT_SHADOW:
remhash(s->symbol.name, hash);
if (s->symbol.hpack == p)
s->symbol.hpack = Cnil;
return(TRUE);
output = TRUE;
OUTPUT:
PACKAGE_UNLOCK(p);
return output;
}
void
@ -384,36 +440,47 @@ cl_export2(cl_object s, cl_object p)
{
cl_object x, l, hash = OBJNULL;
int intern_flag;
BEGIN:
BEGIN:
assert_type_symbol(s);
p = si_coerce_to_package(p);
if (p->pack.locked)
CEpackage_error("Cannot export symbol ~S from locked package ~S.", p,
2, s, p);
x = find_symbol(s, p, &intern_flag);
if (!intern_flag)
PACKAGE_LOCK(p);
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
if (!intern_flag) {
PACKAGE_UNLOCK(p);
FEpackage_error("The symbol ~S is not accessible from ~S.", p, 2,
s, p);
}
if (x != s) {
cl_import2(s, p); /* signals an error */
goto BEGIN;
PACKAGE_UNLOCK(p);
FEpackage_error("Cannot export the symbol ~S~%"
"from ~S,~%"
"because there is already a symbol with the same name~%"
"in the package.", p, 2, s, p);
}
if (intern_flag == EXTERNAL)
return;
goto OUTPUT;
if (intern_flag == INTERNAL)
hash = p->pack.internal;
for (l = p->pack.usedby; CONSP(l); l = CDR(l)) {
x = find_symbol(s, CAR(l), &intern_flag);
x = ecl_find_symbol_nolock(s->symbol.name, CAR(l), &intern_flag);
if (intern_flag && s != x &&
!member_eq(x, CAR(l)->pack.shadowings))
FEpackage_error("Cannot export the symbol ~S~%\
from ~S,~%\
because it will cause a name conflict~%\
in ~S.", p, 3, s, p, CAR(l));
!member_eq(x, CAR(l)->pack.shadowings)) {
PACKAGE_UNLOCK(p);
FEpackage_error("Cannot export the symbol ~S~%"
"from ~S,~%"
"because it will cause a name conflict~%"
"in ~S.", p, 3, s, p, CAR(l));
}
}
if (hash != OBJNULL)
remhash(s->symbol.name, hash);
sethash(s->symbol.name, p->pack.external, s);
OUTPUT:
PACKAGE_UNLOCK(p);
}
cl_object
@ -421,31 +488,53 @@ cl_delete_package(cl_object p)
{
cl_object hash, list;
cl_index i;
cl_object output = Ct;
p = find_package(p);
/* 1) Try to remove the package from the global list */
p = ecl_find_package_nolock(p);
if (Null(p)) {
CEpackage_error("Package ~S not found. Cannot delete it.", p, 0);
@(return Cnil);
}
if (p->pack.locked)
CEpackage_error("Cannot delete locked package ~S.", p, 0);
if (Null(p->pack.name))
@(return Cnil)
if (p == cl_core.lisp_package || p == cl_core.keyword_package)
if (p == cl_core.lisp_package || p == cl_core.keyword_package) {
FEpackage_error("Cannot remove package ~S", p, 0);
}
/* 2) Now remove the package from the other packages that use it
* and empty the package.
*/
if (Null(p->pack.name)) {
@(return Cnil)
}
for (list = p->pack.uses; !endp(list); list = CDR(list))
unuse_package(CAR(list), p);
for (list = p->pack.usedby; !endp(list); list = CDR(list))
unuse_package(p, CAR(list));
PACKAGE_LOCK(p);
for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++)
if (hash->hash.data[i].key != OBJNULL)
unintern(hash->hash.data[i].value, p);
if (hash->hash.data[i].key != OBJNULL) {
cl_object s = hash->hash.data[i].value;
if (s->symbol.hpack == p)
s->symbol.hpack = Cnil;
}
cl_clrhash(p->pack.internal);
for (hash = p->pack.external, i = 0; i < hash->hash.size; i++)
if (hash->hash.data[i].key != OBJNULL)
unintern(hash->hash.data[i].value, p);
delete_eq(p, &cl_core.packages);
if (hash->hash.data[i].key != OBJNULL) {
cl_object s = hash->hash.data[i].value;
if (s->symbol.hpack == p)
s->symbol.hpack = Cnil;
}
cl_clrhash(p->pack.external);
p->pack.shadowings = Cnil;
p->pack.name = Cnil;
PACKAGE_UNLOCK(p);
/* 2) Only at the end, remove the package from the list of packages. */
PACKAGE_OP_LOCK();
cl_core.packages = ecl_remove_eq(p, cl_core.packages);
PACKAGE_OP_UNLOCK();
@(return Ct)
}
@ -463,16 +552,22 @@ cl_unexport2(cl_object s, cl_object p)
if (p->pack.locked)
CEpackage_error("Cannot unexport symbol ~S from locked package ~S.",
p, 2, s, p);
x = find_symbol(s, p, &intern_flag);
if (intern_flag == 0)
PACKAGE_LOCK(p);
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
if (intern_flag == 0) {
PACKAGE_UNLOCK(p);
FEpackage_error("Cannot unexport ~S because it does not belong to package ~S.",
p, 2, s, p);
if (intern_flag != EXTERNAL)
}
if (intern_flag != EXTERNAL) {
/* According to ANSI & Cltl, internal symbols are
ignored in unexport */
return;
remhash(s->symbol.name, p->pack.external);
sethash(s->symbol.name, p->pack.internal, s);
(void)0;
} else {
remhash(s->symbol.name, p->pack.external);
sethash(s->symbol.name, p->pack.internal, s);
}
PACKAGE_UNLOCK(p);
}
void
@ -486,19 +581,24 @@ cl_import2(cl_object s, cl_object p)
if (p->pack.locked)
CEpackage_error("Cannot import symbol ~S into locked package ~S.",
p, 2, s, p);
x = find_symbol(s, p, &intern_flag);
PACKAGE_LOCK(p);
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
if (intern_flag) {
if (x != s)
FEpackage_error("Cannot import the symbol ~S~%\
from ~S,~%\
because there is already a symbol with the same name~%\
in the package.", p, 2, s, p);
if (x != s) {
PACKAGE_UNLOCK(p);
FEpackage_error("Cannot import the symbol ~S~%"
"from ~S,~%"
"because there is already a symbol with the same name~%"
"in the package.", p, 2, s, p);
}
if (intern_flag == INTERNAL || intern_flag == EXTERNAL)
return;
goto OUTPUT;
}
sethash(s->symbol.name, p->pack.internal, s);
if (Null(s->symbol.hpack))
s->symbol.hpack = p;
OUTPUT:
PACKAGE_UNLOCK(p);
}
void
@ -512,16 +612,18 @@ shadowing_import(cl_object s, cl_object p)
if (p->pack.locked)
CEpackage_error("Cannot shadowing-import symbol ~S into locked package ~S.",
p, 2, s, p);
x = find_symbol(s, p, &intern_flag);
PACKAGE_LOCK(p);
x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag);
if (intern_flag && intern_flag != INHERITED) {
if (x == s) {
if (!member_eq(x, p->pack.shadowings))
p->pack.shadowings
= CONS(x, p->pack.shadowings);
return;
goto OUTPUT;
}
if(member_eq(x, p->pack.shadowings))
delete_eq(x, &p->pack.shadowings);
p->pack.shadowings = ecl_remove_eq(x, p->pack.shadowings);
if (intern_flag == INTERNAL)
remhash(x->symbol.name, p->pack.internal);
else
@ -531,6 +633,8 @@ shadowing_import(cl_object s, cl_object p)
}
p->pack.shadowings = CONS(s, p->pack.shadowings);
sethash(s->symbol.name, p->pack.internal, s);
OUTPUT:
PACKAGE_UNLOCK(p);
}
void
@ -545,13 +649,15 @@ shadow(cl_object s, cl_object p)
if (p->pack.locked)
CEpackage_error("Cannot shadow symbol ~S in locked package ~S.",
p, 2, s, p);
x = find_symbol(s, p, &intern_flag);
PACKAGE_LOCK(p);
x = ecl_find_symbol_nolock(s, p, &intern_flag);
if (intern_flag != INTERNAL && intern_flag != EXTERNAL) {
x = make_symbol(s);
sethash(x->symbol.name, p->pack.internal, x);
x->symbol.hpack = p;
}
p->pack.shadowings = CONS(x, p->pack.shadowings);
PACKAGE_UNLOCK(p);
}
void
@ -574,21 +680,29 @@ use_package(cl_object x, cl_object p)
return;
if (member_eq(x, p->pack.uses))
return;
PACKAGE_LOCK(x);
PACKAGE_LOCK(p);
hash_entries = x->pack.external->hash.data;
hash_length = x->pack.external->hash.size;
for (i = 0; i < hash_length; i++)
if (hash_entries[i].key != OBJNULL) {
cl_object here = hash_entries[i].value;
cl_object there = find_symbol(here, p, &intern_flag);
cl_object there = ecl_find_symbol_nolock(here->symbol.name, p, &intern_flag);
if (intern_flag && here != there
&& ! member_eq(there, p->pack.shadowings))
FEpackage_error("Cannot use ~S~%\
from ~S,~%\
because ~S and ~S will cause~%\
a name conflict.", p, 4, x, p, here, there);
&& ! member_eq(there, p->pack.shadowings)) {
PACKAGE_UNLOCK(x);
PACKAGE_UNLOCK(p);
FEpackage_error("Cannot use ~S~%"
"from ~S,~%"
"because ~S and ~S will cause~%"
"a name conflict.", p, 4, x, p, here, there);
}
}
p->pack.uses = CONS(x, p->pack.uses);
x->pack.usedby = CONS(p, x->pack.usedby);
PACKAGE_UNLOCK(x);
PACKAGE_UNLOCK(p);
}
void
@ -599,8 +713,12 @@ unuse_package(cl_object x, cl_object p)
if (p->pack.locked)
CEpackage_error("Cannot unuse package ~S from locked package ~S.",
p, 2, x, p);
delete_eq(x, &p->pack.uses);
delete_eq(p, &x->pack.usedby);
PACKAGE_LOCK(x);
PACKAGE_LOCK(p);
p->pack.uses = ecl_remove_eq(x, p->pack.uses);
x->pack.usedby = ecl_remove_eq(p, x->pack.usedby);
PACKAGE_UNLOCK(p);
PACKAGE_UNLOCK(x);
}
@(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, Cnil)))
@ -619,7 +737,7 @@ si_select_package(cl_object pack_name)
cl_object
cl_find_package(cl_object p)
{
@(return find_package(p))
@(return ecl_find_package_nolock(p))
}
cl_object
@ -647,25 +765,19 @@ cl_package_nicknames(cl_object p)
cl_object
cl_package_use_list(cl_object p)
{
/* FIXME: list should be a fresh one */
p = si_coerce_to_package(p);
@(return p->pack.uses)
return cl_copy_list(si_coerce_to_package(p)->pack.uses);
}
cl_object
cl_package_used_by_list(cl_object p)
{
/* FIXME: list should be a fresh one */
p = si_coerce_to_package(p);
@(return p->pack.usedby)
return cl_copy_list(si_coerce_to_package(p)->pack.usedby);
}
cl_object
cl_package_shadowing_symbols(cl_object p)
{
/* FIXME: list should be a fresh one */
p = si_coerce_to_package(p);
@(return p->pack.shadowings)
return cl_copy_list(si_coerce_to_package(p)->pack.shadowings);
}
cl_object
@ -699,7 +811,7 @@ cl_list_all_packages()
cl_object x;
int intern_flag;
@
x = find_symbol(strng, p, &intern_flag);
x = ecl_find_symbol(strng, p, &intern_flag);
if (intern_flag == INTERNAL)
@(return x @':internal')
if (intern_flag == EXTERNAL)
@ -893,6 +1005,12 @@ BEGIN:
cl_object
si_package_hash_tables(cl_object p)
{
cl_object he, hi, u;
assert_type_package(p);
@(return p->pack.external p->pack.internal p->pack.uses)
PACKAGE_LOCK(p);
he = si_copy_hash_table(p->pack.external);
hi = si_copy_hash_table(p->pack.internal);
u = cl_copy_list(p->pack.uses);
PACKAGE_UNLOCK(p);
@(return he hi u)
}

45
src/c/print.d
View file

@ -64,15 +64,6 @@ stream_or_default_output(cl_object stream)
return stream;
}
static void
writec_PRINTstream(int c)
{
if (c == INDENT || c == INDENT1)
writec_stream(' ', cl_env.print_stream);
else if (c < 0400)
writec_stream(c, cl_env.print_stream);
}
static void
writec_queue(int c)
{
@ -93,7 +84,9 @@ flush_queue(bool force)
BEGIN:
while (cl_env.qc > 0) {
c = cl_env.queue[cl_env.qh];
if (c == MARK)
if (c < 0400) {
writec_stream(c, cl_env.print_stream);
} else if (c == MARK)
goto DO_MARK;
else if (c == UNMARK)
cl_env.isp -= 2;
@ -104,7 +97,7 @@ BEGIN:
} else if (c == INDENT1) {
i = file_column(cl_env.print_stream)-cl_env.indent_stack[cl_env.isp];
if (i < 8 && cl_env.indent_stack[cl_env.isp] < LINE_LENGTH/2) {
writec_PRINTstream(' ');
writec_stream(' ', cl_env.print_stream);
cl_env.indent_stack[cl_env.isp]
= file_column(cl_env.print_stream);
} else {
@ -117,8 +110,7 @@ BEGIN:
} else if (c == INDENT2) {
cl_env.indent_stack[cl_env.isp] = cl_env.indent_stack[cl_env.isp-1] + 2;
goto PUT_INDENT;
} else if (c < 0400)
writec_PRINTstream(c);
}
cl_env.qh = mod(cl_env.qh+1);
--cl_env.qc;
}
@ -143,9 +135,10 @@ DO_MARK:
return;
cl_env.qh = mod(cl_env.qh+1);
--cl_env.qc;
if (++cl_env.isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-1)
if (cl_env.isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-2)
FEerror("Can't pretty-print.", 0);
cl_env.indent_stack[cl_env.isp++] = file_column(cl_env.print_stream);
cl_env.isp+=2;
cl_env.indent_stack[cl_env.isp-1] = file_column(cl_env.print_stream);
cl_env.indent_stack[cl_env.isp] = cl_env.indent_stack[cl_env.isp-1];
goto BEGIN;
@ -190,9 +183,9 @@ DO_INDENT:
PUT_INDENT:
cl_env.qh = mod(cl_env.qh+1);
--cl_env.qc;
writec_PRINTstream('\n');
writec_stream('\n', cl_env.print_stream);
for (i = cl_env.indent_stack[cl_env.isp]; i > 0; --i)
writec_PRINTstream(' ');
writec_stream(' ', cl_env.print_stream);
cl_env.iisp = cl_env.isp;
goto BEGIN;
@ -200,9 +193,9 @@ FLUSH:
for (j = 0; j < i; j++) {
c = cl_env.queue[cl_env.qh];
if (c == INDENT || c == INDENT1 || c == INDENT2)
writec_PRINTstream(' ');
writec_stream(' ', cl_env.print_stream);
else if (c < 0400)
writec_PRINTstream(c);
writec_stream(c, cl_env.print_stream);
cl_env.qh = mod(cl_env.qh+1);
--cl_env.qc;
}
@ -446,14 +439,6 @@ call_structure_print_function(cl_object x, int level)
int oisp;
int oiisp;
while (interrupt_flag) {
interrupt_flag = FALSE;
#ifdef HAVE_ALARM
alarm(0);
#endif
terminal_interrupt(TRUE);
}
if (cl_env.print_pretty)
flush_queue(TRUE);
@ -556,7 +541,7 @@ write_symbol(register cl_object x)
} else if (x->symbol.hpack == cl_core.keyword_package)
write_ch(':');
else if ((cl_env.print_package != OBJNULL && x->symbol.hpack != cl_env.print_package)
|| find_symbol(x, current_package(), &intern_flag)!=x
|| ecl_find_symbol(x, current_package(), &intern_flag)!=x
|| intern_flag == 0) {
escaped = 0;
for (i = 0;
@ -582,7 +567,7 @@ write_symbol(register cl_object x)
}
if (escaped)
write_ch('|');
if (find_symbol(x, x->symbol.hpack, &intern_flag) != x)
if (ecl_find_symbol(x, x->symbol.hpack, &intern_flag) != x)
error("can't print symbol");
if ((cl_env.print_package != OBJNULL &&
x->symbol.hpack != cl_env.print_package)
@ -1435,7 +1420,7 @@ potential_number_p(cl_object strng, int base)
cl_setup_printer(strm);
cl_env.print_escape = TRUE;
cl_env.print_pretty = TRUE;
writec_PRINTstream('\n');
writec_stream('\n', cl_env.print_stream);
cl_write_object(obj);
flush_stream(cl_env.print_stream);
@(return)

29
src/c/read.d
View file

@ -160,11 +160,10 @@ SYMBOL:
p = cl_core.keyword_package;
else {
cl_env.token->string.fillp = colon;
p = find_package(cl_env.token);
if (Null(p)) {
p = ecl_find_package_nolock(cl_env.token);
if (Null(p))
FEerror("There is no package with the name ~A.",
1, copy_simple_string(cl_env.token));
}
1, copy_simple_string(cl_env.token));
}
cl_env.token->string.fillp = length - (colon + 1);
memmove(cl_env.token->string.self,
@ -172,15 +171,16 @@ SYMBOL:
sizeof(*cl_env.token->string.self) * cl_env.token->string.fillp);
if (colon > 0) {
cl_env.token->string.self[cl_env.token->string.fillp] = '\0';
x = find_symbol(cl_env.token, p, &intern_flag);
if (intern_flag != EXTERNAL)
FEerror("Cannot find the external symbol ~A in ~S.",
2, copy_simple_string(cl_env.token), p);
x = ecl_find_symbol(cl_env.token, p, &intern_flag);
if (intern_flag != EXTERNAL) {
FEerror("Cannot find the external symbol ~A in ~S.",
2, copy_simple_string(cl_env.token), p);
}
return(x);
}
} else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) {
cl_env.token->string.fillp = colon;
p = find_package(cl_env.token);
p = ecl_find_package_nolock(cl_env.token);
if (Null(p)) {
/* When loading binary files, we sometimes must create
symbols whose package has not yet been maked. We
@ -207,10 +207,9 @@ SYMBOL:
} else
p = current_package();
cl_env.token->string.self[cl_env.token->string.fillp] = '\0';
x = find_symbol(cl_env.token, p, &intern_flag);
if (intern_flag == 0)
x = intern(copy_simple_string(cl_env.token), p, &intern_flag);
return(x);
/* INV: make_symbol() copies the string */
x = intern(cl_env.token, p, &intern_flag);
return x;
}
/*
@ -866,7 +865,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d)
M:
if (read_suppress)
@(return Cnil)
@(return make_symbol(copy_simple_string(cl_env.token)))
@(return make_symbol(cl_env.token))
}
static cl_object
@ -1777,7 +1776,7 @@ init_read(void)
readtable=copy_readtable(cl_core.standard_readtable, Cnil));
readtable->readtable.table['#'].dispatch_table['!']
= cl_core.default_dispatch_macro; /* We must forget #! macro. */
ECL_SET(@'*read_default_float_format*', @'single-float');
ECL_SET(@'*read-default-float-format*', @'single-float');
}
/*

2
src/c/symbol.d
View file

@ -34,7 +34,7 @@ make_symbol(cl_object st)
x = cl_alloc_object(t_symbol);
/* FIXME! Should we copy? */
x->symbol.name = st;
x->symbol.name = copy_simple_string(st);
x->symbol.dynamic = 0;
ECL_SET(x,OBJNULL);
SYM_FUN(x) = OBJNULL;

17
src/c/symbols_list.h
View file

@ -72,7 +72,7 @@ cl_symbols[] = {
{"*RANDOM-STATE*", CL_SPECIAL, NULL, -1, OBJNULL},
{"*READ-BASE*", CL_SPECIAL, NULL, -1, MAKE_FIXNUM(10)},
{"*READ-DEFAULT-FLOAT-FORMAT*", CL_SPECIAL, NULL, -1, OBJNULL},
{"*READ-EVAL*", CL_SPECIAL, NULL, -1, OBJNULL},
{"*READ-EVAL*", CL_SPECIAL, NULL, -1, Ct},
{"*READ-SUPPRESS*", CL_SPECIAL, NULL, -1, Cnil},
{"*READTABLE*", CL_SPECIAL, NULL, -1, OBJNULL},
{"*STANDARD-INPUT*", CL_SPECIAL, NULL, -1, OBJNULL},
@ -1349,8 +1349,8 @@ cl_symbols[] = {
#endif
#ifdef ECL_THREADS
{MP_ "PROCESS", CL_ORDINARY, NULL, -1, OBJNULL},
{MP_ "LOCK", CL_ORDINARY, NULL, -1, OBJNULL},
{MP_ "PROCESS", MP_ORDINARY, NULL, -1, OBJNULL},
{MP_ "LOCK", MP_ORDINARY, NULL, -1, OBJNULL},
{MP_ "*CURRENT-PROCESS*", CL_SPECIAL, NULL, -1, OBJNULL},
{MP_ "ALL-PROCESSES", MP_ORDINARY, mp_all_processes, 0, OBJNULL},
{MP_ "EXIT-PROCESS", MP_ORDINARY, mp_exit_process, 0, OBJNULL},
@ -1362,10 +1362,15 @@ cl_symbols[] = {
{MP_ "PROCESS-PRESET", MP_ORDINARY, mp_process_preset, -1, OBJNULL},
{MP_ "PROCESS-RUN-FUNCTION", MP_ORDINARY, mp_process_run_function, -1, OBJNULL},
{MP_ "PROCESS-WHOSTATE", MP_ORDINARY, mp_process_whostate, 1, OBJNULL},
{MP_ "MAKE-LOCK", CL_ORDINARY, mp_make_lock, -1, OBJNULL},
{MP_ "GET-LOCK", CL_ORDINARY, mp_get_lock, -1, OBJNULL},
{MP_ "GIVEUP-LOCK", CL_ORDINARY, mp_giveup_lock, 1, OBJNULL},
{MP_ "MAKE-LOCK", MP_ORDINARY, mp_make_lock, -1, OBJNULL},
{MP_ "GET-LOCK", MP_ORDINARY, mp_get_lock, -1, OBJNULL},
{MP_ "GIVEUP-LOCK", MP_ORDINARY, mp_giveup_lock, 1, OBJNULL},
{KEY_ "INITIAL-BINDINGS", KEYWORD, NULL, -1, OBJNULL},
{MP_ "INTERRUPT-PROCESS", MP_ORDINARY, mp_interrupt_process, 2, OBJNULL},
{MP_ "+LOAD-COMPILE-LOCK+", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "WITH-LOCK", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "WITHOUT-INTERRUPTS", MP_CONSTANT, NULL, -1, OBJNULL},
{KEY_ "LOCKABLE", KEYWORD, NULL, -1, OBJNULL},
#endif
/* Tag for end of list */

117
src/c/threads.d
View file

@ -13,9 +13,9 @@
*/
#include <pthread.h>
#include <signal.h>
#include "ecl.h"
pthread_mutex_t ecl_threads_mutex = PTHREAD_MUTEX_INITIALIZER;
#include "internal.h"
static pthread_key_t cl_env_key;
@ -49,21 +49,20 @@ assert_type_process(cl_object o)
static void
thread_cleanup(void *env)
{
cl_object *p, l, process = cl_env.own_process;
pthread_mutex_lock(&ecl_threads_mutex);
p = &cl_core.processes;
for (l = *p; l != Cnil; ) {
if (CAR(l) == process) {
*p = CDR(l);
break;
}
p = &CDR(l);
l = *p;
}
cl_dealloc(process->process.thread, sizeof(pthread_t));
process->process.thread = NULL;
pthread_mutex_unlock(&ecl_threads_mutex);
/* This routine performs some cleanup before a thread is completely
* killed. For instance, it has to remove the associated process
* object from the list, an it has to dealloc some memory.
*
* NOTE: thread_cleanup() does not provide enough "protection". In
* order to ensure that all UNWIND-PROTECT forms are properly
* executed, never use pthread_cancel() to kill a process, but
* rather use the lisp functions mp_interrupt_process() and
* mp_process_kill().
*/
THREAD_OP_LOCK();
cl_core.processes = ecl_remove_eq(cl_env.own_process,
cl_core.processes);
THREAD_OP_UNLOCK();
}
static void *
@ -74,14 +73,21 @@ thread_entry_point(cl_object process)
pthread_setspecific(cl_env_key, process->process.env);
ecl_init_env(process->process.env);
/* 2) Execute the code */
/* 2) Execute the code. The CATCH_ALL point is the destination
* provides us with an elegant way to exit the thread: we just
* do an unwind up to frs_top.
*/
process->process.active = 1;
CL_CATCH_ALL_BEGIN {
bds_bind(@'mp::*current-process*', process);
cl_apply(2, process->process.function, process->process.args);
bds_unwind1();
} CL_CATCH_ALL_END;
process->process.active = 0;
/* 3) Remove the thread. thread_cleanup is automatically invoked. */
/* 3) If everything went right, we should be exiting the thread
* through this point. thread_cleanup is automatically invoked.
*/
pthread_cleanup_pop(1);
return NULL;
}
@ -92,17 +98,19 @@ thread_entry_point(cl_object process)
cl_object hash;
process = cl_alloc_object(t_process);
process->process.active = 0;
process->process.name = name;
process->process.function = Cnil;
process->process.args = Cnil;
process->process.thread = NULL;
process->process.interrupt = Cnil;
process->process.env = cl_alloc(sizeof(*process->process.env));
/* FIXME! Here we should either use INITIAL-BINDINGS or copy lexical
* bindings */
if (initial_bindings != OBJNULL) {
hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024),
make_shortfloat(1.5),
make_shortfloat(0.7));
make_shortfloat(0.7),
Cnil); /* no need for locking */
} else {
hash = si_copy_hash_table(cl_env.bindings_hash);
}
@ -124,16 +132,20 @@ mp_process_preset(int narg, cl_object process, cl_object function, ...)
@(return process)
}
cl_object
mp_interrupt_process(cl_object process, cl_object function)
{
if (mp_process_active_p(process) == Cnil)
FEerror("Cannot interrupt the inactive process ~A", 1, process);
process->process.interrupt = function;
pthread_kill(process->process.thread, SIGUSR1);
@(return Ct)
}
cl_object
mp_process_kill(cl_object process)
{
cl_object output = Cnil;
assert_type_process(process);
if (process->process.thread) {
if (pthread_cancel(*((pthread_t*)process->process.thread)) == 0)
output = Ct;
}
@(return output)
mp_interrupt_process(process, @'mp::exit-process');
}
cl_object
@ -142,18 +154,15 @@ mp_process_enable(cl_object process)
pthread_t *posix_thread;
int code;
assert_type_process(process);
if (process->process.thread != NULL)
if (mp_process_active_p(process) != Cnil)
FEerror("Cannot enable the running process ~A.", 1, process);
posix_thread = cl_alloc_atomic(sizeof(*posix_thread));
process->process.thread = posix_thread;
pthread_mutex_lock(&ecl_threads_mutex);
code = pthread_create(posix_thread, NULL, thread_entry_point, process);
THREAD_OP_LOCK();
code = pthread_create(&process->process.thread, NULL, thread_entry_point, process);
if (!code) {
/* If everything went ok, add the thread to the list. */
cl_core.processes = CONS(process, cl_core.processes);
}
pthread_mutex_unlock(&ecl_threads_mutex);
THREAD_OP_UNLOCK();
@(return (code? Cnil : process))
}
@ -165,14 +174,11 @@ mp_exit_process(void)
program. */
cl_quit(0);
} else {
cl_object tag = cl_env.bindings_hash;
/* We simply throw with a catch value that nobody can have. This
brings up back to the thread entry point, going through all
possible UNWIND-PROTECT.
/* We simply undo the whole of the frame stack. This brings up
back to the thread entry point, going through all possible
UNWIND-PROTECT.
*/
NVALUES=0;
VALUES(0)=Cnil;
cl_throw(tag);
unwind(cl_env.frs_org);
}
}
@ -193,7 +199,7 @@ cl_object
mp_process_active_p(cl_object process)
{
assert_type_process(process);
@(return ((process->process.thread == NULL)? Cnil : Ct))
@(return (process->process.active? Ct : Cnil))
}
cl_object
@ -226,11 +232,14 @@ mp_process_run_function(int narg, cl_object name, cl_object function, ...)
*/
@(defun mp::make-lock (&key name)
pthread_mutexattr_t attr;
@
pthread_mutexattr_init(&attr);
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE_NP);
cl_object output = cl_alloc_object(t_lock);
output->lock.name = name;
output->lock.mutex = cl_alloc(sizeof(pthread_mutex_t));
pthread_mutex_init(output->lock.mutex, NULL);
pthread_mutex_init(&output->lock.mutex, &attr);
pthread_mutexattr_destroy(&attr);
@(return output)
@)
@ -239,7 +248,7 @@ mp_giveup_lock(cl_object lock)
{
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
pthread_mutex_unlock(lock->lock.mutex);
pthread_mutex_unlock(&lock->lock.mutex);
@(return Ct)
}
@ -249,9 +258,9 @@ mp_giveup_lock(cl_object lock)
if (type_of(lock) != t_lock)
FEwrong_type_argument(@'mp::lock', lock);
if (wait == Ct) {
pthread_mutex_lock(lock->lock.mutex);
pthread_mutex_lock(&lock->lock.mutex);
output = Ct;
} else if (pthread_mutex_trylock(lock->lock.mutex) == 0) {
} else if (pthread_mutex_trylock(&lock->lock.mutex) == 0) {
output = Ct;
} else {
output = Cnil;
@ -264,24 +273,26 @@ init_threads()
{
cl_object process;
struct cl_env_struct *env;
pthread_mutexattr_t attr;
cl_core.processes = OBJNULL;
pthread_mutex_init(&ecl_threads_mutex, NULL);
pthread_mutexattr_init(&attr);
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP);
pthread_mutex_init(&cl_core.global_lock, &attr);
pthread_mutexattr_destroy(&attr);
process = cl_alloc_object(t_process);
process->process.active = 1;
process->process.name = @'si::top-level';
process->process.function = Cnil;
process->process.args = Cnil;
process->process.thread = NULL;
process->process.thread = cl_alloc(sizeof(pthread_t));
*((pthread_t *)process->process.thread) = pthread_self();
process->process.thread = pthread_self();
process->process.env = env = cl_alloc(sizeof(*env));
pthread_key_create(&cl_env_key, NULL);
pthread_setspecific(cl_env_key, env);
env->own_process = process;
ECL_SET(@'mp::*current-process*', process);
cl_core.processes = CONS(process, Cnil);
main_thread = pthread_self();

166
src/c/unixint.d
View file

@ -14,134 +14,86 @@
See file '../Copyright' for full details.
*/
#include "ecl.h"
#include <signal.h>
#include <unistd.h>
/******************************* EXPORTS ******************************/
int interrupt_enable; /* console interupt enable */
int interrupt_flag; /* console interupt flag */
#ifdef ECL_THREADS
#include <pthread.h>
#endif
/******************************* ------- ******************************/
typedef void (*signalfn)(int);
#ifndef THREADS
#ifdef SIGALRM
static void
sigalrm(void)
void
handle_signal(int sig)
{
if (interrupt_flag) {
interrupt_flag = FALSE;
terminal_interrupt(TRUE);
switch (sig) {
#ifdef ECL_THREADS
case SIGUSR1:
funcall(1, cl_env.own_process->process.interrupt);
break;
#endif
case SIGINT:
funcall(2, @'si::terminal-interrupt', Ct);
break;
case SIGFPE:
FEerror("Floating-point exception.", 0);
break;
case SIGSEGV:
FEerror("Segmentation violation.", 0);
break;
default:
FEerror("Serious signal ~D caught.", 0, MAKE_FIXNUM(sig));
}
}
#endif
void
sigint(void)
{
if (!interrupt_enable || interrupt_flag) {
if (!interrupt_enable) {
fprintf(stdout, "\n;;;Interrupt delayed.\n"); fflush(stdout);
interrupt_flag = TRUE;
}
signal(SIGINT, (signalfn)sigint);
return;
}
if (symbol_value(@'si::*interrupt-enable*') == Cnil) {
ECL_SETQ(@'si::*interrupt-enable*', Ct);
signal(SIGINT, (signalfn)sigint);
return;
}
#ifdef SIGALRM
#ifdef __GO32__
if (interrupt_flag)
sigalrm();
#endif
interrupt_flag = TRUE;
signal(SIGALRM, (signalfn)sigalrm);
alarm(1);
#endif
signal(SIGINT, (signalfn)sigint);
}
#else /* THREADS */
extern int critical_level;
bool scheduler_interrupted = FALSE;
int scheduler_interruption = 0;
void
sigint()
{
#ifdef SYSV
signal(SIGINT, sigint);
#endif
if (critical_level > 0) {
scheduler_interrupted = TRUE;
scheduler_interruption = ERROR_INT;
return;
}
if (symbol_value(@'si::*interrupt-enable*') == Cnil) {
ECL_SETQ(@'si::*interrupt-enable*', Ct);
return;
}
terminal_interrupt(TRUE);
}
#endif /*THREADS */
static void
sigfpe(void)
signal_catcher(int sig)
{
signal(SIGFPE, (signalfn)sigfpe);
FEerror("Floating-point exception.", 0);
if (symbol_value(@'si::*interrupt-enable*') == Cnil) {
signal(sig, signal_catcher);
cl_env.interrupt_pending = sig;
return;
}
signal(sig, signal_catcher);
CL_UNWIND_PROTECT_BEGIN {
handle_signal(sig);
} CL_UNWIND_PROTECT_EXIT {
sigset_t block_mask;
sigemptyset(&block_mask);
sigaddset(&block_mask, sig);
#ifdef ECL_THREADS
pthread_sigmask(SIG_UNBLOCK, &block_mask, NULL);
#else
sigprocmask(SIG_UNBLOCK, &block_mask, NULL);
#endif
} CL_UNWIND_PROTECT_END;
}
void
signal_catcher(int sig, int code, int scp)
cl_object
si_check_pending_interrupts(void)
{
char str[64];
if (!interrupt_enable) {
sprintf(str, "signal %d caught (during GC)", sig);
error(str);
}
else if (sig == SIGSEGV)
FEerror("Segmentation violation.~%\
Wrong type argument to a compiled function.", 0);
else {
printf("System error. Trying to recover ...\n");
fflush(stdout);
FEerror("Signal ~D caught.~%\
The internal memory may be broken.~%\
You should check the signal and exit from Lisp.", 1,
MAKE_FIXNUM(sig));
}
int what = cl_env.interrupt_pending;
cl_env.interrupt_pending = 0;
handle_signal(what);
@(return)
}
cl_object
si_catch_bad_signals()
{
signal(SIGILL, (signalfn)signal_catcher);
signal(SIGILL, signal_catcher);
#ifndef GBC_BOEHM
signal(SIGBUS, (signalfn)signal_catcher);
signal(SIGBUS, signal_catcher);
#endif
signal(SIGSEGV, (signalfn)signal_catcher);
signal(SIGSEGV, signal_catcher);
#ifdef SIGIOT
signal(SIGIOT, (signalfn)signal_catcher);
signal(SIGIOT, signal_catcher);
#endif
#ifdef SIGEMT
signal(SIGEMT, (signalfn)signal_catcher);
signal(SIGEMT, signal_catcher);
#endif
#ifdef SIGSYS
signal(SIGSYS, (signalfn)signal_catcher);
signal(SIGSYS, signal_catcher);
#endif
@(return Ct)
}
@ -167,12 +119,12 @@ si_uncatch_bad_signals()
}
void
enable_interrupt(void)
init_unixint(void)
{
interrupt_enable = TRUE;
signal(SIGFPE, (signalfn)sigfpe);
signal(SIGINT, (signalfn)sigint);
#ifdef __EMX__
signal(SIGBREAK, (signalfn)sigint);
signal(SIGFPE, signal_catcher);
signal(SIGINT, signal_catcher);
#ifdef ECL_THREADS
signal(SIGUSR1, signal_catcher);
#endif
ECL_SET(@'si::*interrupt-enable*', Ct);
}

2
src/cmp/cmpdefs.lsp
View file

@ -10,6 +10,8 @@
;;;; CMPDEF Definitions
(si::package-lock "CL" nil)
(defpackage "C"
(:nicknames "COMPILER")
(:use "FFI" "CL")

128
src/cmp/cmpmain.lsp
View file

@ -350,37 +350,39 @@ Cannot compile ~a."
(shared-data-pathname (get-output-pathname o-pathname shared-data-file
:sdata)))
(init-env)
(mp:with-lock (mp:+load-compile-lock+)
(init-env)
(when (probe-file "./cmpinit.lsp")
(load "./cmpinit.lsp" :verbose *compile-verbose*))
(when (probe-file "./cmpinit.lsp")
(load "./cmpinit.lsp" :verbose *compile-verbose*))
(if shared-data-file
(if system-p
(data-init shared-data-pathname)
(error "Shared data files are only allowed when compiling ~&
(if shared-data-file
(if system-p
(data-init shared-data-pathname)
(error "Shared data files are only allowed when compiling ~&
with the flag :SYSTEM-P set to T."))
(data-init))
(data-init))
(with-open-file (*compiler-input* *compile-file-pathname*)
(do ((form (read *compiler-input* nil eof)
(read *compiler-input* nil eof)))
((eq form eof))
(t1expr form)))
(with-open-file (*compiler-input* *compile-file-pathname*)
(do ((form (read *compiler-input* nil eof)
(read *compiler-input* nil eof)))
((eq form eof))
(t1expr form)))
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname data-pathname system-p
(if system-p
(pathname-name input-pathname)
"code")
shared-data-file))
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname data-pathname system-p
(if system-p
(pathname-name input-pathname)
"code")
shared-data-file))
(if shared-data-file
(data-dump shared-data-pathname t)
(data-dump data-pathname))
(if shared-data-file
(data-dump shared-data-pathname t)
(data-dump data-pathname))
(init-env)
(init-env)
)
(if (zerop *error-count*)
(progn
@ -430,7 +432,8 @@ Cannot compile ~a."
(setq *error-p* t)
(values nil t t))
))
)
) ; mp:with-lock
)
#-dlopen
(defun compile (name &optional (def nil supplied-p))
@ -491,19 +494,16 @@ Cannot compile ~a."
(o-pathname (compile-file-pathname data-pathname :type :object))
(so-pathname (compile-file-pathname data-pathname)))
(init-env)
(data-init)
(t1expr form)
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname data-pathname nil "code" nil))
(data-dump data-pathname)
(init-env)
(mp:with-lock (mp:+load-compile-lock+)
(init-env)
(data-init)
(t1expr form)
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname data-pathname nil "code" nil))
(data-dump data-pathname)
(init-env)
)
(if (zerop *error-count*)
(progn
@ -571,30 +571,32 @@ Cannot compile ~a."
(*error-count* 0)
(t3local-fun (symbol-function 'T3LOCAL-FUN))
(t3fun (get-sysprop 'DEFUN 'T3)))
(unwind-protect
(progn
(put-sysprop 'DEFUN 'T3
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3fun args))))
(setf (symbol-function 'T3LOCAL-FUN)
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3local-fun args))))
(init-env)
(data-init)
(t1expr disassembled-form)
(if (zerop *error-count*)
(catch *cmperr-tag* (ctop-write "code"
(if h-file (namestring h-file) "")
(if data-file (namestring data-file) "")
:system-p nil))
(setq *error-p* t))
(data-dump data-file)
)
(put-sysprop 'DEFUN 'T3 t3fun)
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
(when h-file (close *compiler-output2*))))
(mp:with-lock (mp:+load-compile-lock+)
(unwind-protect
(progn
(put-sysprop 'DEFUN 'T3
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3fun args))))
(setf (symbol-function 'T3LOCAL-FUN)
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3local-fun args))))
(init-env)
(data-init)
(t1expr disassembled-form)
(if (zerop *error-count*)
(catch *cmperr-tag* (ctop-write "code"
(if h-file (namestring h-file) "")
(if data-file (namestring data-file) "")
:system-p nil))
(setq *error-p* t))
(data-dump data-file)
(init-env)
)
(put-sysprop 'DEFUN 'T3 t3fun)
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
(when h-file (close *compiler-output2*)))))
(values)
)
@ -652,5 +654,7 @@ Cannot compile ~a."
(defmacro with-compilation-unit (options &rest body)
`(progn ,@body))
(si::package-lock "CL" nil)
;;; ----------------------------------------------------------------------
(provide "compiler")

6
src/h/ecl-cmp.h
View file

@ -25,8 +25,10 @@
#include "gmp.h"
#include "object.h"
#include "stacks.h"
#ifdef THREADS
# include "lwp.h"
#ifdef ECL_THREADS
# include <pthread.h>
# define start_critical_section()
# define end_critical_section()
#else
# define start_critical_section()
# define end_critical_section()

6
src/h/ecl.h
View file

@ -26,8 +26,10 @@
#include "gmp.h"
#include "object.h"
#include "stacks.h"
#ifdef THREADS
# include "lwp.h"
#ifdef ECL_THREADS
# include <pthread.h>
# define start_critical_section()
# define end_critical_section()
#else
# define start_critical_section()
# define end_critical_section()

18
src/h/external.h
View file

@ -112,6 +112,7 @@ struct cl_env_struct {
#ifdef ECL_THREADS
cl_object own_process;
#endif
int interrupt_pending;
};
#ifdef ECL_THREADS
@ -176,6 +177,7 @@ struct cl_core_struct {
#ifdef ECL_THREADS
cl_object processes;
pthread_mutex_t global_lock;
#endif
};
@ -434,7 +436,6 @@ extern cl_object cl_cerror _ARGS((int narg, cl_object cformat, cl_object eformat
extern void internal_error(const char *s) __attribute__((noreturn));
extern void cs_overflow(void) __attribute__((noreturn));
extern void error(const char *s) __attribute__((noreturn));
extern void terminal_interrupt(bool correctable);
extern void FEprogram_error(const char *s, int narg, ...) __attribute__((noreturn));
extern void FEcontrol_error(const char *s, int narg, ...) __attribute__((noreturn));
extern void FEreader_error(const char *s, cl_object stream, int narg, ...) __attribute__((noreturn));
@ -582,7 +583,7 @@ extern cl_object compute_method(int narg, cl_object fun, cl_object *args);
/* hash.c */
extern cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold);
extern cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold, cl_object lockable);
extern cl_object cl_hash_table_p(cl_object ht);
extern cl_object si_hash_set(cl_object key, cl_object ht, cl_object val);
extern cl_object cl_remhash(cl_object key, cl_object ht);
@ -603,7 +604,6 @@ extern cl_hashkey hash_eq(cl_object x);
extern cl_hashkey hash_eql(cl_object x);
extern cl_hashkey hash_equal(cl_object x);
extern void sethash(cl_object key, cl_object hashtable, cl_object value);
extern void extend_hashtable(cl_object hashtable);
extern cl_object gethash(cl_object key, cl_object hash);
extern cl_object gethash_safe(cl_object key, cl_object hash, cl_object def);
extern bool remhash(cl_object key, cl_object hash);
@ -727,6 +727,8 @@ extern cl_object assq(cl_object x, cl_object l);
extern cl_object assql(cl_object x, cl_object l);
extern cl_object assoc(cl_object x, cl_object l);
extern cl_object assqlp(cl_object x, cl_object l);
extern cl_object ecl_remove_eq(cl_object x, cl_object l);
extern void ecl_delete_eq(cl_object x, cl_object *l);
/* load.c */
@ -956,12 +958,12 @@ extern cl_object cl_unuse_package _ARGS((int narg, cl_object pack, ...));
extern cl_object make_package(cl_object n, cl_object ns, cl_object ul);
extern cl_object rename_package(cl_object x, cl_object n, cl_object ns);
extern cl_object find_package(cl_object n);
extern cl_object ecl_find_package_nolock(cl_object n);
extern cl_object si_coerce_to_package(cl_object p);
extern cl_object current_package(void);
extern cl_object ecl_find_symbol(cl_object n, cl_object p, int *intern_flag);
extern cl_object intern(cl_object name, cl_object p, int *intern_flag);
extern cl_object _intern(const char *s, cl_object p);
extern cl_object find_symbol(cl_object name, cl_object p, int *intern_flag);
extern bool unintern(cl_object s, cl_object p);
extern void cl_export2(cl_object s, cl_object p);
extern void cl_unexport2(cl_object s, cl_object p);
@ -1325,6 +1327,7 @@ extern cl_object make_stream(cl_object host, int fd, enum ecl_smmode smm);
extern cl_object mp_own_process(void) __attribute__((const));
extern cl_object mp_all_processes(void);
extern cl_object mp_exit_process(void) __attribute__((noreturn));
extern cl_object mp_interrupt_process(cl_object process, cl_object function);
extern cl_object mp_make_process _ARGS((int narg, ...));
extern cl_object mp_process_active_p(cl_object process);
extern cl_object mp_process_enable(cl_object process);
@ -1420,10 +1423,7 @@ extern cl_object homedir_pathname(cl_object user);
extern cl_object si_catch_bad_signals();
extern cl_object si_uncatch_bad_signals();
extern int interrupt_enable;
extern int interrupt_flag;
extern void signal_catcher(int sig, int code, int scp);
extern void enable_interrupt(void);
extern cl_object si_check_pending_interrupts();
/* unixsys.c */

44
src/h/internal.h
View file

@ -28,8 +28,6 @@ extern void init_big(void);
#ifdef CLOS
extern void init_clos(void);
#endif
extern void init_cmpaux(void);
extern void init_compiler(void);
extern void init_error(void);
extern void init_eval(void);
extern void init_file(void);
@ -40,6 +38,7 @@ extern void init_macros(void);
extern void init_number(void);
extern void init_read(void);
extern void init_stacks(int *);
extern void init_unixint(void);
extern void init_unixtime(void);
@ -79,6 +78,9 @@ extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size);
#define OPEN_A "ab"
#define OPEN_RA "a+b"
/* hash.d */
extern void ecl_extend_hashtable(cl_object hashtable);
/* num_log.d */
#define BOOLCLR 0
@ -113,6 +115,10 @@ cl_object ecl_library_error(cl_object block);
void ecl_library_close(cl_object block);
#endif
/* package.d */
extern cl_object ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag);
/* print.d */
#define ECL_PPRINT_QUEUE_SIZE 128
@ -122,7 +128,39 @@ extern void edit_double(int n, double d, int *sp, char *s, int *ep);
extern void cl_setup_printer(cl_object strm);
extern void cl_write_object(cl_object x);
/* read.d */
/* global locks */
#ifdef ECL_THREADS
#if 0
#define HASH_TABLE_LOCK(h) if ((h)->hash.lockable) pthread_mutex_lock(&(h)->hash.lock)
#define HASH_TABLE_UNLOCK(h) if ((h)->hash.lockable) pthread_mutex_unlock(&(h)->hash.lock)
#define PACKAGE_LOCK(p) pthread_mutex_lock(&(p)->pack.lock)
#define PACKAGE_UNLOCK(p) pthread_mutex_unlock(&(p)->pack.lock)
#define PACKAGE_OP_LOCK() pthread_mutex_lock(&cl_core.global_lock)
#define PACKAGE_OP_UNLOCK() pthread_mutex_unlock(&cl_core.global_lock)
#define THREAD_OP_LOCK() pthread_mutex_lock(&cl_core.global_lock)
#define THREAD_OP_UNLOCK() pthread_mutex_unlock(&cl_core.global_lock)
#else
#define HASH_TABLE_LOCK(h) if ((h)->hash.lockable) if (pthread_mutex_lock(&(h)->hash.lock)) internal_error("")
#define PACKAGE_LOCK(p) if (pthread_mutex_lock(&(p)->pack.lock)) internal_error("")
#define PACKAGE_OP_LOCK() if (pthread_mutex_lock(&cl_core.global_lock)) internal_error("")
#define THREAD_OP_LOCK() if (pthread_mutex_lock(&cl_core.global_lock)) internal_error("")
#define HASH_TABLE_UNLOCK(h) if ((h)->hash.lockable) if (pthread_mutex_unlock(&(h)->hash.lock)) internal_error("")
#define PACKAGE_UNLOCK(p) if (pthread_mutex_unlock(&(p)->pack.lock)) internal_error("")
#define PACKAGE_OP_UNLOCK() if (pthread_mutex_unlock(&cl_core.global_lock)) internal_error("")
#define THREAD_OP_UNLOCK() if (pthread_mutex_unlock(&cl_core.global_lock)) internal_error("")
#endif
#else
#define HASH_TABLE_LOCK(h)
#define HASH_TABLE_UNLOCK(h)
#define PACKAGE_LOCK(p)
#define PACKAGE_UNLOCK(p)
#define PACKAGE_OP_LOCK()
#define PACKAGE_OP_UNLOCK()
#endif
/* read.d */
#define RTABSIZE CHAR_CODE_LIMIT /* read table size */
#ifdef __cplusplus

14
src/h/object.h
View file

@ -144,6 +144,9 @@ struct ecl_package {
cl_object usedby; /* used-by-list of packages */
cl_object internal; /* hashtable for internal symbols */
cl_object external; /* hashtable for external symbols */
#ifdef ECL_THREADS
pthread_mutex_t lock; /* thread safe packages */
#endif
};
/*
@ -178,12 +181,15 @@ struct ecl_hashtable_entry { /* hash table entry */
};
struct ecl_hashtable { /* hash table header */
HEADER1(test);
HEADER2(test,lockable);
struct ecl_hashtable_entry *data; /* pointer to the hash table */
cl_object rehash_size; /* rehash size */
cl_object threshold; /* rehash threshold */
cl_index entries; /* number of entries */
cl_index size; /* hash table size */
#ifdef ECL_THREADS
pthread_mutex_t lock; /* mutex to prevent race conditions */
#endif
};
typedef enum { /* array element type */
@ -401,11 +407,11 @@ struct ecl_dummy {
#ifdef ECL_THREADS
struct ecl_process {
HEADER;
HEADER1(active);
cl_object name;
cl_object function;
cl_object args;
void *thread;
pthread_t thread;
struct cl_env_struct *env;
cl_object interrupt;
};
@ -413,7 +419,7 @@ struct ecl_process {
struct ecl_lock {
HEADER;
cl_object name;
void *mutex;
pthread_mutex_t mutex;
};
#endif

6
src/lsp/load.lsp.in
View file

@ -35,12 +35,12 @@
"@abs_srcdir@/ffi.lsp"
#+ffi
"@abs_srcdir@/ffi-objects.lsp"
; #+threads
; "@abs_srcdir@/thread.lsp"
#+tk
"@abs_srcdir@/tk-init.lsp"
"@abs_builddir@/config.lsp"
"@abs_srcdir@/top.lsp"))
"@abs_srcdir@/top.lsp"
"@abs_srcdir@/mp.lsp"
))
(mapc #'(lambda (x) (load x :verbose nil)) (cddddr +lisp-module-files+))