mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-799' into 'develop'

Browse source 
Fix :variables command in top-level env

Closes #799

See merge request embeddable-common-lisp/ecl!359
This commit is contained in:
Marius Gerbershagen 2025-11-30 14:52:28 +00:00
commit 855f93431b
12 changed files with 145 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/compiler.d
View file

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

8
src/c/error.d
View file

@ -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 */

2
src/c/interpreter.d
View file

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

17
src/c/stacks.d
View file

@ -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. */

2
src/c/symbols_list.h
View file

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

2
src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
View file

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

2
src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
View file

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

4
src/cmp/cmpbackend-cxx/cmppass2-var.lsp
View file

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

4
src/cmp/proclamations.lsp
View file

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

2
src/h/external.h
View file

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

6
src/h/stacks.h
View file

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

182
src/lsp/top.lsp
View file

@ -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.