From edf0ccdaa375c4b93a27edcfcf208c92161b75c9 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Wed, 24 Feb 2010 12:33:32 +0100 Subject: [PATCH] Added a new field to the IHS record, with the value of the BDS stack. This allows printing the special variable bindings of a function. --- src/CHANGELOG | 3 ++ src/c/stacks.d | 6 ++++ src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/h/external.h | 1 + src/h/stacks.h | 2 ++ src/lsp/top.lsp | 79 +++++++++++++++++++++++++------------------ 7 files changed, 60 insertions(+), 33 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 736e061e3..bb4fdc5c0 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -128,6 +128,9 @@ and important fixes to let ECL work better with Slime. functions from the core ECL library, generic functions and interpreted functions. + - The debugger now is capable of showing the special variable bindings + from a function. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/c/stacks.d b/src/c/stacks.d index 5fc0165ec..ae9191024 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -452,6 +452,12 @@ si_ihs_next(cl_object x) @(return cl_1P(x)) } +cl_object +si_ihs_bds(cl_object arg) +{ + @(return MAKE_FIXNUM(get_ihs_ptr(fixnnint(arg))->bds)) +} + cl_object si_ihs_fun(cl_object arg) { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 4c7b5f4b9..96a154d66 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1122,6 +1122,7 @@ cl_symbols[] = { {SYS_ "GETPID", SI_ORDINARY, si_getpid, 0, OBJNULL}, {SYS_ "HASH-SET", SI_ORDINARY, si_hash_set, 3, OBJNULL}, {SYS_ "HASH-TABLE-ITERATOR", SI_ORDINARY, si_hash_table_iterator, 1, OBJNULL}, +{SYS_ "IHS-BDS", SI_ORDINARY, si_ihs_bds, 1, OBJNULL}, {SYS_ "IHS-ENV", SI_ORDINARY, si_ihs_env, 1, OBJNULL}, {SYS_ "IHS-FUN", SI_ORDINARY, si_ihs_fun, 1, OBJNULL}, {SYS_ "IHS-NEXT", SI_ORDINARY, si_ihs_next, 1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index a70d5e0c6..c061a972c 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1122,6 +1122,7 @@ cl_symbols[] = { {SYS_ "GETPID","si_getpid"}, {SYS_ "HASH-SET","si_hash_set"}, {SYS_ "HASH-TABLE-ITERATOR","si_hash_table_iterator"}, +{SYS_ "IHS-BDS","si_ihs_bds"}, {SYS_ "IHS-ENV","si_ihs_env"}, {SYS_ "IHS-FUN","si_ihs_fun"}, {SYS_ "IHS-NEXT","si_ihs_next"}, diff --git a/src/h/external.h b/src/h/external.h index cee9c2f5a..142b54e26 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1489,6 +1489,7 @@ extern ECL_API cl_fixnum ecl_length(cl_object x); 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_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); extern ECL_API cl_object si_frs_top(void); diff --git a/src/h/stacks.h b/src/h/stacks.h index a5fb88544..40c58b5c5 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -181,6 +181,7 @@ typedef struct ihs_frame { cl_object function; cl_object lex_env; cl_index index; + cl_index bds; } *ihs_ptr; #define ecl_ihs_push(env,rec,fun,lisp_env) do { \ @@ -190,6 +191,7 @@ typedef struct ihs_frame { r->function=(fun); \ r->lex_env=(lisp_env); \ r->index=__the_env->ihs_top->index+1; \ + r->bds=__the_env->bds_top - __the_env->bds_org; \ __the_env->ihs_top = r; \ } while(0) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 5d457f845..fb53199c1 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -920,49 +920,62 @@ Use special code 0 to cancel this operation.") next)) env))) -(defun tpl-variables-command (&optional no-values) - (let*((*print-level* 2) - (*print-length* 4) - (*print-pretty* t) - (*print-readably* nil) - (functions '()) - (blocks '()) - (variables '()) - record0 record1) - (dolist (record (decode-ihs-env *break-env*)) +(defun ihs-environment (ihs-index) + (let* ((functions '()) + (blocks '()) + (local-variables '()) + (special-variables '())) + (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)) (or (symbolp record0) (stringp record0))) - (setq variables (list* record0 record1 variables))) + (setq local-variables (acons record0 record1 local-variables))) ((symbolp record1) (push record1 blocks)) (t ))) - (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions) - (format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks) + (let ((top (ihs-top))) + (unless (> ihs-index top) + (loop with bds-min = (ihs-bds ihs-index) + with bds-max = (if (= ihs-index top) + (bds-top) + (ihs-bds (1+ ihs-index))) + for i from bds-min below bds-max + for variable = (bds-var i) + for value = (bds-val i) + unless (assoc variable special-variables) + do (setf special-variables (acons variable value special-variables))))) + (values local-variables special-variables functions blocks))) - ;; This format is what was in the orignal code. - ;; It simply does not work when no-values is t. - ;; If you care to debug this kind of conundrum then have fun! - ;;(format t "Local variables: ~:[~:[none~;~:*~{~a~1*~:@{, ~a~1*~}~}~]~;~ - ;; ~:[none~;~:*~{~% ~a: ~s~}~]~]~%" - ;; (not no-values) variables) - (format t "Local variables: ") - (if variables - (if no-values - (do ((vals variables (cddr vals))) - ((endp vals)) - (format t "~% ~S" (car vals)) - ) - (do ((vals variables (cddr vals))) - ((endp vals)) - (format t "~% ~S: ~S" (car vals) (cadr vals)) - ) - ) - (format t "none") - ) +(defun tpl-print-variables (prefix variables no-values) + ;; This format is what was in the orignal code. + ;; It simply does not work when no-values is t. + ;; If you care to debug this kind of conundrum then have fun! + ;;(format t "Local variables: ~:[~:[none~;~:*~{~a~1*~:@{, ~a~1*~}~}~]~;~ + ;; ~:[none~;~:*~{~% ~a: ~s~}~]~]~%" + ;; (not no-values) variables) + (format t prefix) + (if variables + (loop for (var . value) in variables + do (if no-values + (format t "~% ~S" var) + (format t "~% ~S: ~S" var value))) + (format t "none"))) + +(defun tpl-variables-command (&optional no-values) + (let*((*print-level* 2) + (*print-length* 4) + (*print-pretty* t) + (*print-readably* nil)) + (multiple-value-bind (local-variables special-variables functions blocks) + (ihs-environment *ihs-current*) + (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions) + (format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks) + (tpl-print-variables "Local variables: " local-variables no-values) + (tpl-print-variables "~%Special variables: " + special-variables no-values)) (terpri) (values)))