From 3c4c1639c58b7a10d33d5e966694a1311e25206a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Nov 2025 12:48:41 +0100 Subject: [PATCH 1/6] proclamations: fix an invalid proclamation for SI:IHS-ENV It may seem like this proclamation is invalid sincd !346, but the divergence happens much earlier. 8c0314022cefcfe7149e4efdb14ac7c6be48ed88 introduces a feature where c-compiled code can also add debug information, and in that case the environment is a vector, so the proclamation back then should be: (proclamation si:ihs-env (si::index) (or list vector)) Later when we've changed the representation, it should be changed to (proclamation si:ihs-env (si::index) (or null vector)) Where NULL denotes "no lexical environment". --- src/cmp/proclamations.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 4fd32fc66..e4bcc6c88 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -298,7 +298,7 @@ (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:frs-top () si::index) (proclamation si:frs-bds (si::index) si::index) (proclamation si:frs-tag (si::index) t) From ed5471169edc37604f18ae681236621942ecf1ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Nov 2025 14:23:39 +0100 Subject: [PATCH 2/6] ihs: store locals and lexical environment in separate slots Since ~recently we store local variables in the bytevm on the stack. Also, the native comipler under specified debug options, stores locals in ihs, but it has nothing to do with the lexical environment. So it feels justified to push both to a separate field. --- src/c/compiler.d | 2 +- src/c/error.d | 8 ++++---- src/c/interpreter.d | 2 +- src/c/stacks.d | 7 +++++++ src/c/symbols_list.h | 1 + src/cmp/cmpbackend-cxx/cmppass2-fun.lsp | 2 +- src/cmp/proclamations.lsp | 1 + src/h/external.h | 1 + src/h/stacks.h | 6 ++++-- 9 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 97595c79b..15a005815 100644 --- a/src/c/compiler.d +++ b/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 diff --git a/src/c/error.d b/src/c/error.d index b420e47af..58bf24fdc 100644 --- a/src/c/error.d +++ b/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 */ diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1f21d4c2a..67c860bad 100644 --- a/src/c/interpreter.d +++ b/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; diff --git a/src/c/stacks.d b/src/c/stacks.d index 119f03106..055c22401 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -947,6 +947,13 @@ si_ihs_env(cl_object arg) 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); +} + /* -- General purpose stack implementation ----------------------------------- */ /* Stacks are based on actually adjustable simple vectors. */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e988e7d44..89c1f97f2 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1215,6 +1215,7 @@ 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-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)}, diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index 6bbe67c32..712f1fa1c 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/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 diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index e4bcc6c88..382d831d6 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -299,6 +299,7 @@ (proclamation si:ihs-top () si::index) (proclamation si:ihs-fun (si::index) (or null function-designator)) (proclamation si:ihs-env (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) diff --git a/src/h/external.h b/src/h/external.h index 6b0011165..08d228af1 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1649,6 +1649,7 @@ 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_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); diff --git a/src/h/stacks.h b/src/h/stacks.h index 9aa029f36..0fa79433c 100755 --- a/src/h/stacks.h +++ b/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; \ From 8a5007fd4ae1b2b922822d7d66a1369d6fa4f08a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Nov 2025 15:16:40 +0100 Subject: [PATCH 3/6] top: separate correctly lexenv from lclenv in break environment Fixes #799. --- src/lsp/top.lsp | 47 +++++++++++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 18 deletions(-) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index e746724b0..a5e56e03c 100644 --- a/src/lsp/top.lsp +++ b/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,20 +905,28 @@ 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 +(defun decode-ihs-env (*break-locals*) + #+ecl_min nil + #-ecl_min + (let ((env *break-locals*)) + (etypecase env + (vector + (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))) + (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 '()) + (next (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 ihs-environment (ihs-index) (labels ((newly-bound-special-variables (bds-min bds-max) @@ -958,7 +967,7 @@ Use special code 0 to cancel this operation.") (special-variables '()) (restarts '()) record0 record1) - (dolist (record (decode-ihs-env (ihs-env ihs-index))) + (dolist (record (decode-ihs-env (ihs-lcl ihs-index))) (cond ((atom record) (push (compiled-function-name record) functions)) ((progn @@ -1017,7 +1026,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-env *break-locals*) :test #'(lambda (s1 s2) (when (symbolp s2) (setq s2 (symbol-name s2))) (if (stringp s2) @@ -1204,7 +1213,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-env *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))) @@ -1413,7 +1423,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. From e6ae6146a48fe0d723ba441b9aca0b5c884f4ef8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Nov 2025 19:20:25 +0100 Subject: [PATCH 4/6] ihs/swank: make si_ihs_env return the local environment (not lexical) We deprecate the function si_ihs_env in favor of more explicit si_ihs_lex and si_ihs_lcl, but the former is left for backward compatibility with SLIME/SLYNK because they call it to query the environment to add locals to the backtrace. --- src/c/stacks.d | 10 +++++++++- src/c/symbols_list.h | 1 + src/cmp/proclamations.lsp | 1 + src/h/external.h | 1 + src/lsp/top.lsp | 5 +++-- 5 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index 055c22401..623467307 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -941,7 +941,7 @@ 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); @@ -954,6 +954,14 @@ si_ihs_lcl(cl_object arg) 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. */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 89c1f97f2..8a1e5bb0d 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1215,6 +1215,7 @@ 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)}, diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 382d831d6..c8b7e08e0 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -299,6 +299,7 @@ (proclamation si:ihs-top () si::index) (proclamation si:ihs-fun (si::index) (or null function-designator)) (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) diff --git a/src/h/external.h b/src/h/external.h index 08d228af1..ffe69e090 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1649,6 +1649,7 @@ 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); diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index a5e56e03c..9c0021cfa 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -1213,7 +1213,7 @@ Use special code 0 to cancel this operation.") (set-break-env)) (defun set-break-env () - (setq *break-lexenv* (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))) @@ -1310,7 +1310,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) From dfb691ede80413809b46289381b5ba8870ed887e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 28 Nov 2025 13:13:04 +0100 Subject: [PATCH 5/6] top: add captured records to the local environment We include captured functions, blocks and variables along with local variables. This fixes #799. Moreover DECODE-IHS-ENV is deperacated and more DWIM: - calls DECODE-IHS-LOCALS for old arguments - appends DECODE-IHS-LOCALS and DECODE-IHS-LEXENV for ihs index DECODE-IHS-LOCALS and DECODE-IHS-LEXENV are responsible for decoding appropriate environments. --- src/lsp/top.lsp | 176 +++++++++++++++++++++++++++--------------------- 1 file changed, 99 insertions(+), 77 deletions(-) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 9c0021cfa..a639acc77 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -905,84 +905,106 @@ Use special code 0 to cancel this operation.") @(return) = CONS(name,output); " :one-liner nil)) -(defun decode-ihs-env (*break-locals*) - #+ecl_min nil - #-ecl_min - (let ((env *break-locals*)) - (etypecase env - (vector - (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))) - (si:frame - (let* ((lcls '()) - (next (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)))) +;;; 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-lcl 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) @@ -1026,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-locals*) + (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) From 9f9c9a8037c30c033b010a295aa510066c52e689 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 29 Nov 2025 22:22:41 +0100 Subject: [PATCH 6/6] cmp: assign _ecl_debug_env to lcl_env (not lex_env) --- src/cmp/cmpbackend-cxx/cmppass2-exit.lsp | 2 +- src/cmp/cmpbackend-cxx/cmppass2-var.lsp | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index 03397108c..1e327db64 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/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)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index 3f84eab41..be433efaf 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/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