Merge branch 'develop' into 'develop'

Small fixes so that manual.pdf can be created

See merge request embeddable-common-lisp/ecl!360

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

src/c/error.d

@@ -306,7 +306,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 +330,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 +356,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 +387,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 */

src/c/interpreter.d

@@ -371,7 +371,7 @@ 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_ihs_push(the_env, &ihs, bytecodes, closure, lcl_env);
   ecl_stack_frame_open(the_env, lcl_env, nlcl);
   frame_aux.t = t_frame;
   frame_aux.opened = 0;

src/c/stacks.d

@@ -941,12 +941,27 @@ si_ihs_fun(cl_object arg)
 }
 
 cl_object
-si_ihs_env(cl_object arg)
+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. */

src/c/symbols_list.h

@@ -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)},

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/h/external.h

@@ -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);

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;                               \

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,22 +905,56 @@ 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
+;;; 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
-      (let* ((next (decode-ihs-env
+  (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))
-      env)))
+                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)
+  (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)
@@ -951,14 +986,8 @@ Use special code 0 to cancel this operation.")
                      (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)))
+                     (values variables-alist nil))))
+             (process-env-record (record)
                (cond ((atom record)
                       (push (compiled-function-name record) functions))
                      ((progn
@@ -973,7 +1002,9 @@ Use special code 0 to cancel this operation.")
                      ((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.