nucleus: move early stacks to a separate file

This is necessary if we want to link them into nucleus without CL env baggage.

src/c/Makefile.in

@@ -50,7 +50,7 @@ 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 = boot.o escape.o eql.o module.o
+BOOT_OBJS = boot.o escape.o eql.o module.o stacks.o
 
 CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o
 
@@ -82,7 +82,7 @@ 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       \
 	$(BOOT_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(STREAM_OBJS)   \

src/c/escape.d

@@ -46,6 +46,23 @@ ecl_escape(cl_object continuation)
   _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)
 {

src/c/interpreter.d

@@ -63,18 +63,36 @@ VEwrong_arg_type_nth_val()
   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)
 {
   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)
 {
   ecl_ferror(ECL_EX_V_UNBND, var, ECL_NIL);
 }
 
+static void
+VEillegal_variable_name(cl_object name)
+{
+  ecl_ferror(ECL_EX_V_BNAME, name, ECL_NIL);
+}
+
 static void
 VEwrong_num_arguments(cl_object fun)
 {
@@ -310,6 +328,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)
 {

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

@@ -805,215 +805,6 @@ static struct ecl_module module_stacks = {
 
 cl_object ecl_module_stacks = (cl_object)&module_stacks;
 
-/* -- High level interface -------------------------------------------------- */
-
-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 */
-}
-
-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);
-}
-
-/* -- 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);
-}
-
 /* -- General purpose stack implementation ----------------------------------- */
 
 /* Stacks are based on actually adjustable simple vectors. */
@@ -1107,66 +898,3 @@ ecl_stack_popu(cl_object self)
   self->vector.self.t[self->vector.fillp] = ECL_NIL;
   return result;
 }
-
-/* -- 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));
-}
-