1.0.30.41: Octets support for ebcdic-us

[sbcl.git] / src / code / debug-int.lisp

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index d003425..d02edae 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -515,7 +515,7 @@
 (defun fun-word-offset (fun) (fun-word-offset fun))
 
 #!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
-(defun control-stack-pointer-valid-p (x)
+(defun control-stack-pointer-valid-p (x &optional (aligned t))
   (declare (type system-area-pointer x))
   (let* (#!-stack-grows-downward-not-upward
          (control-stack-start
@@ -526,11 +526,11 @@
     #!-stack-grows-downward-not-upward
     (and (sap< x (current-sp))
          (sap<= control-stack-start x)
-         (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))
+         (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))
     #!+stack-grows-downward-not-upward
     (and (sap>= x (current-sp))
          (sap> control-stack-end x)
-         (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))
+         (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))))
 
 (declaim (inline component-ptr-from-pc))
 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
@@ -1206,35 +1206,30 @@ register."
 ;;; Return a DEBUG-FUN that represents debug information for FUN.
 (defun fun-debug-fun (fun)
   (declare (type function fun))
-  (ecase (widetag-of fun)
-    (#.sb!vm:closure-header-widetag
-     (fun-debug-fun (%closure-fun fun)))
-    (#.sb!vm:funcallable-instance-header-widetag
-     (fun-debug-fun (funcallable-instance-fun fun)))
-    (#.sb!vm:simple-fun-header-widetag
-      (let* ((name (%simple-fun-name fun))
-             (component (fun-code-header fun))
-             (res (find-if
-                   (lambda (x)
-                     (and (sb!c::compiled-debug-fun-p x)
-                          (eq (sb!c::compiled-debug-fun-name x) name)
-                          (eq (sb!c::compiled-debug-fun-kind x) nil)))
-                   (sb!c::compiled-debug-info-fun-map
-                    (%code-debug-info component)))))
-        (if res
-            (make-compiled-debug-fun res component)
-            ;; KLUDGE: comment from CMU CL:
-            ;;   This used to be the non-interpreted branch, but
-            ;;   William wrote it to return the debug-fun of fun's XEP
-            ;;   instead of fun's debug-fun. The above code does this
-            ;;   more correctly, but it doesn't get or eliminate all
-            ;;   appropriate cases. It mostly works, and probably
-            ;;   works for all named functions anyway.
-            ;; -- WHN 20000120
-            (debug-fun-from-pc component
-                               (* (- (fun-word-offset fun)
-                                     (get-header-data component))
-                                  sb!vm:n-word-bytes)))))))
+  (let ((simple-fun (%fun-fun fun)))
+    (let* ((name (%simple-fun-name simple-fun))
+           (component (fun-code-header simple-fun))
+           (res (find-if
+                 (lambda (x)
+                   (and (sb!c::compiled-debug-fun-p x)
+                        (eq (sb!c::compiled-debug-fun-name x) name)
+                        (eq (sb!c::compiled-debug-fun-kind x) nil)))
+                 (sb!c::compiled-debug-info-fun-map
+                  (%code-debug-info component)))))
+      (if res
+          (make-compiled-debug-fun res component)
+          ;; KLUDGE: comment from CMU CL:
+          ;;   This used to be the non-interpreted branch, but
+          ;;   William wrote it to return the debug-fun of fun's XEP
+          ;;   instead of fun's debug-fun. The above code does this
+          ;;   more correctly, but it doesn't get or eliminate all
+          ;;   appropriate cases. It mostly works, and probably
+          ;;   works for all named functions anyway.
+          ;; -- WHN 20000120
+          (debug-fun-from-pc component
+                             (* (- (fun-word-offset simple-fun)
+                                   (get-header-data component))
+                                sb!vm:n-word-bytes))))))
 
 ;;; Return the kind of the function, which is one of :OPTIONAL,
 ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
@@ -2565,6 +2560,15 @@ register."
             (debug-signal 'frame-fun-mismatch
                           :code-location loc :form form :frame frame))
           (funcall res frame))))))
+
+;;; EVAL-IN-FRAME
+
+(defun eval-in-frame (frame form)
+  (declare (type frame frame))
+  #!+sb-doc
+  "Evaluate FORM in the lexical context of FRAME's current code location,
+   returning the results of the evaluation."
+  (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
 \f
 ;;;; breakpoints