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

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

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

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

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"},

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

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)
 

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