[nucl] smaller stacks

Previously we've wrongly estimated that the vector with opcodes has the same
length as the number of words, but:

CALLW takes an argument denoting the index of the function on data stack
PUSHQ takes an argument denoting the index of the literal on data stack

Moreover rename some dictionary entries for more descriptive names and add a new
word .V that prints values stored in the environment.

msvc/Makefile

@@ -137,7 +137,7 @@ GCFLAGS = nodebug=1
 CLIBS = $(CLIBS) DbgHelp.lib
 !endif
 
-CFLAGS  = /EHsc /DGC_DLL /DGC_BUILD /nologo /wd4068 /wd4715 /wd4716 /D_CRT_SECURE_NO_DEPRECATE $(CFLAGS_CONFIG)
+CFLAGS  = /EHsc /DGC_DLL /DGC_BUILD /nologo /wd4068 /wd4715 /wd4716 /D_CRT_SECURE_NO_DEPRECATE /std:c11 $(CFLAGS_CONFIG)
 LDFLAGS	= /link /incremental:no /nologo $(LDFLAGS_CONFIG) /STACK:$(ECL_DEFAULT_C_STACK_SIZE)
 
 

msvc/c/Makefile

@@ -47,7 +47,7 @@ ECL_USE_DBGHELP_FLAG=0
 # Programs used by "make":
 #
 CC	= cl
-CFLAGS	= -c $(ECL_CFLAGS) -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I../ecl -I$(srcdir) -I$(srcdir)/unicode
+CFLAGS	= -c $(ECL_CFLAGS) /std:c11 -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I../ecl -I$(srcdir) -I$(srcdir)/unicode
 
 SHELL	= /bin/sh
 RM	= del
@@ -79,6 +79,9 @@ HFILES	= ..\ecl\config.h ..\ecl\config-internal.h ..\ecl\atomic_ops.h \
 	$(HDIR)\cache.h $(HDIR)\stack-resize.h \
 	$(HDIR)\ecl_atomics.h
 
+NUCL_OBJS = boot.obj call.obj jump.obj atomic.obj process.obj memory.obj \
+	module.obj stacks.obj
+
 CLOS_OBJS = cache.obj accessor.obj instance.obj gfun.obj
 
 NUM_OBJS = number.obj num_pred.obj num_arith.obj num_co.obj num_log.obj num_rand.obj \
@@ -112,7 +115,7 @@ OBJS	= main.obj symbol.obj package.obj cons.obj list.obj apply.obj eval.obj \
 	backq.obj stacks.obj time.obj unixint.obj mapfun.obj multival.obj hash.obj \
 	format.obj pathname.obj structure.obj load.obj unixfsys.obj unixsys.obj \
 	serialize.obj atomic.obj process.obj  \
-	big.obj alloc_2.obj tcp.obj \
+	big.obj mem_gc.obj tcp.obj \
 	$(BOOT_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(STREAM_OBJS)   \
 	$(CLOS_OBJS) $(FFI_OBJS) $(THREADS_OBJ)	$(ECL_UCD_OBJ) $(ECL_SSE_OBJ)
 

nucl.sh

@@ -0,0 +1,10 @@
+#!/bin/sh
+
+rm -f nucl
+
+pushd build/c
+make nucl
+mv nucl ../../
+popd
+
+./nucl

src/Makefile.in

@@ -136,7 +136,7 @@ $(ECL_MIN): $(LIBRARIES) .gdbinit libeclmin.a
 	if [ -f CROSS-COMPILER ]; then \
 		touch $@; \
 	else \
-		$(CC) $(LDFLAGS) -o $@ \
+		$(CC) $(LDFLAGS) -rdynamic -o $@ \
 		cinit.o c/all_symbols.o \
 		-L./ libeclmin.a \
 		$(CORE_LIBS) $(FASL_LIBS) $(LIBS);\

src/aclocal.m4

@@ -274,9 +274,10 @@ SHAREDPREFIX='lib'
 LIBPREFIX='lib'
 LIBEXT='a'
 PICFLAG='-fPIC'
-THREAD_CFLAGS=''
+THREAD_CFLAGS='-DGC_NO_THREAD_REDIRECTS'
 THREAD_LIBS=''
 THREAD_GC_FLAGS='--enable-threads=posix'
+CFLAGS=''
 INSTALL_TARGET='install'
 THREAD_OBJ="$THREAD_OBJ threads/thread threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox threads/rwlock"
 clibs='-lm'
@@ -285,7 +286,7 @@ SONAME_LDFLAGS=''
 case "${host_os}" in
         linux-android*)
                 thehost='ANDROID'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH='-Wl,--rpath,~A'
@@ -300,7 +301,7 @@ case "${host_os}" in
         # libdir may have a dollar expression inside
         linux*)
                 thehost='linux'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -314,7 +315,7 @@ case "${host_os}" in
                 ;;
         gnu*)
                 thehost='gnu'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -327,7 +328,7 @@ case "${host_os}" in
                 ;;
         kfreebsd*-gnu)
                 thehost='kfreebsd'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -377,8 +378,6 @@ case "${host_os}" in
                 ;;
         openbsd*)
                 thehost='openbsd'
-                THREAD_CFLAGS=''
-                THREAD_LIBS=''
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH="-Wl,--rpath,~A"
@@ -409,7 +408,7 @@ case "${host_os}" in
                 thehost='cygwin'
                 #enable_threads='no'
                 shared='yes'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -431,7 +430,7 @@ case "${host_os}" in
                 clibs=''
                 shared='yes'
                 enable_threads='yes'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_GC_FLAGS='--enable-threads=win32'
                 SHARED_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}"
                 BUNDLE_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}"
@@ -460,7 +459,7 @@ case "${host_os}" in
                 SHARED_LDFLAGS="-dynamiclib ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-bundle ${LDFLAGS}"
                 ECL_LDRPATH='-Wl,-rpath,~A'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 # The GMP library has not yet been ported to Intel or Arm-OSX
                 case "`uname -m`" in
@@ -498,7 +497,7 @@ case "${host_os}" in
                 thehost='nonstop'
                 shared='yes'
                 PICFLAG='-call_shared'
-                THREAD_CFLAGS='-spthread'
+                THREAD_CFLAGS="-spthread ${THREAD_CFLAGS}"
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH='-Wld=\"-rld_l ~A\"'
@@ -506,7 +505,6 @@ case "${host_os}" in
                 ;;
         haiku*)
                 thehost='haiku'
-                THREAD_LIBS=''
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH="-Wl,--rpath,~A"
@@ -535,7 +533,7 @@ esac
 case "${host}" in
         *-nacl)
                 thehost='linux'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -547,7 +545,7 @@ case "${host}" in
                 ;;
         *-pnacl)
                 thehost='linux'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 dnl SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 dnl BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -1196,7 +1194,6 @@ if test "${enable_boehm}" = auto -o "${enable_boehm}" = system; then
    fi
  else
    FASL_LIBS="${FASL_LIBS} -lgc"
-   EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}"
    AC_DEFINE(GBC_BOEHM, [1], [Use Boehm's garbage collector])
  fi
 fi
@@ -1228,7 +1225,6 @@ if test "${enable_boehm}" = "included"; then
      ECL_BOEHM_GC_HEADER='ecl/gc/gc.h'
      SUBDIRS="${SUBDIRS} gc"
      CORE_LIBS="-leclgc ${CORE_LIBS}"
-     EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}"
      if test "${enable_shared}" = "no"; then
        LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}"
      fi
@@ -1304,7 +1300,6 @@ if test "${enable_libffi}" = "included"; then
      ECL_LIBFFI_HEADER='ecl/ffi.h'
      SUBDIRS="${SUBDIRS} libffi"
      CORE_LIBS="-leclffi ${CORE_LIBS}"
-     EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}"
      if test "${enable_shared}" = "no"; then
        LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}"
      fi

src/c/Makefile.in

@@ -7,6 +7,7 @@
 top_srcdir= @top_srcdir@
 srcdir	= @srcdir@
 VPATH	= @srcdir@
+builddir= @true_builddir@
 
 # Programs used by "make":
 #
@@ -50,7 +51,14 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h
 	$(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h                   \
 	$(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h
 
-BOOT_OBJS =
+NUCL_CFLG = -DECL_NUCL -DECL_BUILD -DGC_NO_THREAD_REDIRECTS \
+        -I$(builddir) -I$(srcdir) -g3 -rdynamic
+
+NUCL_SRCS = boot.c escape.c module.c stacks.c eql.c \
+        memory.c atomic.c process.c apply.c interpreter.c stream.c \
+        streams/strm_nucl.c
+
+BOOT_OBJS = boot.o escape.o module.o stacks.o eql.o
 
 CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o
 
@@ -81,9 +89,10 @@ FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o
 OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o     \
 	compiler.o disassembler.o reference.o character.o error.o               \
 	string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o    \
-	vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o      \
+	vector_push.o sequence.o cmpaux.o macros.o backq.o stack2.o time.o      \
 	unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o    \
 	load.o unixfsys.o unixsys.o serialize.o sse2.o atomic.o process.o       \
+        mem_gc.o                                                                \
 	$(BOOT_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(STREAM_OBJS)   \
 	$(CLOS_OBJS) $(FFI_OBJS) @EXTRA_OBJS@
 
@@ -110,6 +119,9 @@ $(HDIR)/%.h: $(top_srcdir)/h/%.h
 %.o: %.c $(HFILES)
 	$(CC) -DECLDIR="\"@ecldir@\"" $(CFLAGS) -o $@ $<
 
+nucl: $(NUCL_SRCS) nucl.c
+	$(CC) $(NUCL_CFLG) -o $@ $^
+
 ../libeclmin.a: $(OBJS) all_symbols.o all_symbols2.o
 	$(RM) $@
 	$(AR) cr $@ $(OBJS)

src/c/all_symbols.d

@@ -292,8 +292,8 @@ init_all_symbols(void)
   cl_object s, value;
   cl_objectfn fun;
 
-  /* We skip NIL and T */
-  for (i = 2; cl_symbols[i].init.name != NULL; i++) {
+  /* We skip ECL_NIL_SYMBOL */
+  for (i = 1; cl_symbols[i].init.name != NULL; i++) {
     s = (cl_object)(cl_symbols + i);
     code = cl_symbols[i].init.type;
     name = cl_symbols[i].init.name;

src/c/apply.d

@@ -12,7 +12,90 @@
  */
 
 #include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
+#include <ecl/external.h>
+#include <ecl/nucleus.h>
+
+cl_objectfn
+ecl_function_dispatch(cl_env_ptr env, cl_object x)
+{
+  cl_object fun = x;
+  if (ecl_unlikely(fun == ECL_NIL))
+    ecl_ferror(ECL_EX_F_UNDEF, fun, ECL_NIL);
+  switch (ecl_t_of(fun)) {
+  case t_cfunfixed:
+    env->function = fun;
+    return fun->cfunfixed.entry;
+  case t_cfun:
+    env->function = fun;
+    return fun->cfun.entry;
+  case t_cclosure:
+    env->function = fun;
+    return fun->cclosure.entry;
+  case t_instance:
+    env->function = fun;
+    return fun->instance.entry;
+  case t_symbol:
+    fun = ECL_SYM_FUN(fun);
+    env->function = fun;
+    return fun->cfun.entry;
+  case t_bytecodes:
+    env->function = fun;
+    return fun->bytecodes.entry;
+  case t_bclosure:
+    env->function = fun;
+    return fun->bclosure.entry;
+  default:
+    ecl_ferror(ECL_EX_F_INVAL, fun, ECL_NIL);
+  }
+  _ecl_unexpected_return();
+}
+
+/* Calling conventions:
+ * Compiled C code calls lisp function supplying #args, and args.
+ *
+ * Linking function performs check_args, gets jmp_buf with _setjmp, then
+ *
+ * if cfun then stores C code address into function link location and transfers
+ * to jmp_buf at cf_self
+
+ * if cclosure then replaces #args with cc_env and calls cc_self otherwise, it
+ * emulates funcall.
+ */
+
+cl_object
+ecl_apply_from_stack_frame(cl_object frame, cl_object x)
+{
+  cl_object *sp = ECL_STACK_FRAME_PTR(frame);
+  cl_index narg = frame->frame.size;
+  cl_env_ptr env = frame->frame.env;
+  cl_objectfn entry = ecl_function_dispatch(env, x);
+  cl_object ret;
+  env->stack_frame = frame;
+  ret = APPLY(narg, entry, sp);
+  env->stack_frame = NULL;
+  return ret;
+}
+
+cl_object
+cl_funcall(cl_narg narg, cl_object function, ...)
+{
+  cl_object output;
+  --narg;
+  {
+    ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame);
+    output = ecl_apply_from_stack_frame(frame, function);
+    ECL_STACK_FRAME_VARARGS_END(frame);
+  }
+  return output;
+}
+
+cl_object *
+_ecl_va_sp(cl_narg narg)
+{
+  return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg;
+}
 
 #if !(ECL_C_ARGUMENTS_LIMIT == 63)
 #error "Please adjust code to the constant!"
@@ -656,6 +739,7 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
                                                x[50],x[51],x[52],x[53],x[54],x[55],x[56],
                                                x[57],x[58],x[59],x[60],x[61],x[62]);
   default:
-    FEprogram_error("Too many arguments", 0);
+    ecl_ferror(ECL_EX_F_NARGS, ecl_make_fixnum(n), ECL_NIL);
   }
+  _ecl_unexpected_return();
 }

src/c/big.d

@@ -14,10 +14,13 @@
  */
 
 #define ECL_INCLUDE_MATH_H
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+
 #include <limits.h>
 #include <string.h>
-#include <ecl/ecl.h>
-#include <ecl/internal.h>
 
 /*************************************************************
  * MEMORY MANAGEMENT WITH GMP
@@ -39,9 +42,7 @@
  *
  * The GMP library may also allocate temporary memory for its
  * computations. It is configurable at runtime whether we use malloc
- * and free or the corresponding equivalents from the garbage
- * collector (ecl_alloc_uncollectable and ecl_free_uncollectable) for
- * that.
+ * and free or the corresponding equivalents from the GC.
  */
 
 /*************************************************************
@@ -326,22 +327,20 @@ _ecl_fix_divided_by_big(cl_fixnum x, cl_object y)
 static void *
 mp_alloc(size_t size)
 {
-  return ecl_alloc_uncollectable(size);
+  return ecl_malloc(size);
 }
 
 static void
 mp_free(void *ptr, size_t size)
 {
-  ecl_free_uncollectable(ptr);
+  ecl_free(ptr);
 }
 
 static void *
 mp_realloc(void *ptr, size_t osize, size_t nsize)
 {
-  mp_limb_t *p = mp_alloc(nsize);
-  memcpy(p, ptr, (osize < nsize)? osize : nsize);
-  mp_free(ptr, osize);
-  return p;
+  ptr = ecl_realloc(ptr, osize, nsize);
+  return ptr;
 }
 
 #ifdef ECL_GMP_FIXNUM_TO_LIMBS
@@ -607,29 +606,52 @@ _ecl_big_boole_operator(int op)
   return bignum_operations[op];
 }
 
-void
+/* -- module definition ------------------------------------------------------ */
+
+static cl_object
+create_bignum ()
+{
+  if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS])
+    mp_set_memory_functions(mp_alloc, mp_realloc, mp_free);
+  return ECL_NIL;
+}
+
+cl_object
 ecl_init_bignum_registers(cl_env_ptr env)
 {
   int i;
   for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
+    /* INV this implies the standard allocator already initialized. */
     cl_object x = ecl_alloc_object(t_bignum);
     _ecl_big_init2(x, ECL_BIG_REGISTER_SIZE);
     env->big_register[i] = x;
   }
+  return ECL_NIL;
 }
 
-void
-ecl_clear_bignum_registers(cl_env_ptr env)
+cl_object
+ecl_free_bignum_registers(cl_env_ptr env)
 {
   int i;
   for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
     _ecl_big_clear(env->big_register[i]);
+    env->big_register[i] = ECL_NIL;
   }
+  return ECL_NIL;
 }
 
-void
-init_big()
-{
-  if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS])
-    mp_set_memory_functions(mp_alloc, mp_realloc, mp_free);
-}
+ecl_def_ct_base_string(str_bignum, "BIGNUM", 6, static, const);
+
+static struct ecl_module module_bignum = {
+  .name = str_bignum,
+  .create = create_bignum,
+  .enable = ecl_module_no_op,
+  .init_env = ecl_init_bignum_registers,
+  .init_cpu = ecl_module_no_op_cpu,
+  .free_cpu = ecl_module_no_op_cpu,
+  .free_env = ecl_free_bignum_registers,
+  .disable = ecl_module_no_op,
+  .destroy = ecl_module_no_op
+};
+
+cl_object ecl_module_bignum = (cl_object)&module_bignum;

src/c/boot.d

@@ -0,0 +1,295 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/* boot.c - initializing ecl internal data */
+
+/* -- imports --------------------------------------------------------------- */
+
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+
+#ifdef ECL_USE_MPROTECT
+# include <sys/mman.h>
+# ifndef MAP_FAILED
+#  define MAP_FAILED -1
+# endif
+#endif
+#include <limits.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#if defined(ECL_MS_WINDOWS_HOST)
+# include <windows.h>
+# include <shellapi.h>
+# define MAXPATHLEN 512
+#endif
+#ifndef MAXPATHLEN
+# ifdef PATH_MAX
+#   define MAXPATHLEN PATH_MAX
+# else
+#   define MAXPATHLEN sysconf(_PC_PATH_MAX)
+#   include <unistd.h>
+# endif
+#endif
+
+/* -- constants ----------------------------------------------------- */
+
+const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800);
+
+ecl_def_ct_base_string(ecl_ct_null_string,"",0,,const);
+
+ecl_def_ct_single_float(ecl_ct_default_rehash_size,1.5f,,const);
+ecl_def_ct_single_float(ecl_ct_default_rehash_threshold,0.75f,,const);
+
+ecl_def_ct_single_float(ecl_ct_singlefloat_zero,0,,const);
+ecl_def_ct_double_float(ecl_ct_doublefloat_zero,0,,const);
+ecl_def_ct_long_float(ecl_ct_longfloat_zero,0,,const);
+
+ecl_def_ct_single_float(ecl_ct_singlefloat_minus_zero,-0.0,,const);
+ecl_def_ct_double_float(ecl_ct_doublefloat_minus_zero,-0.0,,const);
+ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const);
+
+ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const);
+ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const);
+
+/* These two tags have a special meaning for the frame stack. */
+ecl_def_constant(ecl_ct_protect_tag, ECL_NIL, "PROTECT-TAG", 11);
+ecl_def_constant(ecl_ct_dummy_tag, ECL_NIL, "DUMMY-TAG", 9);
+
+struct ecl_symbol
+ecl_symbols[] = {
+  /* This variable contains handlers for signals and exceptions. */
+  ecl_constexpr_symbol(ecl_stp_special, "*SIGNAL-HANDLERS*", ECL_NIL),
+  /* Restart clusters allow us to estabilish selectable correction actions. */
+  ecl_constexpr_symbol(ecl_stp_special, "*RESTART-CLUSTERS*", ECL_NIL),
+  /* This variable allows for interrupting sygnals from Lisp.. */
+  ecl_constexpr_symbol(ecl_stp_special, "*INTERRUPTS-ENABLED*", ECL_T),
+  /* OP_PUSHKEYS handles specially :ALLOW-OTHER-KEYS (per CL semantics). */
+  ecl_constexpr_symbol(ecl_stp_constant, "ALLOW-OTHER-KEYS", ECL_ALLOW_OTHER_KEYS),
+  /* The universal truth, the supertype of all, the class above classes. */
+  ecl_constexpr_symbol(ecl_stp_constant, "T", ECL_T),
+  /* The marker for unbound slots. This is more a tag than a symbol. */
+  ecl_constexpr_symbol(ecl_stp_constant, "UNBOUND", ECL_UNBOUND),
+};
+
+/* -- implementation ------------------------------------------------ */
+
+#if ECL_FIXNUM_BITS <= 32
+/* 1GB */
+#define ECL_DEFAULT_HEAP_SIZE 1073741824L
+#else
+/* 4GB */
+#define ECL_DEFAULT_HEAP_SIZE 4294967296L
+#endif
+
+#ifndef ECL_DEFAULT_C_STACK_SIZE
+#define ECL_DEFAULT_C_STACK_SIZE 0
+#endif
+
+#ifdef GBC_BOEHM_GENGC
+#define ECL_INCREMENTAL_GC 1
+#else
+#define ECL_INCREMENTAL_GC 0
+#endif
+
+#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
+#define ECL_SIGNAL_HANDLING_THREAD 1
+#else
+#define ECL_SIGNAL_HANDLING_THREAD 0
+#endif
+
+/* INV: see ecl_option enum in external.h */
+cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = {
+  /* ---------------------------------------------------------------- */
+  ECL_INCREMENTAL_GC,           /* ECL_OPT_INCREMENTAL_GC             */
+  1,                            /* ECL_OPT_TRAP_SIGSEGV               */
+  1,                            /* ECL_OPT_TRAP_SIGFPE                */
+  1,                            /* ECL_OPT_TRAP_SIGINT                */
+  1,                            /* ECL_OPT_TRAP_SIGILL                */
+  1,                            /* ECL_OPT_TRAP_SIGBUS                */
+  1,                            /* ECL_OPT_TRAP_SIGPIPE               */
+  1,                            /* ECL_OPT_TRAP_INTERRUPT_SIGNAL      */
+  ECL_SIGNAL_HANDLING_THREAD,   /* ECL_OPT_SIGNAL_HANDLING_THREAD     */
+  16,                           /* ECL_OPT_SIGNAL_QUEUE_SIZE          */
+  0,                            /* ECL_OPT_BOOTED                     */
+  /* ---------------------------------------------------------------- */
+  8192,                         /* ECL_OPT_BIND_STACK_SIZE            */
+  1024,                         /* ECL_OPT_BIND_STACK_SAFETY_AREA     */
+  2048,                         /* ECL_OPT_FRAME_STACK_SIZE           */
+  128,                          /* ECL_OPT_FRAME_STACK_SAFETY_AREA    */
+  32768,                        /* ECL_OPT_LISP_STACK_SIZE            */
+  128,                          /* ECL_OPT_LISP_STACK_SAFETY_AREA     */
+  ECL_DEFAULT_C_STACK_SIZE,     /* ECL_OPT_C_STACK_SIZE               */
+  4*sizeof(cl_index)*1024,      /* ECL_OPT_C_STACK_SAFETY_AREA        */
+  ECL_DEFAULT_HEAP_SIZE,        /* ECL_OPT_HEAP_SIZE                  */
+  1024*1024,                    /* ECL_OPT_HEAP_SAFETY_AREA           */
+  0,                            /* ECL_OPT_THREAD_INTERRUPT_SIGNAL    */
+  1,                            /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS   */
+  1,                            /* ECL_OPT_USE_SETMODE_ON_FILES       */
+  /* ---------------------------------------------------------------- */
+  0};
+
+cl_fixnum
+ecl_get_option(int option)
+{
+  if (option >= ECL_OPT_LIMIT || option < 0) {
+    return -1;
+  }
+  return ecl_option_values[option];
+}
+
+cl_fixnum
+ecl_set_option(int option, cl_fixnum value)
+{
+  if (option > ECL_OPT_LIMIT || option < 0) {
+    return -1;
+  }
+  if (option >= ECL_OPT_BOOTED || !ecl_option_values[ECL_OPT_BOOTED]) {
+    ecl_option_values[option] = value;
+  }
+  return ecl_option_values[option];
+}
+
+/* -- environments ---------------------------------------------------------- */
+
+#ifdef ECL_THREADS
+static void
+add_env(cl_env_ptr the_env)
+{
+  cl_object _env;
+  ecl_mutex_lock(&ecl_core.processes_lock);
+  _env = ecl_cast_ptr(cl_object,the_env);
+  ecl_stack_push(ecl_core.threads, _env);
+  ecl_mutex_unlock(&ecl_core.processes_lock);
+}
+
+static void
+del_env(cl_env_ptr the_env)
+{
+  cl_object _env;
+  ecl_mutex_lock(&ecl_core.processes_lock);
+  _env = ecl_cast_ptr(cl_object,the_env);
+  ecl_stack_del(ecl_core.threads, _env);
+  ecl_mutex_unlock(&ecl_core.processes_lock);
+}
+#endif
+
+cl_env_ptr
+_ecl_alloc_env(cl_env_ptr parent)
+{
+  /* Allocates the lisp environment for a thread. Depending on which mechanism
+   * we use for detecting delayed signals, we may allocate the environment using
+   * mmap or with malloc.
+   *
+   * Note that at this point we are not allocating any other memory which is
+   * stored via a pointer in the environment. If we would do that, an unlucky
+   * interrupt by the gc before the allocated environment is registered in
+   * ecl_core.processes could lead to memory being freed because the gc is not
+   * aware of the pointer to the allocated memory in the environment. */
+  cl_env_ptr output;
+#if defined(ECL_USE_MPROTECT)
+  output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE,
+                             MAP_ANON | MAP_PRIVATE, -1, 0);
+  if (output == MAP_FAILED)
+    ecl_internal_error("Unable to allocate environment structure.");
+#else
+# if defined(ECL_USE_GUARD_PAGE)
+  output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, PAGE_READWRITE);
+  if (output == NULL)
+    ecl_internal_error("Unable to allocate environment structure.");
+# else
+  output = ecl_malloc(sizeof(*output));
+  if (output == NULL)
+    ecl_internal_error("Unable to allocate environment structure.");
+# endif
+#endif
+  /* Initialize the structure with NULL data. */
+  ecl_mset(output, 0, sizeof(*output));
+#ifdef ECL_THREADS
+  add_env(output);
+#endif
+  return output;
+}
+
+void
+_ecl_dealloc_env(cl_env_ptr env)
+{
+#ifdef ECL_THREADS
+  del_env(env);
+#endif
+#if defined(ECL_USE_MPROTECT)
+  if (munmap(env, sizeof(*env)))
+    ecl_internal_error("Unable to deallocate environment structure.");
+#elif defined(ECL_USE_GUARD_PAGE)
+  if (!VirtualFree(env, 0, MEM_RELEASE))
+    ecl_internal_error("Unable to deallocate environment structure.");
+#else
+  ecl_free_unsafe(env);
+#endif
+}
+
+/* -- core runtime ---------------------------------------------------------- */
+
+/* The root environment is a default execution context. */
+static struct cl_env_struct first_env;
+
+struct ecl_core_struct ecl_core = {
+  .first_env = &first_env,
+  /* processes */
+#ifdef ECL_THREADS
+  .threads = ECL_NIL,
+  .last_var_index = 0,
+  .reused_indices = ECL_NIL,
+#endif
+  /* signals */
+  .default_sigmask_bytes = 0,
+  .known_signals = ECL_NIL,
+  /* allocation */
+  .allocator = NULL,
+  .max_heap_size = 0,
+  .bytes_consed = ECL_NIL,
+  .gc_counter = ECL_NIL,
+  .gc_stats = 0,
+  .safety_region = NULL,
+  /* pathnames */
+  .path_max = 0,
+  .pathname_translations = ECL_NIL,
+  /* MODULES is a stack of plugins that may be loaded at boot time. */
+  .modules = ECL_NIL,
+  /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers
+     thanks to the magic in the garbage collector. */
+  .libraries = ECL_NIL,
+  .library_pathname = ECL_NIL
+};
+
+/* note that this function does not create any environment */
+int
+ecl_boot(void)
+{
+  int i;
+
+  i = ecl_option_values[ECL_OPT_BOOTED];
+  if (i) {
+    if (i < 0) {
+      /* The runtime has been only suspended. Resume it.*/
+      ecl_set_option(ECL_OPT_BOOTED, 1);
+    }
+    return 1;
+  }
+  init_memory();
+  init_modules();
+  ecl_core.path_max = MAXPATHLEN;
+  return 0;
+}
+
+int
+ecl_halt(void)
+{
+  int i = ecl_option_values[ECL_OPT_BOOTED];
+  if (i > 0)
+    free_modules();
+  ecl_set_option(ECL_OPT_BOOTED, 0);
+  return 0;
+}

src/c/cinit.d

@@ -68,7 +68,7 @@ si_bind_simple_restarts(cl_object tag, cl_object names)
   if (ECL_FBOUNDP(@'si::bind-simple-restarts'))
     return _ecl_funcall3(@'si::bind-simple-restarts', tag, names);
   else
-    return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*');
+    return ECL_SYM_VAL(ecl_process_env(), ECL_RESTART_CLUSTERS);
 }
 
 extern cl_object
@@ -77,7 +77,7 @@ si_bind_simple_handlers(cl_object tag, cl_object names)
   if (ECL_FBOUNDP(@'si::bind-simple-handlers'))
     return _ecl_funcall3(@'si::bind-simple-handlers', tag, names);
   else
-    return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*');
+    return ECL_SYM_VAL(ecl_process_env(), ECL_SIGNAL_HANDLERS);
 }
 
 extern cl_object

src/c/clos/instance.d

@@ -15,6 +15,27 @@
 #include <ecl/ecl.h>
 #include <ecl/internal.h>
 
+static cl_index stamp = 0;
+cl_index ecl_next_stamp() {
+#if ECL_THREADS
+  return AO_fetch_and_add((AO_t*)&stamp, 1) + 1;
+#else
+  return ++stamp;
+#endif
+}
+
+cl_object
+ecl_alloc_instance(cl_index slots)
+{
+  cl_object i;
+  i = ecl_alloc_object(t_instance);
+  i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots);
+  i->instance.length = slots;
+  i->instance.entry = FEnot_funcallable_vararg;
+  i->instance.slotds = ECL_UNBOUND;
+  return i;
+}
+
 cl_object
 ecl_allocate_instance(cl_object clas, cl_index size)
 {
@@ -379,7 +400,10 @@ enum ecl_built_in_classes {
   ECL_BUILTIN_CODE_BLOCK,
   ECL_BUILTIN_FOREIGN_DATA,
   ECL_BUILTIN_FRAME,
-  ECL_BUILTIN_WEAK_POINTER,
+  ECL_BUILTIN_EXCEPTION,
+  ECL_BUILTIN_MODULE,
+  ECL_BUILTIN_WEAK_POINTER
+  ,
   ECL_BUILTIN_PROCESS,
   ECL_BUILTIN_LOCK,
   ECL_BUILTIN_RWLOCK,
@@ -496,6 +520,10 @@ cl_class_of(cl_object x)
     index = ECL_BUILTIN_FOREIGN_DATA; break;
   case t_frame:
     index = ECL_BUILTIN_FRAME; break;
+  case t_exception:
+    index = ECL_BUILTIN_EXCEPTION; break;
+  case t_module:
+    index = ECL_BUILTIN_MODULE; break;
   case t_weak_pointer:
     index = ECL_BUILTIN_WEAK_POINTER; break;
 #ifdef ECL_SSE2

src/c/cmpaux.d

@@ -129,37 +129,6 @@ ecl_aset_bv(cl_object x, cl_index index, int value)
   return value;
 }
 
-void
-cl_throw(cl_object tag)
-{
-  ecl_frame_ptr fr = frs_sch(tag);
-  if (fr == NULL)
-    FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag);
-  ecl_unwind(ecl_process_env(), fr);
-}
-
-void
-cl_return_from(cl_object block_id, cl_object block_name)
-{
-  ecl_frame_ptr fr = frs_sch(block_id);
-  if (fr == NULL)
-    FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.",
-                    2, block_name, block_id);
-  ecl_unwind(ecl_process_env(), fr);
-}
-
-void
-cl_go(cl_object tag_id, cl_object label)
-{
-  const cl_env_ptr the_env = ecl_process_env();
-  ecl_frame_ptr fr = frs_sch(tag_id);
-  if (fr == NULL)
-    FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id);
-  the_env->values[0] = label;
-  the_env->nvalues = 1;
-  ecl_unwind(the_env, fr);
-}
-
 cl_object
 cl_grab_rest_args(ecl_va_list args)
 {
@@ -211,7 +180,7 @@ cl_parse_key(
       }
     }
     /* the key is a new one */
-    if (keyword == @':allow-other-keys') {
+    if (keyword == ECL_ALLOW_OTHER_KEYS) {
       if (supplied_allow_other_keys == OBJNULL)
         supplied_allow_other_keys = value;
     } else if (unknown_keyword == OBJNULL)
@@ -224,7 +193,8 @@ cl_parse_key(
                    (supplied_allow_other_keys == ECL_NIL ||
                     supplied_allow_other_keys == OBJNULL))) {
     for (i = 0; i < nkey; i++) {
-      if (keys[i] == @':allow-other-keys' && vars[nkey+i] == ECL_T && !Null(vars[i])) {
+      if (keys[i] == ECL_ALLOW_OTHER_KEYS && vars[nkey+i] == ECL_T
+          && !Null(vars[i])) {
         return;
       }
     }

src/c/compiler.d

@@ -551,7 +551,7 @@ c_macro_expand1(cl_env_ptr env, cl_object stmt)
 static void
 import_lexenv(cl_env_ptr env, cl_object lexenv)
 {
-  if (!ECL_VECTORP(lexenv))
+  if (Null(lexenv))
     return;
   /*
    * Given the environment of an interpreted function, we guess a
@@ -3105,10 +3105,11 @@ c_cons_cdr(cl_env_ptr env, cl_object args, int flags)
 cl_object
 si_need_to_make_load_form_p(cl_object object)
 {
-  cl_object load_form_cache = cl__make_hash_table(@'eq',
-                                                  ecl_make_fixnum(16),
-                                                  cl_core.rehash_size,
-                                                  cl_core.rehash_threshold);
+  cl_object load_form_cache =
+    cl__make_hash_table(@'eq',
+                        ecl_make_fixnum(16),
+                        ecl_ct_default_rehash_size,
+                        ecl_ct_default_rehash_threshold);
   cl_object waiting_objects = ecl_list1(object);
   cl_type type = t_start;
 
@@ -3801,8 +3802,8 @@ init_compiler()
   cl_object dispatch_table =
     cl_core.compiler_dispatch =
     cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */
-                        cl_core.rehash_size,
-                        cl_core.rehash_threshold);
+                        ecl_ct_default_rehash_size,
+                        ecl_ct_default_rehash_threshold);
   int i;
   for (i = 0; database[i].symbol; i++) {
     ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i));

src/c/disassembler.d

@@ -204,12 +204,19 @@ disassemble(cl_object bytecodes, cl_opcode *vector) {
     goto OPARG;
 
     /* OP_QUOTE
-       Sets VALUES(0) to an immediate value.
+       Sets REG0 to an immediate value.
     */
   case OP_QUOTE:          string = "QUOTE\t";
     GET_DATA(o, vector, data);
     goto ARG;
 
+    /* OP_CALLW
+       Sets REG0 to a result of calling an immediate value.
+    */
+  case OP_CALLW:          string = "CALLW\t";
+    GET_DATA(o, vector, data);
+    goto ARG;
+
     /* OP_CSET      n{arg}
        Replace constant with a computed value
     */

src/c/dpp.c

@@ -753,7 +753,7 @@ put_declaration(void)
   if (nopt == 0 && !rest_flag && !key_flag) {
     put_lineno();
     fprintf(out, "\tif (ecl_unlikely(narg!=%d))", nreq);
-    fprintf(out, "\t   FEwrong_num_arguments(ecl_make_fixnum(%d));\n",
+    fprintf(out, "\t   ecl_ferror2(ECL_EX_F_NARGS, ecl_make_fixnum(%d));\n",
             function_code);
   } else {
     simple_varargs = !rest_flag && !key_flag && ((nreq + nopt) < 32);
@@ -782,7 +782,7 @@ put_declaration(void)
     if (nopt > 0 && !rest_flag && !key_flag) {
       fprintf(out, "|| narg > %d", nreq + nopt);
     }
-    fprintf(out, ")) FEwrong_num_arguments(ecl_make_fixnum(%d));\n", function_code);
+    fprintf(out, ")) ecl_ferror2(ECL_EX_F_NARGS, ecl_make_fixnum(%d));\n", function_code);
     for (i = 0;  i < nopt;  i++) {
       put_lineno();
       fprintf(out, "\tif (narg > %d) {\n", nreq+i);

src/c/eql.d

@@ -0,0 +1,100 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/* aux.c - early routines */
+
+/* -- imports --------------------------------------------------------------- */
+
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+
+#include <string.h>
+
+/*
+ * EQL-comparison of floats. If we are using signed zeros and NaNs,
+ * numeric comparison of floating points is not equivalent to bit-wise
+ * equality. In particular every two NaNs always give false
+ *      (= #1=(/ 0.0 0.0) #1#) => NIL
+ * and signed zeros always compare equal
+ *      (= 0 -0.0) => T
+ * which is not the same as what EQL should return
+ *      (EQL #1=(/ 0.0 0.0) #1#) => T
+ *      (EQL 0 -0.0) => NIL
+ *
+ * Furthermore, we can not use bit comparisons because in some platforms
+ * long double has unused bits that makes two long floats be = but not eql.
+ */
+#if !defined(ECL_SIGNED_ZERO) && !defined(ECL_IEEE_FP)
+#define FLOAT_EQL(name, type)                           \
+  static bool name(type a, type b) { return a == b; }
+#else
+#define FLOAT_EQL(name, type)                                           \
+  static bool name(type a, type b) {                                    \
+    if (a == b) return signbit(a) == signbit(b);                        \
+    if (isnan(a) || isnan(b)) return isnan(a) && isnan(b);              \
+    return 0;                                                           \
+  }
+#endif
+
+FLOAT_EQL(float_eql, float);
+FLOAT_EQL(double_eql, double);
+FLOAT_EQL(long_double_eql, long double);
+#undef FLOAT_EQL
+
+/* To avoid linking GMP in nucleus we directly compare limbs. */
+static bool
+_bignum_eql(cl_object x, cl_object y)
+{
+  cl_fixnum size;
+  size = ECL_BIGNUM_SIZE(x);
+  if(size != ECL_BIGNUM_SIZE(y)) return 0;
+  return !memcmp(ECL_BIGNUM_LIMBS(x),
+                 ECL_BIGNUM_LIMBS(y),
+                 size * (ECL_BIGNUM_LIMB_BITS/8));
+}
+
+bool
+ecl_eql(cl_object x, cl_object y)
+{
+  if (x == y)
+    return TRUE;
+  if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y))
+    return FALSE;
+  if (x->d.t != y->d.t)
+    return FALSE;
+  switch (x->d.t) {
+  case t_bignum:
+    return _bignum_eql(x, y);
+  case t_ratio:
+    return (ecl_eql(x->ratio.num, y->ratio.num) &&
+            ecl_eql(x->ratio.den, y->ratio.den));
+  case t_singlefloat:
+    return float_eql(ecl_single_float(x), ecl_single_float(y));
+  case t_longfloat:
+    return long_double_eql(ecl_long_float(x), ecl_long_float(y));
+  case t_doublefloat:
+    return double_eql(ecl_double_float(x), ecl_double_float(y));
+  case t_complex:
+    return (ecl_eql(x->gencomplex.real, y->gencomplex.real) &&
+            ecl_eql(x->gencomplex.imag, y->gencomplex.imag));
+#ifdef ECL_COMPLEX_FLOAT
+  case t_csfloat:
+    return (float_eql(crealf(ecl_csfloat(x)), crealf(ecl_csfloat(y))) &&
+            float_eql(cimagf(ecl_csfloat(x)), cimagf(ecl_csfloat(y))));
+  case t_cdfloat:
+    return (double_eql(creal(ecl_cdfloat(x)), creal(ecl_cdfloat(y))) &&
+            double_eql(cimag(ecl_cdfloat(x)), cimag(ecl_cdfloat(y))));
+  case t_clfloat:
+    return (long_double_eql(creall(ecl_clfloat(x)), creall(ecl_clfloat(y))) &&
+            long_double_eql(cimagl(ecl_clfloat(x)), cimagl(ecl_clfloat(y))));
+#endif
+#ifdef ECL_SSE2
+  case t_sse_pack:
+    return !memcmp(x->sse.data.b8, y->sse.data.b8, 16);
+#endif
+  default:
+    return FALSE;
+  }
+}

src/c/error.d

@@ -24,69 +24,12 @@
 #include <ecl/internal.h>
 #include <ecl/ecl-inl.h>
 
-static cl_object
-cl_symbol_or_object(cl_object x)
-{
-  if (ECL_FIXNUMP(x))
-    return (cl_object)(cl_symbols + ecl_fixnum(x));
-  return x;
-}
-
-void
-_ecl_unexpected_return()
-{
-  ecl_internal_error(
-                     "*** \n"
-                     "*** A call to ERROR returned without handling the error.\n"
-                     "*** This should have never happened and is usually a signal\n"
-                     "*** that the debugger or the universal error handler were\n"
-                     "*** improperly coded or altered. Please contact the maintainers\n"
-                     "***\n");
-}
-
-void
-ecl_internal_error(const char *s)
-{
-  int saved_errno = errno;
-  fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s);
-  if (saved_errno) {
-    fprintf(stderr, "  [%d: %s]\n", saved_errno, strerror(saved_errno));
-  }
-  fflush(stderr);
-  _ecl_dump_c_backtrace();
-#ifdef SIGIOT
-  signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */
-#endif
-  abort();
-}
-
-#ifdef ECL_THREADS
-void
-ecl_thread_internal_error(const char *s)
-{
-  int saved_errno = errno;
-  fprintf(stderr, "\nInternal thread error in:\n%s\n", s);
-  if (saved_errno) {
-    fprintf(stderr, "  [%d: %s]\n", saved_errno, strerror(saved_errno));
-  }
-  _ecl_dump_c_backtrace();
-  fprintf(stderr,
-          "\nDid you forget to call `ecl_import_current_thread'?\n"
-          "Exitting thread.\n");
-  fflush(stderr);
-  ecl_thread_exit();
-}
-#endif
-
 void
 ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
 {
-  /*
-   * Right now we have no means of specifying a jump point
-   * for really bad events. We just jump to the outermost
-   * frame, which is equivalent to quitting, and wait for
-   * someone to intercept this jump.
-   */
+  /* Right now we have no means of specifying a jump point for really bad
+   * events. We just jump to the outermost frame, which is equivalent to
+   * quitting, and wait for someone to intercept this jump. */
   ecl_frame_ptr destination;
   cl_object tag;
 
@@ -112,21 +55,139 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
   }
 }
 
-void
-ecl_miscompilation_error()
+/* -- Integration with low-level exceptions */
+cl_object
+ecl_exception_handler(cl_object o)
 {
-  ecl_internal_error(
-                     "***\n"
-                     "*** Encountered a code path that should have never been taken.\n"
-                     "*** This likely indicates a bug in the ECL compiler. Please contact\n"
-                     "*** the maintainers.\n"
-                     "***\n");
+  if (ECL_EXCEPTIONP(o)) {
+    cl_object arg1 = o->exception.arg1;
+    cl_object arg2 = o->exception.arg2;
+    cl_object arg3 = o->exception.arg3;
+    cl_object hand = @'si::universal-error-handler';
+    switch (o->exception.ex_type) {
+    /* General conditions */
+    case ECL_EX_FERROR:
+      ecl_enable_interrupts();
+      return _ecl_funcall4(hand, ECL_NIL, arg1, arg2);
+    case ECL_EX_CERROR:
+      ecl_enable_interrupts();
+      return _ecl_funcall4(hand, ECL_T, arg1, arg2);
+      /* Specific conditions */
+    case ECL_EX_BADARG:
+      FEwrong_type_argument(arg1, arg2);
+      break;
+    case ECL_EX_BADARG_ONLY:
+      FEwrong_type_only_arg(arg1, arg2, arg3);
+      break;
+    case ECL_EX_UNSATISFIED:
+      FEwrong_type_pred_arg(arg1, arg2);
+      break;
+    case ECL_EX_STRM_BADELT:
+      FEwrong_type_strm_elt(arg1, arg2);
+      break;
+    case ECL_EX_STRM_CLOSED:
+      FEclosed_stream(arg1);
+      break;
+    case ECL_EX_STRM_UNREAD:
+      FEunread_stream(arg1, arg2);
+      break;
+    case ECL_EX_EOF:
+      FEend_of_file(arg1);
+      break;
+    case ECL_EX_NIY:
+      FEerror("The operation is not implemented yet.", 0);
+      break;
+    case ECL_EX_NAO:
+      FEerror("The operation is not applicable to ~A.", 1, arg1);
+      break;
+    /* Stack conditions */
+    case ECL_EX_CS_OVR:
+      CEstack_overflow(@'ext::c-stack', arg1, arg2);
+      break;
+    case ECL_EX_FRS_OVR:
+      CEstack_overflow(@'ext::frame-stack', arg1, arg2);
+      break;
+    case ECL_EX_BDS_OVR:
+      CEstack_overflow(@'ext::binding-stack', arg1, arg2);
+      break;
+    /* KLUDGE ByteVM-specific conditions */
+    case ECL_EX_VM_BADARG_EXCD:
+      FEprogram_error("Too many arguments passed to function ~A~&"
+                      "Argument list: ~S",
+                      2, arg1, cl_apply(2, @'list', arg2));
+      break;
+    case ECL_EX_VM_BADARG_UNKK:
+      FEprogram_error("Unknown keyword argument passed to function ~A.~&"
+                      "Argument list: ~S",
+                      2, arg1, cl_apply(2, @'list', arg2));
+      break;
+    case ECL_EX_VM_BADARG_ODDK:
+      FEprogram_error("Odd number of keyword arguments passed to function ~A.~&"
+                      "Argument list: ~S",
+                      2, arg1, cl_apply(2, @'list', arg2));
+      break;
+    case ECL_EX_VM_BADARG_NTH_VAL:
+      FEerror("Wrong index passed to NTH-VAL", 0);
+      break;
+    case ECL_EX_VM_BADARG_ENDP:
+      FEwrong_type_only_arg(@[endp], arg1, @[list]);
+      break;
+    case ECL_EX_VM_BADARG_CAR:
+      FEwrong_type_only_arg(@[car], arg1, @[list]);
+      break;
+    case ECL_EX_VM_BADARG_CDR:
+      FEwrong_type_only_arg(@[cdr], arg1, @[list]);
+      break;
+    case ECL_EX_VM_BADARG_PROGV:
+      FEerror("Wrong arguments to special form PROGV. Either~%"
+              "~A~%or~%~A~%are not proper lists",
+              2, arg1, arg2);
+      break;
+    /* Variable conditions */
+    case ECL_EX_V_CSETQ:
+      FEassignment_to_constant(arg1);
+      break;
+    case ECL_EX_V_CBIND:
+      FEbinding_a_constant(arg1);
+      break;
+    case ECL_EX_V_UNBND:
+      FEunbound_variable(arg1);
+      break;
+    case ECL_EX_V_BNAME:
+      FEunbound_variable(arg1);
+      break;
+    /* Function conditions */
+    case ECL_EX_F_NARGS:
+      FEwrong_num_arguments(arg1);
+      break;
+    case ECL_EX_F_UNDEF:
+      FEundefined_function(arg1);
+      break;
+    case ECL_EX_F_INVAL:
+      FEinvalid_function(arg1);
+      break;
+    case ECL_EX_S_FMISS:
+      FEcontrol_error("UNWIND: frame ~s not found.", 1, arg1);
+      break;
+    default:
+      ecl_internal_error("Unknown exception type.");
+    }
+  }
+  return ECL_NIL;
 }
 
 /*****************************************************************************/
 /*              Support for Lisp Error Handler                               */
 /*****************************************************************************/
 
+static cl_object
+cl_symbol_or_object(cl_object x)
+{
+  if (ECL_FIXNUMP(x))
+    return (cl_object)(cl_symbols + ecl_fixnum(x));
+  return x;
+}
+
 void
 FEerror(const char *s, int narg, ...)
 {
@@ -241,7 +302,7 @@ FEreader_error(const char *s, cl_object stream, int narg, ...)
   } else {
     /* Actual reader error */
     cl_object prefix = @"Reader error in file ~S, position ~D:~%";
-    cl_object position = cl_file_position(1, stream);
+    cl_object position = ecl_file_position(stream);
     message = si_base_string_concatenate(2, prefix, message);
     args_list = cl_listX(3, stream, position, args_list);
     si_signal_simple_error(6,
@@ -281,6 +342,16 @@ FEclosed_stream(cl_object strm)
   cl_error(3, @'stream-error', @':stream', strm);
 }
 
+void
+FEunread_stream(cl_object strm, cl_object twice)
+{
+  if(Null(twice)) {
+    FEerror("Error when using UNREAD-CHAR on stream ~D", 1, strm);
+  } else {
+    FEerror("Used UNREAD-CHAR twice on stream ~D", 1, strm);
+  }
+}
+
 cl_object
 si_signal_type_error(cl_object value, cl_object type)
 {
@@ -294,6 +365,25 @@ FEwrong_type_argument(cl_object type, cl_object value)
   si_signal_type_error(value, cl_symbol_or_object(type));
 }
 
+void
+FEwrong_type_pred_arg(cl_object type, cl_object value)
+{
+  cl_object predicate = cl_symbol_or_object(type);
+  cl_object expected = cl_list(2, @'satisfies', predicate);
+  si_signal_type_error(value, expected);
+}
+
+void
+FEwrong_type_strm_elt(cl_object type, cl_object value)
+{
+  cl_object expected = cl_symbol_or_object(type);
+  cl_error(9, @'simple-type-error', @':format-control',
+           @"~A stream element type is not ~S.",
+           @':format-arguments', cl_list(2, value, expected),
+           @':expected-type', expected,
+           @':datum', cl_stream_element_type(value));
+}
+
 void
 FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
 {
@@ -306,7 +396,7 @@ FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
   function = cl_symbol_or_object(function);
   type = cl_symbol_or_object(type);
   if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
-    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
+    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
   }        
   si_signal_simple_error(8,
                          @'type-error', /* condition name */
@@ -330,7 +420,7 @@ FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_objec
   function = cl_symbol_or_object(function);
   type = cl_symbol_or_object(type);
   if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
-    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
+    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
   }        
   si_signal_simple_error(8,
                          @'type-error', /* condition name */
@@ -356,7 +446,7 @@ FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_obje
   type = cl_symbol_or_object(type);
   key = cl_symbol_or_object(key);
   if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
-    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
+    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
   }        
   si_signal_simple_error(8,
                          @'type-error', /* condition name */
@@ -387,7 +477,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx,
   struct ecl_ihs_frame tmp_ihs;
   function = cl_symbol_or_object(function);
   if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
-    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
+    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
   }        
   cl_error(9,
            @'simple-type-error', /* condition name */
@@ -622,6 +712,5 @@ void
 init_error(void)
 {
   ecl_def_c_function(@'si::universal-error-handler',
-                     (cl_objectfn_fixed)universal_error_handler,
-                     3);
+                     (cl_objectfn_fixed)universal_error_handler, 3);
 }

src/c/escape.d

@@ -0,0 +1,293 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/* control.c - signaling conditions and transfering program control */
+
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+#include <ecl/nucleus.h>
+
+#include <stdio.h>
+#include <string.h>
+#include <errno.h>
+#include <signal.h>
+#include <stdlib.h>
+#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
+# include <windows.h>
+#endif
+
+#if defined(HAVE_BACKTRACE) && defined(HAVE_BACKTRACE_SYMBOLS)
+# include <execinfo.h>
+# define ECL_UNIX_BACKTRACE
+#endif
+
+#if defined(ECL_WINDOWS_BACKTRACE)
+# include <windows.h>
+# include <DbgHelp.h>
+#endif
+
+/* -- Escapes --------------------------------------------------------------- **
+
+Non-local transfer of control. Practically this is like THROW, where
+continuation is the exit point estabilished by an equivalent of CATCH.
+
+** -------------------------------------------------------------------------- */
+
+void
+ecl_escape(cl_object continuation)
+{
+  ecl_frame_ptr fr = frs_sch(continuation);
+  if (!fr) {
+    ecl_ferror(ECL_EX_S_FMISS, continuation, ECL_NIL);
+  }
+  ecl_unwind(ecl_process_env(), fr);
+  _ecl_unexpected_return();
+}
+
+void
+ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr)
+{
+  env->frs_stack.nlj_fr = fr;
+  ecl_frame_ptr top = env->frs_stack.top;
+  while (top != fr && top->frs_val != ECL_PROTECT_TAG){
+    top->frs_val = ECL_DUMMY_TAG;
+    --top;
+  }
+  env->ihs_stack.top = top->frs_ihs;
+  ecl_bds_unwind(env, top->frs_bds_ndx);
+  ECL_STACK_UNWIND(env, top->frs_run_ndx);
+  env->frs_stack.top = top;
+  ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1);
+  /* never reached */
+}
+
+void
+cl_throw(cl_object tag)
+{
+  ecl_escape(tag);
+}
+
+void
+cl_return_from(cl_object block_id, cl_object block_name)
+{
+  ecl_escape(block_id);
+}
+
+void
+cl_go(cl_object tag_id, cl_object label)
+{
+
+  const cl_env_ptr the_env = ecl_process_env();
+  the_env->values[0] = label;
+  the_env->nvalues = 1;
+  ecl_escape(tag_id);
+}
+
+/* -- Signaling conditions -------------------------------------------------- **
+
+Low level signals work slightly different from Common Lisp. There are no handler
+clusters nor restarts. %signal is called with three arguments:
+
+- condition   :: the signaled object (may be any cl_object)
+- returns     :: the flag stating whether whether the function returns
+- destination :: the thread the condition is delivered to (implementme!)
+
+The signal invokes all handlers bound with with-handler in LIFO order and call
+them with the condition. The handler may take do one of the following:
+
+- decline :: return, then signal proceeds to the next handler
+- escape  :: perform non-local transfer of control
+- defer   :: signal a condition, invoke a debugger, ...
+
+The called handler is not bound as an active signal handler during its execution
+to avoid an infinite recursion while resignaling. When all handlers decline and
+the CONTINUABLE is ECL_NIL, then we abort the program by invoking the function
+_ecl_unexpected_return().
+
+** -------------------------------------------------------------------------- */
+
+cl_object
+ecl_signal(cl_object condition, cl_object returns, cl_object thread) {
+  const cl_env_ptr the_env = ecl_process_env();
+  cl_object symbol, cluster, handler;
+  symbol = ECL_SIGNAL_HANDLERS;
+  cluster = ECL_SYM_VAL(the_env, symbol);
+  ecl_bds_bind(the_env, symbol, cluster);
+  while(!Null(cluster)) {
+    handler = ECL_CONS_CAR(cluster);
+    cluster = ECL_CONS_CDR(cluster);
+    ECL_SETQ(the_env, symbol, cluster);
+    _ecl_funcall2(handler, condition);
+  }
+  if (returns == ECL_NIL)
+    _ecl_unexpected_return();
+  ecl_bds_unwind1(the_env);
+  return ECL_NIL;
+}
+
+cl_object
+ecl_call_with_handler(cl_object handler, cl_object continuation)
+{
+  cl_env_ptr the_env = ecl_process_env();
+  cl_object result;
+  ECL_WITH_HANDLER_BEGIN(the_env, handler) {
+    result = _ecl_funcall1(continuation);
+  } ECL_WITH_HANDLER_END;
+  return result;
+}
+
+/* -- Exceptions ------------------------------------------------------------ **
+
+Conditions in Common Lisp are instances of STANDARD-CLASS. While eventually I'd
+like to include classes to the early environment, that would be too much work at
+one go. This is also the reason why ecl_signal accepts all kinds of objects.
+
+In order to signal conditions in the early environment we use a trick: we pass
+to ecl_signal objects of type ecl_exception that are recognized by a Common Lisp
+handler, and that handler resignals proper conditions. Exceptions are allocated
+on the stack and capturing them is prohibited.
+
+ecl_raise is very similar to ecl_signal with an exception that it does not pop
+the current handler from the stack. This is to ensure, that the condition
+handler is invoked despite being "above" the exception handler on the stack. To
+avoid infinite recursion it is prohibited to resignal the exception itself.
+
+** ---------------------------------------------------------------------------*/
+
+cl_object
+ecl_raise(ecl_ex_type type, bool returns,
+          cl_object arg1, cl_object arg2, cl_object arg3, void *arg4)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  struct ecl_exception ex =
+    { .t = t_exception, .ex_type = type,
+      .arg1 = arg1, .arg2 = arg2, .arg3 = arg3, .arg4 = arg4 };
+  cl_object symbol, cluster, handler;
+  cl_object exception = ecl_cast_ptr(cl_object,&ex);
+  symbol = ECL_SIGNAL_HANDLERS;
+  cluster = ECL_SYM_VAL(the_env, symbol);
+  ecl_bds_bind(the_env, symbol, cluster);
+  while(!Null(cluster)) {
+    handler = ECL_CONS_CAR(cluster);
+    cluster = ECL_CONS_CDR(cluster);
+    _ecl_funcall2(handler, exception);
+  }
+  if (!returns)
+    _ecl_unexpected_return();
+  ecl_bds_unwind1(the_env);
+  return ECL_NIL;
+}
+
+/* -- Fatal errors ---------------------------------------------------------- **
+
+Fatal errors that can't be recovered from and result in the program abortion.
+
+** ---------------------------------------------------------------------------*/
+
+void
+ecl_internal_error(const char *s)
+{
+  int saved_errno = errno;
+  fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s);
+  if (saved_errno) {
+    fprintf(stderr, "  [%d: %s]\n", saved_errno, strerror(saved_errno));
+  }
+  fflush(stderr);
+  _ecl_dump_c_backtrace();
+#ifdef SIGIOT
+  signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */
+#endif
+  abort();
+}
+
+#ifdef ECL_THREADS
+void
+ecl_thread_internal_error(const char *s)
+{
+  int saved_errno = errno;
+  fprintf(stderr, "\nInternal thread error in:\n%s\n", s);
+  if (saved_errno) {
+    fprintf(stderr, "  [%d: %s]\n", saved_errno, strerror(saved_errno));
+  }
+  _ecl_dump_c_backtrace();
+  fprintf(stderr, "\nDid you forget to call `ecl_import_current_thread'?\n"
+                  "Exitting thread.\n");
+  fflush(stderr);
+  ecl_thread_exit();
+  _ecl_unexpected_return();
+}
+#endif
+
+void
+_ecl_unexpected_return()
+{
+  ecl_internal_error("*** \n"
+                     "*** A call to ERROR returned without handling the error.\n"
+                     "*** This should have never happened and is usually a signal\n"
+                     "*** that the debugger or the universal error handler were\n"
+                     "*** improperly coded or altered. Please contact the maintainers\n"
+                     "*** \n");
+}
+
+void
+ecl_miscompilation_error()
+{
+  ecl_internal_error("*** \n"
+                     "*** Encountered a code path that should have never been taken.\n"
+                     "*** This likely indicates a bug in the ECL compiler. Please contact\n"
+                     "*** the maintainers.\n"
+                     "*** \n");
+}
+
+
+/* Max number of frames dumped by _ecl_dump_c_backtrace */
+#define MAX_BACKTRACE_SIZE 128
+/* Max length of symbols printed */
+#define MAX_SYMBOL_LENGTH 256
+
+void
+_ecl_dump_c_backtrace()
+{
+#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE)
+  {
+    void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE);
+# if defined(ECL_UNIX_BACKTRACE)
+    int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE);
+    char **names = backtrace_symbols(pointers, nframes);
+# elif defined(ECL_WINDOWS_BACKTRACE)
+    HANDLE process = GetCurrentProcess();
+    if (!SymInitialize(process, NULL, TRUE)) {
+      return;
+    }
+    int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL);
+    char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)];
+    PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer;
+    pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO);
+    pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH;
+# endif
+    int i;
+    fprintf(stderr, "\n;;; ECL C Backtrace\n");
+    for (i = 0; i < nframes; i++) {
+# if defined(ECL_UNIX_BACKTRACE)
+      fprintf(stderr, ";;; %s\n", names[i]);
+# elif defined(ECL_WINDOWS_BACKTRACE)
+      DWORD64 displacement;
+      if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) {
+        fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]);
+      } else {
+        fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]);
+      }
+# endif
+    }
+    fflush(stderr);
+    ecl_free(pointers);
+# if defined(ECL_UNIX_BACKTRACE)
+    ecl_free(names);
+# elif defined(ECL_WINDOWS_BACKTRACE)
+    SymCleanup(process);
+# endif
+  }
+#endif  /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */
+}

src/c/eval.d

@@ -16,127 +16,6 @@
 #include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
 
-cl_object *
-_ecl_va_sp(cl_narg narg)
-{
-  return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg;
-}
-
-/* Calling conventions:
- * Compiled C code calls lisp function supplying #args, and args.
- * Linking function performs check_args, gets jmp_buf with _setjmp, then
- *  if cfun then stores C code address into function link location
- *          and transfers to jmp_buf at cf_self
- *  if cclosure then replaces #args with cc_env and calls cc_self
- *  otherwise, it emulates funcall.
- */
-
-cl_object
-ecl_apply_from_stack_frame(cl_object frame, cl_object x)
-{
-  cl_object *sp = ECL_STACK_FRAME_PTR(frame);
-  cl_index narg = frame->frame.size;
-  cl_object fun = x;
-  cl_object ret;
-  frame->frame.env->stack_frame = frame;
- AGAIN:
-  frame->frame.env->function = fun;
-  if (ecl_unlikely(fun == ECL_NIL))
-    FEundefined_function(x);
-  switch (ecl_t_of(fun)) {
-  case t_cfunfixed:
-    if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
-      FEwrong_num_arguments(fun);
-    ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
-    break;
-  case t_cfun:
-    ret = APPLY(narg, fun->cfun.entry, sp);
-    break;
-  case t_cclosure:
-    ret = APPLY(narg, fun->cclosure.entry, sp);
-    break;
-  case t_instance:
-    switch (fun->instance.isgf) {
-    case ECL_STANDARD_DISPATCH:
-    case ECL_RESTRICTED_DISPATCH:
-      ret = _ecl_standard_dispatch(frame, fun);
-      break;
-    case ECL_USER_DISPATCH:
-      fun = fun->instance.slots[fun->instance.length - 1];
-      goto AGAIN;
-    case ECL_READER_DISPATCH:
-    case ECL_WRITER_DISPATCH:
-      ret = APPLY(narg, fun->instance.entry, sp);
-      break;
-    default:
-      FEinvalid_function(fun);
-    }
-    break;
-  case t_symbol:
-    if (ecl_unlikely(!ECL_FBOUNDP(fun)))
-      FEundefined_function(fun);
-    fun = ECL_SYM_FUN(fun);
-    goto AGAIN;
-  case t_bytecodes:
-    ret = ecl_interpret(frame, ECL_NIL, fun);
-    break;
-  case t_bclosure:
-    ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
-    break;
-  default:
-    FEinvalid_function(x);
-  }
-  frame->frame.env->stack_frame = NULL; /* for gc's sake */
-  return ret;
-}
-
-cl_objectfn
-ecl_function_dispatch(cl_env_ptr env, cl_object x)
-{
-  cl_object fun = x;
-  if (ecl_unlikely(fun == ECL_NIL))
-    FEundefined_function(x);
-  switch (ecl_t_of(fun)) {
-  case t_cfunfixed:
-    env->function = fun;
-    return fun->cfunfixed.entry;
-  case t_cfun:
-    env->function = fun;
-    return fun->cfun.entry;
-  case t_cclosure:
-    env->function = fun;
-    return fun->cclosure.entry;
-  case t_instance:
-    env->function = fun;
-    return fun->instance.entry;
-  case t_symbol:
-    fun = ECL_SYM_FUN(fun);
-    env->function = fun;
-    return fun->cfun.entry;
-  case t_bytecodes:
-    env->function = fun;
-    return fun->bytecodes.entry;
-  case t_bclosure:
-    env->function = fun;
-    return fun->bclosure.entry;
-  default:
-    FEinvalid_function(x);
-  }
-}
-
-cl_object
-cl_funcall(cl_narg narg, cl_object function, ...)
-{
-  cl_object output;
-  --narg;
-  {
-    ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame);
-    output = ecl_apply_from_stack_frame(frame, function);
-    ECL_STACK_FRAME_VARARGS_END(frame);
-  }
-  return output;
-}
-
 @(defun apply (fun lastarg &rest args)
 @ {
     if (narg == 2 && ecl_t_of(lastarg) == t_frame) {

src/c/ffi.d

@@ -13,6 +13,7 @@
 #include <string.h>
 #define ECL_INCLUDE_FFI_H
 #include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
 
 static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = {
@@ -312,7 +313,7 @@ si_allocate_foreign_data(cl_object tag, cl_object size)
   /* FIXME! Should be atomic uncollectable or malloc, but we do not export
    * that garbage collector interface and malloc may be overwritten
    * by the GC library */
-  output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL;
+  output->foreign.data = bytes? ecl_alloc_manual(bytes) : NULL;
   @(return output);
 }
 
@@ -325,7 +326,7 @@ si_free_foreign_data(cl_object f)
   }
   if (f->foreign.size) {
     /* See si_allocate_foreign_data() */
-    ecl_free_uncollectable(f->foreign.data);
+    ecl_free(f->foreign.data);
   }
   f->foreign.size = 0;
   f->foreign.data = NULL;
@@ -1019,3 +1020,32 @@ si_free_ffi_closure(cl_object closure)
     @(return closure_object);
 } @)
 #endif /* HAVE_LIBFFI */
+
+/* -- Module definition ------------------------------------------------------ */
+static cl_object
+init_env_ffi(cl_env_ptr the_env)
+{
+#ifdef HAVE_LIBFFI
+  the_env->ffi_args_limit = 0;
+  the_env->ffi_types = 0;
+  the_env->ffi_values = 0;
+  the_env->ffi_values_ptrs = 0;
+#endif
+  return ECL_NIL;
+}
+
+ecl_def_ct_base_string(str_ffi, "FFI", 3, static, const);
+
+static struct ecl_module module_ffi = {
+  .name = str_ffi,
+  .create = ecl_module_no_op,
+  .enable = ecl_module_no_op,
+  .init_env = init_env_ffi,
+  .init_cpu = ecl_module_no_op_cpu,
+  .free_cpu = ecl_module_no_op_cpu,
+  .free_env = ecl_module_no_op_env,
+  .disable = ecl_module_no_op,
+  .destroy = ecl_module_no_op
+};
+
+cl_object ecl_module_ffi = (cl_object)&module_ffi;

src/c/ffi/backtrace.d

@@ -24,56 +24,9 @@
 # include <DbgHelp.h>
 #endif
 
-/* Max number of frames dumped by _ecl_dump_c_backtrace */
-#define MAX_BACKTRACE_SIZE 128
 /* Max length of symbols printed */
 #define MAX_SYMBOL_LENGTH 256
 
-void
-_ecl_dump_c_backtrace()
-{
-#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE)
-  {
-    void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE);
-# if defined(ECL_UNIX_BACKTRACE)
-    int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE);
-    char **names = backtrace_symbols(pointers, nframes);
-# elif defined(ECL_WINDOWS_BACKTRACE)
-    HANDLE process = GetCurrentProcess();
-    if (!SymInitialize(process, NULL, TRUE)) {
-      return;
-    }
-    int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL);
-    char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)];
-    PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer;
-    pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO);
-    pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH;
-# endif
-    int i;
-    fprintf(stderr, "\n;;; ECL C Backtrace\n");
-    for (i = 0; i < nframes; i++) {
-# if defined(ECL_UNIX_BACKTRACE)
-      fprintf(stderr, ";;; %s\n", names[i]);
-# elif defined(ECL_WINDOWS_BACKTRACE)
-      DWORD64 displacement;
-      if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) {
-        fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]);
-      } else {
-        fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]);
-      }
-# endif
-    }
-    fflush(stderr);
-    free(pointers);
-# if defined(ECL_UNIX_BACKTRACE)
-    free(names);
-# elif defined(ECL_WINDOWS_BACKTRACE)
-    SymCleanup(process);
-# endif
-  }
-#endif  /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */
-}
-
 cl_object
 si_dump_c_backtrace(cl_object size)
 {

src/c/ffi/libraries.d

@@ -221,7 +221,7 @@ static cl_object
 ecl_library_find_by_name(cl_object filename)
 {
   cl_object l;
-  for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
+  for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
     cl_object other = ECL_CONS_CAR(l);
     cl_object name = other->cblock.name;
     if (!Null(name) && ecl_string_eq(name, filename)) {
@@ -235,7 +235,7 @@ static cl_object
 ecl_library_find_by_handle(void *handle)
 {
   cl_object l;
-  for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
+  for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
     cl_object other = ECL_CONS_CAR(l);
     if (handle == other->cblock.handle) {
       return other;
@@ -268,7 +268,7 @@ ecl_library_open_inner(cl_object filename, bool self_destruct)
         block->cblock.refs = ecl_one_plus(block->cblock.refs);
       } else {
         si_set_finalizer(block, ECL_T);
-        cl_core.libraries = CONS(block, cl_core.libraries);
+        ecl_core.libraries = CONS(block, ecl_core.libraries);
       }
     }
     ecl_enable_interrupts();
@@ -341,7 +341,7 @@ ecl_library_symbol(cl_object block, const char *symbol, bool lock) {
   void *p;
   if (block == @':default') {
     cl_object l;
-    for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
+    for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
       cl_object block = ECL_CONS_CAR(l);
       p = ecl_library_symbol(block, symbol, lock);
       if (p) return p;
@@ -426,7 +426,7 @@ ecl_library_close(cl_object block) {
       block = ECL_NIL;
     } else if (block->cblock.handle != NULL) {
       success = GC_call_with_alloc_lock(dlclose_wrapper, block);
-      cl_core.libraries = ecl_remove_eq(block, cl_core.libraries);
+      ecl_core.libraries = ecl_remove_eq(block, ecl_core.libraries);
     } else { /* block not loaded */
       success = FALSE;
     }
@@ -443,8 +443,8 @@ ecl_library_close(cl_object block) {
 void
 ecl_library_close_all(void)
 {
-  while (cl_core.libraries != ECL_NIL) {
-    ecl_library_close(ECL_CONS_CAR(cl_core.libraries));
+  while (ecl_core.libraries != ECL_NIL) {
+    ecl_library_close(ECL_CONS_CAR(ecl_core.libraries));
   }
 }
 

src/c/file.d

@@ -151,3 +151,45 @@ ecl_normalize_stream_element_type(cl_object element_type)
 @
   @(return ecl_stream_dispatch_table(strm)->close(strm));
 @)
+
+cl_object
+si_file_stream_fd(cl_object s)
+{
+  cl_object ret;
+
+  unlikely_if (!ECL_FILE_STREAM_P(s)) {
+    ecl_not_a_file_stream(s);
+  }
+
+  switch ((enum ecl_smmode)s->stream.mode) {
+  case ecl_smm_input:
+  case ecl_smm_output:
+  case ecl_smm_io:
+    ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s)));
+    break;
+  case ecl_smm_input_file:
+  case ecl_smm_output_file:
+  case ecl_smm_io_file:
+    ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s));
+    break;
+  default:
+    ecl_internal_error("not a file stream");
+  }
+  @(return ret);
+}
+
+@(defun file-position (file_stream &o position)
+  cl_object output;
+@
+  if (Null(position)) {
+    output = ecl_file_position(file_stream);
+  } else {
+    if (position == @':start') {
+      position = ecl_make_fixnum(0);
+    } else if (position == @':end') {
+      position = ECL_NIL;
+    }
+    output = ecl_file_position_set(file_stream, position);
+  }
+  @(return output);
+@)

src/c/hash.d

@@ -943,8 +943,8 @@ ecl_extend_hashtable(cl_object hashtable)
                          (weakness ECL_NIL)
                          (synchronized ECL_NIL)
                          (size ecl_make_fixnum(1024))
-                         (rehash_size cl_core.rehash_size)
-                         (rehash_threshold cl_core.rehash_threshold))
+                         (rehash_size ecl_ct_default_rehash_size)
+                         (rehash_threshold ecl_ct_default_rehash_threshold))
 @ {
     cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold);
     if (hash->hash.test == ecl_htt_generic) {

src/c/interpreter.d

@@ -24,85 +24,91 @@
 static void
 VEbad_lambda_too_many_args(cl_object bytecodes, cl_object frame)
 {
-  FEprogram_error("Too many arguments passed to "
-                  "function ~A~&Argument list: ~S",
-                  2, bytecodes, cl_apply(2, @'list', frame));
+  ecl_ferror(ECL_EX_VM_BADARG_EXCD, bytecodes, frame);
 }
 
 static void
 VEbad_lambda_unknown_keyword(cl_object bytecodes, cl_object frame)
 {
-  FEprogram_error("Unknown keyword argument passed to function ~S.~&"
-                  "Argument list: ~S", 2, bytecodes,
-                  cl_apply(2, @'list', frame));
+  ecl_ferror(ECL_EX_VM_BADARG_UNKK, bytecodes, frame);
 }
 
 static void
 VEbad_lambda_odd_keys(cl_object bytecodes, cl_object frame)
 {
-  FEprogram_error("Function ~A called with odd number "
-                  "of keyword arguments.",
-                  1, bytecodes);
+  ecl_ferror(ECL_EX_VM_BADARG_ODDK, bytecodes, frame);
 }
 
 static void
 VEwrong_arg_type_endp(cl_object reg0)
 {
-  FEwrong_type_only_arg(@[endp], reg0, @[list]);
+  ecl_ferror(ECL_EX_VM_BADARG_ENDP, ECL_NIL, reg0);
 }
 
 static void
 VEwrong_arg_type_car(cl_object reg0)
 {
-  FEwrong_type_only_arg(@[car], reg0, @[cons]);
+  ecl_ferror(ECL_EX_VM_BADARG_CAR, ECL_NIL, reg0);
 }
 
 static void
 VEwrong_arg_type_cdr(cl_object reg0)
 {
-  FEwrong_type_only_arg(@[cdr], reg0, @[cons]);
+  ecl_ferror(ECL_EX_VM_BADARG_CDR, ECL_NIL, reg0);
 }
 
 static void
-VEwrong_arg_type_nth_val(cl_fixnum n)
+VEwrong_arg_type_nth_val()
 {
-  FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n));
+  ecl_ferror(ECL_EX_VM_BADARG_NTH_VAL, ECL_NIL, ECL_NIL);
+}
+
+static void
+VEwrong_args_progv(cl_object vars, cl_object vals)
+{
+  ecl_ferror(ECL_EX_VM_BADARG_PROGV, vars, vals);
 }
 
 static void
 VEassignment_to_constant(cl_object var)
 {
-  FEassignment_to_constant(var);
+  ecl_ferror(ECL_EX_V_CSETQ, var, ECL_NIL);
+}
+
+static void
+VEbinding_a_constant(cl_object var)
+{
+  ecl_ferror(ECL_EX_V_CBIND, var, ECL_NIL);
 }
 
 static void
 VEunbound_variable(cl_object var)
 {
-  FEunbound_variable(var);
+  ecl_ferror(ECL_EX_V_UNBND, var, ECL_NIL);
 }
 
 static void
-VEwrong_num_arguments(cl_object fname)
+VEillegal_variable_name(cl_object name)
 {
-  FEwrong_num_arguments(fname);
+  ecl_ferror(ECL_EX_V_BNAME, name, ECL_NIL);
+}
+
+static void
+VEwrong_num_arguments(cl_object fun)
+{
+  ecl_ferror(ECL_EX_F_NARGS, fun, ECL_NIL);
 }
 
 static void
 VEundefined_function(cl_object fun)
 {
-  FEundefined_function(fun);
+  ecl_ferror(ECL_EX_F_UNDEF, fun, ECL_NIL);
 }
 
 static void
 VEinvalid_function(cl_object fun)
 {
-  FEinvalid_function(fun);
-}
-
-static void
-VEclose_around_arg_type()
-{
-  FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0);
+  ecl_ferror(ECL_EX_F_INVAL, fun, ECL_NIL);
 }
 
 /* ------------------------------ LEXICAL ENV. ------------------------------ */
@@ -175,16 +181,22 @@ ecl_lex_env_get_record(cl_object env, int s)
 /* -- Lexical and local env operators ------------------------------------------ */
 
 static cl_object
-make_lex(cl_index n)
+make_lex(cl_index size)
 {
-  return si_make_vector(ECL_T, ecl_make_fixnum(n), ECL_NIL,
-                        ecl_make_fixnum(0), ECL_NIL, ECL_NIL);
+  cl_object x = ecl_alloc_object(t_vector);
+  x->vector.elttype = ecl_aet_object;
+  x->vector.displaced = ECL_NIL;
+  x->vector.dim = size;
+  x->vector.fillp = 0;
+  x->vector.flags = ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER;
+  x->vector.self.t = (cl_object *)ecl_alloc(size * sizeof(cl_object));
+  return x;
 }
 
 static void
 push_lex(cl_object stack, cl_object new)
 {
-  cl_vector_push(new, stack);
+  ecl_stack_push(stack, new);
 }
 
 /* -------------------- AIDS TO THE INTERPRETER -------------------- */
@@ -248,7 +260,7 @@ static cl_object
 close_around_self(cl_object fun) {
   cl_object v, template;
   if(ecl_t_of(fun) != t_bytecodes)
-    VEclose_around_arg_type();
+    VEinvalid_function(fun);
   template = fun->bytecodes.flex;
   if(Null(template)) return fun;
   /* Make a closure */
@@ -286,7 +298,7 @@ close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object lex_env) {
     fun->bclosure.lex = new_lex;
     break;
   default:
-    VEclose_around_arg_type();
+    VEinvalid_function(fun);
   }
 }
 
@@ -296,7 +308,7 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) {
   cl_object v, new_lex, template, entry;
   cl_fixnum nlex, idx, ndx;
   if(ecl_t_of(fun) != t_bytecodes)
-    VEclose_around_arg_type();
+    VEinvalid_function(fun);
   template = fun->bytecodes.flex;
   if(Null(template)) return fun;
   /* Close around */
@@ -322,6 +334,32 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) {
   return v;
 }
 
+cl_index
+ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
+{
+  cl_object vars = vars0, values = values0;
+  cl_index n = env->bds_stack.top - env->bds_stack.org;
+  for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
+    if (Null(vars)) {
+      return n;
+    } else {
+      cl_object var = ECL_CONS_CAR(vars);
+      if (!ECL_SYMBOLP(var) || Null(var))
+        VEillegal_variable_name(var);
+      if (var->symbol.stype & ecl_stp_constant)
+        VEbinding_a_constant(var);
+      if (Null(values)) {
+        ecl_bds_bind(env, var, OBJNULL);
+      } else {
+        ecl_bds_bind(env, var, ECL_CONS_CAR(values));
+        values = ECL_CONS_CDR(values);
+      }
+    }
+  }
+  VEwrong_args_progv(vars0, values0);
+  _ecl_unexpected_return();
+}
+
 static inline cl_object
 call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta)
 {
@@ -371,8 +409,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
   /* INV: bytecodes is of type t_bytecodes */
   lcl_env = ecl_cast_ptr(cl_object, &frame_lcl);
   ecl_cs_check(the_env, ihs);
-  ecl_ihs_push(the_env, &ihs, bytecodes, closure);
-  ecl_stack_frame_open(the_env, lcl_env, nlcl);
+  ecl_ihs_push(the_env, &ihs, bytecodes, closure, lcl_env);
+  if(nlcl) ecl_stack_frame_open(the_env, lcl_env, nlcl);
   frame_aux.t = t_frame;
   frame_aux.opened = 0;
   frame_aux.base = 0;
@@ -385,13 +423,21 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
       the_env->nvalues = 0;
       THREAD_NEXT;
     }
-    /* OP_QUOTE
+    /* OP_QUOTE     n{dat}
        Sets REG0 to an immediate value.
     */
     CASE(OP_QUOTE); {
       GET_DATA(reg0, vector, data);
       THREAD_NEXT;
     }
+    /* OP_CALLW     n{dat}
+       Calls the immediate value and sets REG0 to the result.
+    */
+    CASE(OP_CALLW); {
+      GET_DATA(reg0, vector, data);
+      ecl_apply_from_stack_frame(frame, reg0);
+      THREAD_NEXT;
+    }
     /* OP_VAR       n{lcl}
        OP_VARC      n{lex}
        OP_VARS      n{dat}
@@ -685,12 +731,12 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
         ptr = ECL_STACK_FRAME_PTR(frame) + frame_index;
         end = ptr + limit;
         for (; ptr != end; ptr++) {
-          if (*(ptr++) == @':allow-other-keys') {
+          if (*(ptr++) == ECL_ALLOW_OTHER_KEYS) {
             aok = *ptr;
             count -= 2;
             /* only the first :allow-other-keys argument is considered */
             for (ptr++; ptr != end; ptr++) {
-              if (*(ptr++) != @':allow-other-keys')
+              if (*(ptr++) != ECL_ALLOW_OTHER_KEYS)
                 break;
               count -= 2;
             }
@@ -709,7 +755,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
     */
     CASE(OP_EXIT); {
       ecl_ihs_pop(the_env);
-      ecl_stack_frame_close(lcl_env);
+      if(nlcl) ecl_stack_frame_close(lcl_env);
       return reg0;
     }
     /* OP_FLET      nfun{arg}, fun1{object}
@@ -1241,7 +1287,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
     CASE(OP_NTHVAL); {
       cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env));
       if (ecl_unlikely(n < 0)) {
-        VEwrong_arg_type_nth_val(n);
+        VEwrong_arg_type_nth_val();
       } else if ((cl_index)n >= the_env->nvalues) {
         reg0 = ECL_NIL;
       } else if (n) {

src/c/main.d

@@ -12,29 +12,10 @@
  *
  */
 
-/******************************** IMPORTS *****************************/
+/* -- Imports ------------------------------------------------------- */
 
 #include <ecl/ecl.h>
 #include <limits.h>
-#if defined(ECL_MS_WINDOWS_HOST)
-# include <windows.h>
-# include <shellapi.h>
-# define MAXPATHLEN 512
-#endif
-#ifndef MAXPATHLEN
-# ifdef PATH_MAX
-#   define MAXPATHLEN PATH_MAX
-# else
-#   define NO_PATH_MAX
-#   include <unistd.h>
-# endif
-#endif
-#ifdef ECL_USE_MPROTECT
-# include <sys/mman.h>
-# ifndef MAP_FAILED
-#  define MAP_FAILED -1
-# endif
-#endif
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
@@ -42,254 +23,14 @@
 #include <ecl/internal.h>
 #include <ecl/ecl-inl.h>
 
-
 #include "ecl_features.h"
 #include "iso_latin_names.h"
 
-/******************************* EXPORTS ******************************/
+/* -- Global Initialization ----------------------------------------- */
 
 const char *ecl_self;
-static struct cl_env_struct first_env;
-
-/************************ GLOBAL INITIALIZATION ***********************/
-
-
-/* HEAP */
-
-#if ECL_FIXNUM_BITS <= 32
-/* 1GB */
-#define HEAP_SIZE_DEFAULT 1073741824L
-#else
-/* 4GB */
-#define HEAP_SIZE_DEFAULT 4294967296L
-#endif
-
-
 static int ARGC;
 static char **ARGV;
-/* INV: see ecl_option enum in external.h */
-cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = {
-#ifdef GBC_BOEHM_GENGC
-  1,              /* ECL_OPT_INCREMENTAL_GC */
-#else
-  0,              /* ECL_OPT_INCREMENTAL_GC */
-#endif
-  1,              /* ECL_OPT_TRAP_SIGSEGV */
-  1,              /* ECL_OPT_TRAP_SIGFPE */
-  1,              /* ECL_OPT_TRAP_SIGINT */
-  1,              /* ECL_OPT_TRAP_SIGILL */
-  1,              /* ECL_OPT_TRAP_SIGBUS */
-  1,              /* ECL_OPT_TRAP_SIGPIPE */
-  1,              /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */
-#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
-  1,              /* ECL_OPT_SIGNAL_HANDLING_THREAD */
-#else
-  0,              /* ECL_OPT_SIGNAL_HANDLING_THREAD */
-#endif
-  16,             /* ECL_OPT_SIGNAL_QUEUE_SIZE */
-  0,              /* ECL_OPT_BOOTED */
-  8192,           /* ECL_OPT_BIND_STACK_SIZE */
-  1024,           /* ECL_OPT_BIND_STACK_SAFETY_AREA */
-  2048,           /* ECL_OPT_FRAME_STACK_SIZE */
-  128,            /* ECL_OPT_FRAME_STACK_SAFETY_AREA */
-  32768,          /* ECL_OPT_LISP_STACK_SIZE */
-  128,            /* ECL_OPT_LISP_STACK_SAFETY_AREA */
-  ECL_DEFAULT_C_STACK_SIZE, /* ECL_OPT_C_STACK_SIZE */
-  4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */
-  HEAP_SIZE_DEFAULT, /* ECL_OPT_HEAP_SIZE */
-  1024*1024,      /* ECL_OPT_HEAP_SAFETY_AREA */
-  0,              /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */
-  1,              /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */
-  1,              /* ECL_OPT_USE_SETMODE_ON_FILES */
-  0};
-
-#if !defined(GBC_BOEHM)
-static char stdin_buf[BUFSIZ];
-static char stdout_buf[BUFSIZ];
-#endif
-
-cl_fixnum
-ecl_get_option(int option)
-{
-  if (option >= ECL_OPT_LIMIT || option < 0) {
-    FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option));
-  }
-  return ecl_option_values[option];
-}
-
-void
-ecl_set_option(int option, cl_fixnum value)
-{
-  if (option > ECL_OPT_LIMIT || option < 0) {
-    FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option));
-  } else {
-    if (option < ECL_OPT_BOOTED &&
-        ecl_option_values[ECL_OPT_BOOTED]) {
-      FEerror("Cannot change option ~D while ECL is running",
-              1, ecl_make_fixnum(option));
-    } 
-    ecl_option_values[option] = value;
-  }
-}
-
-static void
-init_env_mp(cl_env_ptr env)
-{
-#if defined(ECL_THREADS)
-  env->cleanup = 0;
-#else
-  env->own_process = ECL_NIL;
-#endif
-}
-
-static void
-init_env_int(cl_env_ptr env)
-{
-  env->interrupt_struct = ecl_alloc(sizeof(*env->interrupt_struct));
-  env->interrupt_struct->pending_interrupt = ECL_NIL;
-#ifdef ECL_THREADS
-  ecl_mutex_init(&env->interrupt_struct->signal_queue_lock, FALSE);
-#endif
-  {
-    int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE];
-    env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size));
-  }
-  env->fault_address = env;
-  env->trap_fpe_bits = 0;
-}
-
-static void
-init_env_ffi(cl_env_ptr env)
-{
-#ifdef HAVE_LIBFFI
-  env->ffi_args_limit = 0;
-  env->ffi_types = 0;
-  env->ffi_values = 0;
-  env->ffi_values_ptrs = 0;
-#endif
-}
-
-static void
-init_env_aux(cl_env_ptr env)
-{
-  /* Reader */
-  env->string_pool = ECL_NIL;
-  env->packages_to_be_created = ECL_NIL;
-  env->packages_to_be_created_p = ECL_NIL;
-  /* Format (written in C) */
-#if !defined(ECL_CMU_FORMAT)
-  env->fmt_aux_stream = ecl_make_string_output_stream(64, 1);
-#endif
-  /* Bignum arithmetic */
-  ecl_init_bignum_registers(env);
-  /* Bytecodes compiler environment */
-  env->c_env = NULL;
-  /* CLOS caches */
-  env->method_cache = ecl_make_cache(64, 4096);
-  env->slot_cache = ecl_make_cache(3, 4096);
-}
-
-void
-ecl_init_first_env(cl_env_ptr env)
-{
-  env->default_sigmask = cl_core.default_sigmask;
-#ifdef ECL_THREADS
-  init_threads();
-#else
-  ecl_cs_init(env);
-#endif
-  init_env_mp(env);
-  init_env_int(env);
-  init_env_aux(env);
-  init_env_ffi(env);
-  init_stacks(env);
-}
-
-void
-ecl_init_env(cl_env_ptr env)
-{
-  init_env_mp(env);
-  init_env_int(env);
-  init_env_aux(env);
-  init_env_ffi(env);
-  init_stacks(env);
-}
-
-void
-_ecl_dealloc_env(cl_env_ptr env)
-{
-  /* Environment cleanup. This is required because the environment is allocated
-   * using mmap or some other method. */
-  free_stacks(env);
-#ifdef ECL_THREADS
-  ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock);
-#endif
-#if defined(ECL_USE_MPROTECT)
-  if (munmap(env, sizeof(*env)))
-    ecl_internal_error("Unable to deallocate environment structure.");
-#elif defined(ECL_USE_GUARD_PAGE)
-  if (!VirtualFree(env, 0, MEM_RELEASE))
-    ecl_internal_error("Unable to deallocate environment structure.");
-#else
-  ecl_free_unsafe(env);
-#endif
-}
-
-cl_env_ptr
-_ecl_alloc_env(cl_env_ptr parent)
-{
-  /*
-   * Allocates the lisp environment for a thread. Depending on which
-   * mechanism we use for detecting delayed signals, we may allocate
-   * the environment using mmap or the garbage collector.
-   *
-   * Note that at this point we are not allocating any other memory
-   * which is stored via a pointer in the environment. If we would do
-   * that, an unlucky interrupt by the gc before the allocated
-   * environment is registered in cl_core.processes could lead to
-   * memory being freed because the gc is not aware of the pointer to
-   * the allocated memory in the environment.
-   */
-  cl_env_ptr output;
-#if defined(ECL_USE_MPROTECT)
-  output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE,
-                             MAP_ANON | MAP_PRIVATE, -1, 0);
-  if (output == MAP_FAILED)
-    ecl_internal_error("Unable to allocate environment structure.");
-#else
-# if defined(ECL_USE_GUARD_PAGE)
-  output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, PAGE_READWRITE);
-  if (output == NULL)
-    ecl_internal_error("Unable to allocate environment structure.");
-# else
-  output = ecl_malloc(sizeof(*output));
-  if (output == NULL)
-    ecl_internal_error("Unable to allocate environment structure.");
-# endif
-#endif
-  {
-    size_t bytes = cl_core.default_sigmask_bytes;
-    if (bytes == 0) {
-      output->default_sigmask = 0;
-    } else if (parent) {
-      output->default_sigmask = ecl_alloc_atomic(bytes);
-      memcpy(output->default_sigmask, parent->default_sigmask, bytes);
-    } else {
-      output->default_sigmask = cl_core.default_sigmask;
-    }
-  }
-  for (cl_index i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
-    output->big_register[i] = ECL_NIL;
-  }
-  output->method_cache = output->slot_cache = NULL;
-  output->interrupt_struct = NULL;
-  /*
-   * An uninitialized environment _always_ disables interrupts. They
-   * are activated later on by the thread entry point or init_unixint().
-   */
-  output->disable_interrupts = 1;
-  return output;
-}
 
 void
 cl_shutdown(void)
@@ -310,11 +51,9 @@ cl_shutdown(void)
     ecl_tcp_close_all();
 #endif
   }
-  ecl_set_option(ECL_OPT_BOOTED, -1);
+  ecl_halt();
 }
 
-ecl_def_ct_single_float(default_rehash_size,1.5f,static,const);
-ecl_def_ct_single_float(default_rehash_threshold,0.75f,static,const);
 ecl_def_ct_base_string(str_common_lisp,"COMMON-LISP",11,static,const);
 ecl_def_ct_base_string(str_common_lisp_user,"COMMON-LISP-USER",16,static,const);
 ecl_def_ct_base_string(str_cl,"CL",2,static,const);
@@ -337,7 +76,6 @@ ecl_def_ct_base_string(str_gray,"GRAY",4,static,const);
 #endif
 ecl_def_ct_base_string(str_star_dot_star,"*.*",3,static,const);
 ecl_def_ct_base_string(str_rel_star_dot_star,"./*.*",5,static,const);
-ecl_def_ct_base_string(str_empty,"",0,static,const);
 ecl_def_ct_base_string(str_G,"G",1,static,const);
 ecl_def_ct_base_string(str_T,"T",1,static,const);
 #ifdef ENABLE_DLOPEN
@@ -352,22 +90,6 @@ ecl_def_ct_base_string(str_lsp,"lsp",3,static,const);
 ecl_def_ct_base_string(str_LSP,"LSP",3,static,const);
 ecl_def_ct_base_string(str_lisp,"lisp",4,static,const);
 ecl_def_ct_base_string(str_NIL,"NIL",3,static,const);
-ecl_def_ct_base_string(str_slash,"/",1,static,const);
-
-ecl_def_ct_single_float(flt_zero,0,static,const);
-ecl_def_ct_single_float(flt_zero_neg,-0.0,static,const);
-ecl_def_ct_double_float(dbl_zero,0,static,const);
-ecl_def_ct_double_float(dbl_zero_neg,-0.0,static,const);
-ecl_def_ct_long_float(ldbl_zero,0,static,const);
-ecl_def_ct_long_float(ldbl_zero_neg,-0.0l,static,const);
-ecl_def_ct_ratio(plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),static,const);
-ecl_def_ct_ratio(minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),static,const);
-ecl_def_ct_single_float(flt_one,1,static,const);
-ecl_def_ct_single_float(flt_one_neg,-1,static,const);
-ecl_def_ct_single_float(flt_two,2,static,const);
-ecl_def_ct_complex(flt_imag_unit,&flt_zero_data,&flt_one_data,static,const);
-ecl_def_ct_complex(flt_imag_unit_neg,&flt_zero_data,&flt_one_neg_data,static,const);
-ecl_def_ct_complex(flt_imag_two,&flt_zero_data,&flt_two_data,static,const);
 
 struct cl_core_struct cl_core = {
   .packages = ECL_NIL,
@@ -384,9 +106,6 @@ struct cl_core_struct cl_core = {
   .c_package = ECL_NIL,
   .ffi_package = ECL_NIL,
 
-  .pathname_translations = ECL_NIL,
-  .library_pathname = ECL_NIL,
-
   .terminal_io = ECL_NIL,
   .null_stream = ECL_NIL,
   .standard_input = ECL_NIL,
@@ -396,61 +115,13 @@ struct cl_core_struct cl_core = {
   .dispatch_reader = ECL_NIL,
 
   .char_names = ECL_NIL,
-  .null_string = (cl_object)&str_empty_data,
 
-  .plus_half = (cl_object)&plus_half_data,
-  .minus_half = (cl_object)&minus_half_data,
-  .imag_unit = (cl_object)&flt_imag_unit_data,
-  .minus_imag_unit = (cl_object)&flt_imag_unit_neg_data,
-  .imag_two = (cl_object)&flt_imag_two_data,
-  .singlefloat_zero = (cl_object)&flt_zero_data,
-  .doublefloat_zero = (cl_object)&dbl_zero_data,
-  .singlefloat_minus_zero = (cl_object)&flt_zero_neg_data,
-  .doublefloat_minus_zero = (cl_object)&dbl_zero_neg_data,
-  .longfloat_zero = (cl_object)&ldbl_zero_data,
-  .longfloat_minus_zero = (cl_object)&ldbl_zero_neg_data,
-
-  .gensym_prefix = (cl_object)&str_G_data,
-  .gentemp_prefix = (cl_object)&str_T_data,
+  .gensym_prefix = ECL_NIL,
+  .gentemp_prefix = ECL_NIL,
   .gentemp_counter = ecl_make_fixnum(0),
 
-  .Jan1st1970UT = ECL_NIL,
-
   .system_properties = ECL_NIL,
-
-  .first_env = &first_env,
-#ifdef ECL_THREADS
-  .processes = ECL_NIL,
-#endif
-  /* LIBRARIES is an adjustable vector of objects. It behaves as
-     a vector of weak pointers thanks to the magic in
-     gbc.d/alloc_2.d */
-  .libraries = ECL_NIL,
-
-  .max_heap_size = 0,
-  .bytes_consed = ECL_NIL,
-  .gc_counter = ECL_NIL,
-  .gc_stats = 0,
-  .path_max = 0,
-#ifdef GBC_BOEHM
-  .safety_region = NULL,
-#endif
-
-  .default_sigmask = NULL,
-  .default_sigmask_bytes = 0,
-
-#ifdef ECL_THREADS
-  .last_var_index = 0,
-  .reused_indices = ECL_NIL,
-#endif
-  .slash = (cl_object)&str_slash_data,
-
   .compiler_dispatch = ECL_NIL,
-
-  .rehash_size = (cl_object)&default_rehash_size_data,
-  .rehash_threshold = (cl_object)&default_rehash_threshold_data,
-
-  .known_signals = ECL_NIL
 };
 
 #if !defined(ECL_MS_WINDOWS_HOST)
@@ -475,6 +146,42 @@ maybe_fix_console_stream(cl_object stream)
 }
 #endif
 
+static void
+init_early_symbol(cl_object symbol, cl_object package) {
+  symbol->symbol.undef_entry = ecl_undefined_function_entry;
+  ECL_FMAKUNBOUND(symbol);
+  cl_import2(symbol, package);
+  cl_export2(symbol, package);
+}
+
+static void
+init_ecl_symbols()
+{
+  init_early_symbol(ECL_SIGNAL_HANDLERS, cl_core.system_package);
+  init_early_symbol(ECL_RESTART_CLUSTERS, cl_core.system_package);
+  init_early_symbol(ECL_INTERRUPTS_ENABLED, cl_core.system_package);
+  init_early_symbol(ECL_T, cl_core.lisp_package);
+  init_early_symbol(ECL_UNBOUND, cl_core.system_package);
+
+  /* SYSTEM:UNBOUND has an associated function si_unbound that returns it. */
+  ECL_SYM_FUN(ECL_UNBOUND)
+    = ecl_make_cfun((cl_objectfn_fixed)si_unbound, ECL_UNBOUND, NULL, 0);
+
+  /* Initialize the :ALLOW-OTHER-KEYS symbol (it is not part of cl_symbols). */
+  {
+    cl_object p = cl_core.keyword_package;
+    cl_object s = ECL_ALLOW_OTHER_KEYS;
+    cl_object n = s->symbol.name;
+    ECL_SET(s, OBJNULL);
+    ECL_FMAKUNBOUND(s);
+    s->symbol.hpack = p;
+    s->symbol.undef_entry = ecl_undefined_function_entry;
+    ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant);
+    ECL_SET(s, s);
+    p->pack.external = _ecl_sethash(n, p->pack.external, s);
+  }
+}
+
 int
 cl_boot(int argc, char **argv)
 {
@@ -482,39 +189,34 @@ cl_boot(int argc, char **argv)
   int i;
   cl_env_ptr env;
 
-  i = ecl_option_values[ECL_OPT_BOOTED];
-  if (i) {
-    if (i < 0) {
-      /* We have called cl_shutdown and want to use ECL again. */
-      ecl_set_option(ECL_OPT_BOOTED, 1);
-    }
-    return 1;
-  }
-
-  /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/
-
-#if !defined(GBC_BOEHM)
-  setbuf(stdin,  stdin_buf);
-  setbuf(stdout, stdout_buf);
-#endif
-  init_process();
+  i = ecl_boot();
+  if (i==1) return 1;
 
   ARGC = argc;
   ARGV = argv;
   ecl_self = argv[0];
 
-  init_unixint(0);
-  init_alloc(0);
-  init_big();
+  ecl_add_module(ecl_module_process);
+  ecl_add_module(ecl_module_stacks);
+  ecl_add_module(ecl_module_gc);
+  ecl_add_module(ecl_module_unixint);
+#ifdef ECL_THREADS
+  ecl_add_module(ecl_module_thread);
+#endif
+  ecl_add_module(ecl_module_bignum);
+  ecl_add_module(ecl_module_ffi);
+  ecl_add_module(ecl_module_aux);
 
   /*
    * Initialize the per-thread data.
    * This cannot come later, because we need to be able to bind
-   * ext::*interrupts-enabled* while creating packages.
+   * ECL_INTERRUPTS_ENABLED while creating packages.
    */
 
-  env = cl_core.first_env;
-  ecl_init_first_env(env);
+  env = ecl_core.first_env;
+
+  /* We need to enable GC because a lot of stuff is to be created */
+  ecl_module_gc->module.enable();
 
   /*
    * 1) Initialize symbols and packages
@@ -536,27 +238,8 @@ cl_boot(int argc, char **argv)
 #endif
   cl_num_symbols_in_core=1;
 
-  ECL_T->symbol.t = (short)t_symbol;
-  ECL_T->symbol.value = ECL_T;
-  ECL_T->symbol.name = str_T;
-  ECL_T->symbol.cname = ECL_NIL;
-  ECL_FMAKUNBOUND(ECL_T);
-  ECL_T->symbol.sfdef = ECL_NIL;
-  ECL_T->symbol.macfun = ECL_NIL;
-  ECL_T->symbol.plist = ECL_NIL;
-  ECL_T->symbol.hpack = ECL_NIL;
-  ECL_T->symbol.stype = ecl_stp_constant;
-  ECL_T->symbol.undef_entry = ecl_undefined_function_entry;
-#ifdef ECL_THREADS
-  ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
-#endif
-  cl_num_symbols_in_core=2;
-
-#ifdef NO_PATH_MAX
-  cl_core.path_max = sysconf(_PC_PATH_MAX);
-#else
-  cl_core.path_max = MAXPATHLEN;
-#endif
+  cl_core.gensym_prefix = (cl_object)&str_G_data;
+  cl_core.gentemp_prefix = (cl_object)&str_T_data;
 
   cl_core.lisp_package =
     ecl_make_package(str_common_lisp,
@@ -614,18 +297,16 @@ cl_boot(int argc, char **argv)
   cl_import2(ECL_NIL, cl_core.lisp_package);
   cl_export2(ECL_NIL, cl_core.lisp_package);
 
-  ECL_T->symbol.hpack = cl_core.lisp_package;
-  cl_import2(ECL_T, cl_core.lisp_package);
-  cl_export2(ECL_T, cl_core.lisp_package);
-
   /* At exit, clean up */
   atexit(cl_shutdown);
 
-  /* These must come _after_ the packages and NIL/T have been created */
+  /* These must come _after_ the packages have been created */
+  init_ecl_symbols();
   init_all_symbols();
 
-  /* We need to enable GC because a lot of stuff is to be created */
-  init_alloc(1);
+  /* Set the default exception handler that coerces exceptions to conditions
+     that are understood by the condition system. */
+  ECL_SET(ECL_SIGNAL_HANDLERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler')));
 
   /*
    * Set *default-pathname-defaults* to a temporary fake value. We
@@ -647,8 +328,8 @@ cl_boot(int argc, char **argv)
    */
   cl_core.char_names = aux =
     cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */
-                        cl_core.rehash_size,
-                        cl_core.rehash_threshold);
+                        ecl_ct_default_rehash_size,
+                        ecl_ct_default_rehash_threshold);
   for (i = 0; char_names[i].elt.self; i++) {
     cl_object name = (cl_object)(char_names + i);
     cl_object code = ecl_make_fixnum(i);
@@ -674,8 +355,8 @@ cl_boot(int argc, char **argv)
    */
   cl_core.system_properties =
     cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */
-                        cl_core.rehash_size,
-                        cl_core.rehash_threshold);
+                        ecl_ct_default_rehash_size,
+                        ecl_ct_default_rehash_threshold);
 
   ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T));
 
@@ -741,8 +422,8 @@ cl_boot(int argc, char **argv)
    */
   ECL_SET(@'si::*class-name-hash-table*',
           cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */
-                              cl_core.rehash_size,
-                              cl_core.rehash_threshold));
+                              ecl_ct_default_rehash_size,
+                              ecl_ct_default_rehash_threshold));
 
   /*
    * Features.
@@ -776,11 +457,56 @@ cl_boot(int argc, char **argv)
 
   /* Jump to top level */
   ECL_SET(@'*package*', cl_core.user_package);
-  init_unixint(1);
+  ecl_module_unixint->module.enable();
   return 1;
 }
 
-/************************* ENVIRONMENT ROUTINES ***********************/
+/* -- Module definition (auxiliary structures) ---------------------- */
+
+static cl_object
+create_aux()
+{
+  cl_env_ptr the_env = ecl_core.first_env;
+  the_env->method_cache = NULL;
+  the_env->slot_cache = NULL;
+  return ECL_NIL;
+}
+
+static cl_object
+init_env_aux(cl_env_ptr the_env)
+{
+  /* Reader */
+  the_env->string_pool = ECL_NIL;
+  the_env->packages_to_be_created = ECL_NIL;
+  the_env->packages_to_be_created_p = ECL_NIL;
+  /* Format (written in C) */
+#if !defined(ECL_CMU_FORMAT)
+  the_env->fmt_aux_stream = ecl_make_string_output_stream(64, 1);
+#endif
+  /* Bytecodes compiler environment */
+  the_env->c_env = NULL;
+  /* CLOS caches */
+  the_env->method_cache = ecl_make_cache(64, 4096);
+  the_env->slot_cache = ecl_make_cache(3, 4096);
+  return ECL_NIL;
+}
+
+ecl_def_ct_base_string(str_aux, "AUX", 3, static, const);
+
+static struct ecl_module module_aux = {
+  .name = str_aux,
+  .create = create_aux,
+  .enable = ecl_module_no_op,
+  .init_env = init_env_aux,
+  .init_cpu = ecl_module_no_op_env,
+  .free_cpu = ecl_module_no_op_cpu,
+  .free_env = ecl_module_no_op_env,
+  .disable = ecl_module_no_op,
+  .destroy = ecl_module_no_op
+};
+cl_object ecl_module_aux = (cl_object)&module_aux;
+
+/* -- Operating system environment routines ------------------------- */
 
 @(defun ext::quit (&optional (code ecl_make_fixnum(0)) (kill_all_threads ECL_T))
 @ {

src/c/mem_gc.d

@@ -0,0 +1,919 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/* mem_gc.d - automatic memory allocator and garbage collector based on bdwgc  */
+
+/* -- imports ---------------------------------------------------------------- */
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+
+#include <stdio.h>
+
+#ifdef ECL_THREADS
+# ifdef ECL_WINDOWS_THREADS
+#  include <windows.h>
+# else
+#  include <pthread.h>
+# endif
+#endif
+
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/page.h>
+
+#ifdef ECL_WSOCK
+# include <winsock.h>
+#endif
+
+#ifdef GBC_BOEHM
+# include <gc/gc_mark.h>
+#endif
+
+static void (*GC_old_start_callback)(void) = NULL;
+static void gather_statistics(void);
+static void update_bytes_consed(void);
+static void ecl_mark_env(struct cl_env_struct *env);
+
+#ifdef GBC_BOEHM_PRECISE
+# if GBC_BOEHM
+#  undef GBC_BOEHM_PRECISE
+# else
+#  include <gc/gc_typed.h>
+#  define GBC_BOEHM_OWN_MARKER
+static int cl_object_kind, cl_object_mark_proc_index;
+static void **cl_object_free_list;
+# endif
+#endif
+
+/* -- object allocation ------------------------------------------------------ */
+
+void
+_ecl_set_max_heap_size(size_t new_size)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  ecl_disable_interrupts_env(the_env);
+  GC_set_max_heap_size(ecl_core.max_heap_size = new_size);
+  if (new_size == 0) {
+    cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA];
+    ecl_core.safety_region = GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(size);
+  } else if (ecl_core.safety_region) {
+    GC_FREE(ecl_core.safety_region);
+    ecl_core.safety_region = 0;
+  }
+  ecl_enable_interrupts_env(the_env);
+}
+
+static int failure;
+static void *
+out_of_memory_check(size_t requested_bytes)
+{
+  failure = 1;
+  return 0;
+}
+
+static void
+no_warnings(char *msg, GC_word arg)
+{
+}
+
+static void *
+out_of_memory(size_t requested_bytes)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  int interrupts = the_env->disable_interrupts;
+  int method = 0;
+  void *output;
+  /* Disable interrupts only with the ECL_INTERRUPTS_ENABLED mechanism to allow
+   * for writes in the thread local environment */
+  if (interrupts)
+    ecl_enable_interrupts_env(the_env);
+  ecl_bds_bind(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);
+  /* Free the input / output buffers */
+  the_env->string_pool = ECL_NIL;
+
+  /* The out of memory condition may happen in more than one thread */
+  /* But then we have to ensure the error has not been solved */
+#ifdef ECL_THREADS
+  ecl_mutex_lock(&ecl_core.error_lock);
+  ECL_UNWIND_PROTECT_BEGIN(the_env)
+#endif
+  {
+    failure = 0;
+    GC_gcollect();
+    GC_set_oom_fn(out_of_memory_check);
+    {
+      output = GC_MALLOC(requested_bytes);
+      GC_set_oom_fn(out_of_memory);
+      if (output != 0 && failure == 0) {
+        method = 2;
+        goto OUTPUT;
+      }
+    }
+    if (ecl_core.max_heap_size == 0) {
+      /* We did not set any limit in the amount of memory,
+       * yet we failed, or we had some limits but we have
+       * not reached them. */
+      if (ecl_core.safety_region) {
+        /* We can free some memory and try handling the error */
+        GC_FREE(ecl_core.safety_region);
+        the_env->string_pool = ECL_NIL;
+        ecl_core.safety_region = 0;
+        method = 0;
+      } else {
+        /* No possibility of continuing */
+        method = 2;
+      }
+    } else {
+      ecl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA];
+      GC_set_max_heap_size(ecl_core.max_heap_size);
+      method = 1;
+    }
+  OUTPUT:
+    (void)0;
+  }
+#ifdef ECL_THREADS
+  ECL_UNWIND_PROTECT_EXIT {
+    ecl_mutex_unlock(&ecl_core.error_lock);
+  } ECL_UNWIND_PROTECT_END;
+#endif
+  ecl_bds_unwind1(the_env);
+  ecl_check_pending_interrupts(the_env);
+  switch (method) {
+  case 0: cl_error(1, @'ext::storage-exhausted');
+    break;
+  case 1: cl_cerror(2, @"Extend heap size", @'ext::storage-exhausted');
+    break;
+  case 2:
+    return output;
+  default:
+    ecl_internal_error("Memory exhausted, quitting program.");
+    break;
+  }
+  if (!interrupts)
+    ecl_disable_interrupts_env(the_env);
+  ecl_core.max_heap_size += (ecl_core.max_heap_size / 2);
+  GC_set_max_heap_size(ecl_core.max_heap_size);
+  /* Default allocation. Note that we do not allocate atomic. */
+  return GC_MALLOC(requested_bytes);
+}
+
+static struct bdw_type_information {
+  size_t size;
+#ifdef GBC_BOEHM_PRECISE
+  GC_word descriptor;
+#endif
+  cl_object (*allocator)(struct bdw_type_information *);
+  size_t t;
+} bdw_type_info[t_end];
+
+static cl_object
+allocate_object_error(struct bdw_type_information *bdw_type_info)
+{
+  printf("\ttype = %d\n", bdw_type_info->t);
+  ecl_internal_error("allocate_object_error: alloc botch.");
+}
+
+static cl_object
+allocate_object_atomic(struct bdw_type_information *bdw_type_info)
+{
+  return GC_MALLOC_ATOMIC(bdw_type_info->size);
+}
+
+static cl_object
+allocate_object_full(struct bdw_type_information *bdw_type_info)
+{
+  return GC_MALLOC(bdw_type_info->size);
+}
+
+#ifdef GBC_BOEHM_PRECISE
+static cl_object
+allocate_object_typed(struct bdw_type_information *bdw_type_info)
+{
+  return GC_malloc_explicitly_typed(bdw_type_info->size, bdw_type_info->descriptor);
+}
+#endif
+
+#ifdef GBC_BOEHM_OWN_MARKER
+
+static struct GC_ms_entry *
+cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl,
+                    GC_word env)
+{
+  cl_type t = ((cl_object)addr)->d.t;
+  if (ecl_likely(t > t_start && t < t_end)) {
+    struct bdw_type_information *info = bdw_type_info + t;
+    GC_word d = info->descriptor;
+    GC_word *p;
+    for (p = addr; d; p++, d<<=1) {
+      if ((GC_signed_word)d < 0) {
+        GC_word aux = *p;
+        if ((aux & 2) ||
+            aux <= (GC_word)GC_least_plausible_heap_addr ||
+            aux >= (GC_word)GC_greatest_plausible_heap_addr)
+          continue;
+        msp = GC_mark_and_push((void*)aux, (void*)msp,
+                               (void*)msl, (void*)p);
+      }
+    }
+  }
+  return msp;
+}
+
+static cl_object
+allocate_object_marked(struct bdw_type_information *bdw_type_info)
+{
+  return GC_generic_malloc(bdw_type_info->size, cl_object_kind);
+}
+#endif
+
+/* -- weak pointers ---------------------------------------------------------- */
+
+cl_object
+ecl_alloc_weak_pointer(cl_object o)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  struct ecl_weak_pointer *obj;
+  ecl_disable_interrupts_env(the_env);
+  obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer));
+  ecl_enable_interrupts_env(the_env);
+  obj->t = t_weak_pointer;
+  obj->value = o;
+  if (!ECL_IMMEDIATE(o)) {
+    GC_GENERAL_REGISTER_DISAPPEARING_LINK((void**)&(obj->value), (void*)o);
+    si_set_finalizer((cl_object)obj, ECL_T);
+  }
+  return (cl_object)obj;
+}
+
+static cl_object
+ecl_weak_pointer_value(cl_object o)
+{
+  return ecl_weak_pointer(o);
+}
+
+cl_object
+si_make_weak_pointer(cl_object o)
+{
+  cl_object pointer = ecl_alloc_weak_pointer(o);
+  @(return pointer);
+}
+
+cl_object
+si_weak_pointer_value(cl_object o)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  cl_object value;
+  if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer))
+    FEwrong_type_only_arg(@[ext::weak-pointer-value], o,
+                          @[ext::weak-pointer]);
+  value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o);
+  if (value) {
+    ecl_return2(the_env, value, ECL_T);
+  } else {
+    ecl_return2(the_env, ECL_NIL, ECL_NIL);
+  }
+}
+
+/* -- graph traversal -------------------------------------------------------- */
+
+void init_bdw_type_info (void)
+{
+  int i;
+  for (i = 0; i < t_end; i++) {
+    uintmax_t desc = ecl_type_info[i].descriptor;
+    bdw_type_info[i].t = i;
+    bdw_type_info[i].size = ecl_type_info[i].size;
+    bdw_type_info[i].allocator =
+      (desc==0) ? allocate_object_atomic : allocate_object_full;
+#ifdef GC_BOEHM_PRECISE
+    bdw_type_info[t_list].descriptor = desc;
+#endif
+  }
+#ifdef GC_BOEHM_PRECISE
+  for (i = 0; i < t_end; i++) {
+    GC_word descriptor = bdw_type_info[i].descriptor;
+    int bits = bdw_type_info[i].size / sizeof(GC_word);
+    if (descriptor) {
+#ifdef GBC_BOEHM_OWN_MARKER
+      bdw_type_info[i].allocator = allocate_object_marked;
+      descriptor = GC_make_descriptor(&descriptor, bits);
+      descriptor &= ~GC_DS_TAGS;
+#else
+      GC_word mask = (1 << (bits-1)) - 1;
+      mask ^= (descriptor >> 1);
+      bdw_type_info[i].allocator =
+        (mask == 0) ? allocate_object_full : allocate_object_typed;
+      descriptor = GC_make_descriptor(&descriptor, bits);
+#endif
+      bdw_type_info[i].descriptor = descriptor;
+    }
+  }
+#endif /* GBC_BOEHM_PRECISE */
+  /* INV these cases are handled inline in ecl_alloc_object. */
+  bdw_type_info[t_list].allocator = allocate_object_error;
+  bdw_type_info[t_character].allocator = allocate_object_error;
+  bdw_type_info[t_fixnum].allocator = allocate_object_error;
+}
+
+extern void (*GC_push_other_roots)();
+static void (*old_GC_push_other_roots)();
+static void stacks_scanner();
+
+/* -- finalization ----------------------------------------------------------- */
+
+static void
+standard_finalizer(cl_object o)
+{
+  switch (o->d.t) {
+#ifdef ENABLE_DLOPEN
+  case t_codeblock:
+    ecl_library_close(o);
+    break;
+#endif
+  case t_stream:
+    cl_close(1, o);
+    break;
+  case t_weak_pointer:
+    GC_unregister_disappearing_link((void**)&(o->weak.value));
+    break;
+#if 0
+  case t_bclosure: {
+    ecl_free_stack(o->bclosure.lex);
+    o->bclosure.lex = ECL_NIL;
+    break;
+  }
+#endif
+#ifdef ECL_THREADS
+  case t_lock: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_mutex_destroy(&o->lock.mutex);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_condition_variable: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_cond_var_destroy(&o->condition_variable.cv);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_barrier: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_mutex_destroy(&o->barrier.mutex);
+    ecl_cond_var_destroy(&o->barrier.cv);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_semaphore: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_mutex_destroy(&o->semaphore.mutex);
+    ecl_cond_var_destroy(&o->semaphore.cv);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_mailbox: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_mutex_destroy(&o->mailbox.mutex);
+    ecl_cond_var_destroy(&o->mailbox.reader_cv);
+    ecl_cond_var_destroy(&o->mailbox.writer_cv);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_rwlock: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_rwlock_destroy(&o->rwlock.mutex);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_process: {
+    const cl_env_ptr the_env = ecl_process_env();
+    ecl_disable_interrupts_env(the_env);
+    ecl_mutex_destroy(&o->process.start_stop_lock);
+    ecl_cond_var_destroy(&o->process.exit_barrier);
+    ecl_enable_interrupts_env(the_env);
+    break;
+  }
+  case t_symbol: {
+    if (o->symbol.binding != ECL_MISSING_SPECIAL_BINDING) {
+      ecl_atomic_push(&ecl_core.reused_indices, ecl_make_fixnum(o->symbol.binding));
+      o->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
+    }
+    break;
+  }
+#endif /* ECL_THREADS */
+  default:;
+  }
+}
+
+static void
+wrapped_finalizer(cl_object o, cl_object finalizer);
+
+static void
+register_finalizer(cl_object o, void *finalized_object,
+                   GC_finalization_proc fn, void *cd,
+                   GC_finalization_proc *ofn, void **ocd)
+{
+  /* Finalizers for some builtin objects are only run when the object is not
+   * reachable by any means, including through other finalizers which might
+   * make the object reachable again. The objects must not contain any cyclic
+   * references for which finalizers are registered.
+   *
+   * We don't use this type of finalizer for user-defined finalizers, because
+   * those might contain cyclic references which would prevent the objects
+   * from being garbage collected. It is instead the duty of the user to write
+   * the finalizers in a consistent way.
+   *
+   * case t_symbol: is not finalized with the "unreachable" finalizer because
+   * it might contain cyclic references; Also running the finalizer too early
+   * doesn't lead to any problems, we will simply choose a new binding index
+   * the next time a binding is established. */
+  switch (o->d.t) {
+#ifdef ENABLE_DLOPEN
+  case t_codeblock:
+#endif
+  case t_stream:
+#if defined(ECL_THREADS)
+  case t_lock:
+  case t_condition_variable:
+  case t_barrier:
+  case t_semaphore:
+  case t_mailbox:
+  case t_rwlock:
+  case t_process:
+#endif  /* ECL_THREADS */
+    /* Don't delete the standard finalizer. */
+    if (fn == NULL) {
+      fn = (GC_finalization_proc)wrapped_finalizer;
+      cd = ECL_T;
+    }
+    GC_REGISTER_FINALIZER_UNREACHABLE(finalized_object, fn, cd, ofn, ocd);
+    break;
+  case t_weak_pointer:
+#if defined(ECL_THREADS)
+  case t_symbol:
+#endif
+    /* Don't delete the standard finalizer. */
+    if (fn == NULL) {
+      fn = (GC_finalization_proc)wrapped_finalizer;
+      cd = ECL_T;
+    }
+    /* fallthrough */
+  default:
+    GC_REGISTER_FINALIZER_NO_ORDER(finalized_object, fn, cd, ofn, ocd);
+    break;
+  }
+}
+
+static void
+deferred_finalizer(cl_object* x)
+{
+  wrapped_finalizer(x[0], x[1]);
+}
+
+static void
+wrapped_finalizer(cl_object o, cl_object finalizer)
+{
+  if (finalizer != ECL_NIL && finalizer != NULL) {
+#ifdef ECL_THREADS
+    const cl_env_ptr the_env = ecl_process_env_unsafe();
+    if (!the_env
+        || !the_env->own_process
+        || the_env->own_process->process.phase < ECL_PROCESS_ACTIVE)
+    {
+       /*
+        * The finalizer is invoked while we are registering or setup a
+        * new lisp process.  As example that may happen when we are
+        * doing ecl_import_current_thread.  That mean the finalizer
+        * can not be executed right now, so in some way we need to
+        * queue the finalization.  When we return from this function
+        * the original finalizer is no more registered to o, and if o
+        * is not anymore reachable it will be colleted.  To prevent
+        * this we need to make this object reachable again after that
+        * roundtrip and postpone the finalization to the next garbage
+        * collection.  Given that this is a rare condition one way to
+        * do that is:
+        */
+       GC_finalization_proc ofn;
+       void *odata;
+       cl_object* wrapper = GC_MALLOC(2*sizeof(cl_object));
+       wrapper[0] = o;
+       wrapper[1] = finalizer;
+
+       register_finalizer(o, wrapper,
+                          (GC_finalization_proc)deferred_finalizer, 0,
+                          &ofn, &odata);
+       return;
+    }
+#endif /* ECL_THREADS */
+    CL_NEWENV_BEGIN {
+      if (finalizer != ECL_T) {
+        funcall(2, finalizer, o);
+      }
+      standard_finalizer(o);
+    } CL_NEWENV_END;
+  }
+}
+
+cl_object
+si_get_finalizer(cl_object o)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  cl_object output;
+  GC_finalization_proc ofn;
+  void *odata;
+  ecl_disable_interrupts_env(the_env);
+  register_finalizer(o, o, (GC_finalization_proc)0, 0, &ofn, &odata);
+  if (ofn == 0) {
+    output = ECL_NIL;
+  } else if (ofn == (GC_finalization_proc)wrapped_finalizer) {
+    output = (cl_object)odata;
+  } else {
+    output = ECL_NIL;
+  }
+  register_finalizer(o, o, ofn, odata, &ofn, &odata);
+  ecl_enable_interrupts_env(the_env);
+  @(return output);
+}
+
+void
+ecl_set_finalizer_unprotected(cl_object o, cl_object finalizer)
+{
+  GC_finalization_proc ofn;
+  void *odata;
+  if (finalizer == ECL_NIL) {
+    register_finalizer(o, o, (GC_finalization_proc)0, 0, &ofn, &odata);
+  } else {
+    GC_finalization_proc newfn;
+    newfn = (GC_finalization_proc)wrapped_finalizer;
+    register_finalizer(o, o, newfn, finalizer, &ofn, &odata);
+  }
+}
+
+cl_object
+si_set_finalizer(cl_object o, cl_object finalizer)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  ecl_disable_interrupts_env(the_env);
+  ecl_set_finalizer_unprotected(o, finalizer);
+  ecl_enable_interrupts_env(the_env);
+  @(return);
+}
+
+/* -- GC stats --------------------------------------------------------------- */
+
+/* If we do not build our own version of the library, we do not have
+ * control over the existence of this variable. */
+#if GBC_BOEHM == 0
+extern int GC_print_stats;
+#else
+static int GC_print_stats;
+#endif
+
+cl_object
+si_gc_stats(cl_object enable)
+{
+  cl_object old_status;
+  cl_object size1;
+  cl_object size2;
+  if (ecl_core.gc_stats == 0) {
+    old_status = ECL_NIL;
+  } else if (GC_print_stats) {
+    old_status = @':full';
+  } else {
+    old_status = ECL_T;
+  }
+  if (ecl_core.bytes_consed == ECL_NIL) {
+    ecl_core.bytes_consed = ecl_alloc_object(t_bignum);
+    mpz_init2(ecl_bignum(ecl_core.bytes_consed), 128);
+    ecl_core.gc_counter = ecl_alloc_object(t_bignum);
+    mpz_init2(ecl_bignum(ecl_core.gc_counter), 128);
+  }
+
+  update_bytes_consed();
+  /* We need fresh copies of the bignums */
+  size1 = _ecl_big_register_copy(ecl_core.bytes_consed);
+  size2 = _ecl_big_register_copy(ecl_core.gc_counter);
+
+  if (enable == ECL_NIL) {
+    GC_print_stats = 0;
+    ecl_core.gc_stats = 0;
+  } else if (enable == ecl_make_fixnum(0)) {
+    mpz_set_ui(ecl_bignum(ecl_core.bytes_consed), 0);
+    mpz_set_ui(ecl_bignum(ecl_core.gc_counter), 0);
+  } else {
+    ecl_core.gc_stats = 1;
+    GC_print_stats = (enable == @':full');
+  }
+  @(return size1 size2 old_status);
+}
+
+/* This procedure is invoked after garbage collection. Note that we
+ * cannot cons because this procedure is invoked with the garbage
+ * collection lock on. */
+static void
+gather_statistics()
+{
+  /* GC stats rely on bignums */
+  if (ecl_core.gc_stats) {
+    update_bytes_consed();
+    mpz_add_ui(ecl_bignum(ecl_core.gc_counter),
+               ecl_bignum(ecl_core.gc_counter),
+               1);
+  }
+  if (GC_old_start_callback)
+    GC_old_start_callback();
+}
+
+static void
+update_bytes_consed () {
+#if GBC_BOEHM == 0
+  mpz_add_ui(ecl_bignum(ecl_core.bytes_consed),
+             ecl_bignum(ecl_core.bytes_consed),
+             GC_get_bytes_since_gc());
+#else
+  /* This is not accurate and may wrap around. We try to detect this
+     assuming that an overflow in an unsigned integer will produce
+     a smaller integer.*/
+  static cl_index bytes = 0;
+  cl_index new_bytes = GC_get_total_bytes();
+  if (bytes > new_bytes) {
+    cl_index wrapped;
+    wrapped = ~((cl_index)0) - bytes;
+    mpz_add_ui(ecl_bignum(ecl_core.bytes_consed),
+               ecl_bignum(ecl_core.bytes_consed),
+               wrapped);
+    mpz_add_ui(ecl_bignum(ecl_core.bytes_consed),
+               ecl_bignum(ecl_core.bytes_consed),
+               new_bytes);
+  } else {
+    mpz_add_ui(ecl_bignum(ecl_core.bytes_consed),
+               ecl_bignum(ecl_core.bytes_consed),
+               new_bytes - bytes);
+  }
+  bytes = new_bytes;
+#endif
+}
+
+/* -- garbage collection ----------------------------------------------------- */
+
+static void
+ecl_mark_env(struct cl_env_struct *env)
+{
+  /* Environments and stacks are allocated without GC */
+  if (env->run_stack.org)
+    GC_push_all((void *)env->run_stack.org, (void *)env->run_stack.top);
+  if (env->frs_stack.org)
+    GC_push_all((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1));
+  if (env->bds_stack.org)
+    GC_push_all((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1));
+#ifdef ECL_THREADS
+  if (env->bds_stack.tl_bindings)
+    GC_push_all((void *)env->bds_stack.tl_bindings,
+                (void *)(env->bds_stack.tl_bindings
+                         + env->bds_stack.tl_bindings_size));
+#endif
+  GC_push_all((void *)env, (void *)(env + 1));
+}
+
+static void
+stacks_scanner()
+{
+  cl_object l = ecl_core.libraries;
+  loop_for_on_unsafe(l) {
+    cl_object dll = ECL_CONS_CAR(l);
+    if (dll->cblock.locked) {
+      GC_push_conditional((void *)dll, (void *)(&dll->cblock + 1), 1);
+      GC_set_mark_bit((void *)dll);
+    }
+  } end_loop_for_on_unsafe(l);
+  /* ECL runtime */
+  GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1));
+  GC_push_all((void *)(ECL_SIGNAL_HANDLERS),
+              (void *)(ECL_SIGNAL_HANDLERS + 1));
+  /* Common Lisp */
+  GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1));
+  GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core));
+  ecl_mark_env(ecl_core.first_env);
+#ifdef ECL_THREADS
+  loop_across_stack_fifo(_env, ecl_core.threads) {
+    cl_env_ptr env = ecl_cast_ptr(cl_env_ptr, _env);
+    if(env != ecl_core.first_env)
+      ecl_mark_env(env);
+  } end_loop_across_stack();
+#endif
+  if (old_GC_push_other_roots)
+    (*old_GC_push_other_roots)();
+}
+
+void
+ecl_register_root(cl_object *p)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  ecl_disable_interrupts_env(the_env);
+  GC_add_roots((char*)p, (char*)(p+1));
+  ecl_enable_interrupts_env(the_env);
+}
+
+cl_object
+si_gc(cl_narg narg, ...)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  ecl_disable_interrupts_env(the_env);
+  GC_gcollect();
+  ecl_enable_interrupts_env(the_env);
+  @(return);
+}
+
+cl_object
+si_gc_dump()
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  ecl_disable_interrupts_env(the_env);
+  GC_dump();
+  ecl_enable_interrupts_env(the_env);
+  @(return);
+}
+
+/* -- module definition ------------------------------------------------------ */
+
+static cl_object
+alloc_object(cl_type t)
+{
+  struct bdw_type_information *ti = bdw_type_info + t;
+  return ti->allocator(ti);
+}
+
+static void *
+alloc_memory(cl_index size)
+{
+  return GC_MALLOC(size);
+}
+
+static void *
+alloc_manual(cl_index size)
+{
+  return GC_MALLOC_UNCOLLECTABLE(size);
+}
+
+static void *
+alloc_atomic(cl_index size)
+{
+  return GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(size);
+}
+
+void
+free_memory(void *ptr)
+{
+  GC_FREE(ptr);
+}
+
+static void
+free_object(cl_object o)
+{
+  standard_finalizer(o);
+  free_memory(o);
+}
+
+struct ecl_allocator_ops gc_ops = {
+  .allocate_memory = alloc_memory,
+  .allocate_atomic = alloc_atomic,
+  .allocate_manual = alloc_manual,
+  .allocate_object = alloc_object,
+  .free_memory = free_memory,
+  .free_object = free_object
+};
+
+static cl_object
+create_gc()
+{
+  /*
+   * Garbage collector restrictions: we set up the garbage collector
+   * library to work as follows
+   *
+   * 1) The garbage collector shall not scan shared libraries
+   *    explicitely.
+   * 2) We only detect objects that are referenced by a pointer to
+   *    the begining or to the first byte.
+   * 3) Out of the incremental garbage collector, we only use the
+   *    generational component.
+   * 4) GC should handle fork() which is used to run subprocess on
+   *    some platforms.
+   */
+  GC_set_no_dls(1);
+  GC_set_all_interior_pointers(0);
+  GC_set_time_limit(GC_TIME_UNLIMITED);
+#ifndef ECL_MS_WINDOWS_HOST
+  GC_set_handle_fork(1);
+#endif
+  GC_init();
+#ifdef ECL_THREADS
+# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1
+  GC_allow_register_threads();
+# endif
+#endif
+  if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) {
+    GC_enable_incremental();
+  }
+  GC_register_displacement(1);
+  GC_clear_roots();
+  GC_disable();
+
+#ifdef GBC_BOEHM_PRECISE
+# ifdef GBC_BOEHM_OWN_MARKER
+  cl_object_free_list = (void **)GC_new_free_list_inner();
+  cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc);
+  cl_object_kind = GC_new_kind_inner(cl_object_free_list,
+                                     GC_MAKE_PROC(cl_object_mark_proc_index, 0),
+                                     FALSE, TRUE);
+# endif
+#endif /* !GBC_BOEHM_PRECISE */
+  ecl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE];
+  GC_set_max_heap_size(ecl_core.max_heap_size);
+  /* Save some memory for the case we get tight. */
+  if (ecl_core.max_heap_size == 0) {
+    cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA];
+    ecl_core.safety_region = GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(size);
+  } else if (ecl_core.safety_region) {
+    ecl_core.safety_region = 0;
+  }
+
+  init_bdw_type_info();
+
+  old_GC_push_other_roots = GC_push_other_roots;
+  GC_push_other_roots = stacks_scanner;
+  GC_old_start_callback = GC_get_start_callback();
+  GC_set_start_callback(gather_statistics);
+  GC_set_java_finalization(1);
+  GC_set_oom_fn(out_of_memory);
+  GC_set_warn_proc(no_warnings);
+
+  ecl_core.allocator = &gc_ops;
+
+  return ECL_NIL;
+}
+
+static cl_object
+enable_gc ()
+{
+  GC_enable();
+  return ECL_NIL;
+}
+
+static cl_object
+disable_gc ()
+{
+  GC_disable();
+  return ECL_NIL;
+}
+
+static cl_object
+init_cpu(cl_env_ptr the_env)
+{
+#ifdef GBC_BOEHM
+  struct GC_stack_base stack;
+  GC_get_stack_base(&stack);
+  the_env->c_stack.org = (char*)stack.mem_base;
+# ifdef ECL_THREADS
+  if (GC_thread_is_registered() == 0) {
+    GC_register_my_thread(&stack);
+  }
+# endif
+#endif
+  return ECL_NIL;
+}
+
+static cl_object
+free_cpu()
+{
+#ifdef GBC_BOEHM
+# ifdef ECL_THREADS
+  if (GC_thread_is_registered() == 1) {
+    GC_unregister_my_thread();
+  }
+# endif
+#endif
+  return ECL_NIL;
+}
+
+ecl_def_ct_base_string(str_gc, "GC", 2, static, const);
+
+static struct ecl_module module_gc = {
+  .name = str_gc,
+  .create = create_gc,
+  .enable = enable_gc,
+  .init_env = ecl_module_no_op_env,
+  .init_cpu = init_cpu,
+  .free_cpu = free_cpu,
+  .free_env = ecl_module_no_op_env,
+  .disable = disable_gc,
+  .destroy = ecl_module_no_op
+};
+
+cl_object ecl_module_gc = (cl_object)&module_gc;

src/c/memory.d

@@ -2,7 +2,7 @@
 /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
 
 /*
- * memory.c - manual memory managament
+ * memory.c - memory managament
  *
  * Copyright (c) 2024 Daniel Kochmański
  *
@@ -32,22 +32,13 @@ out_of_memory()
        goto AGAIN;
 
      For now let's crash with an appropriate error. */
-  ecl_internal_error("*** manual memory allocator: out of memory\n");
+  ecl_internal_error("*** memory allocator: out of memory\n");
 }
 
 void *
 ecl_malloc(cl_index n)
 {
-  /* GC-free equivalent of ecl_alloc_atomic. */
-  const cl_env_ptr the_env = ecl_process_env_unsafe();
-  void *ptr;
-  if (!the_env) {
-    ptr = malloc(n);
-  } else {
-    ecl_disable_interrupts_env(the_env);
-    ptr = malloc(n);
-    ecl_enable_interrupts_env(the_env);
-  }
+  void *ptr = malloc(n);
   if (ptr == NULL) out_of_memory();
   return ptr;
 }
@@ -55,23 +46,15 @@ ecl_malloc(cl_index n)
 void
 ecl_free(void *ptr)
 {
-  const cl_env_ptr the_env = ecl_process_env_unsafe();
-  if (!the_env) {
-    free(ptr);
-  } else {
-    ecl_disable_interrupts_env(the_env);
-    free(ptr);
-    ecl_enable_interrupts_env(the_env);
-  }
+  free(ptr);
 }
 
 void *
 ecl_realloc(void *ptr, cl_index osize, cl_index nsize)
 {
-  void *p = ecl_malloc(nsize);
-  ecl_copy(p, ptr, (osize < nsize) ? osize : nsize);
-  ecl_free(ptr);
-  return p;
+  ptr = realloc(ptr, nsize);
+  if (ptr == NULL) out_of_memory();
+  return ptr;
 }
 
 void
@@ -79,3 +62,398 @@ ecl_copy(void *dst, void *src, cl_index ndx)
 {
   memcpy(dst, src, ndx);
 }
+
+void
+ecl_mset(void *ptr, byte c, cl_index n)
+{
+  memset(ptr, c, n);
+}
+
+/* -- Object database ------------------------------------------------------- */
+struct ecl_type_information ecl_type_info[t_end];
+
+static void
+assert_type_tag(cl_type t)
+{
+  if (ecl_unlikely(t <= t_start || t >= t_end)) {
+    printf("\ttype = %d\n", t);
+    ecl_internal_error("Collector called with invalid tag number.");
+  }
+}
+
+cl_index
+ecl_object_byte_size(cl_type t)
+{
+  assert_type_tag(t);
+  return ecl_type_info[t].size;
+}
+
+static void
+init_type_info(cl_type type, const char *name, cl_index size, uintmax_t desc)
+{
+  ecl_type_info[type].name = name;
+  ecl_type_info[type].size = size;
+  ecl_type_info[type].descriptor = desc;
+}
+
+/* Note that a bitmap in some cases describe pointers that are not ~cl_object~,
+   like ~vector.self.t~ and ~readtable.table~. */
+static cl_index
+to_bitmap(void *x, void *y)
+{
+  cl_index n = (char*)y - (char*)x;
+  if (n % sizeof(void*))
+    ecl_internal_error("Misaligned pointer in ECL structure.");
+  n /= sizeof(void*);
+  return 1 << n;
+}
+
+#define init_tm(type, name, struct_name, descriptor)            \
+  init_type_info(type, name, sizeof(struct struct_name), descriptor)
+
+static void
+init_type_info_database(void)
+{
+  union cl_lispunion o;
+  struct ecl_cons c;
+  int i;
+  for (i = 0; i < t_end; i++) {
+    ecl_type_info[i].t = i;
+    ecl_type_info[i].size = 0;
+    ecl_type_info[i].descriptor = 0;
+  }
+  ecl_type_info[t_character].name = "CHARACTER";
+  ecl_type_info[t_fixnum].name = "FIXNUM";
+  init_tm(t_list, "CONS", ecl_cons,
+          to_bitmap(&c, &(c.car)) |
+          to_bitmap(&c, &(c.cdr)));
+  init_tm(t_bignum, "BIGNUM", ecl_bignum,
+          to_bitmap(&o, &(ECL_BIGNUM_LIMBS(&o))));
+  init_tm(t_ratio, "RATIO", ecl_ratio,
+          to_bitmap(&o, &(o.ratio.num)) |
+          to_bitmap(&o, &(o.ratio.den)));
+  init_tm(t_singlefloat, "SINGLE-FLOAT", ecl_singlefloat, 0);
+  init_tm(t_doublefloat, "DOUBLE-FLOAT", ecl_doublefloat, 0);
+  init_tm(t_longfloat, "LONG-FLOAT", ecl_long_float, 0);
+  init_tm(t_complex, "COMPLEX", ecl_complex,
+          to_bitmap(&o, &(o.gencomplex.real)) |
+          to_bitmap(&o, &(o.gencomplex.imag)));
+#ifdef ECL_COMPLEX_FLOAT
+  init_tm(t_csfloat, "COMPLEX-SINGLE-FLOAT", ecl_csfloat, 0);
+  init_tm(t_cdfloat, "COMPLEX-DOUBLE-FLOAT", ecl_cdfloat, 0);
+  init_tm(t_clfloat, "COMPLEX-LONG-FLOAT", ecl_clfloat, 0);
+#endif
+  init_tm(t_symbol, "SYMBOL", ecl_symbol,
+          to_bitmap(&o, &(o.symbol.value)) |
+          to_bitmap(&o, &(o.symbol.gfdef)) |
+          to_bitmap(&o, &(o.symbol.macfun)) |
+          to_bitmap(&o, &(o.symbol.sfdef)) |
+          to_bitmap(&o, &(o.symbol.plist)) |
+          to_bitmap(&o, &(o.symbol.name)) |
+          to_bitmap(&o, &(o.symbol.hpack)));
+  init_tm(t_package, "PACKAGE", ecl_package,
+          to_bitmap(&o, &(o.pack.name)) |
+          to_bitmap(&o, &(o.pack.nicknames)) |
+          to_bitmap(&o, &(o.pack.local_nicknames)) |
+          to_bitmap(&o, &(o.pack.nicknamedby)) |
+          to_bitmap(&o, &(o.pack.shadowings)) |
+          to_bitmap(&o, &(o.pack.uses)) |
+          to_bitmap(&o, &(o.pack.usedby)) |
+          to_bitmap(&o, &(o.pack.internal)) |
+          to_bitmap(&o, &(o.pack.external)));
+  init_tm(t_hashtable, "HASH-TABLE", ecl_hashtable,
+          to_bitmap(&o, &(o.hash.data)) |
+          to_bitmap(&o, &(o.hash.sync_lock)) |
+          to_bitmap(&o, &(o.hash.generic_test)) |
+          to_bitmap(&o, &(o.hash.generic_hash)) |
+          to_bitmap(&o, &(o.hash.rehash_size)) |
+          to_bitmap(&o, &(o.hash.threshold)));
+  init_tm(t_array, "ARRAY", ecl_array,
+          to_bitmap(&o, &(o.array.dims)) |
+          to_bitmap(&o, &(o.array.self.t)) |
+          to_bitmap(&o, &(o.array.displaced)));
+  init_tm(t_vector, "VECTOR", ecl_vector,
+          to_bitmap(&o, &(o.vector.self.t)) |
+          to_bitmap(&o, &(o.vector.displaced)));
+#ifdef ECL_UNICODE
+  init_tm(t_string, "STRING", ecl_string,
+          to_bitmap(&o, &(o.string.self)) |
+          to_bitmap(&o, &(o.string.displaced)));
+#endif
+  init_tm(t_base_string, "BASE-STRING", ecl_base_string,
+          to_bitmap(&o, &(o.base_string.self)) |
+          to_bitmap(&o, &(o.base_string.displaced)));
+  init_tm(t_bitvector, "BIT-VECTOR", ecl_vector,
+          to_bitmap(&o, &(o.vector.self.t)) |
+          to_bitmap(&o, &(o.vector.displaced)));
+  init_tm(t_stream, "STREAM", ecl_stream,
+          to_bitmap(&o, &(o.stream.ops)) |
+          to_bitmap(&o, &(o.stream.object0)) |
+          to_bitmap(&o, &(o.stream.object1)) |
+          to_bitmap(&o, &(o.stream.last_byte)) |
+          to_bitmap(&o, &(o.stream.byte_stack)) |
+          to_bitmap(&o, &(o.stream.buffer)) |
+          to_bitmap(&o, &(o.stream.format)) |
+          to_bitmap(&o, &(o.stream.format_table)));
+  init_tm(t_random, "RANDOM-STATE", ecl_random,
+          to_bitmap(&o, &(o.random.value)));
+  init_tm(t_readtable, "READTABLE", ecl_readtable,
+# ifdef ECL_UNICODE
+          to_bitmap(&o, &(o.readtable.hash)) |
+# endif
+          to_bitmap(&o, &(o.readtable.table)));
+  init_tm(t_pathname, "PATHNAME", ecl_pathname,
+          to_bitmap(&o, &(o.pathname.version)) |
+          to_bitmap(&o, &(o.pathname.type)) |
+          to_bitmap(&o, &(o.pathname.name)) |
+          to_bitmap(&o, &(o.pathname.directory)) |
+          to_bitmap(&o, &(o.pathname.device)) |
+          to_bitmap(&o, &(o.pathname.host)));
+  init_tm(t_bytecodes, "BYTECODES", ecl_bytecodes,
+          to_bitmap(&o, &(o.bytecodes.name)) |
+          to_bitmap(&o, &(o.bytecodes.definition)) |
+          to_bitmap(&o, &(o.bytecodes.code)) |
+          to_bitmap(&o, &(o.bytecodes.data)) |
+          to_bitmap(&o, &(o.bytecodes.flex)) |
+          to_bitmap(&o, &(o.bytecodes.file)) |
+          to_bitmap(&o, &(o.bytecodes.file_position)));
+  init_tm(t_bclosure, "BCLOSURE", ecl_bclosure,
+          to_bitmap(&o, &(o.bclosure.code)) |
+          to_bitmap(&o, &(o.bclosure.lex)));
+  init_tm(t_cfun, "CFUN", ecl_cfun,
+          to_bitmap(&o, &(o.cfun.name)) |
+          to_bitmap(&o, &(o.cfun.block)) |
+          to_bitmap(&o, &(o.cfun.file)) |
+          to_bitmap(&o, &(o.cfun.file_position)));
+  init_tm(t_cfunfixed, "CFUNFIXED", ecl_cfunfixed,
+          to_bitmap(&o, &(o.cfunfixed.name)) |
+          to_bitmap(&o, &(o.cfunfixed.block)) |
+          to_bitmap(&o, &(o.cfunfixed.file)) |
+          to_bitmap(&o, &(o.cfunfixed.file_position)));
+  init_tm(t_cclosure, "CCLOSURE", ecl_cclosure,
+          to_bitmap(&o, &(o.cclosure.env)) |
+          to_bitmap(&o, &(o.cclosure.block)) |
+          to_bitmap(&o, &(o.cclosure.file)) |
+          to_bitmap(&o, &(o.cclosure.file_position)));
+  init_tm(t_instance, "INSTANCE", ecl_instance,
+          to_bitmap(&o, &(o.instance.clas)) |
+          to_bitmap(&o, &(o.instance.slotds)) |
+          to_bitmap(&o, &(o.instance.slots)));
+#ifdef ECL_THREADS
+  init_tm(t_process, "PROCESS", ecl_process,
+          to_bitmap(&o, &(o.process.name)) |
+          to_bitmap(&o, &(o.process.function)) |
+          to_bitmap(&o, &(o.process.args)) |
+          to_bitmap(&o, &(o.process.inherit_bindings_p)) |
+          to_bitmap(&o, &(o.process.exit_values)) |
+          to_bitmap(&o, &(o.process.woken_up)) |
+          to_bitmap(&o, &(o.process.env)));
+  init_tm(t_lock, "LOCK", ecl_lock,
+          to_bitmap(&o, &(o.lock.name)) |
+          to_bitmap(&o, &(o.lock.owner)));
+  init_tm(t_rwlock, "RWLOCK", ecl_rwlock,
+          to_bitmap(&o, &(o.rwlock.name)));
+  init_tm(t_condition_variable, "CONDITION-VARIABLE", ecl_condition_variable, 0);
+  init_tm(t_semaphore, "SEMAPHORE", ecl_semaphore,
+          to_bitmap(&o, &(o.semaphore.name)));
+  init_tm(t_barrier, "BARRIER", ecl_barrier,
+          to_bitmap(&o, &(o.barrier.name)));
+  init_tm(t_mailbox, "MAILBOX", ecl_mailbox,
+          to_bitmap(&o, &(o.mailbox.name)) |
+          to_bitmap(&o, &(o.mailbox.data)));
+#endif
+  init_tm(t_codeblock, "CODEBLOCK", ecl_codeblock,
+          to_bitmap(&o, &(o.cblock.data)) |
+          to_bitmap(&o, &(o.cblock.temp_data)) |
+          to_bitmap(&o, &(o.cblock.next)) |
+          to_bitmap(&o, &(o.cblock.name)) |
+          to_bitmap(&o, &(o.cblock.links)) |
+          to_bitmap(&o, &(o.cblock.source)) |
+          to_bitmap(&o, &(o.cblock.refs)) |
+          to_bitmap(&o, &(o.cblock.error)));
+  init_tm(t_foreign, "FOREIGN", ecl_foreign,
+          to_bitmap(&o, &(o.foreign.data)) |
+          to_bitmap(&o, &(o.foreign.tag)));
+  init_tm(t_frame, "STACK-FRAME", ecl_stack_frame,
+          to_bitmap(&o, &(o.frame.env)));
+  init_tm(t_exception, "EXCEPTION", ecl_exception,
+          to_bitmap(&o, &(o.exception.arg1)) |
+          to_bitmap(&o, &(o.exception.arg2)) |
+          to_bitmap(&o, &(o.exception.arg3)));
+  init_tm(t_module, "MODULE", ecl_module, 0);
+  init_tm(t_weak_pointer, "WEAK-POINTER", ecl_weak_pointer, 0);
+#ifdef ECL_SSE2
+  init_tm(t_sse_pack, "SSE-PACK", ecl_sse_pack, 0);
+#endif
+}
+
+/* -- Constructors ---------------------------------------------------------- */
+
+cl_object
+ecl_alloc_object(cl_type t)
+{
+  assert_type_tag(t);
+  switch(t) {
+  case t_list:                  /* Small cons (no d.t) */
+    return ecl_cons(ECL_NIL, ECL_NIL);
+  case t_character:
+    return ECL_CODE_CHAR(' ');  /* Immediate character */
+  case t_fixnum:
+    return ecl_make_fixnum(0);  /* Immediate fixnum */
+  default:
+    {
+      const cl_env_ptr the_env = ecl_process_env_unsafe();
+      cl_object o;
+      if(the_env) ecl_disable_interrupts_env(the_env);
+      o = ecl_core.allocator->allocate_object(t);
+      o->d.t = t;
+      if(the_env) ecl_enable_interrupts_env(the_env);
+      return o;
+    }
+  }
+}
+
+void *
+ecl_alloc(cl_index n)
+{
+  const cl_env_ptr the_env = ecl_process_env_unsafe();
+  void *ptr = NULL;
+  if(!the_env) {
+    return ecl_core.allocator->allocate_memory(n);
+  } else {
+    ecl_disable_interrupts_env(the_env);
+    ptr = ecl_core.allocator->allocate_memory(n);
+    ecl_enable_interrupts_env(the_env);
+  }
+  return ptr;
+}
+
+void *
+ecl_alloc_atomic(cl_index n)
+{
+  const cl_env_ptr the_env = ecl_process_env_unsafe();
+  void *ptr = NULL;
+  if(!the_env) {
+    return ecl_core.allocator->allocate_atomic(n);
+  } else {
+    ecl_disable_interrupts_env(the_env);
+    ptr = ecl_core.allocator->allocate_atomic(n);
+    ecl_enable_interrupts_env(the_env);
+  }
+  return ptr;
+}
+
+void *
+ecl_alloc_manual(cl_index n)
+{
+  const cl_env_ptr the_env = ecl_process_env_unsafe();
+  void *ptr = NULL;
+  if(!the_env) {
+    return ecl_core.allocator->allocate_manual(n);
+  } else {
+    ecl_disable_interrupts_env(the_env);
+    ptr = ecl_core.allocator->allocate_manual(n);
+    ecl_enable_interrupts_env(the_env);
+  }
+  return ptr;
+}
+
+void
+ecl_free_object(cl_object ptr)
+{
+  const cl_env_ptr the_env = ecl_process_env_unsafe();
+  if(!the_env) {
+    ecl_core.allocator->free_object(ptr);
+  } else {
+    ecl_disable_interrupts_env(the_env);
+    ecl_core.allocator->free_object(ptr);
+    ecl_enable_interrupts_env(the_env);
+  }
+}
+
+void
+ecl_dealloc(void *ptr)
+{
+  const cl_env_ptr the_env = ecl_process_env_unsafe();
+  if(!the_env) {
+    ecl_core.allocator->free_memory(ptr);
+  } else {
+    ecl_disable_interrupts_env(the_env);
+    ecl_core.allocator->free_memory(ptr);
+    ecl_enable_interrupts_env(the_env);
+  }
+}
+
+/* -- Helpers --------------------------------------------------------------- */
+
+cl_object                       /* used by bignum.d */
+ecl_alloc_compact_object(cl_type t, cl_index extra_space)
+{
+  cl_index size = ecl_type_info[t].size;
+  cl_object x = ecl_alloc_atomic(size + extra_space);
+  x->array.t = t;
+  x->array.displaced = (void*)(((char*)x) + size);
+  return x;
+}
+
+cl_object
+ecl_cons(cl_object a, cl_object d)
+{
+  struct ecl_cons *obj = ecl_alloc(sizeof(struct ecl_cons));
+#ifdef ECL_SMALL_CONS
+  obj->car = a;
+  obj->cdr = d;
+  return ECL_PTR_CONS(obj);
+#else
+  obj->t = t_list;
+  obj->car = a;
+  obj->cdr = d;
+  return (cl_object)obj;
+#endif
+}
+
+cl_object
+ecl_append_unsafe(cl_object x, cl_object y)
+{
+  cl_object head = ECL_NIL, cons;
+  cl_object *tail = &head;
+  loop_for_on_unsafe(x) {
+    cons = ecl_list1(ECL_CONS_CAR(x));
+    *tail = cons;
+    tail = &ECL_CONS_CDR(cons);
+  } end_loop_for_on_unsafe(x);
+  *tail = y;
+  return head;
+}
+
+/* -- Rudimentary manual memory allocator ----------------------------------- */
+
+static cl_object
+alloc_object(cl_type t)
+{
+  struct ecl_type_information *ti = ecl_type_info + t;
+  return ecl_malloc(ti->size);
+}
+
+static void
+free_object(cl_object o)
+{
+  /* FIXME this should invoke the finalizer! That is - reify finalizers here. */
+  ecl_free(o);
+}
+
+struct ecl_allocator_ops manual_allocator = {
+  .allocate_memory = ecl_malloc,
+  .allocate_atomic = ecl_malloc,
+  .allocate_manual = ecl_malloc,
+  .allocate_object = alloc_object,
+  .free_memory = ecl_free,
+  .free_object = free_object
+};
+
+void
+init_memory ()
+{
+  init_type_info_database();
+  ecl_core.allocator = &manual_allocator;
+}

src/c/module.d

@@ -0,0 +1,188 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/* module.c - managing runtime modules */
+
+/* -- imports ---------------------------------------------------------------- */
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+
+/* -- test module ------------------------------------------------------------ */
+
+static cl_object create() {
+  printf("DUMMY: Creating the module!\n");
+  return ECL_NIL;
+}
+
+static cl_object enable() {
+  printf("DUMMY: Enabling the module!\n");
+  return ECL_NIL;
+}
+
+static cl_object init_env(cl_env_ptr the_env) {
+#ifdef ECL_THREADS
+  ecl_thread_t thread_id = the_env->thread;
+  printf("DUMMY: init_env [cpu %p env %p]\n", &thread_id, the_env);
+#else
+  printf("DUMMY: init_env [env %p]\n", the_env);
+#endif
+  return ECL_NIL;
+}
+
+static cl_object init_cpu(cl_env_ptr the_env) {
+#ifdef ECL_THREADS
+  ecl_thread_t thread_id = the_env->thread;
+  printf("DUMMY: init_cpu [cpu %p env %p]\n", &thread_id, the_env);
+#else
+  printf("DUMMY: init_cpu [env %p]\n", the_env);
+#endif
+  return ECL_NIL;
+}
+
+static cl_object free_cpu(cl_env_ptr the_env) {
+#ifdef ECL_THREADS
+  ecl_thread_t thread_id = the_env->thread;
+  printf("DUMMY: free_cpu [cpu %p env %p]\n", &thread_id, the_env);
+#else
+  printf("DUMMY: free_cpu [env %p]\n", the_env);
+#endif
+  return ECL_NIL;
+}
+
+static cl_object free_env(cl_env_ptr the_env) {
+#ifdef ECL_THREADS
+  ecl_thread_t thread_id = the_env->thread;
+  printf("DUMMY: free_env [cpu %p env %p]\n", &thread_id, the_env);
+#else
+  printf("DUMMY: free_env [env %p]\n", the_env);
+#endif
+  return ECL_NIL;
+}
+
+static cl_object disable() {
+  printf("DUMMY: Disabling the module!\n");
+  return ECL_NIL;
+}
+
+static cl_object destroy() {
+  printf("DUMMY: Destroying the module!\n");
+  return ECL_NIL;
+}
+
+ecl_def_ct_base_string(str_dummy, "DUMMY", 5, static, const);
+
+static struct ecl_module module_dummy = {
+  .name = str_dummy,
+  .create = create,
+  .enable = enable,
+  .init_env = init_env,
+  .init_cpu = init_cpu,
+  .free_cpu = free_cpu,
+  .free_env = free_env,
+  .disable = disable,
+  .destroy = destroy
+};
+
+cl_object ecl_module_dummy = (cl_object)&module_dummy;
+
+/* -- implementation --------------------------------------------------------- */
+
+cl_object
+ecl_module_no_op(void)
+{
+  return ECL_NIL;
+}
+
+cl_object
+ecl_module_no_op_env(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+cl_object
+ecl_module_no_op_cpu(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+cl_object
+ecl_add_module(cl_object self)
+{
+  self->module.create();
+  self->module.init_cpu(ecl_core.first_env);
+  self->module.init_env(ecl_core.first_env);
+  ecl_stack_push(ecl_core.modules, self);
+  return ECL_NIL;
+}
+
+cl_object
+ecl_del_module(cl_object self)
+{
+  ecl_stack_del(ecl_core.modules, self);
+  self->module.disable();
+  self->module.free_env(ecl_core.first_env);
+  self->module.free_cpu(ecl_core.first_env);
+  self->module.destroy();
+  return ECL_NIL;
+}
+
+cl_object
+ecl_modules_init_env(cl_env_ptr the_env) {
+  loop_across_stack_fifo(var, ecl_core.modules) {
+    /* printf("> init_env: %s\n", (var->module.name)->base_string.self); */
+    var->module.init_env(the_env);
+    /* printf("< init_env: %s\n", (var->module.name)->base_string.self); */
+  } end_loop_across_stack();
+  return ECL_NIL;
+}
+
+cl_object
+ecl_modules_init_cpu(cl_env_ptr the_env) {
+  loop_across_stack_fifo(var, ecl_core.modules) {
+    /* printf("> init_cpu: %s\n", (var->module.name)->base_string.self); */
+    var->module.init_cpu(the_env);
+    /* printf("< init_cpu: %s\n", (var->module.name)->base_string.self); */
+  } end_loop_across_stack();
+  return ECL_NIL;
+}
+
+cl_object
+ecl_modules_free_cpu(cl_env_ptr the_env) {
+  loop_across_stack_filo(var, ecl_core.modules) {
+    /* printf("> free_cpu: %s\n", (var->module.name)->base_string.self); */
+    var->module.free_cpu(the_env);
+    /* printf("< free_cpu: %s\n", (var->module.name)->base_string.self); */
+  } end_loop_across_stack();
+  return ECL_NIL;
+}
+
+cl_object
+ecl_modules_free_env(cl_env_ptr the_env) {
+  loop_across_stack_filo(var, ecl_core.modules) {
+    /* printf("> free_env: %s\n", (var->module.name)->base_string.self); */
+    var->module.free_env(the_env);
+    /* printf("< free_env: %s\n", (var->module.name)->base_string.self); */
+  } end_loop_across_stack();
+  return ECL_NIL;
+}
+
+/* INV all modules must be loaded before we make new threads.  */
+/* FIXME enforce this invariant. */
+void
+init_modules(void)
+{
+  cl_object self = ecl_make_stack(16);
+  ecl_core.modules = self;
+}
+
+void
+free_modules(void)
+{
+  loop_across_stack_filo(var, ecl_core.modules) {
+    ecl_del_module(var);
+  } end_loop_across_stack();
+  ecl_free_stack(ecl_core.modules);
+  ecl_core.modules = ECL_NIL;
+}

src/c/num_co.d

@@ -431,21 +431,21 @@ cl_imagpart(cl_object x)
     break;
   case t_singlefloat:
     if (signbit(ecl_single_float(x)))
-      x = cl_core.singlefloat_minus_zero;
+      x = ecl_ct_singlefloat_minus_zero;
     else
-      x = cl_core.singlefloat_zero;
+      x = ecl_ct_singlefloat_zero;
     break;
   case t_doublefloat:
     if (signbit(ecl_double_float(x)))
-      x = cl_core.doublefloat_minus_zero;
+      x = ecl_ct_doublefloat_minus_zero;
     else
-      x = cl_core.doublefloat_zero;
+      x = ecl_ct_doublefloat_zero;
     break;
   case t_longfloat:
     if (signbit(ecl_long_float(x)))
-      x = cl_core.longfloat_minus_zero;
+      x = ecl_ct_longfloat_minus_zero;
     else
-      x = cl_core.longfloat_zero;
+      x = ecl_ct_longfloat_zero;
     break;
   case t_complex:
     x = x->gencomplex.imag;

src/c/number.d

@@ -501,9 +501,9 @@ ecl_make_single_float(float f)
   if (f == (float)0.0) {
 #if defined(ECL_SIGNED_ZERO)
     if (signbit(f))
-      return cl_core.singlefloat_minus_zero;
+      return ecl_ct_singlefloat_minus_zero;
 #endif
-    return cl_core.singlefloat_zero;
+    return ecl_ct_singlefloat_zero;
   }
   x = ecl_alloc_object(t_singlefloat);
   ecl_single_float(x) = f;
@@ -519,9 +519,9 @@ ecl_make_double_float(double f)
   if (f == (double)0.0) {
 #if defined(ECL_SIGNED_ZERO)
     if (signbit(f))
-      return cl_core.doublefloat_minus_zero;
+      return ecl_ct_doublefloat_minus_zero;
 #endif
-    return cl_core.doublefloat_zero;
+    return ecl_ct_doublefloat_zero;
   }
   x = ecl_alloc_object(t_doublefloat);
   ecl_double_float(x) = f;
@@ -537,9 +537,9 @@ ecl_make_long_float(long double f)
   if (f == (long double)0.0) {
 #if defined(ECL_SIGNED_ZERO)
     if (signbit(f))
-      return cl_core.longfloat_minus_zero;
+      return ecl_ct_longfloat_minus_zero;
 #endif
-    return cl_core.longfloat_zero;
+    return ecl_ct_longfloat_zero;
   }
   x = ecl_alloc_object(t_longfloat);
   x->longfloat.value = f;

src/c/numbers/atan.d

@@ -15,11 +15,19 @@
 
 #define ECL_INCLUDE_MATH_H
 #include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
 #include <ecl/impl/math_fenv.h>
 
 #pragma STDC FENV_ACCESS ON
 
+ecl_def_ct_single_float(ecl_ct_flt_zero,0,static,const);
+ecl_def_ct_single_float(ecl_ct_flt_one,1,static,const);
+ecl_def_ct_single_float(ecl_ct_flt_one_neg,-1,static,const);
+
+ecl_def_ct_complex(ecl_ct_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one,static,const);
+ecl_def_ct_complex(ecl_ct_minus_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one_neg,static,const);
+
 cl_object
 ecl_atan2(cl_object y, cl_object x)
 {
@@ -53,20 +61,20 @@ ecl_atan1(cl_object y)
 {
   if (ECL_COMPLEXP(y)) {
 #if 0 /* ANSI states it should be this first part */
-    cl_object z = ecl_times(cl_core.imag_unit, y);
+    cl_object z = ecl_times(ecl_ct_imag_unit, y);
     z = ecl_plus(ecl_log1(ecl_one_plus(z)),
                  ecl_log1(ecl_minus(ecl_make_fixnum(1), z)));
     z = ecl_divide(z, ecl_times(ecl_make_fixnum(2),
-                                cl_core.imag_unit));
+                                ecl_ct_imag_unit));
 #else
-    cl_object z1, z = ecl_times(cl_core.imag_unit, y);
+    cl_object z1, z = ecl_times(ecl_ct_imag_unit, y);
     z = ecl_one_plus(z);
     z1 = ecl_times(y, y);
     z1 = ecl_one_plus(z1);
     z1 = ecl_sqrt(z1);
     z = ecl_divide(z, z1);
     z = ecl_log1(z);
-    z = ecl_times(cl_core.minus_imag_unit, z);
+    z = ecl_times(ecl_ct_minus_imag_unit, z);
 #endif /* ANSI */
     return z;
   } else {

src/c/numbers/round.d

@@ -87,12 +87,12 @@ ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object
   cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den);
   cl_object r = ecl_minus(q, q1);
   if (ecl_minusp(r)) {
-    int c = ecl_number_compare(cl_core.minus_half, r);
+    int c = ecl_number_compare(ecl_ct_minus_half, r);
     if (c > 0 || (c == 0 && ecl_oddp(q1))) {
       q1 = ecl_one_minus(q1);
     }
   } else {
-    int c = ecl_number_compare(r, cl_core.plus_half);
+    int c = ecl_number_compare(r, ecl_ct_plus_half);
     if (c > 0 || (c == 0 && ecl_oddp(q1))) {
       q1 = ecl_one_plus(q1);
     }

src/c/numbers/sqrt.d

@@ -76,7 +76,7 @@ ecl_sqrt_long_float(cl_object x)
 static cl_object
 ecl_sqrt_complex(cl_object x)
 {
-  return ecl_expt(x, cl_core.plus_half);
+  return ecl_expt(x, ecl_ct_plus_half);
 }
 
 #ifdef ECL_COMPLEX_FLOAT

src/c/package.d

@@ -23,8 +23,8 @@
  * NOTE 1: we only need to use the package locks when reading/writing the hash
  * tables, or changing the fields of a package.  We do not need the locks to
  * read lists from the packages (i.e. list of shadowing symbols, used
- * packages, etc), or from the global environment (cl_core.packages_list) if
- * we do not destructively modify them (For instance, use ecl_remove_eq
+ * packages, etc), or from the global environment (cl_core.packages_list)
+ * if we do not destructively modify them (For instance, use ecl_remove_eq
  * instead of ecl_delete_eq).
  */
 /*
@@ -114,8 +114,8 @@ make_package_hashtable()
 {
   return cl__make_hash_table(@'package', /* package hash table */
                              ecl_make_fixnum(128), /* initial size */
-                             cl_core.rehash_size,
-                             cl_core.rehash_threshold);
+                             ecl_ct_default_rehash_size,
+                             ecl_ct_default_rehash_threshold);
 }
 
 static cl_object
@@ -270,7 +270,7 @@ ecl_make_package(cl_object name, cl_object nicknames,
       nicknamed->pack.nicknamedby = CONS(x, nicknamed->pack.nicknamedby);
     } end_loop_for_in;
     /* Finally, add it to the list of packages */
-    cl_core.packages = CONS(x, cl_core.packages);
+    cl_core.packages = ecl_cons(x, cl_core.packages);
   OUTPUT:
     (void)0;
   } ECL_WITH_GLOBAL_ENV_WRLOCK_END;

src/c/pathname.d

@@ -461,7 +461,7 @@ parse_word(cl_object s, delim_fn delim, int flags, cl_index start,
   case 0:
     if (flags & WORD_EMPTY_IS_NIL)
       return ECL_NIL;
-    return cl_core.null_string;
+    return ecl_ct_null_string;
   case 1:
     if (ecl_char(s,j) == '*')
       return @':wild';
@@ -505,7 +505,7 @@ parse_directories(cl_object s, int flags, cl_index start, cl_index end,
     cl_object part = parse_word(s, delim, flags, j, end, &i);
     if (part == @':error' || part == ECL_NIL)
       break;
-    if (part == cl_core.null_string) {  /* "/", ";" */
+    if (part == ecl_ct_null_string) {  /* "/", ";" */
       if (j != start) {
         if (flags & WORD_LOGICAL)
           return @':error';
@@ -525,7 +525,7 @@ ecl_logical_hostname_p(cl_object host)
 {
   if (!ecl_stringp(host))
     return FALSE;
-  return !Null(ecl_assqlp(host, cl_core.pathname_translations));
+  return !Null(ecl_assqlp(host, ecl_core.pathname_translations));
 }
 
 /*
@@ -562,7 +562,7 @@ ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep,
   bool logical;
 
   if (start == end) {
-    host = device = path = name = type = aux = version = @'nil';
+    host = device = path = name = type = aux = version = ECL_NIL;
     logical = 0;
     *ep = end;
     goto make_it;
@@ -900,8 +900,8 @@ si_coerce_to_filename(cl_object pathname_orig)
             pathname_orig->pathname.type,
             pathname_orig->pathname.version);
   }
-  if (cl_core.path_max != -1 &&
-      ecl_length(namestring) >= cl_core.path_max - 16)
+  if (ecl_core.path_max != -1 &&
+      ecl_length(namestring) >= ecl_core.path_max - 16)
     FEerror("Too long filename: ~S.", 1, namestring);
   return namestring;
 }
@@ -1318,7 +1318,7 @@ cl_host_namestring(cl_object pname)
   pname = cl_pathname(pname);
   pname = pname->pathname.host;
   if (Null(pname) || pname == @':wild')
-    pname = cl_core.null_string;
+    pname = ecl_ct_null_string;
   @(return pname);
 }
 
@@ -1542,7 +1542,7 @@ coerce_to_from_pathname(cl_object x, cl_object host)
     FEerror("Wrong host syntax ~S", 1, host);
   }
   /* Find its translation list */
-  pair = ecl_assqlp(host, cl_core.pathname_translations);
+  pair = ecl_assqlp(host, ecl_core.pathname_translations);
   if (set == OBJNULL) {
     @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair)));
   }
@@ -1552,7 +1552,7 @@ coerce_to_from_pathname(cl_object x, cl_object host)
   }
   if (pair == ECL_NIL) {
     pair = CONS(host, CONS(ECL_NIL, ECL_NIL));
-    cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations);
+    ecl_core.pathname_translations = CONS(pair, ecl_core.pathname_translations);
   }
   for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) {
     cl_object item = CAR(l);

src/c/predicate.d

@@ -237,81 +237,6 @@ cl_eq(cl_object x, cl_object y)
   @(return ((x == y) ? ECL_T : ECL_NIL));
 }
 
-/*
- * EQL-comparison of floats. If we are using signed zeros and NaNs,
- * numeric comparison of floating points is not equivalent to bit-wise
- * equality. In particular every two NaNs always give false
- *      (= #1=(/ 0.0 0.0) #1#) => NIL
- * and signed zeros always compare equal
- *      (= 0 -0.0) => T
- * which is not the same as what EQL should return
- *      (EQL #1=(/ 0.0 0.0) #1#) => T
- *      (EQL 0 -0.0) => NIL
- *
- * Furthermore, we can not use bit comparisons because in some platforms
- * long double has unused bits that makes two long floats be = but not eql.
- */
-#if !defined(ECL_SIGNED_ZERO) && !defined(ECL_IEEE_FP)
-#define FLOAT_EQL(name, type)                           \
-  static bool name(type a, type b) { return a == b; }
-#else
-#define FLOAT_EQL(name, type)                                           \
-  static bool name(type a, type b) {                                    \
-    if (a == b) return signbit(a) == signbit(b);                        \
-    if (isnan(a) || isnan(b)) return isnan(a) && isnan(b);              \
-    return 0;                                                           \
-  }
-#endif
-
-FLOAT_EQL(float_eql, float);
-FLOAT_EQL(double_eql, double);
-FLOAT_EQL(long_double_eql, long double);
-#undef FLOAT_EQL
-
-bool
-ecl_eql(cl_object x, cl_object y)
-{
-  if (x == y)
-    return TRUE;
-  if (ECL_IMMEDIATE(x) || ECL_IMMEDIATE(y))
-    return FALSE;
-  if (x->d.t != y->d.t)
-    return FALSE;
-  switch (x->d.t) {
-  case t_bignum:
-    return (_ecl_big_compare(x, y) == 0);
-  case t_ratio:
-    return (ecl_eql(x->ratio.num, y->ratio.num) &&
-            ecl_eql(x->ratio.den, y->ratio.den));
-  case t_singlefloat:
-    return float_eql(ecl_single_float(x), ecl_single_float(y));
-  case t_longfloat:
-    return long_double_eql(ecl_long_float(x), ecl_long_float(y));
-  case t_doublefloat:
-    return double_eql(ecl_double_float(x), ecl_double_float(y));
-  case t_complex:
-    return (ecl_eql(x->gencomplex.real, y->gencomplex.real) &&
-            ecl_eql(x->gencomplex.imag, y->gencomplex.imag));
-#ifdef ECL_COMPLEX_FLOAT
-  case t_csfloat:
-    return (float_eql(crealf(ecl_csfloat(x)), crealf(ecl_csfloat(y))) &&
-            float_eql(cimagf(ecl_csfloat(x)), cimagf(ecl_csfloat(y))));
-  case t_cdfloat:
-    return (double_eql(creal(ecl_cdfloat(x)), creal(ecl_cdfloat(y))) &&
-            double_eql(cimag(ecl_cdfloat(x)), cimag(ecl_cdfloat(y))));
-  case t_clfloat:
-    return (long_double_eql(creall(ecl_clfloat(x)), creall(ecl_clfloat(y))) &&
-            long_double_eql(cimagl(ecl_clfloat(x)), cimagl(ecl_clfloat(y))));
-#endif
-#ifdef ECL_SSE2
-  case t_sse_pack:
-    return !memcmp(x->sse.data.b8, y->sse.data.b8, 16);
-#endif
-  default:
-    return FALSE;
-  }
-}
-
 cl_object
 cl_eql(cl_object x, cl_object y)
 {
@@ -344,39 +269,17 @@ ecl_equal(cl_object x, cl_object y)
   case t_fixnum:
     return FALSE;
   case t_bignum:
-    return (tx == ty) && (_ecl_big_compare(x,y) == 0);
   case t_ratio:
-    return (tx == ty) && ecl_eql(x->ratio.num, y->ratio.num) &&
-      ecl_eql(x->ratio.den, y->ratio.den);
-  case t_singlefloat: {
-    if (tx != ty) return 0;
-    return float_eql(ecl_single_float(x), ecl_single_float(y));
-  }
-  case t_doublefloat: {
-    if (tx != ty) return 0;
-    return double_eql(ecl_double_float(x), ecl_double_float(y));
-  }
-  case t_longfloat: {
-    if (tx != ty) return 0;
-    return long_double_eql(ecl_long_float(x), ecl_long_float(y));
-  }
+  case t_singlefloat:
+  case t_doublefloat:
+  case t_longfloat:
   case t_complex:
-    return (tx == ty) && ecl_eql(x->gencomplex.real, y->gencomplex.real) &&
-      ecl_eql(x->gencomplex.imag, y->gencomplex.imag);
 #ifdef ECL_COMPLEX_FLOAT
   case t_csfloat:
-    if (tx != ty) return 0;
-    return (float_eql(crealf(ecl_csfloat(x)), crealf(ecl_csfloat(y))) &&
-            float_eql(cimagf(ecl_csfloat(x)), cimagf(ecl_csfloat(y))));
   case t_cdfloat:
-    if (tx != ty) return 0;
-    return (double_eql(creal(ecl_cdfloat(x)), creal(ecl_cdfloat(y))) &&
-            double_eql(cimag(ecl_cdfloat(x)), cimag(ecl_cdfloat(y))));
   case t_clfloat:
-    if (tx != ty) return 0;
-    return (long_double_eql(creall(ecl_clfloat(x)), creall(ecl_clfloat(y))) &&
-            long_double_eql(cimagl(ecl_clfloat(x)), cimagl(ecl_clfloat(y))));
 #endif
+    return ecl_eql(x, y);
   case t_character:
     return (tx == ty) && (ECL_CHAR_CODE(x) == ECL_CHAR_CODE(y));
   case t_base_string:

src/c/printer/write_object.d

@@ -96,8 +96,8 @@ si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_funct
         cl_object hash =
           cl__make_hash_table(@'eq',
                               ecl_make_fixnum(1024),
-                              cl_core.rehash_size,
-                              cl_core.rehash_threshold);
+                              ecl_ct_default_rehash_size,
+                              ecl_ct_default_rehash_threshold);
         ecl_bds_bind(env, @'si::*circle-counter*', ECL_T);
         ecl_bds_bind(env, @'si::*circle-stack*', hash);
         si_write_object_with_circle(x, cl_core.null_stream, print_function);

src/c/printer/write_ugly.d

@@ -370,6 +370,18 @@ write_frame(cl_object x, cl_object stream)
   _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream);
 }
 
+static void
+write_exception(cl_object x, cl_object stream)
+{
+  _ecl_write_unreadable(x, "exception", ECL_NIL, stream);
+}
+
+static void
+write_module(cl_object x, cl_object stream)
+{
+  _ecl_write_unreadable(x, "module", x->module.name, stream);
+}
+
 static void
 write_weak_pointer(cl_object x, cl_object stream)
 {
@@ -480,6 +492,8 @@ static printer dispatch[FREE+1] = {
   write_codeblock,              /* t_codeblock */
   write_foreign,                /* t_foreign */
   write_frame,                  /* t_frame */
+  write_exception,              /* t_exception */
+  write_module,                 /* t_module */
   write_weak_pointer,           /* t_weak_pointer */
 #ifdef ECL_SSE2
   _ecl_write_sse,               /* t_sse_pack */

src/c/process.d

@@ -36,11 +36,25 @@
 
 #ifdef ECL_THREADS
 # ifdef ECL_WINDOWS_THREADS
+#  define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2))
+#  define ecl_set_process_self(var)             \
+  {                                             \
+    HANDLE aux = GetCurrentThread();            \
+    DuplicateHandle(GetCurrentProcess(),        \
+                    aux,                        \
+                    GetCurrentProcess(),        \
+                    &var,                       \
+                    0,                          \
+                    FALSE,                      \
+                    DUPLICATE_SAME_ACCESS);     \
+  }
 #  define ecl_process_key_t DWORD
 #  define ecl_process_key_create(key) key = TlsAlloc()
 #  define ecl_process_get_tls(key) TlsGetValue(key)
 #  define ecl_process_set_tls(key,val) (TlsSetValue(key,val)!=0)
 # else
+#  define ecl_process_eq(t1, t2) (t1 == t2)
+#  define ecl_set_process_self(var) (var = pthread_self())
 #  define ecl_process_key_t static pthread_key_t
 #  define ecl_process_key_create(key) pthread_key_create(&key, NULL)
 #  define ecl_process_get_tls(key) pthread_getspecific(key)
@@ -79,23 +93,212 @@ ecl_set_process_env(cl_env_ptr env)
 cl_env_ptr cl_env_p = NULL;
 #endif  /* ECL_THREADS */
 
-/* -- Initialiation --------------------------------------------------------- */
+#ifdef ECL_THREADS
+/* -- Thread local bindings */
+static void
+init_tl_bindings(cl_object process, cl_env_ptr env)
+{
+
+  cl_index bindings_size;
+  cl_object *bindings;
+  if (Null(process) || Null(process->process.inherit_bindings_p)) {
+    cl_index idx = 0, size = 256;
+    bindings_size = size;
+    bindings = (cl_object *)ecl_malloc(size*sizeof(cl_object*));
+    for(idx=0; idx<256; idx++) {
+      bindings[idx] = ECL_NO_TL_BINDING;
+    }
+  } else {
+    cl_env_ptr parent_env = ecl_process_env();
+    bindings_size = parent_env->bds_stack.tl_bindings_size;
+    bindings = (cl_object *)ecl_malloc(bindings_size*sizeof(cl_object*));
+    ecl_copy(bindings, parent_env->bds_stack.tl_bindings, bindings_size*sizeof(cl_object*));
+  }
+  env->bds_stack.tl_bindings_size = bindings_size;
+  env->bds_stack.tl_bindings = bindings;
+
+}
+#endif
+
+/* -- Managing the collection of processes ---------------------------------- */
+
+#ifdef ECL_THREADS
+
+/* Run a process in the current system thread. */
+cl_env_ptr
+ecl_adopt_cpu()
+{
+  cl_env_ptr the_env = ecl_process_env_unsafe();
+  if (the_env != NULL)
+    return the_env;
+  the_env = _ecl_alloc_env(0);
+  ecl_set_process_env(the_env);
+  the_env->own_process = ECL_NIL;
+  ecl_modules_init_env(the_env);
+  ecl_modules_init_cpu(the_env);
+
+  return the_env;
+}
 
 void
-init_process(void)
+ecl_disown_cpu()
+{
+  cl_env_ptr the_env = ecl_process_env_unsafe();
+  if (the_env == NULL)
+    return;
+  ecl_modules_free_cpu(the_env);
+  ecl_modules_free_env(the_env);
+  _ecl_dealloc_env(the_env);
+}
+
+#ifdef ECL_WINDOWS_THREADS
+static DWORD WINAPI
+#else
+static void *
+#endif
+thread_entry_point(void *ptr)
+{
+  cl_env_ptr the_env = ecl_cast_ptr(cl_env_ptr, ptr);
+  cl_object process = the_env->own_process;
+  /* Setup the environment for the execution of the thread. */
+  ecl_modules_init_cpu(the_env);
+  /* Start the user routine */
+  process->process.entry(0);
+  ecl_disable_interrupts_env(the_env);
+  ecl_disown_cpu();
+#ifdef ECL_WINDOWS_THREADS
+  return 1;
+#else
+  return NULL;
+#endif
+}
+
+/* Run a process in a new system thread. */
+cl_env_ptr
+ecl_spawn_cpu(cl_object process)
+{
+  cl_env_ptr the_env = ecl_process_env();
+  cl_env_ptr new_env = NULL;
+  int code = 0;
+  /* Allocate and initialize the new cpu env. */
+  {
+    new_env = _ecl_alloc_env(the_env);
+    new_env->trap_fpe_bits = the_env->trap_fpe_bits;
+    new_env->own_process = process;
+    process->process.env = new_env;
+    ecl_modules_init_env(new_env);
+  }
+  /* Spawn the thread */
+  ecl_disable_interrupts_env(the_env);
+#if !defined(ECL_WINDOWS_THREADS) && defined(HAVE_SIGPROCMASK)
+  {
+    /* Block all asynchronous signals until the thread is completely set up. The
+     * synchronous signals SIGSEGV and SIGBUS are needed by the gc and and can't
+     * be blocked. */
+    sigset_t new, previous;
+    sigfillset(&new);
+    sigdelset(&new, SIGSEGV);
+    sigdelset(&new, SIGBUS);
+    ecl_sigmask(SIG_BLOCK, &new, &previous);
+    code = ecl_thread_create(new_env, thread_entry_point);
+    ecl_sigmask(SIG_SETMASK, &previous, NULL);
+  }
+#else
+  code = ecl_thread_create(new_env, thread_entry_point);
+#endif
+  /* Deal with the fallout of the thread creation. */
+  if (code != 0) {
+    process->process.env = NULL;
+    ecl_modules_free_env(new_env);
+    _ecl_dealloc_env(new_env);
+  }
+  ecl_enable_interrupts_env(the_env);
+  return code ? NULL : new_env;
+}
+#endif
+
+/* -- Module definition (so meta!) ------------------------------------------ */
+static cl_object
+create_process(void)
 {
-  cl_env_ptr env = cl_core.first_env;
 #ifdef ECL_THREADS
   ecl_process_key_create(cl_env_key);
-  ecl_mutex_init(&cl_core.processes_lock, 1);
-  ecl_mutex_init(&cl_core.global_lock, 1);
-  ecl_mutex_init(&cl_core.error_lock, 1);
-  ecl_rwlock_init(&cl_core.global_env_lock);
+  ecl_mutex_init(&ecl_core.processes_lock, 1);
+  ecl_mutex_init(&ecl_core.global_lock, 1);
+  ecl_mutex_init(&ecl_core.error_lock, 1);
+  ecl_rwlock_init(&ecl_core.global_env_lock);
+  ecl_core.threads = ecl_make_stack(16);
 #endif
-  ecl_set_process_env(env);
-  env->default_sigmask = NULL;
-  env->method_cache = NULL;
-  env->slot_cache = NULL;
-  env->interrupt_struct = NULL;
-  env->disable_interrupts = 1;
+  return ECL_NIL;
 }
+
+static cl_object
+init_env_process(cl_env_ptr the_env)
+{
+#ifdef ECL_THREAD
+  init_tl_bindings(the_env->own_process, the_env);
+#endif
+  return ECL_NIL;
+}
+
+static cl_object
+init_cpu_process(cl_env_ptr the_env)
+{
+#ifdef ECL_THREADS
+  ecl_thread_t main_thread;
+  ecl_set_process_self(main_thread);
+  the_env->thread = main_thread;
+#endif
+  ecl_set_process_env(the_env);
+  return ECL_NIL;
+}
+
+static cl_object
+free_cpu_process(cl_env_ptr the_env)
+{
+#ifdef ECL_WINDOWS_THREADS
+  CloseHandle(the_env->thread);
+#endif
+#if 0
+  /* KLUDGE when we destroy the module in destroy_process, the stack is freed
+     and threads are dereferenced. It might be that GC will try to pick them up
+     to run finalizers -- in that case we will still require a process env. */
+  ecl_set_process_env(NULL);
+#endif
+  return ECL_NIL;
+}
+
+static cl_object
+free_env_process(cl_env_ptr the_env)
+{
+#ifdef ECL_THREAD
+  the_env->own_process = ECL_NIL;
+#endif
+  return ECL_NIL;
+}
+
+static cl_object
+destroy_process(void)
+{
+#ifdef ECL_THREADS
+  ecl_free_stack(ecl_core.threads);
+  ecl_core.threads = ECL_NIL;
+#endif
+  return ECL_NIL;
+}
+
+ecl_def_ct_base_string(str_process, "PROCESS", 7, static, const);
+
+static struct ecl_module module_process = {
+  .name = str_process,
+  .create = create_process,
+  .enable = ecl_module_no_op,
+  .init_env = init_env_process,
+  .init_cpu = init_cpu_process,
+  .free_cpu = free_cpu_process,
+  .free_env = free_env_process,
+  .disable = ecl_module_no_op,
+  .destroy = destroy_process
+};
+
+cl_object ecl_module_process = (cl_object)&module_process;

src/c/read.d

@@ -1277,8 +1277,8 @@ patch_sharp(const cl_env_ptr the_env, cl_object x)
   } else {
     cl_object table = 
       cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */
-                          cl_core.rehash_size,
-                          cl_core.rehash_threshold);
+                          ecl_ct_default_rehash_size,
+                          ecl_ct_default_rehash_threshold);
     do {
       cl_object pair = ECL_CONS_CAR(pairs);
       _ecl_sethash(pair, table, ECL_CONS_CDR(pair));
@@ -1718,7 +1718,7 @@ do_read_delimited_list(int d, cl_object in, bool proper_list)
       @(return ECL_CODE_CHAR(c));
     }
   } else if (f == ECL_LISTEN_NO_CHAR) {
-    @(return @'nil');
+    @(return ECL_NIL);
   }
   /* We reach here if there was an EOF */
  END_OF_FILE:
@@ -1859,8 +1859,8 @@ ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat,
     cl_object hash = readtable->readtable.hash;
     if (Null(hash)) {
       hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128),
-                                 cl_core.rehash_size,
-                                 cl_core.rehash_threshold);
+                                 ecl_ct_default_rehash_size,
+                                 ecl_ct_default_rehash_threshold);
       readtable->readtable.hash = hash;
     }
     _ecl_sethash(ECL_CODE_CHAR(c), hash,
@@ -1937,8 +1937,8 @@ ecl_invalid_character_p(int c)
   c = ecl_char_code(chr);
   cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating;
   table = cl__make_hash_table(@'eql', ecl_make_fixnum(128),
-                              cl_core.rehash_size,
-                              cl_core.rehash_threshold);
+                              ecl_ct_default_rehash_size,
+                              ecl_ct_default_rehash_threshold);
   ecl_readtable_set(readtable, c, cat, table);
   @(return ECL_T);
   @)

src/c/serialize.d

@@ -76,6 +76,8 @@ static cl_index object_size[] = {
   ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */
   ROUNDED_SIZE(ecl_foreign), /* t_foreign */
   ROUNDED_SIZE(ecl_stack_frame), /* t_frame */
+  ROUNDED_SIZE(ecl_exception), /* t_exception */
+  ROUNDED_SIZE(ecl_module), /* t_module */
   ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */
 #ifdef ECL_SSE2
   , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */
@@ -349,8 +351,8 @@ init_pool(pool_t pool, cl_object root)
                               ECL_NIL,
                               ecl_make_fixnum(0));
   pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256),
-                                   cl_core.rehash_size,
-                                   cl_core.rehash_threshold);
+                                   ecl_ct_default_rehash_size,
+                                   ecl_ct_default_rehash_threshold);
   ecl_sethash(root, pool->hash, ecl_make_fixnum(0));
   pool->queue = ecl_list1(root);
   pool->last = pool->queue;

src/c/stack2.d

@@ -0,0 +1,251 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * stacks.d - runtime, binding, history and frame stacks
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <signal.h>
+#include <string.h>
+#ifdef HAVE_SYS_RESOURCE_H
+# include <sys/time.h>
+# include <sys/resource.h>
+#endif
+#include <ecl/nucleus.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/stack-resize.h>
+
+/* -- Bindings stack -------------------------------------------------------- */
+
+static ecl_bds_ptr
+get_bds_ptr(cl_object x)
+{
+  if (ECL_FIXNUMP(x)) {
+    cl_env_ptr env = ecl_process_env();
+    ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x);
+    if (env->bds_stack.org <= p && p <= env->bds_stack.top)
+      return(p);
+  }
+  FEerror("~S is an illegal bds index.", 1, x);
+}
+
+cl_object
+si_bds_top()
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org));
+}
+
+cl_object
+si_bds_var(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, get_bds_ptr(arg)->symbol);
+}
+
+cl_object
+si_bds_val(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  cl_object v = get_bds_ptr(arg)->value;
+  ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
+}
+
+/* -- Frame stack ----------------------------------------------------------- */
+
+static ecl_frame_ptr
+get_frame_ptr(cl_object x)
+{
+  if (ECL_FIXNUMP(x)) {
+    cl_env_ptr env = ecl_process_env();
+    ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x);
+    if (env->frs_stack.org <= p && p <= env->frs_stack.top)
+      return p;
+  }
+  FEerror("~S is an illegal frs index.", 1, x);
+}
+
+cl_object
+si_frs_top()
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org));
+}
+
+cl_object
+si_frs_bds(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx));
+}
+
+cl_object
+si_frs_tag(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, get_frame_ptr(arg)->frs_val);
+}
+
+cl_object
+si_frs_ihs(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
+}
+
+cl_object
+si_sch_frs_base(cl_object fr, cl_object ihs)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_frame_ptr x;
+  cl_index y = ecl_to_size(ihs);
+  for (x = get_frame_ptr(fr);
+       x <= env->frs_stack.top && x->frs_ihs->index < y;
+       x++);
+  ecl_return1(env, ((x > env->frs_stack.top)
+                    ? ECL_NIL
+                    : ecl_make_fixnum(x - env->frs_stack.org)));
+}
+
+/* -- Invocation stack ------------------------------------------------------ */
+
+static ecl_ihs_ptr
+get_ihs_ptr(cl_index n)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_ihs_ptr p = env->ihs_stack.top;
+  if (n > p->index)
+    FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n));
+  while (n < p->index)
+    p = p->next;
+  return p;
+}
+
+cl_object
+si_ihs_top(void)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, ecl_make_fixnum(env->ihs_stack.top->index));
+}
+
+cl_object
+si_ihs_prev(cl_object x)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, cl_1M(x));
+}
+
+cl_object
+si_ihs_next(cl_object x)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, cl_1P(x));
+}
+
+cl_object
+si_ihs_bds(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds));
+}
+
+cl_object
+si_ihs_fun(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function);
+}
+
+cl_object
+si_ihs_lex(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env);
+}
+
+cl_object
+si_ihs_lcl(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lcl_env);
+}
+
+/* DEPRECATED backward compatibility with SWANK/SLYNK. --jd 2025-11-17 */
+cl_object
+si_ihs_env(cl_object arg)
+{
+  cl_env_ptr env = ecl_process_env();
+  ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lcl_env);
+}
+
+/* -- Lisp ops on stacks ---------------------------------------------------- */
+
+cl_object
+si_set_limit(cl_object type, cl_object limit)
+{
+  cl_env_ptr env = ecl_process_env();
+  cl_index margin;
+  if (type == @'ext::frame-stack') {
+    cl_index current_size = env->frs_stack.top - env->frs_stack.org;
+    cl_index request_size = ecl_to_size(limit);
+    if(current_size > request_size)
+      FEerror("Cannot shrink frame stack below ~D.", 1, limit);
+    ecl_frs_set_limit(env, request_size);
+  } else if (type == @'ext::binding-stack') {
+    cl_index current_size = env->bds_stack.top - env->bds_stack.org;
+    cl_index request_size = ecl_to_size(limit);
+    if(current_size > request_size)
+      FEerror("Cannot shrink binding stack below ~D.", 1, limit);
+    ecl_bds_set_limit(env, request_size);
+  } else if (type == @'ext::lisp-stack') {
+    cl_index current_size = env->run_stack.top - env->run_stack.org;
+    cl_index request_size = ecl_to_size(limit);
+    if(current_size > request_size)
+      FEerror("Cannot shrink lisp stack below ~D.", 1, limit);
+    ecl_data_stack_set_limit(env, request_size);
+  } else if (type == @'ext::c-stack') {
+    cl_index the_size = ecl_to_size(limit);
+    margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
+    ecl_cs_set_size(env, the_size + 2*margin);
+  } else if (type == @'ext::heap-size') {
+    /*
+     * size_t can be larger than cl_index, and ecl_to_size()
+     * creates a fixnum which is too small for size_t on 32-bit.
+     */
+    size_t the_size = (size_t)ecl_to_ulong(limit);
+    _ecl_set_max_heap_size(the_size);
+  }
+
+  ecl_return1(env, si_get_limit(type));
+}
+
+cl_object
+si_get_limit(cl_object type)
+{
+  cl_env_ptr env = ecl_process_env();
+  cl_index output = 0;
+  if (type == @'ext::frame-stack')
+    output = env->frs_stack.limit_size;
+  else if (type == @'ext::binding-stack')
+    output = env->bds_stack.limit_size;
+  else if (type == @'ext::lisp-stack')
+    output = env->run_stack.limit_size;
+  else if (type == @'ext::c-stack')
+    output = env->c_stack.limit_size;
+  else if (type == @'ext::heap-size') {
+    /* size_t can be larger than cl_index */
+    ecl_return1(env, ecl_make_unsigned_integer(ecl_core.max_heap_size));
+  }
+
+  ecl_return1(env, ecl_make_unsigned_integer(output));
+}

src/c/stacks.d

@@ -20,6 +20,7 @@
 # include <sys/time.h>
 # include <sys/resource.h>
 #endif
+#include <ecl/nucleus.h>
 #include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
 #include <ecl/stack-resize.h>
@@ -32,17 +33,11 @@ ecl_cs_init(cl_env_ptr env)
   cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
   cl_index new_size = ecl_option_values[ECL_OPT_C_STACK_SIZE];
   cl_index max_size = new_size;
-#ifdef GBC_BOEHM
-  struct GC_stack_base base;
-  if (GC_get_stack_base(&base) == GC_SUCCESS)
-    env->c_stack.org = (char*)base.mem_base;
-  else
+  if (env->c_stack.org == NULL) {
+    /* Rough estimate. Not very safe. We assume that cl_boot() is invoked from
+     * the main() routine of the program. */
     env->c_stack.org = (char*)(&env);
-#else
-  /* Rough estimate. Not very safe. We assume that cl_boot() is invoked from the
-   * main() routine of the program. */
-  env->c_stack.org = (char*)(&env);
-#endif
+  }
 #ifdef ECL_CAN_SET_STACK_SIZE
   {
     struct rlimit rl;
@@ -162,9 +157,9 @@ ecl_cs_overflow(void)
   else
     ecl_internal_error(stack_overflow_msg);
   if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size)
-    CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_T);
+    ecl_cerror(ECL_EX_CS_OVR, ecl_make_fixnum(size), ECL_T);
   else
-    CEstack_overflow(@'ext::c-stack', ecl_make_fixnum(size), ECL_NIL);
+    ecl_ferror(ECL_EX_CS_OVR, ecl_make_fixnum(size), ECL_NIL);
 }
 
 /* -- Data stack ------------------------------------------------------------ */
@@ -375,7 +370,7 @@ bds_init(cl_env_ptr env)
   margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
   limit_size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE];
   size = limit_size + 2 * margin;
-  env->bds_stack.org = (ecl_bds_ptr)ecl_malloc(size * sizeof(*env->bds_stack.org));
+  env->bds_stack.org = (ecl_bds_ptr)ecl_malloc(size * sizeof(cl_object*));
   env->bds_stack.top = env->bds_stack.org-1;
   env->bds_stack.limit = &env->bds_stack.org[limit_size];
   env->bds_stack.size = size;
@@ -392,13 +387,14 @@ ecl_bds_overflow(void)
   cl_env_ptr env = ecl_process_env();
   cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
   cl_index size = env->bds_stack.size;
+  cl_index limit_size = env->bds_stack.limit_size;
   ecl_bds_ptr org = env->bds_stack.org;
   ecl_bds_ptr last = org + size;
   if (env->bds_stack.limit >= last) {
     ecl_internal_error(stack_overflow_msg);
   }
   env->bds_stack.limit += margin;
-  CEstack_overflow(@'ext::binding-stack', ecl_make_fixnum(size), ECL_T);
+  ecl_cerror(ECL_EX_BDS_OVR, ecl_make_fixnum(limit_size), ECL_T);
   return env->bds_stack.top;
 }
 
@@ -440,11 +436,11 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol)
   cl_object pool;
   cl_index new_index = symbol->symbol.binding;
   if (new_index == ECL_MISSING_SPECIAL_BINDING) {
-    pool = ecl_atomic_pop(&cl_core.reused_indices);
+    pool = ecl_atomic_pop(&ecl_core.reused_indices);
     if (!Null(pool)) {
       new_index = ecl_fixnum(ECL_CONS_CAR(pool));
     } else {
-      new_index = ecl_atomic_index_incf(&cl_core.last_var_index);
+      new_index = ecl_atomic_index_incf(&ecl_core.last_var_index);
     }
     symbol->symbol.binding = new_index;
   }
@@ -460,7 +456,7 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s)
   }
   if (index >= env->bds_stack.tl_bindings_size) {
     cl_index osize = env->bds_stack.tl_bindings_size;
-    cl_index nsize = cl_core.last_var_index * 1.25;
+    cl_index nsize = ecl_core.last_var_index * 1.25;
     cl_object *old_vector = env->bds_stack.tl_bindings;
     cl_object *new_vector = ecl_realloc(old_vector,
                                         osize*sizeof(cl_object*),
@@ -677,7 +673,7 @@ frs_overflow(void)
     ecl_internal_error(stack_overflow_msg);
   }
   env->frs_stack.limit += margin;
-  CEstack_overflow(@'ext::frame-stack', ecl_make_fixnum(limit_size), ECL_T);
+  ecl_cerror(ECL_EX_FRS_OVR, ecl_make_fixnum(limit_size), ECL_T);
 }
 
 ecl_frame_ptr
@@ -713,239 +709,91 @@ frs_sch (cl_object frame_id)
   return(NULL);
 }
 
-/* -- Initialization -------------------------------------------------------- */
-cl_object
-init_stacks(cl_env_ptr the_env)
+/* -- Module definition ------------------------------------------------------ */
+
+static cl_object
+create_stacks(void)
 {
+  cl_env_ptr the_env = ecl_core.first_env;
 #ifdef ECL_THREADS
-  if (the_env == cl_core.first_env) {
-    cl_index idx;
-    cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*));
-    for(idx=0; idx<1024; idx++) {
-      vector[idx] = ECL_NO_TL_BINDING;
-    }
-    the_env->bds_stack.tl_bindings_size = 1024;
-    the_env->bds_stack.tl_bindings = vector;
+  cl_index idx;
+  cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*));
+  for(idx=0; idx<1024; idx++) {
+    vector[idx] = ECL_NO_TL_BINDING;
   }
+  the_env->bds_stack.tl_bindings_size = 1024;
+  the_env->bds_stack.tl_bindings = vector;
 #endif
+  the_env->c_stack.org = NULL;
+  return ECL_NIL;
+}
+
+static cl_object
+enable_stacks(void)
+{
+  return ECL_NIL;
+}
+
+static cl_object
+init_env_stacks(cl_env_ptr the_env)
+{
   frs_init(the_env);
   bds_init(the_env);
   run_init(the_env);
   ihs_init(the_env);
-  /* FIXME ecl_cs_init must be called from the thread entry point at the
-     beginning to correctly determine the stack base. */
-#if 0
-  cs_init(the_env);
-#endif
+  the_env->c_stack.org = NULL;
   return ECL_NIL;
 }
 
-cl_object
-free_stacks(cl_env_ptr the_env)
+static cl_object
+init_cpu_stacks(cl_env_ptr the_env)
+{
+  ecl_cs_init(the_env);
+  return ECL_NIL;
+}
+
+static cl_object
+free_cpu_stacks(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+static cl_object
+free_env_stacks(cl_env_ptr the_env)
 {
-#ifdef ECL_THREADS
-  ecl_free(the_env->bds_stack.tl_bindings);
-  the_env->bds_stack.tl_bindings_size = 0;
-#endif
   ecl_free(the_env->run_stack.org);
   ecl_free(the_env->bds_stack.org);
   ecl_free(the_env->frs_stack.org);
   return ECL_NIL;
 }
 
-/* -- High level interface -------------------------------------------------- */
-
-void
-ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr)
+static cl_object
+destroy_stacks(void)
 {
-  env->frs_stack.nlj_fr = fr;
-  ecl_frame_ptr top = env->frs_stack.top;
-  while (top != fr && top->frs_val != ECL_PROTECT_TAG){
-    top->frs_val = ECL_DUMMY_TAG;
-    --top;
-  }
-  env->ihs_stack.top = top->frs_ihs;
-  ecl_bds_unwind(env, top->frs_bds_ndx);
-  ECL_STACK_UNWIND(env, top->frs_run_ndx);
-  env->frs_stack.top = top;
-  ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1);
-  /* never reached */
+  cl_env_ptr the_env = ecl_core.first_env;
+#ifdef ECL_THREADS
+  ecl_free(the_env->bds_stack.tl_bindings);
+  the_env->bds_stack.tl_bindings_size = 0;
+  the_env->bds_stack.tl_bindings = NULL;
+#endif
+  return ECL_NIL;
 }
 
-cl_index
-ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
-{
-  cl_object vars = vars0, values = values0;
-  cl_index n = env->bds_stack.top - env->bds_stack.org;
-  for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
-    if (Null(vars)) {
-      return n;
-    } else {
-      cl_object var = ECL_CONS_CAR(vars);
-      if (!ECL_SYMBOLP(var))
-        FEillegal_variable_name(var);
-      if (ecl_symbol_type(var) & ecl_stp_constant)
-        FEbinding_a_constant(var);
-      if (Null(values)) {
-        ecl_bds_bind(env, var, OBJNULL);
-      } else {
-        ecl_bds_bind(env, var, ECL_CONS_CAR(values));
-        values = ECL_CONS_CDR(values);
-      }
-    }
-  }
-  FEerror("Wrong arguments to special form PROGV. Either~%"
-          "~A~%or~%~A~%are not proper lists",
-          2, vars0, values0);
-}
+ecl_def_ct_base_string(str_stacks, "STACKS", 6, static, const);
 
-/* -- Bindings stack -------------------------------------------------------- */
+static struct ecl_module module_stacks = {
+  .name = str_stacks,
+  .create = create_stacks,
+  .enable = enable_stacks,
+  .init_env = init_env_stacks,
+  .init_cpu = init_cpu_stacks,
+  .free_cpu = free_cpu_stacks,
+  .free_env = free_env_stacks,
+  .disable = ecl_module_no_op,
+  .destroy = destroy_stacks
+};
 
-static ecl_bds_ptr
-get_bds_ptr(cl_object x)
-{
-  if (ECL_FIXNUMP(x)) {
-    cl_env_ptr env = ecl_process_env();
-    ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x);
-    if (env->bds_stack.org <= p && p <= env->bds_stack.top)
-      return(p);
-  }
-  FEerror("~S is an illegal bds index.", 1, x);
-}
-
-cl_object
-si_bds_top()
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org));
-}
-
-cl_object
-si_bds_var(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, get_bds_ptr(arg)->symbol);
-}
-
-cl_object
-si_bds_val(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  cl_object v = get_bds_ptr(arg)->value;
-  ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
-}
-
-/* -- Frame stack ----------------------------------------------------------- */
-
-static ecl_frame_ptr
-get_frame_ptr(cl_object x)
-{
-  if (ECL_FIXNUMP(x)) {
-    cl_env_ptr env = ecl_process_env();
-    ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x);
-    if (env->frs_stack.org <= p && p <= env->frs_stack.top)
-      return p;
-  }
-  FEerror("~S is an illegal frs index.", 1, x);
-}
-
-cl_object
-si_frs_top()
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org));
-}
-
-cl_object
-si_frs_bds(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx));
-}
-
-cl_object
-si_frs_tag(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, get_frame_ptr(arg)->frs_val);
-}
-
-cl_object
-si_frs_ihs(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
-}
-
-cl_object
-si_sch_frs_base(cl_object fr, cl_object ihs)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_frame_ptr x;
-  cl_index y = ecl_to_size(ihs);
-  for (x = get_frame_ptr(fr);
-       x <= env->frs_stack.top && x->frs_ihs->index < y;
-       x++);
-  ecl_return1(env, ((x > env->frs_stack.top)
-                    ? ECL_NIL
-                    : ecl_make_fixnum(x - env->frs_stack.org)));
-}
-
-/* -- Invocation stack ------------------------------------------------------ */
-
-static ecl_ihs_ptr
-get_ihs_ptr(cl_index n)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_ihs_ptr p = env->ihs_stack.top;
-  if (n > p->index)
-    FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n));
-  while (n < p->index)
-    p = p->next;
-  return p;
-}
-
-cl_object
-si_ihs_top(void)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, ecl_make_fixnum(env->ihs_stack.top->index));
-}
-
-cl_object
-si_ihs_prev(cl_object x)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, cl_1M(x));
-}
-
-cl_object
-si_ihs_next(cl_object x)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, cl_1P(x));
-}
-
-cl_object
-si_ihs_bds(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds));
-}
-
-cl_object
-si_ihs_fun(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function);
-}
-
-cl_object
-si_ihs_env(cl_object arg)
-{
-  cl_env_ptr env = ecl_process_env();
-  ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env);
-}
+cl_object ecl_module_stacks = (cl_object)&module_stacks;
 
 /* -- General purpose stack implementation ----------------------------------- */
 
@@ -953,6 +801,7 @@ si_ihs_env(cl_object arg)
 cl_object
 ecl_make_stack(cl_index size)
 {
+  /* XXX ecl_alloc flags=manual */
   cl_object x = ecl_malloc(sizeof(struct ecl_vector));
   x->vector.t = t_vector;
   x->vector.elttype = ecl_aet_object;
@@ -1007,6 +856,31 @@ ecl_stack_push(cl_object self, cl_object elt)
   return self;
 }
 
+cl_object
+ecl_stack_pop(cl_object self)
+{
+  cl_index fillp = self->vector.fillp;
+  cl_object elt = ECL_NIL;
+  if (ecl_unlikely(fillp == 0)) {
+    ecl_internal_error("ecl_stack_pop: stack underflow");
+  }
+  elt = self->vector.self.t[fillp-1];
+  self->vector.self.t[fillp-1] = ECL_NIL;
+  self->vector.fillp--;
+  return elt;
+}
+
+cl_object
+ecl_stack_dup(cl_object self)
+{
+  cl_index fillp = self->vector.fillp;
+  if (ecl_unlikely(fillp == 0)) {
+    ecl_internal_error("ecl_stack_dup: empty stack");
+  }
+  ecl_stack_push(self, self->vector.self.t[fillp-1]);
+  return self;
+}
+
 cl_object
 ecl_stack_del(cl_object self, cl_object elt)
 {
@@ -1033,64 +907,14 @@ ecl_stack_popu(cl_object self)
   return result;
 }
 
-/* -- Lisp ops on stacks ---------------------------------------------------- */
-
-cl_object
-si_set_limit(cl_object type, cl_object limit)
+void
+ecl_stack_grow(cl_object self, cl_index n)
 {
-  cl_env_ptr env = ecl_process_env();
-  cl_index margin;
-  if (type == @'ext::frame-stack') {
-    cl_index current_size = env->frs_stack.top - env->frs_stack.org;
-    cl_index request_size = ecl_to_size(limit);
-    if(current_size > request_size)
-      FEerror("Cannot shrink frame stack below ~D.", 1, limit);
-    ecl_frs_set_limit(env, request_size);
-  } else if (type == @'ext::binding-stack') {
-    cl_index current_size = env->bds_stack.top - env->bds_stack.org;
-    cl_index request_size = ecl_to_size(limit);
-    if(current_size > request_size)
-      FEerror("Cannot shrink binding stack below ~D.", 1, limit);
-    ecl_bds_set_limit(env, request_size);
-  } else if (type == @'ext::lisp-stack') {
-    cl_index current_size = env->run_stack.top - env->run_stack.org;
-    cl_index request_size = ecl_to_size(limit);
-    if(current_size > request_size)
-      FEerror("Cannot shrink lisp stack below ~D.", 1, limit);
-    ecl_data_stack_set_limit(env, request_size);
-  } else if (type == @'ext::c-stack') {
-    cl_index the_size = ecl_to_size(limit);
-    margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
-    ecl_cs_set_size(env, the_size + 2*margin);
-  } else if (type == @'ext::heap-size') {
-    /*
-     * size_t can be larger than cl_index, and ecl_to_size()
-     * creates a fixnum which is too small for size_t on 32-bit.
-     */
-    size_t the_size = (size_t)ecl_to_ulong(limit);
-    _ecl_set_max_heap_size(the_size);
-  }
-
-  ecl_return1(env, si_get_limit(type));
+  self->vector.fillp += n;
 }
 
-cl_object
-si_get_limit(cl_object type)
+void
+ecl_stack_drop(cl_object self, cl_index n)
 {
-  cl_env_ptr env = ecl_process_env();
-  cl_index output = 0;
-  if (type == @'ext::frame-stack')
-    output = env->frs_stack.limit_size;
-  else if (type == @'ext::binding-stack')
-    output = env->bds_stack.limit_size;
-  else if (type == @'ext::lisp-stack')
-    output = env->run_stack.limit_size;
-  else if (type == @'ext::c-stack')
-    output = env->c_stack.limit_size;
-  else if (type == @'ext::heap-size') {
-    /* size_t can be larger than cl_index */
-    ecl_return1(env, ecl_make_unsigned_integer(cl_core.max_heap_size));
-  }
-
-  ecl_return1(env, ecl_make_unsigned_integer(output));
+  self->vector.fillp -= n;
 }

src/c/stream.d

@@ -18,6 +18,21 @@
 #include <ecl/ecl.h>
 #include <ecl/internal.h>
 
+/* FIXME for now we break the dependency chain for NUCL, but later we want to
+   bring proto-clos into the early runtime and pull clos streams with it. */
+#ifdef ECL_NUCL
+# undef ECL_CLOS_STREAMS
+#endif
+
+static ecl_character
+_ecl_char_code(cl_object c)
+{
+  if (ecl_unlikely(!ECL_CHARACTERP(c))) {
+    ecl_ferror(ECL_EX_BADARG, @[character], c);
+  }
+  return ECL_CHAR_CODE(c);
+}
+
 #ifdef ECL_CLOS_STREAMS
 extern const struct ecl_file_ops clos_stream_ops;
 #endif
@@ -66,7 +81,7 @@ ecl_stream_dispatch_table(cl_object strm)
   }
 #endif
   if (!ECL_ANSI_STREAM_P(strm))
-    FEwrong_type_argument(@[stream], strm);
+    ecl_ferror(ECL_EX_BADARG, @[stream], strm);
   return (const struct ecl_file_ops *)strm->stream.ops;
 }
 
@@ -117,7 +132,7 @@ ecl_read_char_noeof(cl_object strm)
 {
   ecl_character c = ecl_read_char(strm);
   if (c == EOF)
-    FEend_of_file(strm);
+    ecl_ferror(ECL_EX_EOF, strm, ECL_NIL);
   return c;
 }
 
@@ -249,7 +264,7 @@ cl_object
 si_unread_char(cl_object strm, cl_object c)
 {
   cl_env_ptr the_env = ecl_process_env();
-  ecl_unread_char(ecl_char_code(c), strm);
+  ecl_unread_char(_ecl_char_code(c), strm);
   ecl_return1(the_env, ECL_NIL);
 }
 
@@ -265,7 +280,7 @@ cl_object
 si_write_char(cl_object strm, cl_object c)
 {
   cl_env_ptr the_env = ecl_process_env();
-  ecl_write_char(ecl_char_code(c), strm);
+  ecl_write_char(_ecl_char_code(c), strm);
   ecl_return1(the_env, c);
 }
 
@@ -354,28 +369,25 @@ cl_file_length(cl_object strm)
   @(return ecl_file_length(strm));
 }
 
-@(defun file-position (file_stream &o position)
-  cl_object output;
-@
-  if (Null(position)) {
-    output = ecl_file_position(file_stream);
-  } else {
-    if (position == @':start') {
-      position = ecl_make_fixnum(0);
-    } else if (position == @':end') {
-      position = ECL_NIL;
-    }
-    output = ecl_file_position_set(file_stream, position);
-  }
-  @(return output);
-@)
-
 cl_object
 cl_file_string_length(cl_object stream, cl_object string)
 {
   @(return ecl_file_string_length(stream, string));
 }
 
+cl_object
+si_file_position_get(cl_object strm)
+{
+  @(return ecl_file_position(strm));
+
+}
+
+cl_object
+si_file_position_set(cl_object strm, cl_object position)
+{
+  @(return ecl_file_position_set(strm, position));
+}
+
 cl_object
 cl_input_stream_p(cl_object strm)
 {
@@ -406,7 +418,7 @@ cl_open_stream_p(cl_object strm)
   }
 #endif
   unlikely_if (!ECL_ANSI_STREAM_P(strm))
-    FEwrong_type_only_arg(@'open-stream-p', strm, @'stream');
+    ecl_ferror(ECL_EX_UNSATISFIED, @[output-stream-p], strm);
   @(return (strm->stream.closed ? ECL_NIL : ECL_T));
 }
 
@@ -429,11 +441,14 @@ cl_stream_external_format(cl_object strm)
   else
 #endif
     unlikely_if (t != t_stream)
-      FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]);
+      ecl_ferror4(ECL_EX_BADARG_ONLY, @[stream-external-format], strm, @[stream]);
   if (strm->stream.mode == ecl_smm_synonym) {
-    strm = SYNONYM_STREAM_STREAM(strm);
-    goto AGAIN;
-  }
+    cl_env_ptr the_env = ecl_process_env();
+    cl_object sym = SYNONYM_STREAM_SYMBOL(strm);
+    strm = Null(sym) ? sym : ECL_SYM_VAL(the_env, sym);
+    if(strm==OBJNULL)
+      ecl_ferror2(ECL_EX_V_UNBND, sym);
+    goto AGAIN;  }
   output = strm->stream.format;
   @(return output);
 }
@@ -467,29 +482,3 @@ si_copy_stream(cl_object in, cl_object out, cl_object wait)
   ecl_force_output(out);
   @(return ((c==EOF) ? ECL_T : ECL_NIL));
 }
-
-cl_object
-si_file_stream_fd(cl_object s)
-{
-  cl_object ret;
-
-  unlikely_if (!ECL_FILE_STREAM_P(s)) {
-    ecl_not_a_file_stream(s);
-  }
-
-  switch ((enum ecl_smmode)s->stream.mode) {
-  case ecl_smm_input:
-  case ecl_smm_output:
-  case ecl_smm_io:
-    ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s)));
-    break;
-  case ecl_smm_input_file:
-  case ecl_smm_output_file:
-  case ecl_smm_io_file:
-    ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s));
-    break;
-  default:
-    ecl_internal_error("not a file stream");
-  }
-  @(return ret);
-}

src/c/streams/strm_common.d

@@ -23,52 +23,31 @@
 cl_object
 ecl_not_a_file_stream(cl_object strm)
 {
-  cl_error(9, @'simple-type-error', @':format-control',
-           @"~A is not an file stream",
-           @':format-arguments', cl_list(1, strm),
-           @':expected-type', @'file-stream',
-           @':datum', strm);
+  ecl_ferror(ECL_EX_BADARG, @[file-stream], strm);
 }
 
 void
 ecl_not_an_input_stream(cl_object strm)
 {
-  cl_error(9, @'simple-type-error', @':format-control',
-           @"~A is not an input stream",
-           @':format-arguments', cl_list(1, strm),
-           @':expected-type',
-           cl_list(2, @'satisfies', @'input-stream-p'),
-           @':datum', strm);
+  ecl_ferror(ECL_EX_UNSATISFIED, @[input-stream-p], strm);
 }
 
 void
 ecl_not_an_output_stream(cl_object strm)
 {
-  cl_error(9, @'simple-type-error', @':format-control',
-           @"~A is not an output stream",
-           @':format-arguments', cl_list(1, strm),
-           @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'),
-           @':datum', strm);
+  ecl_ferror(ECL_EX_UNSATISFIED, @[output-stream-p], strm);
 }
 
 static void
-not_a_character_stream(cl_object s)
+not_a_character_stream(cl_object strm)
 {
-  cl_error(9, @'simple-type-error', @':format-control',
-           @"~A is not a character stream",
-           @':format-arguments', cl_list(1, s),
-           @':expected-type', @'character',
-           @':datum', cl_stream_element_type(s));
+  ecl_ferror(ECL_EX_STRM_BADELT, @[character], strm);
 }
 
 static void
-not_a_binary_stream(cl_object s)
+not_a_binary_stream(cl_object strm)
 {
-  cl_error(9, @'simple-type-error', @':format-control',
-           @"~A is not a binary stream",
-           @':format-arguments', cl_list(1, s),
-           @':expected-type', @'integer',
-           @':datum', cl_stream_element_type(s));
+  ecl_ferror(ECL_EX_STRM_BADELT, @[integer], strm);
 }
 
 /**********************************************************************
@@ -235,14 +214,14 @@ ecl_unknown_column(cl_object strm)
 static cl_index
 closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
   return 0;
 }
 
 static cl_index
 closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
   return 0;
 }
 
@@ -268,34 +247,34 @@ closed_stream_unread_byte(cl_object strm, cl_object byte)
 static ecl_character
 closed_stream_read_char(cl_object strm)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
   return 0;
 }
 
 static ecl_character
 closed_stream_write_char(cl_object strm, ecl_character c)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
   return c;
 }
 
 static void
 closed_stream_unread_char(cl_object strm, ecl_character c)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
 }
 
 static int
 closed_stream_listen(cl_object strm)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
   return 0;
 }
 
 static void
 closed_stream_clear_input(cl_object strm)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
 }
 
 #define closed_stream_clear_output closed_stream_clear_input
@@ -305,7 +284,7 @@ closed_stream_clear_input(cl_object strm)
 static cl_object
 closed_stream_length(cl_object strm)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
 }
 
 #define closed_stream_get_position closed_stream_length
@@ -313,7 +292,7 @@ closed_stream_length(cl_object strm)
 static cl_object
 closed_stream_set_position(cl_object strm, cl_object position)
 {
-  FEclosed_stream(strm);
+  ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL);
 }
 
 /**********************************************************************
@@ -459,4 +438,3 @@ ecl_generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index
   }
   return start;
 }
-

src/c/streams/strm_composite.d

@@ -194,7 +194,6 @@ const struct ecl_file_ops two_way_ops = {
   two_way_close
 };
 
-
 cl_object
 cl_make_two_way_stream(cl_object istrm, cl_object ostrm)
 {

src/c/streams/strm_nucl.c

@@ -0,0 +1,278 @@
+/* -- imports ------------------------------------------------------- */
+
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#include <ecl/internal.h>
+#include <ecl/external.h>
+#include <ecl/bytecodes.h>
+
+cl_index
+not_implemented_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+  return 0;
+}
+
+static cl_index
+not_implemented_vector(cl_object strm, cl_object data, cl_index start, cl_index end)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+  return 0;
+}
+
+static void
+not_implemented_writer(cl_object strm, cl_object c)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+}
+
+static void
+not_implemented_option(cl_object strm)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+}
+
+static cl_object
+not_implemented_setter(cl_object strm, cl_object val)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+}
+
+static cl_object
+not_implemented_reader(cl_object strm)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+  return ECL_NIL;
+}
+
+static int
+not_implemented_reader_raw(cl_object strm)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+  return 0;
+}
+
+static int
+not_implemented_writer_raw(cl_object strm, int c)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+  return 0;
+}
+
+static void
+not_implemented_unread_raw(cl_object strm, int c)
+{
+  ecl_ferror(ECL_EX_NIY, ECL_NIL, ECL_NIL);
+}
+
+struct ecl_file_ops stub_io_ops = {
+  /* Used to implement encodings */
+  .write_byte8   = not_implemented_byte8,
+  .read_byte8    = not_implemented_byte8,
+  /* Binary I/O */
+  .write_byte    = not_implemented_writer,
+  .read_byte     = not_implemented_reader,
+  /* String I/O */
+  .read_char     = not_implemented_reader_raw,
+  .write_char    = not_implemented_writer_raw,
+  .unread_char   = not_implemented_unread_raw,
+  .peek_char     = not_implemented_reader_raw,
+  /* Used to implement r/w sequence */
+  .read_vector   = not_implemented_vector,
+  .write_vector  = not_implemented_vector,
+  /* Stream operations */
+  .listen        = not_implemented_reader_raw,
+  .clear_input   = not_implemented_option,
+  .clear_output  = not_implemented_option,
+  .finish_output = not_implemented_option,
+  .force_output  = not_implemented_option,
+  /* Stream appraisal */
+  .input_p       = not_implemented_reader_raw,
+  .output_p      = not_implemented_reader_raw,
+  .interactive_p = not_implemented_reader_raw,
+  .element_type  = not_implemented_reader,
+  /* Cursor operations */
+  .length        = not_implemented_reader,
+  .get_position  = not_implemented_reader,
+  .set_position  = not_implemented_setter,
+  .string_length = not_implemented_setter,
+  .column        = not_implemented_reader_raw,
+  /* File stream readers */
+  .pathname      = not_implemented_reader,
+  .truename      = not_implemented_reader,
+  /* Closing the stream (generic_close replaces the dispatch table) */
+  .close         = not_implemented_reader,
+};
+
+cl_object
+ecl_make_stub_stream(void)
+{
+  cl_object strm = ecl_alloc_stream();
+  strm->stream.ops = &stub_io_ops;
+  strm->stream.mode = ecl_smm_other;
+  return strm;
+}
+
+
+/* Nucl stream is an input stream that implements only operations that are
+   necessary for I/O (either character or binary). Limitations:
+
+ * char === byte === (unsigned-byte 8)
+ * use C99 streams (fopen, fread, fwrite etc)
+ * streams are bivalent
+ * streams are either input or output (io)
+ * not all stream operations are implemented
+
+Other than that we follow the same implementation strategy as other streams.
+~{read,write}_byte8~ are used to churn bytes and {read,write}_{byte,char}
+composes them bytes (in our case it is simply byte casting to lisp type). */
+
+static int
+nucl_io_error(cl_object strm, const char *s)
+{
+  const cl_env_ptr the_env = ecl_process_env();
+  volatile int old_errno = errno;
+  FILE *f = IO_STREAM_FILE(strm);
+  if (f != NULL) clearerr(f);
+  ecl_enable_interrupts_env(the_env);
+  if (old_errno == EINTR)
+    return 1;
+  ecl_internal_error("nucl_io_error: something happened!");
+}
+
+static cl_index
+nucl_r8(cl_object strm, unsigned char *c, cl_index n)
+{
+  FILE *f = IO_STREAM_FILE(strm);
+  cl_fixnum out = 0;
+  ecl_disable_interrupts();
+  do {
+    out = fread(c, sizeof(char), n, f);
+  } while (out < n && ferror(f) && nucl_io_error(strm, "fread"));
+  ecl_enable_interrupts();
+  return out;
+}
+
+static cl_index
+nucl_w8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_index out;
+  ecl_disable_interrupts();
+  do {
+    out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm));
+  } while (out < n && nucl_io_error(strm, "fwrite"));
+  ecl_enable_interrupts();
+  return out;
+}
+
+static ecl_character
+nucl_read_char(cl_object strm)
+{
+  unsigned char c;
+  if (!Null(strm->stream.byte_stack)) {
+    cl_object value = strm->stream.byte_stack;
+    strm->stream.byte_stack = ECL_NIL;
+    return ECL_CHAR_CODE(value);
+  }
+  if (nucl_r8(strm, &c, 1) < 1) {
+    return EOF;
+  }
+  return c;
+}
+
+static cl_object
+nucl_read_byte(cl_object strm)
+{
+  unsigned char c;
+  if (nucl_r8(strm, &c, 1) < 1) {
+    return ECL_NIL;
+  }
+  return ecl_make_fixnum(c);
+}
+
+static void
+nucl_unread_char(cl_object strm, int ch)
+{
+  strm->stream.byte_stack = ECL_CODE_CHAR(ch);
+}
+
+/* FIXME write_char and write_char have different order of args(!) */
+/* FIXME write_char and write_byte have different results(!) */
+static void
+nucl_write_byte(cl_object strm, cl_object byte)
+{
+  unsigned char v = (unsigned char)ecl_fixnum(byte);
+  nucl_w8(strm, &v, 1);
+}
+
+static ecl_character
+nucl_write_char(cl_object strm, ecl_character c)
+{
+  unsigned char v = (unsigned char)c;
+  nucl_w8(strm, &v, 1);
+  return c;
+}
+
+struct ecl_file_ops nucl_io_ops = {
+  /* Used to implement encodings */
+  .write_byte8   = nucl_r8,
+  .read_byte8    = nucl_w8,
+  /* Binary I/O */
+  .write_byte    = nucl_write_byte,
+  .read_byte     = nucl_read_byte,
+  /* String I/O */
+  .read_char     = nucl_read_char,
+  .write_char    = nucl_write_char,
+  .unread_char   = nucl_unread_char,
+  .peek_char     = not_implemented_reader_raw,
+  /* Used to implement r/w sequence */
+  .read_vector   = not_implemented_vector,
+  .write_vector  = not_implemented_vector,
+  /* Stream operations */
+  .listen        = not_implemented_reader_raw,
+  .clear_input   = not_implemented_option,
+  .clear_output  = not_implemented_option,
+  .finish_output = not_implemented_option,
+  .force_output  = not_implemented_option,
+  /* Stream appraisal */
+  .input_p       = not_implemented_reader_raw,
+  .output_p      = not_implemented_reader_raw,
+  .interactive_p = not_implemented_reader_raw,
+  .element_type  = not_implemented_reader,
+  /* Cursor operations */
+  .length        = not_implemented_reader,
+  .get_position  = not_implemented_reader,
+  .set_position  = not_implemented_setter,
+  .string_length = not_implemented_setter,
+  .column        = not_implemented_reader_raw,
+  /* File stream readers */
+  .pathname      = not_implemented_reader,
+  .truename      = not_implemented_reader,
+  /* Closing the stream (generic_close replaces the dispatch table) */
+  .close         = not_implemented_reader,
+};
+
+cl_object
+ecl_make_nucl_stream(FILE *f)
+{
+  cl_object strm = ecl_alloc_stream();
+  /* ecl_make_stream_from_FILE() */
+  strm->stream.mode = ecl_smm_other;
+  strm->stream.closed = 0;
+  strm->stream.column = 0;
+  strm->stream.last_op = 0;
+  strm->stream.ops = ecl_duplicate_dispatch_table(&nucl_io_ops);
+  strm->stream.byte_stack = ECL_NIL;
+  IO_STREAM_FILENAME(strm) = ECL_NIL;
+  IO_STREAM_FILE(strm) = f;
+#if 0                              /* currently we don't do formatting */
+  si_set_finalizer(stream, ECL_T); /* calls cl_close */
+  /* ecl_set_stream_elt_type() */
+  stream->stream.flags = ECL_STREAM_DEFAULT_FORMAT;
+  IO_STREAM_ELT_TYPE(stream) = @'base-char';
+  stream->stream.format = @':pass-through';
+  stream->stream.encoder = passthrough_encoder;
+  stream->stream.decoder = passthrough_decoder;
+#endif
+  return strm;
+}

src/c/symbol.d

@@ -159,7 +159,7 @@ ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s)
 #ifndef ECL_FINAL
   /* Symbols are not initialized yet. This test is issued only during ECL
      compilation to ensure, that we have no early references in the core. */
-  if(cl_num_symbols_in_core < 3) {
+  if(cl_num_symbols_in_core < 2) {
     ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet.");
   }
 #endif

src/c/symbols_list.h

@@ -102,13 +102,11 @@ cl_symbol_initializer
 cl_symbols[] = {
 
 {"NIL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)},
-{"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)},
-{SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)},
-{SYS_ "PROTECT-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
-{SYS_ "DUMMY-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
-{SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
-{SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
-{EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)},
+
+{SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)},
+
+{SYS_ "EXCEPTION-HANDLER" ECL_FUN("ecl_exception_handler", ecl_exception_handler, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 
 /* LISP PACKAGE */
 {"&ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)},
@@ -1189,6 +1187,8 @@ cl_symbols[] = {
 {SYS_ "EXPAND-DEFMACRO" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "FILE-COLUMN" ECL_FUN("si_file_column", si_file_column, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {EXT_ "FILE-KIND" ECL_FUN("si_file_kind", si_file_kind, 2) ECL_VAR(EXT_ORDINARY, OBJNULL)},
+{SYS_ "FILE-POSITION-GET" ECL_FUN("si_file_position_get", si_file_position_get, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "FILE-POSITION-SET" ECL_FUN("si_file_position_set", si_file_position_set, 2) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "FILL-POINTER-SET" ECL_FUN("si_fill_pointer_set", si_fill_pointer_set, 2) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {EXT_ "FILE-STREAM-FD" ECL_FUN("si_file_stream_fd", si_file_stream_fd, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
 {EXT_ "MAKE-STREAM-FROM-FD" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
@@ -1215,6 +1215,8 @@ cl_symbols[] = {
 {SYS_ "HASH-TABLE-ITERATOR" ECL_FUN("si_hash_table_iterator", si_hash_table_iterator, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "IHS-BDS" ECL_FUN("si_ihs_bds", si_ihs_bds, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "IHS-ENV" ECL_FUN("si_ihs_env", si_ihs_env, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "IHS-LEX" ECL_FUN("si_ihs_lex", si_ihs_lex, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "IHS-LCL" ECL_FUN("si_ihs_lcl", si_ihs_lcl, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "IHS-FUN" ECL_FUN("si_ihs_fun", si_ihs_fun, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "IHS-NEXT" ECL_FUN("si_ihs_next", si_ihs_next, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "IHS-PREV" ECL_FUN("si_ihs_prev", si_ihs_prev, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
@@ -1355,7 +1357,6 @@ cl_symbols[] = {
 {KEY_ "ADJUSTABLE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
 {KEY_ "ABORT" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
 {KEY_ "ABSOLUTE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
-{KEY_ "ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
 {KEY_ "APPEND" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
 {KEY_ "ARRAY" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
 {KEY_ "BACK" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
@@ -1845,6 +1846,8 @@ cl_symbols[] = {
 
 {SYS_ "CODE-BLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 
+{SYS_ "EXCEPTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
+{SYS_ "MODULE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
 {SYS_ "APPLY-FROM-STACK-FRAME" ECL_FUN("si_apply_from_stack_frame", si_apply_from_stack_frame, 2) ECL_VAR(SI_ORDINARY, OBJNULL)},
 

src/c/threads/thread.d

@@ -31,111 +31,25 @@
 # include <sched.h>
 #endif
 
-/* -- Macros -------------------------------------------------------- */
-
-#ifdef ECL_WINDOWS_THREADS
-# define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2))
-# define ecl_set_process_self(var)              \
-  {                                             \
-    HANDLE aux = GetCurrentThread();            \
-    DuplicateHandle(GetCurrentProcess(),        \
-                    aux,                        \
-                    GetCurrentProcess(),        \
-                    &var,                       \
-                    0,                          \
-                    FALSE,                      \
-                    DUPLICATE_SAME_ACCESS);     \
-  }
-#else
-# define ecl_process_eq(t1, t2) (t1 == t2)
-# define ecl_set_process_self(var) (var = pthread_self())
-#endif  /* ECL_WINDOWS_THREADS */
-
 /* -- Core ---------------------------------------------------------- */
 
-static void
-extend_process_vector()
-{
-  cl_object v = cl_core.processes;
-  cl_index new_size = v->vector.dim + v->vector.dim/2;
-  cl_env_ptr the_env = ecl_process_env();
-  ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) {
-    cl_object other = cl_core.processes;
-    if (new_size > other->vector.dim) {
-      cl_object new = si_make_vector(ECL_T,
-                                     ecl_make_fixnum(new_size),
-                                     ecl_make_fixnum(other->vector.fillp),
-                                     ECL_NIL, ECL_NIL, ECL_NIL);
-      ecl_copy_subarray(new, 0, other, 0, other->vector.dim);
-      cl_core.processes = new;
-    }
-  } ECL_WITH_NATIVE_LOCK_END;
-}
-
-static void
-ecl_list_process(cl_object process)
-{
-  cl_env_ptr the_env = ecl_process_env();
-  bool ok = 0;
-  do {
-    ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) {
-      cl_object vector = cl_core.processes;
-      cl_index size = vector->vector.dim;
-      cl_index ndx = vector->vector.fillp;
-      if (ndx < size) {
-        vector->vector.self.t[ndx++] = process;
-        vector->vector.fillp = ndx;
-        ok = 1;
-      }
-    } ECL_WITH_NATIVE_LOCK_END;
-    if (ok) break;
-    extend_process_vector();
-  } while (1);
-}
-
-/* Must be called with disabled interrupts to prevent race conditions
- * in thread_cleanup */
-static void
-ecl_unlist_process(cl_object process)
-{
-  ecl_mutex_lock(&cl_core.processes_lock);
-  cl_object vector = cl_core.processes;
-  cl_index i;
-  for (i = 0; i < vector->vector.fillp; i++) {
-    if (vector->vector.self.t[i] == process) {
-      vector->vector.fillp--;
-      do {
-        vector->vector.self.t[i] =
-          vector->vector.self.t[i+1];
-      } while (++i < vector->vector.fillp);
-      break;
-    }
-  }
-  ecl_mutex_unlock(&cl_core.processes_lock);
-}
-
 static cl_object
 ecl_process_list()
 {
   cl_env_ptr the_env = ecl_process_env();
   cl_object output = ECL_NIL;
-  ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) {
-    cl_object vector = cl_core.processes;
-    cl_object *data = vector->vector.self.t;
-    cl_index i;
-    for (i = 0; i < vector->vector.fillp; i++) {
-      cl_object p = data[i];
-      if (p != ECL_NIL)
-        output = ecl_cons(p, output);
-    }
+  ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) {
+    loop_across_stack_fifo(_env, ecl_core.threads) {
+      cl_env_ptr env = ecl_cast_ptr(cl_env_ptr, _env);
+      cl_object p = env->own_process;
+      output = ecl_cons(p, output);
+    } end_loop_across_stack();
   } ECL_WITH_NATIVE_LOCK_END;
   return output;
 }
 
 /* -- Environment --------------------------------------------------- */
 
-extern void ecl_init_env(struct cl_env_struct *env);
-
 cl_object
 mp_current_process(void)
 {
@@ -151,27 +65,62 @@ assert_type_process(cl_object o)
     FEwrong_type_argument(@[mp::process], o);
 }
 
-static void
-thread_cleanup(void *aux)
+static cl_object
+run_process(cl_narg narg, ...)
 {
-  /* 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.
+  /* Upon entering this routine the process environment is set up, the process
+   * phase is ECL_PROCESS_BOOTING, signals are disabled in the environment and
+   * the communication interrupt is disabled (sigmasked).
    *
-   * 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().
+   * This process will not receive signals that originate from other processes.
+   * Furthermore, we expect not to get any other interrupts (SIGSEGV, SIGFPE) if
+   * we do things right.
    */
-  cl_object process = (cl_object)aux;
-  cl_env_ptr env = process->process.env;
+  cl_env_ptr the_env = ecl_process_env();
+  cl_object process = the_env->own_process;
+  cl_object fun = process->process.function;
+  cl_object args = process->process.args;
+  cl_object output = ECL_NIL;
+  /* Entry barrier. enable_process releases this lock before exit. */
+  ecl_mutex_lock(&process->process.start_stop_lock);
+
+  /* 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. */
+  ECL_CATCH_ALL_BEGIN(the_env) {
+#ifdef HAVE_SIGPROCMASK
+    {
+      sigset_t *new = (sigset_t*)the_env->default_sigmask;
+      ecl_sigmask(SIG_SETMASK, new, NULL);
+    }
+#endif
+    process->process.phase = ECL_PROCESS_ACTIVE;
+    ecl_mutex_unlock(&process->process.start_stop_lock);
+    si_trap_fpe(@'last', ECL_T);
+
+    ecl_enable_interrupts_env(the_env);
+    ecl_bds_bind(the_env, @'mp::*current-process*', process);
+
+    ECL_RESTART_CASE_BEGIN(the_env, @'abort') {
+      the_env->values[0] = cl_apply(2, fun, args);
+      int i = the_env->nvalues;
+      while (i--) {
+        output = CONS(the_env->values[i], output);
+      }
+      process->process.exit_values = output;
+    } ECL_RESTART_CASE(1,args) {
+      /* ABORT restart. */
+      process->process.exit_values = args;
+    } ECL_RESTART_CASE_END;
+    /* This routine performs some cleanup before a thread is finished. Note that
+       it does not provide enough protection -- in order to ensure that all
+       UNWIND-PROTECT forms are properly executed, enver use the function
+       pthread_cancel() to kill a process, but rather use the lisp functions
+       mp_interrupt_process() and mp_process_kill(). */
+    ecl_bds_unwind1(the_env);
+  } ECL_CATCH_ALL_END;
+
+  ecl_disable_interrupts_env(the_env);
 
-  /* The following flags will disable all interrupts. */
-  if (env) {
-    ecl_disable_interrupts_env(env);
-    ecl_clear_bignum_registers(env);
-  }
   ecl_mutex_lock(&process->process.start_stop_lock);
   process->process.phase = ECL_PROCESS_EXITING;
 #ifdef HAVE_SIGPROCMASK
@@ -180,137 +129,30 @@ thread_cleanup(void *aux)
     sigset_t new[1];
     sigemptyset(new);
     sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]);
-    pthread_sigmask(SIG_BLOCK, new, NULL);
+    ecl_sigmask(SIG_BLOCK, new, NULL);
   }
 #endif
   process->process.env = NULL;
-  ecl_unlist_process(process);
-#ifdef ECL_WINDOWS_THREADS
-  CloseHandle(process->process.thread);
-#endif
-  ecl_set_process_env(NULL);
-  if (env) _ecl_dealloc_env(env);
-
   process->process.phase = ECL_PROCESS_INACTIVE;
   ecl_cond_var_broadcast(&process->process.exit_barrier);
   ecl_mutex_unlock(&process->process.start_stop_lock);
-}
 
-#ifdef ECL_WINDOWS_THREADS
-static DWORD WINAPI
-#else
-static void *
-#endif
-thread_entry_point(void *arg)
-{
-  cl_object process = (cl_object)arg;
-  cl_env_ptr env = process->process.env;
-
-  /*
-   * Upon entering this routine
-   *      process.env = our environment for lisp
-   *      process.phase = ECL_PROCESS_BOOTING
-   *      signals are disabled in the environment
-   *      the communication interrupt is disabled (sigmasked)
-   *
-   * This process will not receive signals that originate from
-   * other processes. Furthermore, we expect not to get any
-   * other interrupts (SIGSEGV, SIGFPE) if we do things right.
-   */
-  /* 1) Setup the environment for the execution of the thread */
-  ecl_set_process_env(env = process->process.env);
-#ifndef ECL_WINDOWS_THREADS
-  pthread_cleanup_push(thread_cleanup, (void *)process);
-#endif
-  ecl_cs_init(env);
-  ecl_mutex_lock(&process->process.start_stop_lock);
-
-  /* 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.
-   */
-  ECL_CATCH_ALL_BEGIN(env) {
-#ifdef HAVE_SIGPROCMASK
-    {
-      sigset_t *new = (sigset_t*)env->default_sigmask;
-      pthread_sigmask(SIG_SETMASK, new, NULL);
-    }
-#endif
-    process->process.phase = ECL_PROCESS_ACTIVE;
-    ecl_mutex_unlock(&process->process.start_stop_lock);
-    ecl_enable_interrupts_env(env);
-    si_trap_fpe(@'last', ECL_T);
-    ecl_bds_bind(env, @'mp::*current-process*', process);
-
-    ECL_RESTART_CASE_BEGIN(env, @'abort') {
-      env->values[0] = cl_apply(2, process->process.function,
-                                process->process.args);
-      {
-        cl_object output = ECL_NIL;
-        int i = env->nvalues;
-        while (i--) {
-          output = CONS(env->values[i], output);
-        }
-        process->process.exit_values = output;
-      }
-    } ECL_RESTART_CASE(1,args) {
-      /* ABORT restart. */
-      process->process.exit_values = args;
-    } ECL_RESTART_CASE_END;
-    ecl_bds_unwind1(env);
-  } ECL_CATCH_ALL_END;
-
-  /* 4) If everything went right, we should be exiting the thread
-   *    through this point. thread_cleanup is automatically invoked
-   *    marking the process as inactive.
-   */
-#ifdef ECL_WINDOWS_THREADS
-  thread_cleanup(process);
-  return 1;
-#else
-  pthread_cleanup_pop(1);
-  return NULL;
-#endif
-}
-
-static void
-init_tl_bindings(cl_object process, cl_env_ptr env)
-{
-  cl_index bindings_size;
-  cl_object *bindings;
-  if (Null(process->process.inherit_bindings_p)) {
-    cl_index idx = 0, size = 256;
-    bindings_size = size;
-    bindings = (cl_object *)ecl_malloc(size*sizeof(cl_object*));
-    for(idx=0; idx<256; idx++) {
-      bindings[idx] = ECL_NO_TL_BINDING;
-    }
-  } else {
-    cl_env_ptr parent_env = ecl_process_env();
-    bindings_size = parent_env->bds_stack.tl_bindings_size;
-    bindings = (cl_object *)ecl_malloc(bindings_size*sizeof(cl_object*));
-    ecl_copy(bindings, parent_env->bds_stack.tl_bindings, bindings_size*sizeof(cl_object*));
-  }
-  env->bds_stack.tl_bindings_size = bindings_size;
-  env->bds_stack.tl_bindings = bindings;
+  return the_env->values[0];
 }
 
 static cl_object
 alloc_process(cl_object name, cl_object initial_bindings_p)
 {
   cl_env_ptr env = ecl_process_env();
-  cl_object process = ecl_alloc_object(t_process), array;
-  cl_index bindings_size;
-  cl_object* bindings;
+  cl_object process = ecl_alloc_object(t_process);
   process->process.phase = ECL_PROCESS_INACTIVE;
+  process->process.exit_values = ECL_NIL;
+  process->process.entry = run_process;
   process->process.name = name;
   process->process.function = ECL_NIL;
   process->process.args = ECL_NIL;
-  process->process.interrupt = ECL_NIL;
-  process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL;
-  process->process.exit_values = ECL_NIL;
-  process->process.env = NULL;
   process->process.woken_up = ECL_NIL;
+  process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL;
   ecl_disable_interrupts_env(env);
   ecl_mutex_init(&process->process.start_stop_lock, TRUE);
   ecl_cond_var_init(&process->process.exit_barrier);
@@ -322,87 +164,49 @@ alloc_process(cl_object name, cl_object initial_bindings_p)
 bool
 ecl_import_current_thread(cl_object name, cl_object bindings)
 {
-  struct cl_env_struct env_aux[1];
   cl_object process;
-  ecl_thread_t current;
-  cl_env_ptr env;
-  int registered;
-  struct GC_stack_base stack;
-  ecl_set_process_self(current);
-#ifdef GBC_BOEHM
-  GC_get_stack_base(&stack);
-  switch (GC_register_my_thread(&stack)) {
-  case GC_SUCCESS:
-    registered = 1;
-    break;
-  case GC_DUPLICATE:
-    /* Thread was probably created using the GC hooks for thread creation. */
-    registered = 0;
-    break;
-  default:
+  cl_env_ptr the_env;
+  if (ecl_process_env_unsafe() != NULL)
     return 0;
-  }
-#endif
-  {
-    cl_object processes = cl_core.processes;
-    cl_index i, size;
-    for (i = 0, size = processes->vector.fillp; i < size; i++) {
-      cl_object p = processes->vector.self.t[i];
-      if (!Null(p) && ecl_process_eq(p->process.thread, current)) {
-          return 0;
-      }
-    }
-  }
-  /* We need a fake env to allow for interrupts blocking and to set up
-   * frame stacks or other stuff which may be needed by alloc_process
-   * and ecl_list_process. Since the fake env is allocated on the stack,
-   * we can safely store pointers to memory allocated by the gc there. */
-  memset(env_aux, 0, sizeof(*env_aux));
-  env_aux->disable_interrupts = 1;
-  env_aux->interrupt_struct = ecl_alloc_unprotected(sizeof(*env_aux->interrupt_struct));
-  env_aux->interrupt_struct->pending_interrupt = ECL_NIL;
-  ecl_mutex_init(&env_aux->interrupt_struct->signal_queue_lock, FALSE);
-  env_aux->interrupt_struct->signal_queue = ECL_NIL;
-  ecl_set_process_env(env_aux);
-  ecl_init_env(env_aux);
+  ecl_module_gc->module.disable();
+  the_env = ecl_adopt_cpu();
+  ecl_module_gc->module.enable();
+  ecl_enable_interrupts_env(the_env);
 
-  /* Allocate real environment, link it together with process */
-  env = _ecl_alloc_env(0);
   process = alloc_process(name, ECL_NIL);
-  process->process.env = env;
+  process->process.env = the_env;
   process->process.phase = ECL_PROCESS_BOOTING;
-  process->process.thread = current;
-
-  /* Copy initial bindings from process to the fake environment */
-  env_aux->cleanup = registered;
-  init_tl_bindings(process, env_aux);
-
-  /* Switch over to the real environment */
-  memcpy(env, env_aux, sizeof(*env));
-  env->own_process = process;
-  ecl_set_process_env(env);
-  ecl_list_process(process);
-  ecl_enable_interrupts_env(env);
-
+  the_env->own_process = process;
   process->process.phase = ECL_PROCESS_ACTIVE;
 
-  ecl_bds_bind(env, @'mp::*current-process*', process);
+  ecl_bds_bind(the_env, @'mp::*current-process*', process);
   return 1;
 }
 
 void
 ecl_release_current_thread(void)
 {
-  cl_env_ptr env = ecl_process_env();
-
-  int cleanup = env->cleanup;
-  cl_object own_process = env->own_process;
-  thread_cleanup(own_process);
-#ifdef GBC_BOEHM
-  if (cleanup) {
-    GC_unregister_my_thread();
+  cl_object process;
+  cl_env_ptr the_env = ecl_process_env_unsafe();
+  if (the_env == NULL)
+    return;
+  process = the_env->own_process;
+  ecl_mutex_lock(&process->process.start_stop_lock);
+  process->process.env = NULL;
+  process->process.phase = ECL_PROCESS_EXITING;
+  ecl_disown_cpu();
+#ifdef HAVE_SIGPROCMASK
+  /* ...but we might get stray signals. */
+  {
+    sigset_t new[1];
+    sigemptyset(new);
+    sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]);
+    ecl_sigmask(SIG_BLOCK, new, NULL);
   }
 #endif
+  process->process.phase = ECL_PROCESS_INACTIVE;
+  ecl_cond_var_broadcast(&process->process.exit_barrier);
+  ecl_mutex_unlock(&process->process.start_stop_lock);
 }
 
 @(defun mp::make-process (&key name ((:initial-bindings initial_bindings_p) ECL_T))
@@ -495,109 +299,33 @@ mp_process_yield(void)
 cl_object
 mp_process_enable(cl_object process)
 {
-  /* process_env and ok are changed after the setjmp call in
-   * ECL_UNWIND_PROTECT_BEGIN, so they need to be declared volatile */
-  volatile cl_env_ptr process_env = NULL;
   cl_env_ptr the_env = ecl_process_env();
-  volatile int ok = 1;
-  ECL_UNWIND_PROTECT_BEGIN(the_env) {
-    /* Try to gain exclusive access to the process. This prevents two
-     * concurrent calls to process-enable from different threads on
-     * the same process */
-    ecl_mutex_lock(&process->process.start_stop_lock);
-    /* Ensure that the process is inactive. */
-    if (process->process.phase != ECL_PROCESS_INACTIVE) {
-      FEerror("Cannot enable the running process ~A.", 1, process);
-    }
-    ok = 0;
-    process->process.phase = ECL_PROCESS_BOOTING;
-
-    process->process.parent = mp_current_process();
-    process->process.trap_fpe_bits =
-      process->process.parent->process.env->trap_fpe_bits;
-
-    /* Link environment and process together */
-    process_env = _ecl_alloc_env(the_env);
-    process_env->own_process = process;
-    process->process.env = process_env;
-
-    /* Immediately list the process such that its environment is
-     * marked by the gc when its contents are allocated */
-    ecl_list_process(process);
-
-    /* Now we can safely allocate memory for the environment contents
-     * and store pointers to it in the environment */
-    ecl_init_env(process_env);
-
-    process_env->trap_fpe_bits = process->process.trap_fpe_bits;
-    init_tl_bindings(process, process_env);
-
-    ecl_disable_interrupts_env(the_env);
-#ifdef ECL_WINDOWS_THREADS
-    {
-      HANDLE code;
-      DWORD threadId;
-
-      code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId);
-      ok = (process->process.thread = code) != NULL;
-    }
-#else
-    {
-      int code;
-      pthread_attr_t pthreadattr;
-
-      pthread_attr_init(&pthreadattr);
-      pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED);
-      /*
-       * Block all asynchronous signals until the thread is completely
-       * set up. The synchronous signals SIGSEGV and SIGBUS are needed
-       * by the gc and thus can't be blocked.
-       */
-#ifdef HAVE_SIGPROCMASK
-      {
-        sigset_t new, previous;
-        sigfillset(&new);
-        sigdelset(&new, SIGSEGV);
-        sigdelset(&new, SIGBUS);
-        pthread_sigmask(SIG_BLOCK, &new, &previous);
-        code = pthread_create(&process->process.thread, &pthreadattr,
-                              thread_entry_point, process);
-        pthread_sigmask(SIG_SETMASK, &previous, NULL);
-      }
-#else
-      code = pthread_create(&process->process.thread, &pthreadattr,
-                            thread_entry_point, process);
-#endif
-      ok = (code == 0);
-    }
-#endif
-    ecl_enable_interrupts_env(the_env);
-  } ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT {
-    if (!ok) {
-      /* INV: interrupts are already disabled through thread safe
-       * unwind-protect */
-      ecl_unlist_process(process);
-      process->process.phase = ECL_PROCESS_INACTIVE;
-      /* Alert possible waiting processes. */
-      ecl_cond_var_broadcast(&process->process.exit_barrier);
-      process->process.env = NULL;
-      if (process_env != NULL)
-        _ecl_dealloc_env(process_env);
-    }
-    /* Unleash the thread */
+  cl_env_ptr process_env = NULL;
+  /* Try to gain exclusive access to the process. This prevents two concurrent
+   * calls to process-enable from different threads on the same process */
+  ecl_mutex_lock(&process->process.start_stop_lock);
+  /* Ensure that the process is inactive. */
+  if (process->process.phase != ECL_PROCESS_INACTIVE) {
     ecl_mutex_unlock(&process->process.start_stop_lock);
-  } ECL_UNWIND_PROTECT_THREAD_SAFE_END;
-
-  @(return (ok? process : ECL_NIL));
+    FEerror("Cannot enable the running process ~A.", 1, process);
+  }
+  process->process.phase = ECL_PROCESS_BOOTING;
+  /* Spawn the thread (allocates the environment)*/
+  process_env = ecl_spawn_cpu(process);
+  if (process_env == NULL) {
+    process->process.phase = ECL_PROCESS_INACTIVE;
+    ecl_cond_var_broadcast(&process->process.exit_barrier);
+  }
+  /* Unleash the thread */
+  ecl_mutex_unlock(&process->process.start_stop_lock);
+  ecl_return1(the_env, (process_env ? process : ECL_NIL));
 }
 
 cl_object
 mp_exit_process(void)
 {
-  /* We simply undo the whole of the frame stack. 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. */
   const cl_env_ptr the_env = ecl_process_env();
   ecl_unwind(the_env, the_env->frs_stack.org);
   /* Never reached */
@@ -628,8 +356,9 @@ mp_process_active_p(cl_object process)
 cl_object
 mp_process_whostate(cl_object process)
 {
+  const cl_env_ptr the_env = ecl_process_env();
   assert_type_process(process);
-  @(return (cl_core.null_string));
+  ecl_return1(the_env, ecl_ct_null_string);
 }
 
 cl_object
@@ -667,8 +396,7 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...)
   ecl_va_start(args, function, narg, 2);
   rest = cl_grab_rest_args(args);
   ecl_va_end(args);
-  cl_apply(4, @'mp::process-preset', process, function,
-           rest);
+  cl_apply(4, @'mp::process-preset', process, function, rest);
   return mp_process_enable(process);
 }
 
@@ -701,8 +429,8 @@ mp_get_sigmask(void)
   sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8;
   sigset_t no_signals;
   sigemptyset(&no_signals);
-  if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr))
-    FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0);
+  if (ecl_sigmask(SIG_BLOCK, &no_signals, mask_ptr))
+    FElibc_error("MP:GET-SIGMASK failed in a call to ecl_sigmask", 0);
   @(return data);
 }
 
@@ -710,8 +438,8 @@ static cl_object
 mp_set_sigmask(cl_object data)
 {
   sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8;
-  if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL))
-    FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0);
+  if (ecl_sigmask(SIG_SETMASK, mask_ptr, NULL))
+    FElibc_error("MP:SET-SIGMASK failed in a call to ecl_sigmask", 0);
   @(return data);
 }
 #endif
@@ -721,8 +449,8 @@ mp_block_signals(void)
 {
 #ifdef ECL_WINDOWS_THREADS
   cl_env_ptr the_env = ecl_process_env();
-  cl_object previous = ecl_cmp_symbol_value(the_env, @'ext::*interrupts-enabled*');
-  ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL);
+  cl_object previous = ecl_cmp_symbol_value(the_env, ECL_INTERRUPTS_ENABLED);
+  ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);
   @(return previous);
 #else
   cl_object previous = mp_get_sigmask();
@@ -732,8 +460,8 @@ mp_block_signals(void)
    * can thus never be blocked */
   sigdelset(&all_signals, SIGSEGV);
   sigdelset(&all_signals, SIGBUS);
-  if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL))
-    FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0);
+  if (ecl_sigmask(SIG_SETMASK, &all_signals, NULL))
+    FElibc_error("MP:BLOCK-SIGNALS failed in a call to ecl_sigmask",0);
   @(return previous);
 #endif
 }
@@ -743,7 +471,7 @@ mp_restore_signals(cl_object sigmask)
 {
 #ifdef ECL_WINDOWS_THREADS
   cl_env_ptr the_env = ecl_process_env();
-  ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask);
+  ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, sigmask);
   ecl_check_pending_interrupts(the_env);
   @(return sigmask);
 #else
@@ -751,37 +479,75 @@ mp_restore_signals(cl_object sigmask)
 #endif
 }
 
-/* -- Initialization ------------------------------------------------ */
+/* -- Module definition --------------------------------------------- */
 
 void
 init_threads()
 {
-  cl_env_ptr the_env = ecl_process_env();
-  cl_object process;
-  ecl_thread_t main_thread;
+}
+
+static cl_object
+create_thread()
+{
+  cl_env_ptr the_env = ecl_core.first_env;
+  cl_object process, _env = ecl_cast_ptr(cl_object,the_env);
   /* We have to set the environment before any allocation takes place,
    * so that the interrupt handling code works. */
-  ecl_cs_init(the_env);
-  ecl_set_process_self(main_thread);
   process = ecl_alloc_object(t_process);
   process->process.phase = ECL_PROCESS_ACTIVE;
   process->process.name = @'si::top-level';
   process->process.function = ECL_NIL;
   process->process.args = ECL_NIL;
-  process->process.thread = main_thread;
   process->process.env = the_env;
-  process->process.woken_up = ECL_NIL;
   ecl_mutex_init(&process->process.start_stop_lock, TRUE);
   ecl_cond_var_init(&process->process.exit_barrier);
-
   the_env->own_process = process;
-  {
-    cl_object v = si_make_vector(ECL_T, /* Element type */
-                                 ecl_make_fixnum(256), /* Size */
-                                 ecl_make_fixnum(0), /* fill pointer */
-                                 ECL_NIL, ECL_NIL, ECL_NIL);
-    v->vector.self.t[0] = process;
-    v->vector.fillp = 1;
-    cl_core.processes = v;
-  }
+  ecl_stack_push(ecl_core.threads, _env);
+  return ECL_NIL;
 }
+
+static cl_object
+enable_thread()
+{
+  return ECL_NIL;
+}
+
+static cl_object
+init_env_thread(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+static cl_object
+init_cpu_thread(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+static cl_object
+free_cpu_thread(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+static cl_object
+free_env_thread(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+ecl_def_ct_base_string(str_thread, "THREAD", 6, static, const);
+
+static struct ecl_module module_thread = {
+  .name = str_thread,
+  .create = create_thread,
+  .enable = enable_thread,
+  .init_env = init_env_thread,
+  .init_cpu = init_cpu_thread,
+  .free_cpu = free_cpu_thread,
+  .free_env = free_env_thread,
+  .disable = ecl_module_no_op,
+  .destroy = ecl_module_no_op
+};
+
+cl_object ecl_module_thread = (cl_object)&module_thread;

src/c/time.d

@@ -221,18 +221,14 @@ cl_get_internal_real_time()
 cl_object
 cl_get_universal_time()
 {
+  cl_env_ptr env = ecl_process_env();
   cl_object utc = ecl_make_integer(time(0));
-  @(return ecl_plus(utc, cl_core.Jan1st1970UT));
+  ecl_return1(env, ecl_plus(utc, ecl_ct_Jan1st1970UT));
 }
 
 void
 init_unixtime(void)
 {
   ecl_get_internal_real_time(&beginning);
-
   ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000000));
-
-  cl_core.Jan1st1970UT =
-    ecl_times(ecl_make_fixnum(24 * 60 * 60),
-              ecl_make_fixnum(17 + 365 * 70));
 }

src/c/typespec.d

@@ -181,6 +181,10 @@ ecl_type_to_symbol(cl_type t)
     return @'si::foreign-data';
   case t_frame:
     return @'si::frame';
+  case t_exception:
+    return @'si::exception';
+  case t_module:
+    return @'si::module';
   case t_weak_pointer:
     return @'ext::weak-pointer';
 #ifdef ECL_SSE2

src/c/unixfsys.d

@@ -1085,7 +1085,7 @@ dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int f
 cl_object
 si_get_library_pathname(void)
 {
-  cl_object s = cl_core.library_pathname;
+  cl_object s = ecl_core.library_pathname;
   if (!Null(s)) {
     goto OUTPUT_UNCHANGED;
   } else {
@@ -1100,11 +1100,11 @@ si_get_library_pathname(void)
     ecl_filename_char *buffer;
     HMODULE hnd;
     cl_index len, ep;
-    s = ecl_alloc_adjustable_filename(cl_core.path_max);
+    s = ecl_alloc_adjustable_filename(ecl_core.path_max);
     buffer = ecl_filename_self(s);
     ecl_disable_interrupts();
     hnd = GetModuleHandle("ecl.dll");
-    len = ecl_GetModuleFileName(hnd, buffer, cl_core.path_max-1);
+    len = ecl_GetModuleFileName(hnd, buffer, ecl_core.path_max-1);
     ecl_enable_interrupts();
     if (len == 0) {
       FEerror("GetModuleFileName failed (last error = ~S)",
@@ -1125,9 +1125,9 @@ si_get_library_pathname(void)
       s = current_dir();
     }
   }
-  cl_core.library_pathname = ecl_decode_filename(s, ECL_NIL);
+  ecl_core.library_pathname = ecl_decode_filename(s, ECL_NIL);
  OUTPUT_UNCHANGED:
-  @(return cl_core.library_pathname);
+  @(return ecl_core.library_pathname);
 }
 
 @(defun ext::chdir (directory &optional (change_d_p_d ECL_T))

src/c/unixint.d

@@ -41,7 +41,7 @@
  * sections of code which are interruptible, and in which it is safe
  * for the handler to run arbitrary code, protect anything else. In
  * principle this "marking" can be done using POSIX functions such as
- * pthread_sigmask() or sigprocmask().
+ * pthread_sigmask() or sigprocmask() abstracted with ecl_sigmask().
  *
  * However in practice this is slow, as it involves at least a
  * function call, resolving thread-local variables, etc, etc, and it
@@ -257,7 +257,7 @@ static ECL_INLINE bool
 interrupts_disabled_by_lisp(cl_env_ptr the_env)
 {
   return !ecl_option_values[ECL_OPT_BOOTED] ||
-    Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*'));
+    Null(ECL_SYM_VAL(the_env, ECL_INTERRUPTS_ENABLED));
 }
 
 static void early_signal_error() ecl_attr_noreturn;
@@ -265,8 +265,8 @@ static void early_signal_error() ecl_attr_noreturn;
 static void
 early_signal_error()
 {
-  ecl_internal_error("Got signal before environment was installed"
-                     " on our thread");
+  ecl_internal_error
+    ("Got signal before environment was installed on our thread");
 }
 
 static void illegal_signal_code(cl_object code) ecl_attr_noreturn;
@@ -307,11 +307,7 @@ unblock_signal(cl_env_ptr the_env, int signal)
    * We do not really "unblock" the signal, but rather restore
    * ECL's default sigmask.
    */
-# ifdef ECL_THREADS
-  pthread_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL);
-# else
-  sigprocmask(SIG_SETMASK, the_env->default_sigmask, NULL);
-# endif
+  ecl_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL);
 }
 #endif
 
@@ -366,15 +362,14 @@ handle_all_queued(cl_env_ptr env)
 static void
 handle_all_queued_interrupt_safe(cl_env_ptr env)
 {
-  /* We have to save and later restore thread-local variables to
-   * ensure that they don't get overwritten by the interrupting
-   * code */
-  /* INV: - IHS stack manipulations are interrupt safe
-   *      - The rest of the thread local variables are
-   *        guaranteed to be used in an interrupt safe way. This
-   *        is not true for the compiler environment and ffi
-   *        data, but it is unclear whether the DFFI or compiler
-   *        are thread safe anyway. */
+  /* We have to save and later restore thread-local variables to ensure that
+   * they don't get overwritten by the interrupting code. */
+  /* FIXME introduce save/load procedure in modules. */
+  /* INV IHS stack manipulations are interrupt safe; the rest of the thread
+   * local variables are guaranteed to be used in an interrupt safe way[1].
+   *
+   * [1] This is not true for the compiler environment and ffi data, but it is
+   * unclear whether the DFFI or the compiler are thread safe anyway. */
   cl_object fun = env->function;
   cl_index nvalues = env->nvalues;
   cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
@@ -387,7 +382,8 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
    * not init and clear them before calling the interrupting
    * code we would risk memory leaks. */
   cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER];
-  memcpy(big_register, env->big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object));
+  cl_index big_register_size = ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object);
+  ecl_copy(big_register, env->big_register, big_register_size);
   ecl_init_bignum_registers(env);
   /* We might have been interrupted while we push/pop in the stack. Increasing
    * env->run_stack.top ensures that we don't overwrite the topmost stack
@@ -407,8 +403,8 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
   memcpy(env->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame));
   memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame));
   env->run_stack.top--;
-  ecl_clear_bignum_registers(env);
-  memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object));
+  ecl_free_bignum_registers(env);
+  ecl_copy(env->big_register, big_register, big_register_size);
   env->packages_to_be_created_p = packages_to_be_created_p;
   env->packages_to_be_created = packages_to_be_created;
   env->stack_frame = stack_frame;
@@ -534,7 +530,7 @@ handler_fn_prototype(non_evil_signal_handler, int sig, siginfo_t *siginfo, void
   unlikely_if (zombie_process(the_env))
     return;
   signal_object = ecl_gethash_safe(ecl_make_fixnum(sig),
-                                   cl_core.known_signals,
+                                   ecl_core.known_signals,
                                    ECL_NIL);
   handle_or_queue(the_env, signal_object, sig);
   errno = old_errno;
@@ -552,7 +548,7 @@ handler_fn_prototype(evil_signal_handler, int sig, siginfo_t *siginfo, void *dat
   unlikely_if (zombie_process(the_env))
     return;
   signal_object = ecl_gethash_safe(ecl_make_fixnum(sig),
-                                   cl_core.known_signals,
+                                   ecl_core.known_signals,
                                    ECL_NIL);
   handle_signal_now(signal_object);
   errno = old_errno;
@@ -619,7 +615,7 @@ asynchronous_signal_servicing_thread()
       sigdelset(&handled_set, SIGSEGV);
       sigdelset(&handled_set, SIGBUS);
     }
-    pthread_sigmask(SIG_BLOCK, &handled_set, NULL);
+    ecl_sigmask(SIG_BLOCK, &handled_set, NULL);
   }
   /*
    * We create the object for communication. We need a lock to prevent other
@@ -629,6 +625,7 @@ asynchronous_signal_servicing_thread()
   pipe(signal_thread_pipe);
   ecl_mutex_unlock(&signal_thread_lock);
   signal_thread_msg.process = ECL_NIL;
+  ECL_UNWIND_PROTECT_BEGIN(the_env);
   for (;;) {
     cl_object signal_code;
     signal_thread_msg.process = ECL_NIL;
@@ -647,7 +644,7 @@ asynchronous_signal_servicing_thread()
       break;
     }
     signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo),
-                                   cl_core.known_signals,
+                                   ecl_core.known_signals,
                                    ECL_NIL);
     if (!Null(signal_code)) {
       mp_process_run_function(3, @'si::handle-signal',
@@ -655,12 +652,14 @@ asynchronous_signal_servicing_thread()
                               signal_code);
     }
   }
+  ECL_UNWIND_PROTECT_EXIT;
 # if defined(ECL_USE_MPROTECT)
   /* We might have protected our own environment */
   mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE);
 # endif /* ECL_USE_MPROTECT */
   close(signal_thread_pipe[0]);
   close(signal_thread_pipe[1]);
+  ECL_UNWIND_PROTECT_END;
   ecl_return0(the_env);
 }
 #endif /* ECL_THREADS && !ECL_MS_WINDOWS_HOST */
@@ -869,7 +868,7 @@ cl_object
 si_check_pending_interrupts(void)
 {
   const cl_env_ptr the_env = ecl_process_env();
-  handle_all_queued(ecl_process_env());
+  handle_all_queued(the_env);
   ecl_return0(the_env);
 }
 
@@ -906,25 +905,25 @@ do_catch_signal(int code, cl_object action, cl_object process)
       return ECL_T;
     } else {
       sigset_t handled_set;
-      pthread_sigmask(SIG_SETMASK, NULL, &handled_set);
+      ecl_sigmask(SIG_SETMASK, NULL, &handled_set);
       if (action == @':mask') {
         sigaddset(&handled_set, code);
       } else {
         sigdelset(&handled_set, code);
       }
-      pthread_sigmask(SIG_SETMASK, &handled_set, NULL);
+      ecl_sigmask(SIG_SETMASK, &handled_set, NULL);
       return ECL_T;
     }
 # else
     {
       sigset_t handled_set;
-      sigprocmask(SIG_SETMASK, NULL, &handled_set);
+      ecl_sigmask(SIG_SETMASK, NULL, &handled_set);
       if (action == @':mask') {
         sigaddset(&handled_set, code);
       } else {
         sigdelset(&handled_set, code);
       }
-      sigprocmask(SIG_SETMASK, &handled_set, NULL);
+      ecl_sigmask(SIG_SETMASK, &handled_set, NULL);
       return ECL_T;
     }
 # endif /* !ECL_THREADS */
@@ -950,8 +949,7 @@ do_catch_signal(int code, cl_object action, cl_object process)
     }
     return ECL_T;
   } else {
-    FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1,
-            action);
+    FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, action);
   }
 }
 
@@ -959,7 +957,7 @@ cl_object
 si_get_signal_handler(cl_object code)
 {
   const cl_env_ptr the_env = ecl_process_env();
-  cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL);
+  cl_object handler = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL);
   unlikely_if (handler == OBJNULL) {
     illegal_signal_code(code);
   }
@@ -970,11 +968,11 @@ cl_object
 si_set_signal_handler(cl_object code, cl_object handler)
 {
   const cl_env_ptr the_env = ecl_process_env();
-  cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL);
+  cl_object action = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL);
   unlikely_if (action == OBJNULL) {
     illegal_signal_code(code);
   }
-  ecl_sethash(code, cl_core.known_signals, handler);
+  ecl_sethash(code, ecl_core.known_signals, handler);
   si_catch_signal(2, code, ECL_T);
   ecl_return0(the_env);
 }
@@ -984,7 +982,7 @@ si_set_signal_handler(cl_object code, cl_object handler)
   {
     const cl_env_ptr the_env = ecl_process_env();
     int code_int;
-    unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) {
+    unlikely_if (ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL) == OBJNULL) {
       illegal_signal_code(code);
     }
     code_int = ecl_fixnum(code);
@@ -992,19 +990,16 @@ si_set_signal_handler(cl_object code, cl_object handler)
 # ifdef SIGSEGV
     unlikely_if ((code == ecl_make_fixnum(SIGSEGV)) &&
                  ecl_option_values[ECL_OPT_INCREMENTAL_GC])
-      FEerror("It is not allowed to change the behavior of SIGSEGV.",
-              0);
+      FEerror("It is not allowed to change the behavior of SIGSEGV.", 0);
 # endif
 # ifdef SIGBUS
     unlikely_if (code_int == SIGBUS)
-      FEerror("It is not allowed to change the behavior of SIGBUS.",
-              0);
+      FEerror("It is not allowed to change the behavior of SIGBUS.", 0);
 # endif
 #endif
 #if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST)
     unlikely_if (code_int == ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]) {
-      FEerror("It is not allowed to change the behavior of signal ~D", 1,
-              code);
+      FEerror("It is not allowed to change the behavior of signal ~D", 1, code);
     }
 #endif
 #ifdef SIGFPE
@@ -1036,40 +1031,34 @@ wakeup_noop(ULONG_PTR foo)
 static bool
 do_interrupt_thread(cl_object process)
 {
+  cl_env_ptr process_env = process->process.env;
 # ifdef ECL_WINDOWS_THREADS
 #  ifndef ECL_USE_GUARD_PAGE
 #   error "Cannot implement ecl_interrupt_process without guard pages"
 #  endif
-  HANDLE thread = process->process.thread;
+  HANDLE thread = process_env->thread;
   CONTEXT context;
-  void *trap_address = process->process.env;
+  void *trap_address = ecl_cast_ptr(void*, process_env);;
   DWORD guard = PAGE_GUARD | PAGE_READWRITE;
   int ok = 1;
   if (SuspendThread(thread) == (DWORD)-1) {
-    FEwin32_error("Unable to suspend thread ~A", 1,
-                  process);
+    FEwin32_error("Unable to suspend thread ~A", 1, process);
     ok = 0;
     goto EXIT;
   }
-  process->process.interrupt = ECL_T;
-  if (!VirtualProtect(process->process.env,
-                      sizeof(struct cl_env_struct),
-                      guard,
-                      &guard))
+  process_env->interrupt_struct->inside_interrupt = true;
+  if (!VirtualProtect(process_env, sizeof(struct cl_env_struct), guard, &guard))
     {
-      FEwin32_error("Unable to protect memory from thread ~A",
-                    1, process);
+      FEwin32_error("Unable to protect memory from thread ~A", 1, process);
       ok = 0;
     }
  RESUME:
   if (!QueueUserAPC(wakeup_function, thread, 0)) {
-    FEwin32_error("Unable to queue APC call to thread ~A",
-                  1, process);
+    FEwin32_error("Unable to queue APC call to thread ~A", 1, process);
     ok = 0;
   }
   if (ResumeThread(thread) == (DWORD)-1)  {
-    FEwin32_error("Unable to resume thread ~A", 1,
-                  process);
+    FEwin32_error("Unable to resume thread ~A", 1, process);
     ok = 0;
     goto EXIT;
   }
@@ -1077,9 +1066,8 @@ do_interrupt_thread(cl_object process)
   return ok;
 # else
   int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL];
-  if (pthread_kill(process->process.thread, signal)) {
-    FElibc_error("Unable to interrupt process ~A", 1,
-                 process);
+  if (pthread_kill(process_env->thread, signal)) {
+    FElibc_error("Unable to interrupt process ~A", 1, process);
   }
   return 1;
 # endif
@@ -1120,10 +1108,10 @@ void
 ecl_wakeup_process(cl_object process)
 {
 # ifdef ECL_WINDOWS_THREADS
-  HANDLE thread = process->process.thread;
+  cl_env_ptr process_env = process->process.env;
+  HANDLE thread = process_env->thread;
   if (!QueueUserAPC(wakeup_noop, thread, 0)) {
-    FEwin32_error("Unable to queue APC call to thread ~A",
-                  1, process);
+    FEwin32_error("Unable to queue APC call to thread ~A", 1, process);
   }
 # else
   do_interrupt_thread(process);
@@ -1145,9 +1133,8 @@ _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep)
     {
       /* Access to guard page */
     case STATUS_GUARD_PAGE_VIOLATION: {
-      cl_object process = the_env->own_process;
-      if (!Null(process->process.interrupt)) {
-        process->process.interrupt = ECL_NIL;
+      if(the_env->interrupt_struct->inside_interrupt) {
+        the_env->interrupt_struct->inside_interrupt = false;
         handle_all_queued_interrupt_safe(the_env);
       }
       return EXCEPTION_CONTINUE_EXECUTION;
@@ -1207,8 +1194,7 @@ static cl_object
 W32_handle_in_new_thread(cl_object signal_code)
 {
   int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL);
-  mp_process_run_function(3, @'si::handle-signal',
-                          @'si::handle-signal',
+  mp_process_run_function(3, @'si::handle-signal', @'si::handle-signal',
                           signal_code);
   if (outside_ecl) ecl_release_current_thread();
 }
@@ -1294,46 +1280,38 @@ si_trap_fpe(cl_object condition, cl_object flag)
  * detect and process them.
  */
 static void
-install_asynchronous_signal_handlers()
+install_asynchronous_signal_handlers(void)
 {
 #if defined(ECL_MS_WINDOWS_HOST)
-# define async_handler(signal,handler,mask)
+# define async_handler(signal,handler)
 #else
 # if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
-#  define async_handler(signal,handler,mask)  {                 \
+#  define async_handler(signal,handler)  {                      \
     if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) {    \
       mysignal(signal, deferred_signal_handler);                \
     } else {                                                    \
       mysignal(signal,handler);                                 \
     }}
 # else
-#  define async_handler(signal,handler,mask)    \
+#  define async_handler(signal,handler)         \
   mysignal(signal,handler)
 # endif
 #endif
 #ifdef HAVE_SIGPROCMASK
-  sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask;
-  cl_core.default_sigmask_bytes = sizeof(sigset_t);
-# ifdef ECL_THREADS
-  pthread_sigmask(SIG_SETMASK, NULL, sigmask);
-# else
-  sigprocmask(SIG_SETMASK, NULL, sigmask);
-# endif
+  sigset_t *sigmask = ecl_core.first_env->default_sigmask = &main_thread_sigmask;
+  ecl_core.default_sigmask_bytes = sizeof(sigset_t);
+  ecl_sigmask(SIG_SETMASK, NULL, sigmask);
 #endif
 #if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
   ecl_mutex_init(&signal_thread_lock, TRUE);
 #endif
 #ifdef SIGINT
   if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) {
-    async_handler(SIGINT, non_evil_signal_handler, sigmask);
+    async_handler(SIGINT, non_evil_signal_handler);
   }
 #endif
 #ifdef HAVE_SIGPROCMASK
-# if defined(ECL_THREADS)
-  pthread_sigmask(SIG_SETMASK, sigmask, NULL);
-# else
-  sigprocmask(SIG_SETMASK, sigmask, NULL);
-# endif
+  ecl_sigmask(SIG_SETMASK, sigmask, NULL);
 #endif
 #ifdef ECL_WINDOWS_THREADS
   old_W32_exception_filter =
@@ -1345,42 +1323,76 @@ install_asynchronous_signal_handlers()
 #undef async_handler
 }
 
+static void
+uninstall_asynchronous_signal_handlers(void)
+{
+#ifdef HAVE_SIGPROCMASK
+  sigset_t *sigmask = ecl_core.first_env->default_sigmask = &main_thread_sigmask;
+  ecl_core.default_sigmask_bytes = sizeof(sigset_t);
+  ecl_sigmask(SIG_SETMASK, NULL, sigmask);
+#endif
+#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
+  ecl_mutex_init(&signal_thread_lock, TRUE);
+#endif
+#ifdef SIGINT
+  if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) {
+    mysignal(SIGINT, SIG_IGN);
+  }
+#endif
+#ifdef HAVE_SIGPROCMASK
+  ecl_sigmask(SIG_SETMASK, sigmask, NULL);
+#endif
+#ifdef ECL_WINDOWS_THREADS
+  SetUnhandledExceptionFilter(NULL);
+  if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) {
+    SetConsoleCtrlHandler(W32_console_ctrl_handler, FALSE);
+  }
+#endif
+#undef async_handler
+}
+
 /*
  * In POSIX systems we may set up a background thread that detects
  * synchronous signals and spawns a new thread to handle each of them.
  */
 static void
-install_signal_handling_thread()
+install_signal_handling_thread(void)
 {
 #if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
   ecl_process_env()->default_sigmask = &main_thread_sigmask;
   if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) {
     cl_object fun =
-      ecl_make_cfun((cl_objectfn_fixed)
-                    asynchronous_signal_servicing_thread,
-                    @'si::signal-servicing',
-                    ECL_NIL,
-                    0);
+      ecl_make_cfun((cl_objectfn_fixed) asynchronous_signal_servicing_thread,
+                    @'si::signal-servicing', ECL_NIL, 0);
     cl_object process =
       signal_thread_process =
-      mp_process_run_function_wait(2,
-                                   @'si::signal-servicing',
-                                   fun);
+      mp_process_run_function_wait(2, @'si::signal-servicing', fun);
     if (Null(process)) {
-      ecl_internal_error("Unable to create signal "
-                         "servicing thread");
+      ecl_internal_error("Unable to create signal servicing thread.");
     }
   }
 #endif
 }
 
+static void
+uninstall_signal_handling_thread(void)
+{
+#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
+  if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]
+      && signal_thread_process->process.phase == ECL_PROCESS_ACTIVE) {
+    mp_process_kill(signal_thread_process);
+    mp_process_join(signal_thread_process);
+  }
+#endif
+}
+
 /*
  * This routine sets up handlers for all exceptions, such as access to
  * restricted regions of memory. They have to be set up before we call
  * init_GC().
  */
 static void
-install_synchronous_signal_handlers()
+install_synchronous_signal_handlers(void)
 {
 #ifdef SIGBUS
   if (ecl_option_values[ECL_OPT_TRAP_SIGBUS]) {
@@ -1416,13 +1428,55 @@ install_synchronous_signal_handlers()
     int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL];
     if (signal == 0) {
       signal = DEFAULT_THREAD_INTERRUPT_SIGNAL;
-      ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL,
-                     signal);
+      ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, signal);
     }
     mysignal(signal, process_interrupt_handler);
 #ifdef HAVE_SIGPROCMASK
     sigdelset(&main_thread_sigmask, signal);
-    pthread_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL);
+    ecl_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL);
+#endif
+  }
+#endif
+}
+
+static void
+uninstall_synchronous_signal_handlers(void)
+{
+#ifdef SIGBUS
+  if (ecl_option_values[ECL_OPT_TRAP_SIGBUS]) {
+    do_catch_signal(SIGBUS, ECL_NIL, ECL_NIL);
+  }
+#endif
+#ifdef SIGSEGV
+  if (ecl_option_values[ECL_OPT_TRAP_SIGSEGV]) {
+    do_catch_signal(SIGSEGV, ECL_NIL, ECL_NIL);
+  }
+#endif
+#ifdef SIGPIPE
+  if (ecl_option_values[ECL_OPT_TRAP_SIGPIPE]) {
+    do_catch_signal(SIGPIPE, ECL_NIL, ECL_NIL);
+  }
+#endif
+#ifdef SIGILL
+  if (ecl_option_values[ECL_OPT_TRAP_SIGILL]) {
+    do_catch_signal(SIGILL, ECL_NIL, ECL_NIL);
+  }
+#endif
+  /* In order to implement MP:INTERRUPT-PROCESS, MP:PROCESS-KILL
+   * and the like, we use signals. This sets up a synchronous
+   * signal handler for that particular signal.
+   */
+#if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST)
+  if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) {
+    int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL];
+    if (signal == 0) {
+      signal = DEFAULT_THREAD_INTERRUPT_SIGNAL;
+      ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, signal);
+    }
+    mysignal(signal, SIG_IGN);
+#ifdef HAVE_SIGPROCMASK
+    sigdelset(&main_thread_sigmask, signal);
+    ecl_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL);
 #endif
   }
 #endif
@@ -1472,15 +1526,14 @@ static void
 create_signal_code_constants()
 {
   cl_object hash =
-    cl_core.known_signals =
+    ecl_core.known_signals =
     cl__make_hash_table(@'eql', ecl_make_fixnum(128),
-                        cl_core.rehash_size,
-                        cl_core.rehash_threshold);
+                        ecl_ct_default_rehash_size,
+                        ecl_ct_default_rehash_threshold);
   int i;
   for (i = 0; known_signals[i].code >= 0; i++) {
     add_one_signal(hash, known_signals[i].code,
-                   _ecl_intern(known_signals[i].name,
-                               cl_core.ext_package),
+                   _ecl_intern(known_signals[i].name, cl_core.ext_package),
                    known_signals[i].handler);
   }
 #ifdef SIGRTMIN
@@ -1503,17 +1556,130 @@ create_signal_code_constants()
 #endif
 }
 
-void
-init_unixint(int pass)
+/* -- module definition ------------------------------------------------------ */
+
+static cl_object
+create_unixint(void)
 {
-  if (pass == 0) {
-    install_asynchronous_signal_handlers();
-    install_synchronous_signal_handlers();
-  } else {
-    create_signal_code_constants();
-    install_fpe_signal_handlers();
-    install_signal_handling_thread();
-    ECL_SET(@'ext::*interrupts-enabled*', ECL_T);
-    ecl_process_env()->disable_interrupts = 0;
-  }
+  cl_env_ptr the_env = ecl_core.first_env;
+  the_env->default_sigmask = NULL;
+  the_env->interrupt_struct = NULL;
+  ecl_disable_interrupts_env(the_env);
+  /* Install handlers */
+  install_asynchronous_signal_handlers();
+  install_synchronous_signal_handlers();
+  return ECL_NIL;
 }
+
+static cl_object
+enable_unixint(void)
+{
+  create_signal_code_constants();
+  install_fpe_signal_handlers();
+  install_signal_handling_thread();
+  ECL_SET(ECL_INTERRUPTS_ENABLED, ECL_T);
+  ecl_process_env()->disable_interrupts = 0;
+  return ECL_NIL;
+}
+
+static cl_object
+init_env_unixint(cl_env_ptr the_env)
+{
+  cl_env_ptr parent_env = ecl_process_env_unsafe();
+  size_t bytes = ecl_core.default_sigmask_bytes;
+  if (bytes == 0) {
+    the_env->default_sigmask = 0;
+  } else if (parent_env) {
+    the_env->default_sigmask = ecl_alloc_atomic(bytes);
+    memcpy(the_env->default_sigmask, parent_env->default_sigmask, bytes);
+  } else {
+    the_env->default_sigmask = ecl_core.first_env->default_sigmask;
+  }
+  the_env->interrupt_struct = ecl_alloc(sizeof(*the_env->interrupt_struct));
+  the_env->interrupt_struct->pending_interrupt = ECL_NIL;
+#ifdef ECL_THREADS
+  ecl_mutex_init(&the_env->interrupt_struct->signal_queue_lock, FALSE);
+#endif
+#ifdef ECL_WINDOWS_THREADS
+  the_env->interrupt_struct->inside_interrupt = false;
+#endif
+  {
+    int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE];
+    the_env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size));
+  }
+  the_env->fault_address = the_env;
+  the_env->trap_fpe_bits = 0;
+  /* An fresh environment _always_ disables interrupts. They are activated later
+   * on by the thread entry point or ecl_module_unixint. */
+  ecl_disable_interrupts_env(the_env);
+  return ECL_NIL;
+}
+
+static cl_object
+init_cpu_unixint(cl_env_ptr the_env)
+{
+  return ECL_NIL;
+}
+
+static cl_object
+free_cpu_unixint(cl_env_ptr the_env)
+{
+  ecl_disable_interrupts_env(the_env);
+  return ECL_NIL;
+}
+
+static cl_object
+free_env_unixint(cl_env_ptr the_env)
+{
+#ifdef ECL_THREADS
+  ecl_mutex_destroy(&the_env->interrupt_struct->signal_queue_lock);
+#endif
+  the_env->trap_fpe_bits = 0;
+  si_trap_fpe(@'last', ECL_NIL);
+  return ECL_NIL;
+}
+
+static cl_object
+disable_unixint(void)
+{
+  cl_env_ptr the_env = ecl_core.first_env;
+  ecl_disable_interrupts_env(the_env);
+  ECL_SET(ECL_INTERRUPTS_ENABLED, ECL_NIL);
+  return ECL_NIL;
+}
+
+static cl_object
+destroy_unixint(void)
+{
+  uninstall_signal_handling_thread();
+  uninstall_synchronous_signal_handlers();
+  uninstall_asynchronous_signal_handlers();
+  /* FIXME this is messy. */
+  /* remove_signal_code_constants(); */
+  return ECL_NIL;
+}
+
+/* KLUDGE UNIXINT and MEM_GC are interwened - GC expects stop_world to work and
+   unixint relies on the GC to allocate its internal structures.
+
+   When we start add MEM_GC module before UNIXINT and enable GC after both are
+   created. That is enough to get GC going. Finally we enable UNIXINT.
+
+   When we adopt a new cpu we first disable MEM_GC, then initialize UNIXINT
+   (allocator works fine despite GC collector being disabled), then initialize
+   GC to register the current thread and enable the GC. -- jd 2024-12-05 */
+
+ecl_def_ct_base_string(str_unixint, "UNIXINT", 7, static, const);
+static struct ecl_module module_unixint = {
+  .name = str_unixint,
+  .create = create_unixint,
+  .enable = enable_unixint,
+  .init_env = init_env_unixint,
+  .init_cpu = init_cpu_unixint,
+  .free_cpu = free_cpu_unixint,
+  .free_env = free_env_unixint,
+  .disable = disable_unixint,
+  .destroy = destroy_unixint
+};
+
+cl_object ecl_module_unixint = (cl_object)&module_unixint;

src/clos/conditions.lsp

@@ -88,15 +88,6 @@
                                      :function f)))
           *restart-clusters*)))
 
-(defun bind-simple-handlers (tag names)
-  (flet ((simple-handler-function (tag code)
-           #'(lambda (c) (throw tag (values code c)))))
-    (cons (loop for i from 1
-             for n in (if (atom names) (list names) names)
-             for f = (simple-handler-function tag i)
-             collect (cons n f))
-          *handler-clusters*)))
-
 (defmacro restart-bind (bindings &body forms)
   `(let ((*restart-clusters*
           (cons (list ,@(mapcar #'(lambda (binding)
@@ -382,28 +373,33 @@
 |#
 
 
-(defparameter *handler-clusters* nil)
+(defvar *signal-handlers* nil)
 
-(defmacro handler-bind (bindings &body forms)
-  (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
-    (error "Ill-formed handler bindings."))
-  `(let ((*handler-clusters*
-          (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
-                                bindings))
-                *handler-clusters*)))
-     ,@forms))
+(defmacro handler-bind (bindings &body body)
+  (with-gensyms (handler condition)
+    `(flet ((,handler (,condition)
+              (typecase ,condition
+                ,@(loop for (type func . rest) in bindings
+                        when rest do
+                          (error "Ill-formed handler bindings.")
+                        collect `(,type (funcall ,func ,condition))))))
+       (declare (dynamic-extent (function ,handler)))
+       (let ((*signal-handlers* (cons (function ,handler) *signal-handlers*)))
+         ,@body))))
+
+(defun bind-simple-handlers (tag names)
+  (flet ((simple-handler (condition)
+           (loop for code from 1
+                 for type in (if (atom names) (list names) names)
+                 when (typep condition type) do
+                   (throw tag (values code condition)))))
+    (cons #'simple-handler *signal-handlers*)))
 
 (defun signal (datum &rest arguments)
-  (let* ((condition
-           (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))
-         (*handler-clusters* *handler-clusters*))
+  (let ((condition (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)))
     (when (typep condition *break-on-signals*)
       (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition))
-    (loop (unless *handler-clusters* (return))
-          (let ((cluster (pop *handler-clusters*)))
-            (dolist (handler cluster)
-              (when (typep condition (car handler))
-                (funcall (cdr handler) condition)))))
+    (%signal condition t nil)
     nil))
 
 

src/clos/hierarchy.lsp

@@ -228,6 +228,8 @@
             (si::code-block)
             (si::foreign-data)
             (si::frame)
+            (si::exception)
+            (si::module)
             (si::weak-pointer)
             (:threads mp::process)
             (:threads mp::lock)

src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp

@@ -42,12 +42,12 @@
    '(
      ;; Order is important: on platforms where 0.0 and -0.0 are the same
      ;; the last one is prioritized.
-     (#.(coerce 0 'cl:single-float) "cl_core.singlefloat_zero")
-     (#.(coerce 0 'cl:double-float) "cl_core.doublefloat_zero")
-     (#.(coerce -0.0 'cl:single-float) "cl_core.singlefloat_minus_zero")
-     (#.(coerce -0.0 'cl:double-float) "cl_core.doublefloat_minus_zero")
-     (#.(coerce 0 'cl:long-float) "cl_core.longfloat_zero")
-     (#.(coerce -0.0 'cl:long-float) "cl_core.longfloat_minus_zero")
+     (#.(coerce 0 'cl:single-float) "ecl_ct_singlefloat_zero")
+     (#.(coerce 0 'cl:double-float) "ecl_ct_doublefloat_zero")
+     (#.(coerce -0.0 'cl:single-float) "ecl_ct_singlefloat_minus_zero")
+     (#.(coerce -0.0 'cl:double-float) "ecl_ct_doublefloat_minus_zero")
+     (#.(coerce 0 'cl:long-float) "ecl_ct_longfloat_zero")
+     (#.(coerce -0.0 'cl:long-float) "ecl_ct_longfloat_minus_zero")
 
      ;; We temporarily remove this constant, because the bytecodes compiler
      ;; does not know how to externalize it.

src/cmp/cmpbackend-cxx/cmppass2-exit.lsp

@@ -199,7 +199,7 @@
       (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
   (case ihs-p
     (IHS     (wt-nl "ecl_ihs_pop(cl_env_copy);"))
-    (IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
+    (IHS-ENV (wt-nl "ihs.lcl_env = _ecl_debug_env;"))))
 
 (defun %unwind (into from)
   (declare (si::c-local))

src/cmp/cmpbackend-cxx/cmppass2-fun.lsp

@@ -207,7 +207,7 @@
       (push 'IHS *unwind-exit*)
       (when (policy-debug-variable-bindings)
         (build-debug-lexical-env (reverse requireds) t))
-      (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," fname ",_ecl_debug_env);")))
+      (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," fname ",ECL_NIL,_ecl_debug_env);")))
 
   ;; Bind optional parameters as long as there remain arguments.
   (when optionals

src/cmp/cmpbackend-cxx/cmppass2-var.lsp

@@ -75,11 +75,11 @@
              (+ 2 (length filtered-locations))
              ",,);")
       (unless first
-        (wt-nl "ihs.lex_env = _ecl_debug_env;")))
+        (wt-nl "ihs.lcl_env = _ecl_debug_env;")))
     filtered-codes))
 
 (defun pop-debug-lexical-env ()
-  (wt-nl "ihs.lex_env = _ecl_debug_env;"))
+  (wt-nl "ihs.lcl_env = _ecl_debug_env;"))
 
 (defun c2let* (c1form vars forms body
                &aux

src/cmp/proclamations.lsp

@@ -298,7 +298,9 @@
 
 (proclamation si:ihs-top () si::index)
 (proclamation si:ihs-fun (si::index) (or null function-designator))
-(proclamation si:ihs-env (si::index) environment)
+(proclamation si:ihs-env (si::index) (or null vector))
+(proclamation si:ihs-lex (si::index) (or null vector))
+(proclamation si:ihs-lcl (si::index) (or null vector si::frame))
 (proclamation si:frs-top () si::index)
 (proclamation si:frs-bds (si::index) si::index)
 (proclamation si:frs-tag (si::index) t)

src/configure

@@ -6100,9 +6100,10 @@ SHAREDPREFIX='lib'
 LIBPREFIX='lib'
 LIBEXT='a'
 PICFLAG='-fPIC'
-THREAD_CFLAGS=''
+THREAD_CFLAGS='-DGC_NO_THREAD_REDIRECTS'
 THREAD_LIBS=''
 THREAD_GC_FLAGS='--enable-threads=posix'
+CFLAGS=''
 INSTALL_TARGET='install'
 THREAD_OBJ="$THREAD_OBJ threads/thread threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox threads/rwlock"
 clibs='-lm'
@@ -6111,7 +6112,7 @@ SONAME_LDFLAGS=''
 case "${host_os}" in
         linux-android*)
                 thehost='ANDROID'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH='-Wl,--rpath,~A'
@@ -6130,7 +6131,7 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
         # libdir may have a dollar expression inside
         linux*)
                 thehost='linux'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -6146,7 +6147,7 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
                 ;;
         gnu*)
                 thehost='gnu'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -6161,7 +6162,7 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
                 ;;
         kfreebsd*-gnu)
                 thehost='kfreebsd'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -6227,8 +6228,6 @@ LSP_FEATURES="${LSP_FEATURES} :bsd"
                 ;;
         openbsd*)
                 thehost='openbsd'
-                THREAD_CFLAGS=''
-                THREAD_LIBS=''
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH="-Wl,--rpath,~A"
@@ -6265,7 +6264,7 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
                 thehost='cygwin'
                 #enable_threads='no'
                 shared='yes'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -6290,7 +6289,7 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
                 clibs=''
                 shared='yes'
                 enable_threads='yes'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_GC_FLAGS='--enable-threads=win32'
                 SHARED_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}"
                 BUNDLE_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}"
@@ -6432,7 +6431,7 @@ fi
                 SHARED_LDFLAGS="-dynamiclib ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-bundle ${LDFLAGS}"
                 ECL_LDRPATH='-Wl,-rpath,~A'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 # The GMP library has not yet been ported to Intel or Arm-OSX
                 case "`uname -m`" in
@@ -6476,7 +6475,7 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
                 thehost='nonstop'
                 shared='yes'
                 PICFLAG='-call_shared'
-                THREAD_CFLAGS='-spthread'
+                THREAD_CFLAGS="-spthread ${THREAD_CFLAGS}"
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH='-Wld=\"-rld_l ~A\"'
@@ -6484,7 +6483,6 @@ LSP_FEATURES="${LSP_FEATURES} :unix"
                 ;;
         haiku*)
                 thehost='haiku'
-                THREAD_LIBS=''
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
                 ECL_LDRPATH="-Wl,--rpath,~A"
@@ -6517,7 +6515,7 @@ esac
 case "${host}" in
         *-nacl)
                 thehost='linux'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                 SHARED_LDFLAGS="-shared ${LDFLAGS}"
                 BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
@@ -6531,7 +6529,7 @@ LSP_FEATURES="${LSP_FEATURES} :nacl"
                 ;;
         *-pnacl)
                 thehost='linux'
-                THREAD_CFLAGS='-D_THREAD_SAFE'
+                THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}"
                 THREAD_LIBS='-lpthread'
                                                                 CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ${CFLAGS}"
 
@@ -7216,7 +7214,7 @@ if test "${enable_threads}" = "yes" ; then
     as_fn_error $? "Threads aren't supported on this system." "$LINENO" 5
   else
     LIBS="${THREAD_LIBS} ${LIBS}"
-    CFLAGS="${CFLAGS} ${THREAD_CFLAGS}"
+    CFLAGS="${CFLAGS} ${THREAD_CFLAGS} -DGC_NO_THREAD_REDIRECTS"
 
 ac_fn_c_check_func "$LINENO" "pthread_rwlock_init" "ac_cv_func_pthread_rwlock_init"
 if test "x$ac_cv_func_pthread_rwlock_init" = xyes
@@ -7274,8 +7272,6 @@ fi
 
 if test ${enable_boehm} = "no" ; then
   as_fn_error $? "Boehm GC library is currently needed to build ECL" "$LINENO" 5;
-  EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}"
-  enable_smallcons="no"
 else
 
 
@@ -7528,7 +7524,6 @@ printf "%s\n" "${system_boehm} " >&6; }
    fi
  else
    FASL_LIBS="${FASL_LIBS} -lgc"
-   EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}"
 
 printf "%s\n" "#define GBC_BOEHM 1" >>confdefs.h
 
@@ -7558,7 +7553,6 @@ printf "%s\n" "$as_me: Configuring included Boehm GC library:" >&6;}
      ECL_BOEHM_GC_HEADER='ecl/gc/gc.h'
      SUBDIRS="${SUBDIRS} gc"
      CORE_LIBS="-leclgc ${CORE_LIBS}"
-     EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}"
      if test "${enable_shared}" = "no"; then
        LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}"
      fi
@@ -7715,7 +7709,6 @@ printf "%s\n" "$as_me: Configuring included libffi library:" >&6;}
      ECL_LIBFFI_HEADER='ecl/ffi.h'
      SUBDIRS="${SUBDIRS} libffi"
      CORE_LIBS="-leclffi ${CORE_LIBS}"
-     EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}"
      if test "${enable_shared}" = "no"; then
        LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}"
      fi

src/configure.ac

@@ -603,8 +603,6 @@ dnl ----------------------------------------------------------------------
 dnl		Boehm-Weiser garbage collector
 if test ${enable_boehm} = "no" ; then
   AC_MSG_ERROR([Boehm GC library is currently needed to build ECL]);
-  EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}"
-  enable_smallcons="no"
 else
   ECL_BOEHM_GC
   ECL_ADD_FEATURE(boehm-gc)

src/h/bytecodes.h

@@ -13,6 +13,7 @@
 enum {
   OP_NOP,
   OP_QUOTE,
+  OP_CALLW,
   OP_ENDP,
   OP_CONS,
   OP_CAR,
@@ -176,6 +177,7 @@ typedef int16_t cl_opcode;
         static const int offsets[] = {\
   &&LBL_OP_NOP - &&LBL_OP_NOP,\
   &&LBL_OP_QUOTE - &&LBL_OP_NOP,\
+  &&LBL_OP_CALLW - &&LBL_OP_NOP,\
   &&LBL_OP_ENDP - &&LBL_OP_NOP,\
   &&LBL_OP_CONS - &&LBL_OP_NOP,\
   &&LBL_OP_CAR - &&LBL_OP_NOP,\

src/h/ecl-inl.h

@@ -129,35 +129,91 @@
 #define ecl_cast_ptr(type,n) ((type)(n))
 #endif
 
+#define ecl_constexpr_string(name)                                      \
+  ((struct ecl_base_string)                                             \
+   { (int8_t)t_base_string, 0, ecl_aet_bc, 0, ECL_NIL,                  \
+     (cl_index)((sizeof(name)-1)), (cl_index)((sizeof(name)-1)),        \
+     (ecl_base_char*)(name) })
+
+#ifdef ECL_THREADS
+#define ecl_constexpr_symbol(type, name, value)                         \
+  ((struct ecl_symbol)                                                  \
+   { (int8_t)t_symbol, 0, type, 0,                                      \
+     value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/,       \
+     ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \
+     ECL_NIL, ECL_NIL, ECL_MISSING_SPECIAL_BINDING } )
+#else
+#define ecl_constexpr_symbol(type, name, value)                         \
+  ((struct ecl_symbol)                                                  \
+   { (int8_t)t_symbol, 0, type, 0,                                      \
+     value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/,       \
+     ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \
+     ECL_NIL, ECL_NIL } )
+#endif
+
+#define ecl_def_variable(name, value, chars, len)                       \
+        ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \
+        ecl_def_ct_token(name, ecl_stp_special, name ## _var_name, value,,)
+
+#define ecl_def_constant(name, value, chars, len)                       \
+        ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \
+        ecl_def_ct_token(name, ecl_stp_constant, name ## _var_name, value,,const)
+
+#ifdef ECL_THREADS
+#define ecl_def_ct_token(name,stype,sname,value,static,const)           \
+        static const struct ecl_symbol name ## _data = {                \
+                (int8_t)t_symbol, 0, stype, 0,                          \
+                value, ECL_NIL, NULL /*ecl_undefined_function_entry*/,  \
+                ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL,     \
+                ECL_MISSING_SPECIAL_BINDING };                          \
+        static const cl_object name = (cl_object)(& name ## _data)
+#else
+#define ecl_def_ct_token(name,stype,sname,value,static,const)           \
+        static const struct ecl_symbol name ## _data = {                \
+                (int8_t)t_symbol, 0, stype, 0,                          \
+                value, ECL_NIL, NULL /*ecl_undefined_function_entry*/,  \
+                ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL };   \
+        static const cl_object name = (cl_object)(& name ## _data)
+#endif
+
+#define ecl_def_function(name, cname, static, const)                    \
+        static const struct ecl_cfunfixed name ##_data = {              \
+                (int8_t)t_cfunfixed, 0, 0, 0,                           \
+                /*name*/ECL_NIL, /*block*/ECL_NIL,                      \
+                /*entry*/(cl_objectfn)cname,                            \
+                /*funfixed_entry*/(cl_objectfn_fixed)NULL,              \
+                ECL_NIL, ECL_NIL };                                     \
+        static const cl_object name = (cl_object)(& name ## _data)
+
 #define ecl_def_string_array(name,static,const)                         \
         static const union {                                            \
                 struct ecl_base_string elt;                             \
                 cl_fixnum padding[(sizeof(struct ecl_base_string)+3)/4*4]; \
         } name[]
 
-#define ecl_def_string_array_elt(chars) { {                      \
-                (int8_t)t_base_string, 0, ecl_aet_bc, 0,            \
-                        ECL_NIL, (cl_index)(sizeof(chars))-1,      \
-                        (cl_index)(sizeof(chars))-1,            \
+#define ecl_def_string_array_elt(chars) { {                         \
+                        (int8_t)t_base_string, 0, ecl_aet_bc, 0,    \
+                        ECL_NIL, (cl_index)(sizeof(chars))-1,       \
+                        (cl_index)(sizeof(chars))-1,                \
                         (ecl_base_char*)(chars) } }
 
-#define ecl_def_ct_base_string(name,chars,len,static,const)     \
-        static const struct ecl_base_string name ## _data = {    \
+#define ecl_def_ct_base_string(name,chars,len,static,const)         \
+        static const struct ecl_base_string name ## _data = {       \
                 (int8_t)t_base_string, 0, ecl_aet_bc, 0,            \
-                ECL_NIL, (cl_index)(len), (cl_index)(len),         \
-                (ecl_base_char*)(chars) };                      \
+                ECL_NIL, (cl_index)(len), (cl_index)(len),          \
+                (ecl_base_char*)(chars) };                          \
         static const cl_object name = (cl_object)(& name ## _data)
 
-#define ecl_def_ct_single_float(name,f,static,const)            \
-        static const struct ecl_singlefloat name ## _data = {    \
-                (int8_t)t_singlefloat, 0, 0, 0,                 \
-                (float)(f) };                                   \
+#define ecl_def_ct_single_float(name,f,static,const)                    \
+        static const struct ecl_singlefloat name ## _data = {           \
+                (int8_t)t_singlefloat, 0, 0, 0,                         \
+                (float)(f) };                                           \
         static const cl_object name = (cl_object)(& name ## _data)
 
-#define ecl_def_ct_double_float(name,f,static,const)            \
-        static const struct ecl_doublefloat name ## _data = {    \
-                (int8_t)t_doublefloat, 0, 0, 0,                 \
-                (double)(f) };                                  \
+#define ecl_def_ct_double_float(name,f,static,const)                    \
+        static const struct ecl_doublefloat name ## _data = {           \
+                (int8_t)t_doublefloat, 0, 0, 0,                         \
+                (double)(f) };                                          \
         static const cl_object name = (cl_object)(& name ## _data)
 
 #define ecl_def_ct_long_float(name,f,static,const)                      \

src/h/ecl.h

@@ -62,13 +62,7 @@
 #  include <windows.h>
 # endif
 # ifdef ECL_THREADS
-   typedef HANDLE pthread_t;
-   typedef HANDLE pthread_mutex_t;
-   typedef HANDLE pthread_cond_t; /*Dummy, not really used*/
 #  undef ERROR
-#  ifdef GBC_BOEHM
-#   define CreateThread GC_CreateThread
-#  endif
 # else
 #  error "The Windows ports cannot be built without threads."
 # endif /* ECL_THREADS */
@@ -80,6 +74,7 @@
 #endif
 
 #include <ecl/object.h>
+#include <ecl/nucleus.h>
 #include <ecl/external.h>
 #include <ecl/cons.h>
 #include <ecl/stacks.h>

src/h/external.h

@@ -64,7 +64,6 @@ struct ecl_c_stack {
  * Per-thread data.
  */
 
-typedef struct cl_env_struct *cl_env_ptr;
 struct cl_env_struct {
         /* Flag for disabling interrupts while we call C library functions. */
         volatile int disable_interrupts;
@@ -103,7 +102,7 @@ struct cl_env_struct {
         /* -- System Processes (native threads) ------------------------------ */
         cl_object own_process; /* Backpointer to the host process. */
 #ifdef ECL_THREADS
-        int cleanup;
+        ecl_thread_t thread;
 #endif
 
         /* -- System Interrupts ---------------------------------------------- */
@@ -152,6 +151,9 @@ struct ecl_interrupt_struct {
 #ifdef ECL_THREADS
         ecl_mutex_t signal_queue_lock;
 #endif
+#ifdef ECL_WINDOWS_THREADS
+        bool inside_interrupt;
+#endif
 };
 
 #ifndef __GNUC__
@@ -170,9 +172,7 @@ struct ecl_interrupt_struct {
   extern ECL_API cl_env_ptr cl_env_p;
 #endif
 
-/*
- * Per-process data. Modify main.d accordingly.
- */
+/* Per-process data. Modify main.d accordingly. */
 
 struct cl_core_struct {
         cl_object packages;
@@ -189,9 +189,6 @@ struct cl_core_struct {
         cl_object c_package;
         cl_object ffi_package;
 
-        cl_object pathname_translations;
-        cl_object library_pathname;
-
         cl_object terminal_io;
         cl_object null_stream;
         cl_object standard_input;
@@ -201,97 +198,75 @@ struct cl_core_struct {
         cl_object dispatch_reader;
 
         cl_object char_names;
-        cl_object null_string;
-
-        cl_object plus_half;
-        cl_object minus_half;
-        cl_object imag_unit;
-        cl_object minus_imag_unit;
-        cl_object imag_two;
-        cl_object singlefloat_zero;
-        cl_object doublefloat_zero;
-        cl_object singlefloat_minus_zero;
-        cl_object doublefloat_minus_zero;
-        cl_object longfloat_zero;
-        cl_object longfloat_minus_zero;
 
         cl_object gensym_prefix;
         cl_object gentemp_prefix;
         cl_object gentemp_counter;
 
-        cl_object Jan1st1970UT;
-
         cl_object system_properties;
-
-        cl_env_ptr first_env;
-#ifdef ECL_THREADS
-        cl_object processes;
-        ecl_mutex_t processes_lock;
-        ecl_mutex_t global_lock;
-        ecl_mutex_t error_lock;
-        ecl_rwlock_t global_env_lock;
-#endif
-        cl_object libraries;
-
-        size_t max_heap_size;
-        cl_object bytes_consed;
-        cl_object gc_counter;
-        bool gc_stats;
-        int path_max;
-#ifdef GBC_BOEHM
-        char *safety_region;
-#endif
-        void *default_sigmask;
-        cl_index default_sigmask_bytes;
-
-#ifdef ECL_THREADS
-        cl_index last_var_index;
-        cl_object reused_indices;
-#endif
-        cl_object slash;
-
         cl_object compiler_dispatch;
-
-        cl_object rehash_size;
-        cl_object rehash_threshold;
-
-        cl_object known_signals;
 };
 
+extern ECL_API struct ecl_type_information ecl_type_info[t_end];
+extern ECL_API struct ecl_core_struct ecl_core;
 extern ECL_API struct cl_core_struct cl_core;
 
+/* variables */
+extern ECL_API cl_object ecl_vr_shandlers;
+extern ECL_API cl_object ecl_vr_allow_other_keys;
+
 /* memory.c */
 extern ECL_API void *ecl_malloc(cl_index n);
 extern ECL_API void *ecl_realloc(void *ptr, cl_index o, cl_index n);
 extern ECL_API void ecl_free(void *ptr);
 extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx);
+extern ECL_API void ecl_mset(void *dst, byte val, cl_index ndx);
 #define ecl_free_unsafe(x) ecl_free(x);
 
-/* alloc.c / alloc_2.c */
+/* boot.c */
+extern ECL_API int ecl_boot(void);
+extern ECL_API int ecl_halt(void);
+
+extern ECL_API const cl_object ecl_ct_Jan1st1970UT;
+extern ECL_API const cl_object ecl_ct_null_string;
+
+extern ECL_API const cl_object ecl_ct_default_rehash_size;
+extern ECL_API const cl_object ecl_ct_default_rehash_threshold;
+
+extern ECL_API const cl_object ecl_ct_singlefloat_zero;
+extern ECL_API const cl_object ecl_ct_doublefloat_zero;
+extern ECL_API const cl_object ecl_ct_longfloat_zero;
+
+extern ECL_API const cl_object ecl_ct_singlefloat_minus_zero;
+extern ECL_API const cl_object ecl_ct_doublefloat_minus_zero;
+extern ECL_API const cl_object ecl_ct_longfloat_minus_zero;
+
+extern ECL_API const cl_object ecl_ct_plus_half;
+extern ECL_API const cl_object ecl_ct_minus_half;
+
+extern ECL_API const cl_object ecl_ct_protect_tag;
+extern ECL_API const cl_object ecl_ct_dummy_tag;
+
+/* memory */
 
 extern ECL_API cl_object ecl_alloc_object(cl_type t);
 extern ECL_API cl_object ecl_alloc_instance(cl_index slots);
 extern ECL_API cl_object ecl_alloc_weak_pointer(cl_object o);
 extern ECL_API cl_object ecl_alloc_compact_object(cl_type t, cl_index extra_space);
 extern ECL_API cl_object ecl_cons(cl_object a, cl_object d);
+extern ECL_API void ecl_free_object(cl_object o);
 #define ecl_list1(x) ecl_cons(x, ECL_NIL)
 
 extern ECL_API cl_object si_make_weak_pointer(cl_object o);
 extern ECL_API cl_object si_weak_pointer_value(cl_object o);
 
-#ifdef GBC_BOEHM
-extern ECL_API void *ecl_alloc_unprotected(cl_index n);
-extern ECL_API void *ecl_alloc_atomic_unprotected(cl_index n);
 extern ECL_API void *ecl_alloc(cl_index n);
+extern ECL_API void *ecl_alloc_manual(cl_index n);
 extern ECL_API void *ecl_alloc_atomic(cl_index n);
-extern ECL_API void *ecl_alloc_uncollectable(size_t size);
-extern ECL_API void ecl_free_uncollectable(void *);
 extern ECL_API void ecl_dealloc(void *);
+
 #define ecl_alloc_align(s,d) ecl_alloc(s)
 #define ecl_alloc_atomic_align(s,d) ecl_alloc_atomic(s)
-#else  /* Ideally the core would not depend on these. */
-# error "IMPLEMENT ME!"
-#endif /* GBC_BOEHM */
 
 /* all_symbols */
 
@@ -310,6 +285,7 @@ typedef union {
 } cl_symbol_initializer;
 extern ECL_API cl_symbol_initializer cl_symbols[];
 extern ECL_API cl_index cl_num_symbols_in_core;
+extern ECL_API struct ecl_symbol ecl_symbols[];
 
 #define ECL_SYM(name,code) ((cl_object)(cl_symbols+(code)))
 
@@ -328,6 +304,7 @@ extern ECL_API cl_index ecl_atomic_index_incf(cl_index *slot);
 
 /* stack.c */
 extern ECL_API cl_object ecl_make_stack(cl_index dim);
+extern ECL_API void ecl_free_stack(cl_object o);
 extern ECL_API cl_object ecl_stack_push(cl_object stack, cl_object elt);
 extern ECL_API cl_object ecl_stack_del(cl_object stack, cl_object elt);
 extern ECL_API cl_object ecl_stack_popu(cl_object stack);
@@ -572,6 +549,8 @@ extern ECL_API cl_object si_bc_join(cl_object lex, cl_object code, cl_object dat
 extern ECL_API cl_object cl_error _ECL_ARGS((cl_narg narg, cl_object eformat, ...)) ecl_attr_noreturn;
 extern ECL_API cl_object cl_cerror _ECL_ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...));
 
+extern ECL_API cl_object ecl_exception_handler(cl_object exception);
+
 extern ECL_API void ecl_internal_error(const char *s) ecl_attr_noreturn;
 #ifdef ECL_THREADS
 extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn;
@@ -579,6 +558,8 @@ extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn;
 extern ECL_API void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_attr_noreturn;
 extern ECL_API void ecl_miscompilation_error(void) ecl_attr_noreturn;
 extern ECL_API void ecl_cs_overflow(void) /*ecl_attr_noreturn*/;
+
+extern ECL_API void CEstack_overflow(cl_object resume, cl_object type, cl_object size);
 extern ECL_API void FEprogram_error(const char *s, int narg, ...) ecl_attr_noreturn;
 extern ECL_API void FEcontrol_error(const char *s, int narg, ...) ecl_attr_noreturn;
 extern ECL_API void FEreader_error(const char *s, cl_object stream, int narg, ...) ecl_attr_noreturn;
@@ -587,7 +568,10 @@ extern ECL_API void FEerror(const char *s, int narg, ...) ecl_attr_noreturn;
 extern ECL_API void FEcannot_open(cl_object fn) ecl_attr_noreturn;
 extern ECL_API void FEend_of_file(cl_object strm) ecl_attr_noreturn;
 extern ECL_API void FEclosed_stream(cl_object strm) ecl_attr_noreturn;
+extern ECL_API void FEunread_stream(cl_object strm, cl_object twice) ecl_attr_noreturn;
 extern ECL_API void FEwrong_type_argument(cl_object type, cl_object value) ecl_attr_noreturn;
+extern ECL_API void FEwrong_type_pred_arg(cl_object type, cl_object value) ecl_attr_noreturn;
+extern ECL_API void FEwrong_type_strm_elt(cl_object type, cl_object value) ecl_attr_noreturn;
 extern ECL_API void FEwrong_type_only_arg(cl_object function, cl_object type, cl_object value) ecl_attr_noreturn;
 extern ECL_API void FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type) ecl_attr_noreturn;
 extern ECL_API void FEwrong_type_key_arg(cl_object function, cl_object keyo, cl_object type, cl_object value) ecl_attr_noreturn;
@@ -691,8 +675,20 @@ extern ECL_API cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag type
 extern ECL_API void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_object value);
 
 /* stream.c */
-cl_object si_unread_byte(cl_object strm, cl_object byte);
-cl_object si_peek_byte(cl_object strm, cl_object eof_value);
+extern ECL_API cl_object si_write_char(cl_object strm, cl_object c);
+extern ECL_API cl_object si_write_byte(cl_object strm, cl_object c);
+extern ECL_API cl_object si_read_char(cl_object strm, cl_object eof_value);
+extern ECL_API cl_object si_read_byte(cl_object strm, cl_object eof_value);
+extern ECL_API cl_object si_peek_char(cl_object strm, cl_object eof_value);
+extern ECL_API cl_object si_peek_byte(cl_object strm, cl_object eof_value);
+extern ECL_API cl_object si_unread_char(cl_object strm, cl_object c);
+extern ECL_API cl_object si_unread_byte(cl_object strm, cl_object byte);
+
+extern ECL_API cl_object si_listen(cl_object strm);
+extern ECL_API cl_object si_clear_input(cl_object strm);
+extern ECL_API cl_object si_finish_output(cl_object strm);
+extern ECL_API cl_object si_force_output(cl_object strm);
+extern ECL_API cl_object si_clear_output(cl_object strm);
 
 /* file.c */
 
@@ -735,6 +731,8 @@ extern ECL_API cl_object cl_file_string_length(cl_object stream, cl_object strin
 extern ECL_API cl_object si_do_write_sequence(cl_object string, cl_object stream, cl_object start, cl_object end);
 extern ECL_API cl_object si_do_read_sequence(cl_object string, cl_object stream, cl_object start, cl_object end);
 extern ECL_API cl_object si_file_column(cl_object strm);
+extern ECL_API cl_object si_file_position_get(cl_object strm);
+extern ECL_API cl_object si_file_position_set(cl_object strm, cl_object position);
 extern ECL_API cl_object cl_interactive_stream_p(cl_object strm);
 #if defined(ECL_MS_WINDOWS_HOST)
 extern ECL_API cl_object si_windows_codepage_encoding();
@@ -749,6 +747,8 @@ extern ECL_API bool ecl_interactive_stream_p(cl_object strm);
 extern ECL_API cl_object ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist, cl_fixnum byte_size, int flags, cl_object external_format);
 extern ECL_API cl_object ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend);
 extern ECL_API cl_object ecl_make_string_output_stream(cl_index line_length, int extended);
+extern ECL_API cl_index ecl_read_byte8(cl_object strm, unsigned char *c, cl_index n);
+extern ECL_API cl_index ecl_write_byte8(cl_object strm, unsigned char *c, cl_index n);
 extern ECL_API cl_object ecl_read_byte(cl_object strm);
 extern ECL_API void ecl_write_byte(cl_object byte, cl_object strm);
 extern ECL_API void ecl_unread_byte(cl_object byte, cl_object strm);
@@ -1010,7 +1010,7 @@ typedef enum {
 } ecl_option;
 
 extern ECL_API const char *ecl_self;
-extern ECL_API void ecl_set_option(int option, cl_fixnum value);
+extern ECL_API cl_fixnum ecl_set_option(int option, cl_fixnum value);
 extern ECL_API cl_fixnum ecl_get_option(int option);
 extern ECL_API int cl_boot(int argc, char **argv);
 extern ECL_API void cl_shutdown(void);
@@ -1649,6 +1649,8 @@ extern ECL_API __m128d ecl_unbox_double_sse_pack(cl_object value);
 extern ECL_API cl_object si_ihs_top(void);
 extern ECL_API cl_object si_ihs_fun(cl_object arg);
 extern ECL_API cl_object si_ihs_env(cl_object arg);
+extern ECL_API cl_object si_ihs_lex(cl_object arg);
+extern ECL_API cl_object si_ihs_lcl(cl_object arg);
 extern ECL_API cl_object si_ihs_bds(cl_object arg);
 extern ECL_API cl_object si_ihs_next(cl_object arg);
 extern ECL_API cl_object si_ihs_prev(cl_object arg);
@@ -1882,6 +1884,19 @@ extern ECL_API cl_object ecl_make_rwlock(cl_object lock);
 
 #endif /* ECL_THREADS */
 
+/* nucleus/module.c */
+
+extern ECL_API cl_object ecl_add_module(cl_object self);
+extern ECL_API cl_object ecl_del_module(cl_object self);
+extern ECL_API cl_object ecl_modules_init_env(cl_env_ptr the_env);
+extern ECL_API cl_object ecl_modules_free_env(cl_env_ptr the_env);
+extern ECL_API cl_object ecl_modules_init_cpu(cl_env_ptr the_env);
+extern ECL_API cl_object ecl_modules_free_cpu(cl_env_ptr the_env);
+
+extern ECL_API cl_object ecl_module_no_op_env(cl_env_ptr the_env);
+extern ECL_API cl_object ecl_module_no_op_cpu(cl_env_ptr the_env);
+extern ECL_API cl_object ecl_module_no_op();
+
 /* time.c */
 
 extern ECL_API cl_object cl_sleep(cl_object z);

src/h/internal.h

@@ -23,37 +23,42 @@ extern "C" {
 #define unlikely_if(x) if (ecl_unlikely(x))
 
 /* booting */
+extern ECL_API cl_object ecl_module_process;
+extern ECL_API cl_object ecl_module_stacks;
+extern ECL_API cl_object ecl_module_dummy;
+extern ECL_API cl_object ecl_module_gc;
+extern ECL_API cl_object ecl_module_unixint;
+#ifdef ECL_THREADS
+extern ECL_API cl_object ecl_module_thread;
+#endif
+extern ECL_API cl_object ecl_module_bignum;
+extern ECL_API cl_object ecl_module_ffi;
+extern ECL_API cl_object ecl_module_aux;
+
+extern void init_memory(void);
 extern void init_all_symbols(void);
-extern void init_alloc(int pass);
 extern void init_backq(void);
 extern void init_big();
 extern void init_clos(void);
 extern void init_error(void);
 extern void init_eval(void);
 extern void init_file(void);
-#ifndef GBC_BOEHM
-extern void init_GC(void);
-#endif
+extern void init_gc(void);
 extern void init_macros(void);
 extern void init_read(void);
-
-extern cl_object init_stacks(cl_env_ptr);
-extern cl_object free_stacks(cl_env_ptr);
-
-extern void init_unixint(int pass);
 extern void init_unixtime(void);
 extern void init_compiler(void);
 extern void init_process(void);
-#ifdef ECL_THREADS
-extern void init_threads(void);
-#endif
+extern void init_modules(void);
 extern void ecl_init_env(cl_env_ptr);
 extern void init_lib_LSP(cl_object);
 
+extern void free_modules(void);
+
 extern cl_env_ptr _ecl_alloc_env(cl_env_ptr parent);
 extern void _ecl_dealloc_env(cl_env_ptr);
 
-/* alloc.d/alloc_2.d */
+/* mem_gc.d */
 
 #ifdef GBC_BOEHM
 #define ECL_COMPACT_OBJECT_EXTRA(x) ((void*)((x)->array.displaced))
@@ -411,8 +416,8 @@ cl_object si_finish_output(cl_object strm);
 cl_object si_force_output(cl_object strm);
 cl_object si_clear_output(cl_object strm);
 
-#define ecl_unread_error(s) FEerror("Error when unreading to stream ~D", 1, s)
-#define ecl_unread_twice(s) FEerror("Unread twice twice to stream ~D", 1, s)
+#define ecl_unread_error(s) ecl_ferror(ECL_EX_STRM_UNREAD, strm, ECL_NIL);
+#define ecl_unread_twice(s) ecl_ferror(ECL_EX_STRM_UNREAD, strm, ECL_T);
 
 /* streams/strm_common.d */
 cl_object ecl_not_a_file_stream(cl_object strm);
@@ -597,8 +602,8 @@ extern cl_object _ecl_long_double_to_integer(long double d);
 
 extern cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1];
 
-extern void ecl_init_bignum_registers(cl_env_ptr env);
-extern void ecl_clear_bignum_registers(cl_env_ptr env);
+extern cl_object ecl_init_bignum_registers(cl_env_ptr env);
+extern cl_object ecl_free_bignum_registers(cl_env_ptr env);
 
 /* threads/mutex.d */
 
@@ -691,13 +696,6 @@ extern void ecl_cs_set_size(cl_env_ptr env, cl_index n);
 #ifdef ECL_THREADS
 extern ECL_API cl_object mp_suspend_loop();
 extern ECL_API cl_object mp_break_suspend_loop();
-
-# ifdef ECL_WINDOWS_THREADS
-#  define ecl_thread_exit() ExitThread(0);
-# else
-#  define ecl_thread_exit() pthread_exit(NULL);
-# endif  /* ECL_WINDOWS_THREADS */
-
 #endif
 
 /* time.d */
@@ -711,7 +709,7 @@ extern void ecl_get_internal_real_time(struct ecl_timeval *time);
 extern void ecl_get_internal_run_time(struct ecl_timeval *time);
 extern void ecl_musleep(double time);
 
-#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),cl_core.Jan1st1970UT)
+#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),ecl_ct_Jan1st1970UT)
 extern cl_fixnum ecl_runtime(void);
 
 /* unixfsys.d */
@@ -867,9 +865,30 @@ extern void ecl_interrupt_process(cl_object process, cl_object function);
 
 #include <ecl/threads.h>
 
+/* sigmask */
+
+#ifdef HAVE_SIGPROCMASK
+# include <signal.h>
+# ifdef ECL_THREADS
+static inline int
+ecl_sigmask(int how, const sigset_t *set, sigset_t *oldset)
+{
+  return pthread_sigmask(how, set, oldset);
+}
+# else
+static inline int
+ecl_sigmask(int how, const sigset_t *set, sigset_t *oldset)
+{
+  return sigprocmask(how, set, oldset);
+}
+# endif
+#endif
+
+/* global locks */
+
 #ifdef ECL_THREADS
-# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env)                    \
-        ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.global_lock)
+# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env)                            \
+        ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.global_lock)
 # define ECL_WITH_GLOBAL_LOCK_END               \
         ECL_WITH_NATIVE_LOCK_END
 # define ECL_WITH_LOCK_BEGIN(the_env,lock) {             \
@@ -894,21 +913,21 @@ extern void ecl_interrupt_process(cl_object process, cl_object function);
         ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT {            \
                 ecl_mutex_unlock(__ecl_the_lock);        \
         } ECL_UNWIND_PROTECT_THREAD_SAFE_END; }
-# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) {      \
-        const cl_env_ptr __ecl_pack_env = the_env;        \
+# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) {                    \
+        const cl_env_ptr __ecl_pack_env = the_env;                      \
         ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);  \
-        ecl_rwlock_lock_read(&cl_core.global_env_lock);
-# define ECL_WITH_GLOBAL_ENV_RDLOCK_END                   \
-        ecl_rwlock_unlock_read(&cl_core.global_env_lock); \
-        ecl_bds_unwind1(__ecl_pack_env);                  \
+        ecl_rwlock_lock_read(&ecl_core.global_env_lock);
+# define ECL_WITH_GLOBAL_ENV_RDLOCK_END                    \
+        ecl_rwlock_unlock_read(&ecl_core.global_env_lock); \
+        ecl_bds_unwind1(__ecl_pack_env);                   \
         ecl_check_pending_interrupts(__ecl_pack_env); }
 # define ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) {      \
         const cl_env_ptr __ecl_pack_env = the_env;        \
         ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);  \
-        ecl_rwlock_lock_write(&cl_core.global_env_lock);
-# define ECL_WITH_GLOBAL_ENV_WRLOCK_END                    \
-        ecl_rwlock_unlock_write(&cl_core.global_env_lock); \
-        ecl_bds_unwind1(__ecl_pack_env);                   \
+        ecl_rwlock_lock_write(&ecl_core.global_env_lock);
+# define ECL_WITH_GLOBAL_ENV_WRLOCK_END                     \
+        ecl_rwlock_unlock_write(&ecl_core.global_env_lock); \
+        ecl_bds_unwind1(__ecl_pack_env);                    \
         ecl_check_pending_interrupts(__ecl_pack_env); }
 #else
 # define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env)

src/h/nucleus.h

@@ -6,4 +6,72 @@
 
 #include "external.h"
 
+struct ecl_core_struct {
+  cl_env_ptr first_env;
+#ifdef ECL_THREADS
+  cl_object threads;
+  ecl_mutex_t processes_lock;
+  ecl_mutex_t global_lock;
+  ecl_mutex_t error_lock;
+  ecl_rwlock_t global_env_lock;
+  cl_index last_var_index;
+  cl_object reused_indices;
+#endif
+  struct ecl_allocator_ops *allocator;
+  size_t max_heap_size;
+  cl_object bytes_consed;
+  cl_object gc_counter;
+  bool gc_stats;
+  char *safety_region;
+
+  cl_index default_sigmask_bytes;
+  cl_object known_signals;
+
+  int path_max;
+  cl_object pathname_translations;
+
+  cl_object modules;
+  cl_object libraries;
+  cl_object library_pathname;
+};
+
+/* process.c */
+cl_env_ptr ecl_adopt_cpu();
+cl_env_ptr ecl_spawn_cpu();
+void ecl_disown_cpu();
+
+/* control.c */
+void ecl_escape(cl_object continuation) ecl_attr_noreturn;
+cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread);
+cl_object ecl_call_with_handler(cl_object handler, cl_object continuation);
+
+/* Binding a handler conses a new list, but at this stage we don't assume the
+   the garbage collector to work! Luckily the extent of the binding is dynamic
+   and we can allocate cons on the stack. */
+#define ECL_WITH_HANDLER_BEGIN(the_env, handler) do {                   \
+  const cl_env_ptr __the_env = the_env;                                 \
+  cl_object __ecl_sym = ECL_SIGNAL_HANDLERS;                            \
+  cl_object __ecl_hnd = ECL_SYM_VAL(__the_env, __ecl_sym);              \
+  cl_object __ecl_hnds = ecl_cons_stack(handler, __ecl_hnd);            \
+  ecl_bds_bind(__the_env, __ecl_sym, __ecl_hnds);
+
+#define ECL_WITH_HANDLER_END ecl_bds_unwind1(__the_env); } while(0)
+
+cl_object ecl_raise(ecl_ex_type t, bool ret,
+                    cl_object a1, cl_object a2, cl_object a3, void *a4);
+
+#define ecl_ferror ecl_ferror3
+#define ecl_ferror1(extype) ecl_raise(extype, 0, ECL_NIL, ECL_NIL, ECL_NIL, NULL)
+#define ecl_ferror2(extype,a1) ecl_raise(extype, 0, a1, ECL_NIL, ECL_NIL, NULL)
+#define ecl_ferror3(extype,a1,a2) ecl_raise(extype, 0, a1, a2, ECL_NIL, NULL)
+#define ecl_ferror4(extype,a1,a2,a3) ecl_raise(extype, 0, a1, a2, a3, NULL)
+#define ecl_ferror5(extype,a1,a2,a3,p4) ecl_raise(extype, 0, a1, a2, a3, p4)
+
+#define ecl_cerror ecl_cerror3
+#define ecl_cerror1(extype) ecl_raise(extype, 1, ECL_NIL, ECL_NIL, ECL_NIL, NULL)
+#define ecl_cerror2(extype,a1) ecl_raise(extype, 1, a1, ECL_NIL, ECL_NIL, NULL)
+#define ecl_cerror3(extype,a1,a2) ecl_raise(extype, 1, a1, a2, ECL_NIL, NULL)
+#define ecl_cerror4(extype,a1,a2,a3) ecl_raise(extype, 1, a1, a2, a3, NULL)
+#define ecl_cerror5(extype,a1,a2,a3,p4) ecl_raise(extype, 1, a1, a2, a3, p4)
+
 #endif  /* ECL_NUCLEUS_H */

src/h/object.h

@@ -84,6 +84,8 @@ typedef enum {
         t_codeblock,
         t_foreign,
         t_frame,
+        t_exception,
+        t_module,
         t_weak_pointer,
 #ifdef ECL_SSE2
         t_sse_pack,
@@ -94,15 +96,33 @@ typedef enum {
         FREE = 127              /*  free object  */
 } cl_type;
 
-
 /*
         Definition of the type of LISP objects.
 */
 typedef union cl_lispunion *cl_object;
+typedef struct cl_env_struct *cl_env_ptr;
 typedef cl_object cl_return;
 typedef cl_fixnum cl_narg;
 typedef cl_object (*cl_objectfn)(cl_narg narg, ...);
 typedef cl_object (*cl_objectfn_fixed)();
+typedef cl_object (*cl_objectfn_envfn)(cl_env_ptr);
+
+/* Allocator interface */
+struct ecl_allocator_ops {
+  void *(*allocate_memory)(cl_index n);    /* low-level  alloc */
+  void *(*allocate_manual)(cl_index n);    /* low-level  alloc */
+  void *(*allocate_atomic)(cl_index n);    /* low-level  alloc */
+  cl_object (*allocate_object)(cl_type t); /* high-level alloc */
+  void (*free_memory)(void*);              /* low-level  free */
+  void (*free_object)(cl_object);          /* high-level free */
+};
+
+struct ecl_type_information {
+  cl_type t;
+  const char * name;
+  size_t size;
+  uintmax_t descriptor;
+};
 
 /*
         OBJect NULL value.
@@ -258,16 +278,20 @@ enum ecl_stype {                /*  symbol type  */
 };
 
 #define ECL_NIL                 ((cl_object)t_list)
-#define ECL_NIL_SYMBOL          ((cl_object)cl_symbols)
-#define ECL_T                   ((cl_object)(cl_symbols+1))
-#define ECL_UNBOUND             ((cl_object)(cl_symbols+2))
-#define ECL_PROTECT_TAG         ((cl_object)(cl_symbols+3))
-#define ECL_DUMMY_TAG           ((cl_object)(cl_symbols+4))
-#define ECL_RESTART_CLUSTERS    ((cl_object)(cl_symbols+5))
-#define ECL_HANDLER_CLUSTERS    ((cl_object)(cl_symbols+6))
-#define ECL_INTERRUPTS_ENABLED  ((cl_object)(cl_symbols+7))
 #define ECL_NO_TL_BINDING       ((cl_object)(1 << ECL_TAG_BITS))
 
+#define ECL_PROTECT_TAG         ecl_ct_protect_tag
+#define ECL_DUMMY_TAG           ecl_ct_dummy_tag
+
+#define ECL_SIGNAL_HANDLERS     ((cl_object)(ecl_symbols+0))
+#define ECL_RESTART_CLUSTERS    ((cl_object)(ecl_symbols+1))
+#define ECL_INTERRUPTS_ENABLED  ((cl_object)(ecl_symbols+2))
+#define ECL_ALLOW_OTHER_KEYS    ((cl_object)(ecl_symbols+3))
+#define ECL_T                   ((cl_object)(ecl_symbols+4))
+#define ECL_UNBOUND             ((cl_object)(ecl_symbols+5))
+
+#define ECL_NIL_SYMBOL          ((cl_object)(cl_symbols+0))
+
 struct ecl_symbol {
         _ECL_HDR1(stype);        /*  symbol type */
         cl_object value;         /*  global value of the symbol  */
@@ -574,6 +598,7 @@ enum ecl_smmode {               /*  stream mode  */
         ecl_smm_string_input,   /*  string input  */
         ecl_smm_string_output,  /*  string output  */
         ecl_smm_probe,          /*  probe (only used in open_stream())  */
+        ecl_smm_other,          /*  custom stream implementation */
 #if defined(ECL_WSOCK)
         ecl_smm_input_wsock,    /*  input socket (Win32) */
         ecl_smm_output_wsock,   /*  output socket (Win32) */
@@ -946,6 +971,65 @@ struct ecl_stack_frame {
         struct cl_env_struct *env;
 };
 
+typedef enum {
+        ECL_EX_FERROR,          /* general purpose fatal error */
+        ECL_EX_CERROR,          /* general purpose continuable error */
+        ECL_EX_CS_OVR,          /* stack overflow */
+        ECL_EX_FRS_OVR,         /* stack overflow */
+        ECL_EX_BDS_OVR,         /* stack overflow */
+        ECL_EX_BADARG,          /* wrong type of argument */
+        ECL_EX_BADARG_ONLY,     /* wrong type of the only argument */
+        ECL_EX_UNSATISFIED,     /* wrong type of argument (predicate) */
+        ECL_EX_EOF,             /* end of file */
+        ECL_EX_NIY,             /* not implemented yet */
+        ECL_EX_NAO,             /* not applicable operation */
+        ECL_EX_STRM_BADELT,     /* invalid stream element type */
+        ECL_EX_STRM_CLOSED,     /* the stream is closed */
+        ECL_EX_STRM_UNREAD,     /* error while unreading into the stream */
+        /* Kludges for the bytecodes VM */
+        ECL_EX_VM_BADARG_EXCD,
+        ECL_EX_VM_BADARG_UNKK,
+        ECL_EX_VM_BADARG_ODDK,
+        ECL_EX_VM_BADARG_NTH_VAL,
+        ECL_EX_VM_BADARG_ENDP,
+        ECL_EX_VM_BADARG_CAR,
+        ECL_EX_VM_BADARG_CDR,
+        ECL_EX_VM_BADARG_PROGV,
+        /* Specific normal conditions */
+        ECL_EX_V_CSETQ,         /* assigning a constant */
+        ECL_EX_V_CBIND,         /* binding a constant */
+        ECL_EX_V_UNBND,         /* unbound variable */
+        ECL_EX_V_BNAME,         /* illegal variable name */
+        ECL_EX_F_NARGS,         /* wrong number of arguments */
+        ECL_EX_F_UNDEF,         /* undefined function */
+        ECL_EX_F_INVAL,         /* non-function passed as function */
+        ECL_EX_S_FMISS          /* missing unwind frame (ecl_escape) */
+} ecl_ex_type;
+
+#define ECL_EXCEPTIONP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_exception))
+
+struct ecl_exception {
+        _ECL_HDR1(ex_type);
+        /* Slots for storing contextual data. Depends on the exception type.  */
+        cl_object arg1;      /* usually the offending object or the type.     */
+        cl_object arg2;      /* usually additional arguments or the flag.     */
+        cl_object arg3;      /* arbitrary lisp extra argument (i.e ECL_NIL).  */
+        void * arg4;         /* arbitrary last ditch argument (usually NULL). */
+};
+
+struct ecl_module {
+        _ECL_HDR;
+        cl_object name;
+        cl_objectfn_fixed create;
+        cl_objectfn_fixed enable;
+        cl_objectfn_envfn init_env;
+        cl_objectfn_envfn init_cpu;
+        cl_objectfn_envfn free_cpu;
+        cl_objectfn_envfn free_env;
+        cl_objectfn_fixed disable;
+        cl_objectfn_fixed destroy;
+};
+
 struct ecl_weak_pointer {       /*  weak pointer to value  */
         _ECL_HDR;
         cl_object value;
@@ -1000,18 +1084,15 @@ struct ecl_process {
         _ECL_HDR;
         cl_object name;
         cl_object function;
+        cl_objectfn entry;      /* entry address (matches ecl_cfun offset) */
         cl_object args;
-        struct cl_env_struct *env;
-        cl_object interrupt;
         cl_object inherit_bindings_p;
-        cl_object parent;
         cl_object exit_values;
         cl_object woken_up;
         ecl_mutex_t start_stop_lock; /* phase is updated only when we hold this lock */
         ecl_cond_var_t exit_barrier; /* process-join waits on this barrier */
         cl_index phase;
-        ecl_thread_t thread;
-        int trap_fpe_bits;
+        struct cl_env_struct *env;
 };
 
 enum {
@@ -1174,6 +1255,8 @@ union cl_lispunion {
         struct ecl_cclosure     cclosure;       /*  compiled closure  */
         struct ecl_dummy        d;              /*  dummy  */
         struct ecl_instance     instance;       /*  clos instance */
+        struct ecl_exception    exception;      /*  exception */
+        struct ecl_module       module;         /*  core module */
 #ifdef ECL_THREADS
         struct ecl_process      process;        /*  process  */
         struct ecl_lock         lock;           /*  lock  */

src/h/stack-resize.h

@@ -14,11 +14,10 @@
 #ifndef ECL_STACK_RESIZE_H
 #define ECL_STACK_RESIZE_H
 
-/* We can't block interrupts with ecl_disable_interrupts() and write
- * in the thread local environment if we use fast interrupt dispatch
- * via mprotect(), so we have to use sigprocmask instead. No
- * performance problems, since this is only used for stack
- * resizing. */
+/* We can't block interrupts with ecl_disable_interrupts() and write in the
+ * thread local environment if we use fast interrupt dispatch via mprotect(), so
+ * we have to use sigprocmask instead. No performance problems, since this is
+ * only used for stack resizing. */
 #if defined(ECL_THREADS) && defined(ECL_USE_MPROTECT)
 # ifdef HAVE_SIGPROCMASK
 #  include <signal.h>

src/h/stacks.h

@@ -233,16 +233,18 @@ typedef struct ecl_ihs_frame {
         struct ecl_ihs_frame *next;
         cl_object function;
         cl_object lex_env;
+        cl_object lcl_env;
         cl_index index;
         cl_index bds;
 } *ecl_ihs_ptr;
 
-#define ecl_ihs_push(env,rec,fun,lisp_env) do { \
+#define ecl_ihs_push(env,rec,fun,lex,lcl) do { \
         const cl_env_ptr __the_env = (env);     \
         ecl_ihs_ptr const r = (ecl_ihs_ptr const)(rec); \
         r->next=__the_env->ihs_stack.top;             \
         r->function=(fun);                            \
-        r->lex_env=(lisp_env);                        \
+        r->lex_env=(lex);                             \
+        r->lcl_env=(lcl);                             \
         r->index=__the_env->ihs_stack.top->index+1;   \
         r->bds=__the_env->bds_stack.top - __the_env->bds_stack.org; \
         __the_env->ihs_stack.top = r;                               \
@@ -508,7 +510,7 @@ ecl_data_stack_set_index(cl_env_ptr env, cl_index ndx)
 #define ECL_HANDLER_CASE_BEGIN(the_env, names) do {                     \
         const cl_env_ptr __the_env = (the_env);                         \
         const cl_object __ecl_tag = ecl_list1(names);                   \
-        ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS,                   \
+        ecl_bds_bind(__the_env, ECL_SIGNAL_HANDLERS,                    \
                      si_bind_simple_handlers(__ecl_tag, names));        \
         ecl_frs_push(__the_env,__ecl_tag);                              \
         if (__ecl_frs_push_result == 0) {

src/h/threads.h

@@ -22,8 +22,8 @@
 # endif
 #endif
 
-#ifndef ECL_MUTEX_H
-#define ECL_MUTEX_H
+#ifndef ECL_THREADS_H
+#define ECL_THREADS_H
 
 #include <errno.h>
 #ifdef ECL_WINDOWS_THREADS
@@ -38,6 +38,45 @@
 #endif
 #include <math.h>
 
+#ifdef ECL_WINDOWS_THREADS
+/* Windows can't into typedefs in parameter lists. */
+/* typedef DWORD WINAPI (*ecl_thread_entry)(void *ptr); */
+static inline int
+ecl_thread_create(cl_env_ptr the_env, /* ecl_thread_entry */ void* fun)
+{
+  HANDLE code;
+  DWORD threadId;
+  code = (HANDLE)CreateThread(NULL, 0, fun, the_env, 0, &threadId);
+  the_env->thread = code;
+  /* NULL handle is a failure. */
+  return (code != NULL) ? 0 : 1;
+}
+
+static inline void
+ecl_thread_exit()
+{
+  ExitThread(0);
+}
+#else /* ECL_WINDOWS_THREADS */
+typedef void* (*ecl_thread_entry)(void *ptr);
+
+static inline int
+ecl_thread_create(cl_env_ptr the_env, ecl_thread_entry fun)
+{
+  pthread_attr_t pthreadattr;
+  pthread_attr_init(&pthreadattr);
+  pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED);
+  return pthread_create(&the_env->thread, &pthreadattr, fun, the_env);
+}
+
+static inline void
+ecl_thread_exit()
+{
+  pthread_exit(NULL);
+}
+#endif /* ECL_WINDOWS_THREADS */
+
+
 #if !defined(ECL_WINDOWS_THREADS)
 
 #define ECL_MUTEX_SUCCESS 0
@@ -734,6 +773,6 @@ ecl_rwlock_lock_write(ecl_rwlock_t *rwlock)
 
 #endif /* ECL_WINDOWS_THREADS */
 
-#endif /* ECL_MUTEX_H */
+#endif /* ECL_THREADS_H */
 
 #endif /* ECL_THREADS */

src/lsp/top.lsp

@@ -26,7 +26,8 @@
 (defparameter *quit-tag* (cons nil nil))
 (defparameter *quit-tags* nil)
 (defparameter *break-level* 0)          ; nesting level of error loops
-(defparameter *break-env* nil)
+(defparameter *break-lexenv* nil)
+(defparameter *break-locals* nil)
 (defparameter *ihs-base* 0)
 (defparameter *ihs-top* (ihs-top))
 (defparameter *ihs-current* 0)
@@ -601,7 +602,7 @@ Use special code 0 to cancel this operation.")
                            (tpl-prompt)
                            (tpl-read))
                        values (multiple-value-list
-                               (eval-with-env - *break-env*))
+                               (eval-with-env - *break-lexenv*))
                        /// // // / / values *** ** ** * * (car /))
                  (tpl-format "~&~{~s~^~%~}~%" values)))))
       (loop
@@ -904,76 +905,106 @@ Use special code 0 to cancel this operation.")
         @(return) = CONS(name,output);
 " :one-liner nil))
 
-(defun decode-ihs-env (*break-env*)
-  (let ((env *break-env*))
-    (if (vectorp env)
-      #+ecl-min
-      nil
-      #-ecl-min
-      (let* ((next (decode-ihs-env
-                    (ffi:c-inline (env) (:object) :object
-                                  "(#0)->vector.self.t[0]" :one-liner t))))
-        (nreconc (loop with l = (- (length env) 2)
-                       for i from 0 below l
-                       do (push (decode-env-elt env i) next))
-                   next))
-      env)))
+;;; This function is here for backward compatibility. We also extend it to
+;;; "simply work" with ihs indexes - then it decodes both locals and lexenv.
+(defun decode-ihs-env (env)
+  (etypecase env
+    ((or vector si:frame)
+     (decode-ihs-locals env))
+    (integer
+     (append (decode-ihs-locals (ihs-lcl env))
+             (decode-ihs-lexenv (ihs-lex env))))
+    (null
+     nil)))
+
+(defun decode-ihs-locals (env)
+  #+ecl-min nil
+  #-ecl-min
+  (etypecase env
+    (vector
+     (let ((next (decode-ihs-locals
+                  (ffi:c-inline (env) (:object) :object
+                                "(#0)->vector.self.t[0]" :one-liner t))))
+       (nreconc (loop with l = (- (length env) 2)
+                      for i from 0 below l
+                      do (push (decode-env-elt env i) next))
+                next)))
+    (si:frame
+     (let* ((lcls '()))
+       (ffi:c-inline (env lcls) (:object :object) :void
+                     "loop_across_frame_fifo(elt, (#0)) {
+                        (#1)=ecl_cons(elt, (#1));
+                      } end_loop_across_frame();")
+       lcls))
+    (null
+     nil)))
+
+(defun decode-ihs-lexenv (env)
+  #+ecl-min nil
+  #-ecl-min
+  (etypecase env
+    (vector
+     (loop for elt across env collect elt))
+    (null
+     nil)))
 
 (defun ihs-environment (ihs-index)
-  (labels ((newly-bound-special-variables (bds-min bds-max)
-             (loop for i from bds-min to bds-max
-                for variable = (bds-var i)
-                unless (member variable output :test #'eq)
-                collect variable into output
-                finally (return output)))
-           (special-variables-alist (ihs-index)
-             (let ((top (ihs-top)))
-               (unless (> ihs-index top)
-                 (let* ((bds-min (1+ (ihs-bds ihs-index)))
-                        (bds-top (bds-top))
-                        (bds-max (if (= ihs-index top)
-                                     bds-top
-                                     (ihs-bds (1+ ihs-index))))
-                        (variables (newly-bound-special-variables bds-min bds-max)))
-                   (loop with output = '()
-                      for i from (1+ bds-max) to bds-top
-                      for var = (bds-var i)
-                      when (member var variables :test #'eq)
-                      do (setf variables (delete var variables)
-                               output (acons var (bds-val i) output))
-                      finally (return
-                                (append (loop for v in variables
-                                           collect (cons v (symbol-value v)))
-                                        output)))))))
-           (extract-restarts (variables-alist)
-             (let ((record (assoc '*restart-clusters* variables-alist)))
-               (if record
-                   (let* ((bindings (cdr record))
-                          (new-bindings (first bindings)))
-                     (values (delete record variables-alist) new-bindings))
-                   (values variables-alist nil)))))
-    (let* ((functions '())
-           (blocks '())
-           (local-variables '())
-           (special-variables '())
-           (restarts '())
-           record0 record1)
-      (dolist (record (decode-ihs-env (ihs-env ihs-index)))
-        (cond ((atom record)
-               (push (compiled-function-name record) functions))
-              ((progn
-                 (setf record0 (car record) record1 (cdr record))
-                 (when (stringp record0)
-                   (setf record0
-                         (let ((*package* (find-package "KEYWORD")))
-                           (with-standard-io-syntax
-                             (read-from-string record0)))))
-                 (or (symbolp record0) (stringp record0)))
-               (setq local-variables (acons record0 record1 local-variables)))
-              ((symbolp record1)
-               (push record1 blocks))
-              (t
-               )))
+  (let ((functions '())
+        (blocks '())
+        (local-variables '())
+        (special-variables '())
+        (restarts '())
+        record0 record1)
+    (labels ((newly-bound-special-variables (bds-min bds-max)
+               (loop for i from bds-min to bds-max
+                     for variable = (bds-var i)
+                     unless (member variable output :test #'eq)
+                       collect variable into output
+                     finally (return output)))
+             (special-variables-alist (ihs-index)
+               (let ((top (ihs-top)))
+                 (unless (> ihs-index top)
+                   (let* ((bds-min (1+ (ihs-bds ihs-index)))
+                          (bds-top (bds-top))
+                          (bds-max (if (= ihs-index top)
+                                       bds-top
+                                       (ihs-bds (1+ ihs-index))))
+                          (variables (newly-bound-special-variables bds-min bds-max)))
+                     (loop with output = '()
+                           for i from (1+ bds-max) to bds-top
+                           for var = (bds-var i)
+                           when (member var variables :test #'eq)
+                             do (setf variables (delete var variables)
+                                      output (acons var (bds-val i) output))
+                           finally (return
+                                     (append (loop for v in variables
+                                                   collect (cons v (symbol-value v)))
+                                             output)))))))
+             (extract-restarts (variables-alist)
+               (let ((record (assoc '*restart-clusters* variables-alist)))
+                 (if record
+                     (let* ((bindings (cdr record))
+                            (new-bindings (first bindings)))
+                       (values (delete record variables-alist) new-bindings))
+                     (values variables-alist nil))))
+             (process-env-record (record)
+               (cond ((atom record)
+                      (push (compiled-function-name record) functions))
+                     ((progn
+                        (setf record0 (car record) record1 (cdr record))
+                        (when (stringp record0)
+                          (setf record0
+                                (let ((*package* (find-package "KEYWORD")))
+                                  (with-standard-io-syntax
+                                    (read-from-string record0)))))
+                        (or (symbolp record0) (stringp record0)))
+                      (setq local-variables (acons record0 record1 local-variables)))
+                     ((symbolp record1)
+                      (push record1 blocks))
+                     (t
+                      ))))
+      (map nil #'process-env-record (decode-ihs-locals (ihs-lcl ihs-index)))
+      (map nil #'process-env-record (decode-ihs-lexenv (ihs-lex ihs-index)))
       (multiple-value-bind (special-variables restarts)
           (extract-restarts (special-variables-alist ihs-index))
         (values (nreverse local-variables)
@@ -1017,7 +1048,7 @@ Use special code 0 to cancel this operation.")
 (defun tpl-inspect-command (var-name)
   (when (symbolp var-name)
     (setq var-name (symbol-name var-name)))
-  (let ((val-pair (assoc var-name (decode-ihs-env *break-env*)
+  (let ((val-pair (assoc var-name (decode-ihs-locals *break-locals*)
                          :test #'(lambda (s1 s2)
                                    (when (symbolp s2) (setq s2 (symbol-name s2)))
                                    (if (stringp s2)
@@ -1204,7 +1235,8 @@ Use special code 0 to cancel this operation.")
   (set-break-env))
 
 (defun set-break-env ()
-  (setq *break-env* (ihs-env *ihs-current*)))
+  (setq *break-lexenv* (ihs-lex *ihs-current*))
+  (setq *break-locals* (ihs-lcl *ihs-current*)))
 
 (defun ihs-search (string unrestricted &optional (start (si::ihs-top)))
   (do ((ihs start (si::ihs-prev ihs)))
@@ -1300,7 +1332,8 @@ Use the following functions to directly access ECL stacks.
 Invocation History Stack:
 (SYS:IHS-TOP)   Returns the index of the TOP of the IHS.
 (SYS:IHS-FUN i) Returns the function of the i-th entity in IHS.
-(SYS:IHS-ENV i)
+(SYS:IHS-LEX i) Returns the lexical environment of the i-th entry in IHS.
+(SYS:IHS-LCL i) Returns the local environment of the i-th entry in IHS.
 (SYS:IHS-PREV i)
 (SYS:IHS-NEXT i)
 
@@ -1413,7 +1446,8 @@ package."
            (*break-condition* condition)
            (*break-level* (1+ *break-level*))
            (break-level *break-level*)
-           (*break-env* nil))
+           (*break-locals* nil)
+           (*break-lexenv* nil))
       (check-default-debugger-runaway)
       #+threads
       ;; We give our process priority for grabbing the console.

src/tests/normal-tests/compiler.lsp

@@ -192,7 +192,7 @@
 ;;; Fixed: 10/10/2006
 ;;; Description:
 ;;;
-;;;     Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized
+;;;     Nested calls to queue_finalizer trashed the value of ecl_core.to_be_finalized
 ;;;     The following code tests that at least three objects are finalized.
 ;;;
 ;;; Note: this test fails in multithreaded mode. GC takes too long!

src/util/nucleus.org

@@ -0,0 +1,182 @@
+
+* Runtime
+
+When we initialize ECL we need to take care of a few things. First we need to
+recognize the distinction between different environments:
+
+- ecl_core and cl-core structures are global and shared by all processes
+- cl_env_struct is local to each process/thread
+
+Note that currently we don't put a hard distinction between processes and
+threads, but in the near future I plan to separate them in N-to-M scheme.
+That's why I'm going to treat them as distinct in this overview.
+
+In other words:
+- current :: ~[core] 1-n [process] 1-1 [environment]~.
+- planned :: ~[core] 1-n [process] 1-n [environment]~.
+
+Sometimes I'll use the word ~cpu~ in place of ~process~ and ~env~ in place of
+~environment~.
+
+First, when the program starts, we need to initialize the global state, adopt
+the current process and associate the first environment with it. That creates a
+single computation context that will be used for further initialization.
+
+To allow loose coupling of components we introduce the concept of modules. Each
+module implements a certain aspect of the system and is initialized separately
+in each context: core, process and thread. When we leave the context (i.e the
+thread exits, or we disown the cpu) a matching "release" procedure is called.
+
+#+begin_src lisp
+  (defstruct module
+    create destroy
+    enable disable
+    init_cpu free_cpu
+    init_env init_env)
+#+end_src
+
+Not all options make sense for each module -- in that case a no-op function is
+used. To avoid the situation where we need to retroactively initialize a module
+for pre-existing processes and environments, all modules must be added before we
+start using the first process.
+
+- create :: initialize global structure
+- enable :: start the module
+- delete :: stop the module and release all resources
+
+- init_env :: initialization for the current environment
+- free_env :: clean up before we destroy the environment
+
+- init_cpu :: initialization for the current process
+- free_cpu :: clean up before we destroy the process
+
+It is important to note that the environment is usually initialized on a
+different cpu than the one that it runs on. This is to avoid race conditions.
+
+** The core
+
+The core encapsulates the following:
+
+- user defined global options
+- a set of modules that need to be initialized
+- a set of processes (adopted and spawned)
+
+The initialization requires us to parse user options and initialize modules.
+Process manager may be treated as a special module, thus:
+
+#+begin_src lisp
+  (defun initialize-core ()
+    (parse-user-options)
+    (initialize-modules)
+    (enable :process-module))
+
+  (defun initialize-modules ()
+    (add-module :process-module)
+    (add-module :c-stack-module)
+    (add-module :big-num-module)
+    ;; ... (depends on the runtime)
+    (seal-modules))
+
+  (defun add-module (module)
+    ;; Initialize for the first cpu and environment.
+    (create module)
+    (init-cpu module +first-env+)
+    (init-env module +first-env+))
+
+  (defun del-module (module)
+    (disable module)
+    (free-env module +first-env+)
+    (free-cpu module +first-env+)
+    (delete module))
+#+end_src
+
+** Processes
+
+#+begin_src lisp
+  (define-module :process-module
+      :create #'init-process
+      :enable #'enable-process)
+
+  (defun init-process ()
+    (initialize-locks :core)
+    (initialize-self main_thread)
+    (initialize-tls cl_env_key)
+    (initialize-env :first-env))
+
+  (defun enable-process ()
+    (dolist (module *modules*)
+      (init-cpu module)))
+#+end_src
+
+** Threads
+
+#+begin_src lisp
+  (define-module :thread-module
+      :create #'init-thread
+      :enable #'enable-thread)
+
+  (defun init-thread ()
+    (error "not implemented yet")
+    (init-bindings))
+
+  (defun enable-thread ()
+    (dolist (module *modules*)
+      (init-env module)))
+#+end_src
+
+* Early Languages
+
+** F42
+
+f42 is a forth dialect that compiles directly to the bytecodes vm. It is
+available very early before a full environment is estabilished. It consists of:
+
+- readtable that reads symbols (case sensitive), strings, fixnums and lists
+- character stream using C stream interface (we bind stdin/stdout)
+- dictionary with a set of core words and raw bytevm opcodes
+- command reader that defines and executes lines of words (commands)
+- one pass compiler that takes a line of words and produces bytecodes
+
+Lazy as I am I've added an additional opcode to the bytevm besides OP_QUOTE.
+That word is OP_CALLW and it is responsible for calling an immediate word.
+Thanks to that bytecodes size will always match the length of the command.
+
+The repl works in two modes: execution mode and compilation mode. Conventionally
+the compilation mode is entered by typing the word ~:~ and it is left when after
+we type ~;~, for examlpe ~: new-word 42 13 + ;~.
+
+It is important to note that there are no guard rails. If the line contains an
+opcode leading segfaults (i.e popping from an empty stack), then it is on you.
+
+| :        | start definition   |           |
+| ;        | end definition     |           |
+| .        | pop from the stack | safe      |
+| .S       | print the stack    |           |
+| .D       | print a dictionary |           |
+| [opcode] | insert an opcode   | i.e ~NOP~ |
+| [word]   | invoke a word      | i.e ~foo~ |
+
+This poor dictionary will be extended when deemed necessary. Note that special
+operators are catered to by a virtue of embedding opcodes. A dictionary entries
+are symbols and a definition is stored as a symbol value.
+
+** UCL
+
+Operator ~defm~ is for defining macros and ~defc~ for defining typed functions
+that can be transpiled to C99. ~defl~ as defined below could be used as an
+operator that defines functions that may be used with Lisp runtime (value-wise).
+
+#+begin_src scheme
+  (defm (twice form)
+    `(progn ,form ,form))
+
+  (defn ((hello :void) (name :string) (n :index))
+    "Prints 'Hello {STRING}' n times."
+    (do ((i 0) (1+ i))
+        ((>= i times))
+      (out "Hello " name "\n")))
+
+  (defm ((defl . args) . body)
+    `(defn ,(mapcar (lambda (a) (list a :object)))
+       ,@body))
+#+end_src