mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-22 17:50:39 -07:00
Code Issues Projects Releases Packages Wiki Activity

Fixed conflict

Browse source
This commit is contained in:
Juan Jose Garcia-Ripoll 2008-10-01 10:54:00 +02:00
commit 8a36069121
30 changed files with 557 additions and 202 deletions
Download patch file Download diff file Expand all files Collapse all files

85
msvc/Makefile
View file

@ -59,12 +59,7 @@ TAR_DIR = %CD%\ecl-$(ECL_VERSION)
#
CC = cl
MFLAGS = /MD
CFLAGS = /EHsc /DGC_DLL /nologo
LIBS = eclgc.lib eclgmp.lib user32.lib ws2_32.lib shell32.lib
LDFLAGS = /link /nologo /nodefaultlib:libcmt /nodefaultlib:libcmtd /nodefaultlib:libc /nodefaultlib:libd
SHARED_LDFLAGS = /LD
GCFLAGS = nodebug=1
RM = del
RMDIR = rmdir /Q /S
MKDIR = mkdir
@ -74,6 +69,48 @@ MV = move /Y
MSDEV = msdev
MKNSI = makensis.exe
# ==================== Flags ====================
#
# Configuration-specific (Debug/Release) options
#
!if "$(ECL_DEBUG)" != ""
CFLAGS_OPTIMIZE = /Od
CFLAGS_CONFIG = /Zi /D_DEBUG /MDd $(CFLAGS_OPTIMIZE)
LDFLAGS_CONFIG = /debug /nodefaultlib:msvcrt.lib
SHARED_LDFLAGS = /LDd
GCFLAGS =
!else
CFLAGS_OPTIMIZE = /O2
CFLAGS_CONFIG = /DNDEBUG /MD $(CFLAGS_OPTIMIZE)
LDFLAGS_CONFIG = /nodefaultlib:msvcrtd.lib
SHARED_LDFLAGS = /LD
GCFLAGS = nodebug=1
!endif
CFLAGS = /EHsc /DGC_DLL /nologo /D_CRT_SECURE_NO_DEPRECATE $(CFLAGS_CONFIG)
LDFLAGS = /link /nologo /verbose:lib /nodefaultlib:libcmt /nodefaultlib:libcmtd /nodefaultlib:libc /nodefaultlib:libcd $(LDFLAGS_CONFIG)
# Additional configuration for thread support
#
!if "$(ECL_THREADS)" == ""
ENV_EXPORT = cl_env,DATA
!else
ENV_EXPORT = ecl_process_env
CFLAGS = $(CFLAGS) /DECL_THREADS
DEF = ecl-threads.def
!endif
# Additional configuration for Unicode support
#
!if "$(ECL_UNICODE)" != ""
CFLAGS = $(CFLAGS) /DECL_UNICODE
!endif
!MESSAGE C++ compiler flags: $(CFLAGS)
!MESSAGE C++ linker flags: $(LDFLAGS)
# ==================== Where To Install Things ====================
# The default location for installation. Everything is placed in
@ -103,32 +140,6 @@ LIBRARIES =
TARGETS = ecl2$(EXE)
DEF = ecl.def
# Enable debug information
#
!if "$(ECL_DEBUG)" != ""
CFLAGS = /Z7 $(CFLAGS)
LDFLAGS = /Z7 $(LDFLAGS)
SHARED_LDFLAGS = /LDd
#MFLAGS = -MDd
GCFLAGS =
!endif
# Additional configuration for thread support
#
!if "$(ECL_THREADS)" == ""
ENV_EXPORT = cl_env,DATA
!else
ENV_EXPORT = ecl_process_env
CFLAGS = $(CFLAGS) -DECL_THREADS
DEF = ecl-threads.def
!endif
# Additional configuration for Unicode support
#
!if "$(ECL_UNICODE)" != ""
CFLAGS = $(CFLAGS) -DECL_UNICODE
!endif
# Additional modules
#
ECL_MODULES =
@ -162,11 +173,8 @@ ECL_MODULES = $(ECL_MODULES) profile
ECL_FEATURES = (cons :wants-profile $(ECL_FEATURES))
!endif
!MESSAGE $(ECL_MODULES)
!MESSAGE $(ECL_FEATURES)
CFLAGS = $(MFLAGS) $(CFLAGS)
LDFLAGS = $(MFLAGS) $(LDFLAGS)
!MESSAGE ECL Modules: $(ECL_MODULES)
!MESSAGE ECL Features: $(ECL_FEATURES)
# Build rules
#
@ -248,6 +256,7 @@ cmp/load.lsp: $(srcdir)/cmp/load.lsp.in
cmp/cmpdefs.lsp: $(srcdir)/cmp/cmpdefs.lsp Makefile
c\cut "@ECL_CC@" "$(CC)" \
"@CFLAGS@" "$(CFLAGS)" \
"@CFLAGS_OPTIMIZE@" "$(CFLAGS_OPTIMIZE)" \
"@ECL_CFLAGS@" "" \
"@CPPFLAGS@" "" \
"@LDRPATH@" "" \
@ -290,7 +299,7 @@ eclmin.lib: eclgmp.lib eclgc.lib lsp/config.lsp
cd ..
eclgc.lib:
cd gc
$(MAKE) $(GCFLAGS) ECL_THREADS=$(ECL_THREADS) "MFLAGS=$(MFLAGS)" gc.lib
$(MAKE) $(GCFLAGS) ECL_THREADS=$(ECL_THREADS) "CFLAGS_CONFIG=$(CFLAGS_CONFIG)" gc.lib
$(CP) gc.lib ..\eclgc.lib
cd ..
if not exist ecl\gc $(MKDIR) ecl\gc
@ -301,7 +310,7 @@ eclgc.lib:
do $(CP) $(srcdir)\gc\include\%h ecl\gc\%h
eclgmp.lib:
cd gmp
$(MAKE) "MPN_TYPE = $(GMP_TYPE)" "MFLAGS = $(MFLAGS)"
$(MAKE) "MPN_TYPE = $(GMP_TYPE)" "CFLAGS_CONFIG=$(CFLAGS_CONFIG)"
$(CP) gmp.lib ..\eclgmp.lib
$(CP) gmp.h ..\ecl\gmp.h
cd ..

6
msvc/gc/Makefile
View file

@ -17,17 +17,15 @@ THREADS_OBJ=
THREADS_FLAGS= -DGC_DLL -DGC_BUILD
!endif
MFLAGS = /MD
OBJS= alloc.obj reclaim.obj allchblk.obj misc.obj mach_dep.obj os_dep.obj mark_rts.obj headers.obj mark.obj obj_map.obj blacklst.obj finalize.obj new_hblk.obj dbg_mlc.obj malloc.obj stubborn.obj dyn_load.obj typd_mlc.obj ptr_chck.obj gc_cpp.obj mallocx.obj $(THREADS_OBJ)
all: gc.lib
{$(srcdir)}.c{}.obj:
$(cc) $(MFLAGS) $(cdebug) $(cflags) $(cvars) -I$(srcdir)\include -DSILENT -DALL_INTERIOR_POINTERS -D__STDC__ -DGC_DLL -DGC_BUILD -DLARGE_CONFIG $(THREADS_FLAGS) $< /Fo$*.obj
$(cc) $(cflags) $(CFLAGS_CONFIG) -I$(srcdir)\include -DSILENT -DALL_INTERIOR_POINTERS -D__STDC__ -DGC_DLL -DGC_BUILD -DLARGE_CONFIG $(THREADS_FLAGS) $< /Fo$*.obj
{$(srcdir)\tests}.c{tests}.obj:
$(cc) $(MFLAGS) $(cdebug) $(cflags) $(cvars) -I$(srcdir)\include -DSILENT -DALL_INTERIOR_POINTERS -D__STDC__ -DGC_DLL -DGC_BUILD -DLARGE_CONFIG $(THREADS_FLAGS) $< /Fo$*.obj
$(cc) $(cflags) $(CFLAGS_CONFIG) -I$(srcdir)\include -DSILENT -DALL_INTERIOR_POINTERS -D__STDC__ -DGC_DLL -DGC_BUILD -DLARGE_CONFIG $(THREADS_FLAGS) $< /Fo$*.obj
#.c.obj:
# $(cc) $(cdebug) $(cflags) $(cvars) -Iinclude -DSILENT -DALL_INTERIOR_POINTERS -D__STDC__ -DGC_NOT_DLL -DGC_BUILD $*.c /Fo$*.obj

5
msvc/gmp/Makefile
View file

@ -408,8 +408,7 @@ mpn_p4.lib: msvc-build $(MPN_P4_OBJS)
gmp.lib: mpn_$(MPN_TYPE).lib $(GMP_ALL_OBJS)
link -lib /NOLOGO /OUT:$@ *.obj mpf\*.obj mpz\*.obj mpq\*.obj $(PRINTF_OBJS) $(SCANF_OBJS) mpn_$(MPN_TYPE).lib
MFLAGS = /MD
CFLAGS = /nologo $(MFLAGS) /W3 /EHsc /I "." /I $(srcdir) /I "$(srcdir)\mpn\generic" /D "WIN32" /D "NDEBUG" /D "_LIB" /D "_WIN32" /D "_MBCS"
CFLAGS = $(CFLAGS_CONFIG) /nologo /W3 /EHsc /I "." /I $(srcdir) /I "$(srcdir)\mpn\generic" /D "WIN32" /D "_LIB" /D "_WIN32" /D "_MBCS"
{.\mpn\generic}.c{.\mpn\generic}.obj:
cl -c $(CFLAGS) /Fo$@ $?
@ -490,4 +489,4 @@ clean:
-erase config.h
-erase gmp.h
-erase msvc-build
-erase *.exe *.manifest
-erase *.exe *.manifest

37
src/CHANGELOG
View file

@ -42,6 +42,18 @@ ECL 8.9.0:
- New configuration flag, --without-fpe, to disable floating point exception
code in platforms that have buggy implementations of feenableexcept().
- Changes in the build process of the Microsoft Visual C++ port contributed
by Muhammad Haggag.
- All known C signals are now exported by ECL as constants in the EXT package,
such as EXT:+SIGINT+, EXT:+SIGFPE+, etc.
- Function (EXT:CATCH-SIGNAL signal-code boolean) can be used to tell ECL to
trap or ignore certain signals. In a near future a function can be provided.
- In platforms that support sigaltstack(), ECL may detect stack overflows and
gracefully quit.
* Bugs fixed:
- The optimizer for COERCE might enter an infinite loop for certain
@ -93,6 +105,31 @@ ECL 8.9.0:
- In FTYPE proclamations and declarations, the type may now be a user defined
function type (Josh Elsasser).
- COMPILE would create an extra empty file which would not get deleted after
finishing compilation (Josh Elsasser).
- On overflow, binding and frame stack signal a correctable error with
STACK-OVERFLOW condition.
(block faa
(labels ((foo (x)
(catch 'foo (foo (1+ x))))
(handle-overflow (c)
(let ((s (ext:stack-overflow-size c)))
(if (< s 2304)
(continue)
(return-from faa (ext::stack-overflow-type c))))))
(handler-bind ((ext:stack-overflow #'handle-overflow))
(foo 1))))
- New function (EXT:SET-STACK-SIZE type size) can resize type =
EXT:BINDING-STACK, EXT:LISP-STACK and EXT:FRAME-STACK.
- FLOAT-SIGN returns the right value on negative zeros.
- The reader and the printer now understand negative zeros.
- Negative and nonnegative zeros are not EQL.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***

9
src/Makefile.in
View file

@ -149,10 +149,11 @@ install-base:
fi \
done
if [ "x@SONAME@" != "x" ]; then \
mv $(DESTDIR)$(libdir)/@SONAME@ $(DESTDIR)$(libdir)/@SONAME3@; \
$(LN_S) $(DESTDIR)$(libdir)/@SONAME3@ $(DESTDIR)$(libdir)/@SONAME2@; \
$(LN_S) $(DESTDIR)$(libdir)/@SONAME3@ $(DESTDIR)$(libdir)/@SONAME1@; \
$(LN_S) $(DESTDIR)$(libdir)/@SONAME3@ $(DESTDIR)$(libdir)/@SONAME@; \
( cd $(DESTDIR)$(libdir) && rm -f @SONAME3@ @SONAME2@ @SONAME1@ && \
mv @SONAME@ @SONAME3@ && \
$(LN_S) @SONAME3@ @SONAME2@ && \
$(LN_S) @SONAME3@ @SONAME1@ && \
$(LN_S) @SONAME3@ @SONAME@ ) \
fi
for i in c/dpp$(EXE) ecl_min$(EXE) `cat MODULES`; do \
case $$i in \

6
src/c/alloc_2.d
View file

@ -205,9 +205,9 @@ init_alloc(void)
GC_all_interior_pointers = 0;
GC_time_limit = GC_TIME_UNLIMITED;
GC_init();
#ifdef GBC_BOEHM_GENGC
GC_enable_incremental();
#endif
if (ecl_get_option(ECL_INCREMENTAL_GC)) {
GC_enable_incremental();
}
GC_register_displacement(1);
#if 0
GC_init_explicit_typing();

4
src/c/compiler.d
View file

@ -1010,7 +1010,7 @@ c_catch(cl_object args, int flags) {
static int
c_compiler_let(cl_object args, int flags) {
cl_object bindings;
bds_ptr old_bds_top = cl_env.bds_top;
cl_index old_bds_top_index = cl_env.bds_top - cl_env.bds_org;
for (bindings = pop(&args); !ecl_endp(bindings); ) {
cl_object form = pop(&bindings);
@ -1019,7 +1019,7 @@ c_compiler_let(cl_object args, int flags) {
bds_bind(var, value);
}
flags = compile_body(args, flags);
bds_unwind(old_bds_top);
bds_unwind(old_bds_top_index);
return flags;
}

6
src/c/interpreter.d
View file

@ -504,7 +504,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
ECL_OFFSET_TABLE
typedef struct cl_env_struct *cl_env_ptr;
const cl_env_ptr the_env = &cl_env;
volatile bds_ptr old_bds_top = cl_env.bds_top;
volatile cl_index old_bds_top_index = cl_env.bds_top - cl_env.bds_org;
cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code + offset;
cl_object *data = bytecodes->bytecodes.data;
cl_object reg0, reg1, lex_env = env;
@ -788,7 +788,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
*/
CASE(OP_EXIT); {
ihs_pop();
bds_unwind(old_bds_top);
bds_unwind(old_bds_top_index);
return reg0;
}
/* OP_FLET nfun{arg}, fun1{object}
@ -1296,7 +1296,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
THREAD_NEXT;
}
CASE(OP_PROTECT_NORMAL); {
bds_unwind(the_env->frs_top->frs_bds_top);
bds_unwind(the_env->frs_top->frs_bds_top_index);
frs_pop(the_env);
STACK_POP(the_env);
lex_env = STACK_POP(the_env);

6
src/c/load.d
View file

@ -351,9 +351,9 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print)
/* A full garbage collection enables us to detect unused code
and leave space for the library to be loaded. This is only
required when we use the dlopen wrappers. */
#ifndef GBC_BOEHM_GENGC
si_gc(Ct);
#endif
if (!ecl_get_option(ECL_INCREMENTAL_GC)) {
si_gc(Ct);
}
/* We need the full pathname */
filename = cl_namestring(cl_truename(filename));

47
src/c/main.d
View file

@ -20,6 +20,7 @@
#include <ecl/ecl.h>
#include <limits.h>
#if defined(_MSC_VER) || defined(mingw32)
# include <windows.h>
# include <shellapi.h>
# define MAXPATHLEN 512
#endif
@ -49,14 +50,46 @@ const char *ecl_self;
/************************ GLOBAL INITIALIZATION ***********************/
static int ARGC;
static char **ARGV;
static int ARGC;
static char **ARGV;
static cl_index boot_options = ECL_TRAP_SIGSEGV
| ECL_TRAP_SIGFPE
| ECL_TRAP_SIGINT
| ECL_TRAP_SIGILL
#ifdef GBC_BOEHM_GENGC
| ECL_INCREMENTAL_GC
#endif
| ECL_TRAP_SIGBUS;
#if !defined(GBC_BOEHM)
static char stdin_buf[BUFSIZ];
static char stdout_buf[BUFSIZ];
#endif
int
ecl_get_option(int option)
{
if (option > ECL_INCREMENTAL_GC || option < 0) {
FEerror("Invalid boot option ~D", 0, MAKE_FIXNUM(option));
}
return (boot_options >> option) & 1;
}
void
ecl_set_option(int option, int value)
{
if (option > ECL_INCREMENTAL_GC || option < 0) {
FEerror("Invalid boot option ~D", 0, MAKE_FIXNUM(option));
} else {
cl_index mask = 1 << option;
if (value) {
boot_options |= mask;
} else {
boot_options &= ~mask;
}
}
}
void
ecl_init_env(struct cl_env_struct *env)
{
@ -103,8 +136,7 @@ ecl_init_env(struct cl_env_struct *env)
env->method_hash_clear_list = Cnil;
#endif
#endif
init_stacks(&i);
init_stacks(env, &i);
}
static const struct {
@ -197,6 +229,7 @@ cl_boot(int argc, char **argv)
ARGV = argv;
ecl_self = argv[0];
init_unixint(0);
init_alloc();
GC_disable();
#ifdef ECL_THREADS
@ -522,8 +555,7 @@ cl_boot(int argc, char **argv)
/* Jump to top level */
ECL_SET(@'*package*', cl_core.user_package);
init_unixint();
si_catch_bad_signals();
init_unixint(1);
return 1;
}
@ -613,9 +645,6 @@ si_pointer(cl_object x)
}
#if defined(_MSC_VER) || defined(mingw32)
#if !defined(ECL_THREADS)
#include <windows.h>
#endif
void
ecl_get_commandline_args(int* argc, char*** argv) {
LPWSTR *wArgs;

17
src/c/num_co.d
View file

@ -1030,22 +1030,29 @@ cl_float_radix(cl_object x)
@(return MAKE_FIXNUM(FLT_RADIX))
}
@(defun float_sign (x &optional (y x))
#ifndef signbit
# define signbit(x) ((x) < 0)
#endif
@(defun float_sign (x &optional (y x yp))
int negativep;
@
if (!yp) {
y = cl_float(2, MAKE_FIXNUM(1), x);
}
AGAIN:
switch (type_of(x)) {
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
negativep = ecl_short_float(x) < 0; break;
negativep = signbit(ecl_short_float(x)); break;
#endif
case t_singlefloat:
negativep = sf(x) < 0; break;
negativep = signbit(sf(x)); break;
case t_doublefloat:
negativep = df(x) < 0; break;
negativep = signbit(df(x)); break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
negativep = ecl_long_float(x) < 0; break;
negativep = signbit(ecl_long_float(x)); break;
#endif
default:
x = ecl_type_error(@'float-sign',"argument",x,@'float');

15
src/c/number.d
View file

@ -146,8 +146,11 @@ ecl_make_singlefloat(float f)
cl_object x;
ecl_detect_fpe();
if (f == (float)0.0)
#ifdef signbit
if ((f == (float)0.0) && !signbit(f)) {
return(cl_core.singlefloat_zero);
}
#endif
if (isnan(f)) {
cl_error(1, @'division-by-zero');
}
@ -165,8 +168,11 @@ ecl_make_doublefloat(double f)
cl_object x;
ecl_detect_fpe();
if (f == (double)0.0)
#ifdef signbit
if ((f == (double)0.0) && !signbit(f)) {
return(cl_core.doublefloat_zero);
}
#endif
if (isnan(f)) {
cl_error(1, @'division-by-zero');
}
@ -185,8 +191,11 @@ make_longfloat(long double f)
cl_object x;
ecl_detect_fpe();
if (f == (long double)0.0)
#ifdef signbit
if ((f == (long double)0.0) && !signbit(f)) {
return cl_core.longfloat_zero;
}
#endif
if (isnan(f)) {
cl_error(1, @'division-by-zero');
}

15
src/c/predicate.d
View file

@ -16,6 +16,7 @@
*/
#include <ecl/ecl.h>
#include <math.h>
cl_object
cl_identity(cl_object x)
@ -254,6 +255,12 @@ cl_eq(cl_object x, cl_object y)
@(return ((x == y) ? Ct : Cnil))
}
#ifdef signbit
# define float_eql(a,b) (((a) == (b)) && (signbit((a)) == signbit((b))))
#else
# define float_eql(a,b) (((a) == (b)))
#endif
bool
ecl_eql(cl_object x, cl_object y)
{
@ -272,15 +279,15 @@ ecl_eql(cl_object x, cl_object y)
ecl_eql(x->ratio.den, y->ratio.den));
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
return ecl_short_float(x) == ecl_short_float(y);
return float_eql(ecl_short_float(x),ecl_short_float(y));
#endif
case t_singlefloat:
return (sf(x) == sf(y));
return float_eql(sf(x),sf(y));
case t_doublefloat:
return (df(x) == df(y));
return float_eql(df(x),df(y));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_long_float(x) == ecl_long_float(y);
return float_eql(ecl_long_float(x),ecl_long_float(y));
#endif
case t_complex:
return (ecl_eql(x->complex.real, y->complex.real) &&

7
src/c/print.d
View file

@ -576,7 +576,12 @@ write_double(DBL_TYPE d, int e, int n, cl_object stream)
d = -d;
}
if (d == 0.0) {
write_str("0.0", stream);
#ifdef signbit
if (signbit(d))
write_str("-0.0", stream);
else
#endif
write_str("0.0", stream);
exp = 0;
} else if (d < 1e-3 || d > 1e7) {
int sign;

178
src/c/stacks.d
View file

@ -16,6 +16,8 @@
*/
#include <ecl/ecl.h>
#include <signal.h>
#include <string.h>
#ifdef HAVE_SYS_RESOURCE_H
# include <sys/time.h>
# include <sys/resource.h>
@ -29,6 +31,10 @@ bds_bind(cl_object s, cl_object value)
{
struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
struct bds_bd *slot = ++cl_env.bds_top;
if (slot >= cl_env.bds_limit) {
bds_overflow();
slot = cl_env.bds_top;
}
if (h->key == OBJNULL) {
/* The previous binding was at most global */
slot->symbol = s;
@ -48,6 +54,10 @@ bds_push(cl_object s)
{
struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash);
struct bds_bd *slot = ++cl_env.bds_top;
if (slot >= cl_env.bds_limit) {
bds_overflow();
slot = cl_env.bds_top;
}
if (h->key == OBJNULL) {
/* The previous binding was at most global */
slot->symbol = s;
@ -78,12 +88,6 @@ bds_unwind1(void)
}
}
void
bds_unwind_n(int n)
{
while (n--) bds_unwind1();
}
cl_object *
ecl_symbol_slot(cl_object s)
{
@ -111,19 +115,50 @@ ecl_set_symbol(cl_object s, cl_object value)
#endif
void
bds_overflow(void)
bds_unwind_n(int n)
{
--cl_env.bds_top;
if (cl_env.bds_limit > cl_env.bds_org + cl_env.bds_size)
ecl_internal_error("bind stack overflow.");
cl_env.bds_limit += BDSGETA;
FEerror("Bind stack overflow.", 0);
while (n--) bds_unwind1();
}
static void
bds_set_size(cl_index size)
{
cl_index limit = (cl_env.bds_top - cl_env.bds_org);
if (size <= limit) {
FEerror("Cannot shrink the binding stack below ~D.", 1,
ecl_make_unsigned_integer(limit));
} else {
bds_ptr org;
org = cl_alloc_atomic(size * sizeof(*org));
memcpy(org, cl_env.bds_org, (cl_env.bds_top - cl_env.bds_org) * sizeof(*org));
cl_env.bds_top = org + (cl_env.bds_top - cl_env.bds_org);
cl_env.bds_org = org;
cl_env.bds_limit = org + (size - 2*BDSGETA);
cl_env.bds_size = size;
}
}
void
bds_unwind(bds_ptr new_bds_top)
bds_overflow(void)
{
register bds_ptr bds = cl_env.bds_top;
cl_index size = cl_env.bds_size;
bds_ptr org = cl_env.bds_org;
bds_ptr last = org + size;
if (cl_env.bds_limit >= last) {
ecl_internal_error("Bind stack overflow, cannot grow larger.");
}
cl_env.bds_limit += BDSGETA;
cl_cerror(6, make_constant_base_string("Extend stack size"),
@'ext::stack-overflow', @':size', MAKE_FIXNUM(size),
@':type', @'ext::binding-stack');
bds_set_size(size + (size / 2));
}
void
bds_unwind(cl_index new_bds_top_index)
{
bds_ptr new_bds_top = new_bds_top_index + cl_env.bds_org;
bds_ptr bds = cl_env.bds_top;
for (; bds > new_bds_top; bds--)
#ifdef ECL_THREADS
bds_unwind1();
@ -139,9 +174,9 @@ get_bds_ptr(cl_object x)
bds_ptr p;
if (FIXNUMP(x)) {
p = cl_env.bds_org + fix(x);
if (cl_env.bds_org <= p && p <= cl_env.bds_top)
return(p);
p = cl_env.bds_org + fix(x);
if (cl_env.bds_org <= p && p <= cl_env.bds_top)
return(p);
}
FEerror("~S is an illegal bds index.", 1, x);
}
@ -251,22 +286,49 @@ new_frame_id(void)
return(MAKE_FIXNUM(frame_id++));
}
int
static void
frs_set_size(cl_index size)
{
cl_index limit = (cl_env.frs_top - cl_env.frs_org);
if (size <= limit) {
FEerror("Cannot shrink frame stack below ~D.", 1,
ecl_make_unsigned_integer(limit));
} else {
ecl_frame_ptr org;
org = cl_alloc_atomic(size * sizeof(*org));
memcpy(org, cl_env.frs_org, (cl_env.frs_top - cl_env.frs_org) * sizeof(*org));
cl_env.frs_top = org + (cl_env.frs_top - cl_env.frs_org);
cl_env.frs_org = org;
cl_env.frs_limit = org + (size - 2*FRSGETA);
cl_env.frs_size = size;
}
}
static void
frs_overflow(void) /* used as condition in list.d */
{
--cl_env.frs_top;
if (cl_env.frs_limit > cl_env.frs_org + cl_env.frs_size)
ecl_internal_error("frame stack overflow.");
cl_index size = cl_env.frs_size;
ecl_frame_ptr org = cl_env.frs_org;
ecl_frame_ptr last = org + size;
if (cl_env.frs_limit >= last) {
ecl_internal_error("Frame stack overflow, cannot grow larger.");
}
cl_env.frs_limit += FRSGETA;
FEerror("Frame stack overflow.", 0);
cl_cerror(6, make_constant_base_string("Extend stack size"),
@'ext::stack-overflow', @':size', MAKE_FIXNUM(size),
@':type', @'ext::frame-stack');
frs_set_size(size + size / 2);
}
ecl_frame_ptr
_frs_push(register cl_object val)
{
ecl_frame_ptr output = ++cl_env.frs_top;
if (output >= cl_env.frs_limit) frs_overflow();
output->frs_bds_top = cl_env.bds_top;
if (output >= cl_env.frs_limit) {
frs_overflow();
output = cl_env.frs_top;
}
output->frs_bds_top_index = cl_env.bds_top - cl_env.bds_org;
output->frs_val = val;
output->frs_ihs = cl_env.ihs_top;
output->frs_sp = cl_stack_index();
@ -280,7 +342,7 @@ ecl_unwind(ecl_frame_ptr fr)
while (cl_env.frs_top != fr && cl_env.frs_top->frs_val != ECL_PROTECT_TAG)
--cl_env.frs_top;
cl_env.ihs_top = cl_env.frs_top->frs_ihs;
bds_unwind(cl_env.frs_top->frs_bds_top);
bds_unwind(cl_env.frs_top->frs_bds_top_index);
cl_stack_set_index(cl_env.frs_top->frs_sp);
ecl_longjmp(cl_env.frs_top->frs_jmpbuf, 1);
/* never reached */
@ -319,7 +381,7 @@ si_frs_top()
cl_object
si_frs_bds(cl_object arg)
{
@(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_bds_top - cl_env.bds_org))
@(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_bds_top_index))
}
cl_object
@ -374,47 +436,73 @@ si_reset_stack_limits()
@(return Cnil)
}
cl_object
si_set_stack_size(cl_object type, cl_object size)
{
cl_index the_size = fixnnint(size);
if (type == @'ext::frame-stack') {
frs_set_size(the_size);
} else if (type == @'ext::binding-stack') {
bds_set_size(the_size);
} else {
cl_stack_set_size(the_size);
}
@(return)
}
void
init_stacks(int *new_cs_org)
init_stacks(struct cl_env_struct *env, int *new_cs_org)
{
static struct ihs_frame ihs_org = { NULL, NULL, NULL, 0};
cl_index size;
cl_env.frs_size = size = FRSSIZE + 2*FRSGETA;
cl_env.frs_org = (ecl_frame_ptr)cl_alloc_atomic(size * sizeof(*cl_env.frs_org));
cl_env.frs_top = cl_env.frs_org-1;
cl_env.frs_limit = &cl_env.frs_org[size - 2*FRSGETA];
cl_env.bds_size = size = BDSSIZE + 2*BDSGETA;
cl_env.bds_org = (bds_ptr)cl_alloc_atomic(size * sizeof(*cl_env.bds_org));
cl_env.bds_top = cl_env.bds_org-1;
cl_env.bds_limit = &cl_env.bds_org[size - 2*BDSGETA];
env->frs_size = size = FRSSIZE + 2*FRSGETA;
env->frs_org = (ecl_frame_ptr)cl_alloc_atomic(size * sizeof(*env->frs_org));
env->frs_top = env->frs_org-1;
env->frs_limit = &env->frs_org[size - 2*FRSGETA];
env->bds_size = size = BDSSIZE + 2*BDSGETA;
env->bds_org = (bds_ptr)cl_alloc_atomic(size * sizeof(*env->bds_org));
env->bds_top = env->bds_org-1;
env->bds_limit = &env->bds_org[size - 2*BDSGETA];
cl_env.ihs_top = &ihs_org;
env->ihs_top = &ihs_org;
ihs_org.function = @'si::top-level';
ihs_org.lex_env = Cnil;
ihs_org.index = 0;
cl_env.cs_org = new_cs_org;
env->cs_org = new_cs_org;
#if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK)
{
struct rlimit rl;
getrlimit(RLIMIT_STACK, &rl);
cl_env.cs_size = rl.rlim_cur/4 - 4*CSGETA;
env->cs_size = rl.rlim_cur/4 - 4*CSGETA;
}
#else
cl_env.cs_size = CSSIZE;
env->cs_size = CSSIZE;
#endif
#ifdef DOWN_STACK
/* Sanity check - in case rlimit is set too high */
if (cl_env.cs_org - cl_env.cs_size > cl_env.cs_org) {
cl_env.cs_size = CSSIZE;
if (env->cs_org - env->cs_size > env->cs_org) {
env->cs_size = CSSIZE;
}
cl_env.cs_limit = cl_env.cs_org - cl_env.cs_size; /* in THREADS I'm assigning to the main thread clwp */
env->cs_limit = env->cs_org - env->cs_size; /* in THREADS I'm assigning to the main thread clwp */
#else
/* Sanity check - in case rlimit is set too high */
if (cl_env.cs_org + cl_env.cs_size < cl_env.cs_org) {
cl_env.cs_size = CSSIZE;
if (env->cs_org + env->cs_size < env->cs_org) {
env->cs_size = CSSIZE;
}
env->cs_limit = env->cs_org + env->cs_size;
#endif
#if defined(HAVE_SIGPROCMASK) && defined(SA_SIGINFO)
{
stack_t new_stack;
env->altstack_size = SIGSTKSZ + (sizeof(double)*16) + (sizeof(cl_object)*4);
env->altstack = cl_alloc_atomic(env->altstack_size);
memset(&new_stack, 0, sizeof(new_stack));
new_stack.ss_size = env->altstack_size;
new_stack.ss_sp = env->altstack;
new_stack.ss_flags = 0;
sigaltstack(&new_stack, NULL);
}
cl_env.cs_limit = cl_env.cs_org + cl_env.cs_size;
#endif
}

13
src/c/symbols_list.h
View file

@ -1244,8 +1244,7 @@ cl_symbols[] = {
{SYS_ "LOOKUP-HOST-ENTRY", SI_ORDINARY, si_lookup_host_entry, 1, OBJNULL},
#endif
{SYS_ "CATCH-BAD-SIGNALS", SI_ORDINARY, si_catch_bad_signals, 0, OBJNULL},
{SYS_ "UNCATCH-BAD-SIGNALS", SI_ORDINARY, si_uncatch_bad_signals, 0, OBJNULL},
{SYS_ "CATCH-SIGNAL", SI_ORDINARY, si_catch_signal, 2, OBJNULL},
/* KEYWORD PACKAGE */
{KEY_ "ADJUSTABLE", KEYWORD, NULL, -1, OBJNULL},
@ -1702,5 +1701,15 @@ cl_symbols[] = {
{EXT_ "INTERACTIVE-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "STACK-OVERFLOW", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "STACK-OVERFLOW-SIZE", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "STACK-OVERFLOW-TYPE", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "BINDING-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "FRAME-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "LISP-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "C-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "SET-STACK-SIZE", SI_ORDINARY, si_set_stack_size, 2, OBJNULL},
{EXT_ "SEGMENTATION-VIOLATION", SI_ORDINARY, NULL, -1, OBJNULL},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

13
src/c/symbols_list2.h
View file

@ -1244,8 +1244,7 @@ cl_symbols[] = {
{SYS_ "LOOKUP-HOST-ENTRY","si_lookup_host_entry"},
#endif
{SYS_ "CATCH-BAD-SIGNALS","si_catch_bad_signals"},
{SYS_ "UNCATCH-BAD-SIGNALS","si_uncatch_bad_signals"},
{SYS_ "CATCH-SIGNAL","si_catch_signal"},
/* KEYWORD PACKAGE */
{KEY_ "ADJUSTABLE",NULL},
@ -1702,5 +1701,15 @@ cl_symbols[] = {
{EXT_ "INTERACTIVE-INTERRUPT",NULL},
{EXT_ "STACK-OVERFLOW",NULL},
{EXT_ "STACK-OVERFLOW-SIZE",NULL},
{EXT_ "STACK-OVERFLOW-TYPE",NULL},
{EXT_ "BINDING-STACK",NULL},
{EXT_ "FRAME-STACK",NULL},
{EXT_ "LISP-STACK",NULL},
{EXT_ "C-STACK",NULL},
{EXT_ "SET-STACK-SIZE","si_set_stack_size"},
{EXT_ "SEGMENTATION-VIOLATION",NULL},
/* Tag for end of list */
{NULL,NULL}};

3
src/c/time.d
View file

@ -37,13 +37,14 @@
#include <ecl/internal.h>
#if defined(mingw32) || defined(_MSC_VER)
#include <windows.h>
#include <WinSock.h>
#endif
#ifdef darwin
#undef HAVE_NANOSLEEP
#endif
#if !defined(HAVE_GETTIMEOFDAY) && !defined(HAVE_GETRUSAGE) && !defined(mingw32)
#if !defined(HAVE_GETTIMEOFDAY) && !defined(HAVE_GETRUSAGE) && !defined(mingw32) && !defined(_MSC_VER)
struct timeval {
long tv_sec;
long tv_usec;

211
src/c/unixint.d
View file

@ -45,6 +45,109 @@ void handle_fpe_signal(int,int);
#endif
#include <ecl/internal.h>
static struct {
int code;
char *text;
} known_signals[] = {
#ifdef SIGHUP
{ SIGHUP, "+SIGHUP+" },
#endif
#ifdef SIGINT
{ SIGINT, "+SIGINT+" },
#endif
#ifdef SIGQUIT
{ SIGQUIT, "+SIGQUIT+" },
#endif
#ifdef SIGILL
{ SIGILL, "+SIGILL+" },
#endif
#ifdef SIGTRAP
{ SIGTRAP, "+SIGTRAP+" },
#endif
#ifdef SIGABRT
{ SIGABRT, "+SIGABRT+" },
#endif
#ifdef SIGEMT
{ SIGEMT, "+SIGEMT+" },
#endif
#ifdef SIGFPE
{ SIGFPE, "+SIGFPE+" },
#endif
#ifdef SIGKILL
{ SIGKILL, "+SIGKILL+" },
#endif
#ifdef SIGBUS
{ SIGBUS, "+SIGBUS+" },
#endif
#ifdef SIGSEGV
{ SIGSEGV, "+SIGSEGV+" },
#endif
#ifdef SIGSYS
{ SIGSYS, "+SIGSYS+" },
#endif
#ifdef SIGPIPE
{ SIGPIPE, "+SIGPIPE+" },
#endif
#ifdef SIGALRM
{ SIGALRM, "+SIGALRM+" },
#endif
#ifdef SIGTERM
{ SIGTERM, "+SIGTERM+" },
#endif
#ifdef SIGURG
{ SIGURG, "+SIGURG+" },
#endif
#ifdef SIGSTOP
{ SIGSTOP, "+SIGSTOP+" },
#endif
#ifdef SIGTSTP
{ SIGTSTP, "+SIGTSTP+" },
#endif
#ifdef SIGCONT
{ SIGCONT, "+SIGCONT+" },
#endif
#ifdef SIGCHLD
{ SIGCHLD, "+SIGCHLD+" },
#endif
#ifdef SIGTTIN
{ SIGTTIN, "+SIGTTIN+" },
#endif
#ifdef SIGTTOU
{ SIGTTOU, "+SIGTTOU+" },
#endif
#ifdef SIGIO
{ SIGIO, "+SIGIO+" },
#endif
#ifdef SIGXCPU
{ SIGXCPU, "+SIGXCPU+" },
#endif
#ifdef SIGXFSZ
{ SIGXFSZ, "+SIGXFSZ+" },
#endif
#ifdef SIGVTALRM
{ SIGVTALRM, "+SIGVTALRM+" },
#endif
#ifdef SIGPROF
{ SIGPROF, "+SIGPROF+" },
#endif
#ifdef SIGWINCH
{ SIGWINCH, "+SIGWINCH+" },
#endif
#ifdef SIGINFO
{ SIGINFO, "+SIGINFO+" },
#endif
#ifdef SIGUSR1
{ SIGUSR1, "+SIGUSR1+" },
#endif
#ifdef SIGUSR2
{ SIGUSR2, "+SIGUSR2+" },
#endif
#ifdef SIGTHR
{ SIGTHR, "+SIGTHR+" },
#endif
{ -1, "" }
};
/******************************* ------- ******************************/
bool ecl_interrupt_enable;
@ -54,11 +157,13 @@ static void
mysignal(int code, void *handler)
{
struct sigaction new_action, old_action;
#ifdef SA_SIGINFO
new_action.sa_sigaction = handler;
sigemptyset(&new_action.sa_mask);
new_action.sa_flags = SA_SIGINFO;
if (code == SIGSEGV) {
new_action.sa_flags |= SA_ONSTACK;
}
#else
new_action.sa_handler = handler;
sigemptyset(&new_action.sa_mask);
@ -116,7 +221,13 @@ handle_signal(int sig)
break;
}
case SIGSEGV:
FEerror("Segmentation violation.", 0);
#ifdef SA_SIGINFO
if (sbrk(0) < info->si_addr) {
GC_disable();
cl_error(3, @'ext::stack-overflow', @':type', @'ext::c-stack');
}
#endif
cl_error(1, @'ext::segmentation-violation');
break;
default:
FEerror("Serious signal ~D caught.", 1, MAKE_FIXNUM(sig));
@ -134,6 +245,9 @@ signal_catcher(int sig, siginfo_t *siginfo, void *data)
signal_catcher(int sig)
#endif
{
#ifdef GBC_BOEHM
int old_GC_enabled = GC_enabled();
#endif
if (!ecl_interrupt_enable ||
ecl_symbol_value(@'si::*interrupt-enable*') == Cnil) {
mysignal(sig, signal_catcher);
@ -157,6 +271,7 @@ signal_catcher(int sig)
#else
sigprocmask(SIG_UNBLOCK, &block_mask, NULL);
#endif
if (old_GC_enabled) GC_enable() else GC_disable();
} CL_UNWIND_PROTECT_END;
#else
#if defined (_MSC_VER)
@ -184,45 +299,29 @@ si_check_pending_interrupts(void)
}
cl_object
si_catch_bad_signals()
si_catch_signal(cl_object code, cl_object boolean)
{
mysignal(SIGILL, signal_catcher);
#ifndef GBC_BOEHM
mysignal(SIGBUS, signal_catcher);
int code_int = fixnnint(signal);
int i;
#ifdef GBC_BOEHM
if ((code_int == SIGSEGV && ecl_get_option(ECL_INCREMENTAL_GC)) ||
(code_int == SIGBUS)) {
FEerror("It is not allowed to change the behavior of SIGBUS/SEGV.",
0);
}
#endif
#ifndef GBC_BOEHM_GENGC
mysignal(SIGSEGV, signal_catcher);
#if defined(ECL_THREADS) && !defined(_MSC_VER) && !defined(mingw32)
if (code_int == SIGUSR1) {
FEerror("It is not allowed to change the behavior of SIGUSR1", 0);
}
#endif
#ifdef SIGIOT
mysignal(SIGIOT, signal_catcher);
#endif
#ifdef SIGEMT
mysignal(SIGEMT, signal_catcher);
#endif
#ifdef SIGSYS
mysignal(SIGSYS, signal_catcher);
#endif
@(return Ct)
}
cl_object
si_uncatch_bad_signals()
{
mysignal(SIGILL, SIG_DFL);
#ifndef GBC_BOEHM
mysignal(SIGBUS, SIG_DFL);
#endif
mysignal(SIGSEGV, SIG_DFL);
#ifdef SIGIOT
mysignal(SIGIOT, SIG_DFL);
#endif
#ifdef SIGEMT
mysignal(SIGEMT, SIG_DFL);
#endif
#ifdef SIGSYS
mysignal(SIGSYS, SIG_DFL);
#endif
@(return Ct)
for (i = 0; known_signals[i].code >= 0; i++) {
if (known_signals[i].code == code) {
mysignal(code, Null(boolean)? SIG_DFL : signal_catcher);
@(return Ct)
}
}
@(return Cnil)
}
#ifdef _MSC_VER
@ -328,18 +427,40 @@ si_trap_fpe(cl_object condition, cl_object flag)
}
void
init_unixint(void)
init_unixint(int pass)
{
mysignal(SIGFPE, signal_catcher);
si_trap_fpe(Ct, Ct);
mysignal(SIGINT, signal_catcher);
if (pass == 0) {
if (ecl_get_option(ECL_TRAP_SIGSEGV)) {
mysignal(SIGSEGV, signal_catcher);
}
#ifndef GBC_BOEHM
if (ecl_get_option(ECL_TRAP_SIGBUS)) {
mysignal(SIGBUS, signal_catcher);
}
#endif
if (ecl_get_option(ECL_TRAP_SIGINT)) {
mysignal(SIGINT, signal_catcher);
}
if (ecl_get_option(ECL_TRAP_SIGFPE)) {
mysignal(SIGFPE, signal_catcher);
si_trap_fpe(Ct, Ct);
}
#if defined(ECL_THREADS) && !defined(_MSC_VER) && !defined(mingw32)
mysignal(SIGUSR1, signal_catcher);
mysignal(SIGUSR1, signal_catcher);
#endif
#ifdef _MSC_VER
SetUnhandledExceptionFilter(W32_exception_filter);
SetConsoleCtrlHandler(W32_console_ctrl_handler, TRUE);
SetUnhandledExceptionFilter(W32_exception_filter);
SetConsoleCtrlHandler(W32_console_ctrl_handler, TRUE);
#endif
} else {
int i;
for (i = 0; known_signals[i].code >= 0; i++) {
cl_object name =
_ecl_intern(known_signals[i].text,
cl_core.system_package);
si_Xmake_constant(name, MAKE_FIXNUM(known_signals[i].code));
}
}
ECL_SET(@'si::*interrupt-enable*', Ct);
ecl_interrupt_enable = 1;
}

18
src/clos/conditions.lsp
View file

@ -527,11 +527,25 @@ returns with NIL."
(define-condition style-warning (warning) ())
(define-condition simple-style-warning (style-warning simple-condition) ())
(define-condition simple-error (simple-condition error) ())
(define-condition storage-condition (serious-condition) ())
(define-condition stack-overflow (storage-condition) ())
(define-condition ext:segmentation-violation (storage-condition) ())
(define-condition ext:stack-overflow (storage-condition)
((size :initarg :size :initform 0 :reader ext:stack-overflow-size)
(type :initarg :type :initform nil :reader ext:stack-overflow-type))
(:REPORT
(lambda (condition stream)
(let ((type (ext::stack-overflow-type condition)))
(if (eq type 'ext:c-stack)
(format stream "Machine stack overflow. Stack cannot grow any further. Either exit
or return to an outer frame, undoing all the function calls so far.")
(format stream "~A overflow at size ~D. Stack can probably be resized."
type (ext:stack-overflow-size condition)))))))
(define-condition storage-exhausted (storage-condition) ())
@ -698,7 +712,7 @@ returns with NIL."
cases)))
`(block ,tag
(let ((,var nil))
(declare (ignore ,var))
(declare (ignorable ,var))
(tagbody
(handler-bind ,(mapcar #'(lambda (annotated-case)
(list (cadr annotated-case)

4
src/clos/standard.lsp
View file

@ -414,7 +414,9 @@ because it contains a reference to the undefined class~% ~A"
(error "~a is not a valid class specifier." class-or-symbol))
((find-class class-or-symbol fail))
(t
(warn "Class ~A has been forward referenced." class-or-symbol)
(warn 'ext::simple-style-warning
:format-control "Class ~A has been forward referenced."
:format-arguments (list class-or-symbol))
(ensure-class class-or-symbol
:metaclass 'forward-referenced-class
:direct-superclasses (list (find-class 'standard-object))

2
src/cmp/cmpdefs.lsp
View file

@ -441,7 +441,7 @@ coprocessor).")
(defvar *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@")
(defvar *cc-optimize* #-msvc "-O"
#+msvc "-O2")
#+msvc "@CFLAGS_OPTIMIZE@")
(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@?"
#+msvc "~A -Fe~S~* ~{~S ~} ~@?")

2
src/cmp/cmpmain.lsp
View file

@ -662,8 +662,6 @@ the environment variable TMPDIR to a different value." template)
(return-from compile (values nil t t))))
(let*((*load-time-values* 'values) ;; Only the value is kept
(template (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))
(data-pathname (or (si::mkstemp template) "foo"))
(c-pathname (compile-file-pathname data-pathname :type :c))
(h-pathname (compile-file-pathname data-pathname :type :h))
(o-pathname (compile-file-pathname data-pathname :type :object))

2
src/cmp/cmpname.lsp
View file

@ -103,7 +103,7 @@ the function name it precedes."
(or (and (probe-file pathname)
(find-init-name pathname))
(error "Cannot find out entry point for binary file" pathname))
(compute-init-name pathname kind)))
(compute-init-name pathname :kind kind)))
(defun compute-init-name (pathname &key (kind (guess-kind pathname)))
(let ((filename (pathname-name pathname)))

2
src/cmp/cmpvar.lsp
View file

@ -336,7 +336,7 @@
(sym-loc (make-lcl-var))
(val-loc (make-lcl-var)))
(wt-nl "{cl_object " sym-loc "," val-loc ";")
(wt-nl "bds_ptr " lcl "=cl_env.bds_top;")
(wt-nl "cl_index " lcl " = cl_env.bds_top - cl_env.bds_org;")
(push lcl *unwind-exit*)
(let ((*destination* sym-loc)) (c2expr* symbols))

3
src/cmp/sysfun.lsp
View file

@ -396,8 +396,7 @@
;; file unixint.d
(proclaim-function si:catch-bad-signals (*) t)
(proclaim-function si:uncatch-bad-signals (*) t)
(proclaim-function ext:catch-signal (t t) t)
;; file format.d

21
src/h/external.h
View file

@ -107,6 +107,10 @@ struct cl_env_struct {
/* foreign function interface */
void *fficall;
/* Alternative stack for processing signals */
void *altstack;
cl_index altstack_size;
};
#ifndef __GNUC__
@ -831,8 +835,18 @@ extern ECL_API cl_object si_setenv(cl_object var, cl_object value);
extern ECL_API cl_object si_pointer(cl_object x);
extern ECL_API cl_object si_quit _ARGS((cl_narg narg, ...)) /*__attribute__((noreturn))*/;
typedef enum {
ECL_TRAP_SIGSEGV = 1,
ECL_TRAP_SIGFPE = 2,
ECL_TRAP_SIGINT = 4,
ECL_TRAP_SIGILL = 8,
ECL_TRAP_SIGBUS = 16,
ECL_INCREMENTAL_GC = 128
} ecl_option;
extern ECL_API bool ecl_booted;
extern ECL_API const char *ecl_self;
extern ECL_API void ecl_set_option(int option, int value);
extern ECL_API int ecl_get_option(int option);
extern ECL_API int cl_boot(int argc, char **argv);
extern ECL_API int cl_shutdown(void);
#if defined(_MSC_VER) || defined(mingw32)
@ -1293,10 +1307,10 @@ extern ECL_API cl_object si_bds_var(cl_object arg);
extern ECL_API cl_object si_bds_val(cl_object arg);
extern ECL_API cl_object si_sch_frs_base(cl_object fr, cl_object ihs);
extern ECL_API cl_object si_reset_stack_limits(void);
extern ECL_API cl_object si_set_stack_size(cl_object type, cl_object size);
extern ECL_API void bds_overflow(void) /*__attribute__((noreturn))*/;
extern ECL_API void bds_unwind(bds_ptr new_bds_top);
extern ECL_API int frs_overflow(void) /*__attribute__((noreturn))*/;
extern ECL_API void bds_unwind(cl_index new_bds_top_index);
extern ECL_API void ecl_unwind(ecl_frame_ptr fr) /*__attribute__((noreturn))*/;
extern ECL_API ecl_frame_ptr frs_sch(cl_object frame_id);
extern ECL_API ecl_frame_ptr frs_sch_catch(cl_object frame_id);
@ -1519,8 +1533,7 @@ extern ECL_API cl_object si_get_library_pathname(void);
/* unixint.c */
extern ECL_API cl_object si_catch_bad_signals(void);
extern ECL_API cl_object si_uncatch_bad_signals(void);
extern ECL_API cl_object si_catch_signal(cl_object signal, cl_object state);
extern ECL_API cl_object si_check_pending_interrupts(void);
extern ECL_API cl_object si_trap_fpe(cl_object condition, cl_object flag);

4
src/h/internal.h
View file

@ -39,8 +39,8 @@ extern void init_GC(void);
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_stacks(struct cl_env_struct *, int *);
extern void init_unixint(int pass);
extern void init_unixtime(void);
#ifdef mingw32
extern void init_compiler(void);

4
src/h/object.h
View file

@ -661,6 +661,10 @@ struct ecl_process {
pthread_t thread;
struct cl_env_struct *env;
cl_object interrupt;
/*void *stack;*/
/*cl_index stack_size;*/
void *altstack;
cl_index altstack_size;
};
struct ecl_lock {

14
src/h/stacks.h
View file

@ -28,14 +28,12 @@ typedef struct bds_bd {
} *bds_ptr;
#define bds_check \
if (cl_env.bds_top >= cl_env.bds_limit) \
bds_overflow()
((cl_env.bds_top >= cl_env.bds_limit)? bds_overflow() : (void)0)
#ifdef ECL_THREADS
extern ECL_API void bds_bind(cl_object symbol, cl_object value);
extern ECL_API void bds_push(cl_object symbol);
extern ECL_API void bds_unwind1();
extern ECL_API void bds_unwind_n(int n);
extern ECL_API cl_object *ecl_symbol_slot(cl_object s);
#define SYM_VAL(s) (*ecl_symbol_slot(s))
#if 0
@ -51,19 +49,17 @@ extern ECL_API cl_object ecl_set_symbol(cl_object s, cl_object v);
#define ECL_SET(s,v) ((s)->symbol.value=(v))
#define ECL_SETQ(s,v) ((s)->symbol.value=(v))
#define bds_bind(sym, val) \
((++cl_env.bds_top)->symbol = (sym), \
(bds_check,(++cl_env.bds_top)->symbol = (sym), \
cl_env.bds_top->value = SYM_VAL(sym), \
SYM_VAL(sym) = (val))
#define bds_push(sym) \
((++cl_env.bds_top)->symbol = (sym), cl_env.bds_top->value = SYM_VAL(sym))
(bds_check,(++cl_env.bds_top)->symbol = (sym), cl_env.bds_top->value = SYM_VAL(sym))
#define bds_unwind1() \
(SYM_VAL(cl_env.bds_top->symbol) = cl_env.bds_top->value, --cl_env.bds_top)
#define bds_unwind_n(n) \
bds_unwind(cl_env.bds_top - (n))
#endif /* ECL_THREADS */
extern ECL_API void bds_unwind_n(int n);
/****************************
* INVOCATION HISTORY STACK
@ -115,7 +111,7 @@ extern ECL_API cl_object ihs_top_function_name(void);
typedef struct ecl_frame {
jmp_buf frs_jmpbuf;
cl_object frs_val;
bds_ptr frs_bds_top;
cl_index frs_bds_top_index;
ihs_ptr frs_ihs;
cl_index frs_sp;
} *ecl_frame_ptr;