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..623467307 100644 --- a/src/c/stacks.d +++ b/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. */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e988e7d44..8a1e5bb0d 100644 --- a/src/c/symbols_list.h +++ b/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)}, 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-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/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 diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 4fd32fc66..c8b7e08e0 100644 --- a/src/cmp/proclamations.lsp +++ b/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) diff --git a/src/h/external.h b/src/h/external.h index 6b0011165..ffe69e090 100755 --- a/src/h/external.h +++ b/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); 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; \ diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index e746724b0..a639acc77 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,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.