0.pre7.86.flaky7.22:

	removed various /SHOW-ish cruft
	about that debugger/restart/QUIT problem...
	...revived SB-DI:FRAME-CATCHES enough that (BREAK), F 4,
		(SB-DI::FRAME-CATCHES SB-DEBUG::*CURRENT-FRAME*)
		shows %END-OF-THE-WORLD
	...exported SB-VM:*CURRENT-CATCH-BLOCK* to support this

diff --git a/BUGS b/BUGS
index e905d42..2f5f538 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1300,6 +1300,21 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
   internal compiler error. (This error occurs in sbcl-0.6.13 and in
   0.pre7.86.flaky7.14.)
 
   internal compiler error. (This error occurs in sbcl-0.6.13 and in
   0.pre7.86.flaky7.14.)
 

+133:
+  Trying to compile something like 
+    (sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void
+      (code-obj sb!c-call:unsigned-long)
+      (pc-offset sb!c-call:int)
+      (old-inst sb!c-call:unsigned-long))
+  in SBCL-0.pre7.86.flaky7.22 after warm init fails with an error
+    cannot use values types here
+  probably because the SB-C-CALL:VOID type gets translated to (VALUES).
+  It should be valid to use VOID for a function return type, so perhaps
+  instead of calling SPECIFIER-TYPE (which excludes all VALUES types
+  automatically) we should call VALUES-SPECIFIER-TYPE and handle VALUES
+  types manually, allowing the special case (VALUES) but still excluding
+  all more-complex VALUES types.
+

 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 
 (Now that the IR1 interpreter has gone away, these should be 
 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 
 (Now that the IR1 interpreter has gone away, these should be 

diff --git a/make.sh b/make.sh
index 756d173..9d48783 100755 (executable)
--- a/make.sh
+++ b/make.sh
@@ -1,3 +1,4 @@
+

 #!/bin/sh
 
 # "When we build software, it's a good idea to have a reliable method
 #!/bin/sh
 
 # "When we build software, it's a good idea to have a reliable method

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 94d7d43..881f3f0 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -372,8 +372,9 @@ like *STACK-TOP-HINT*"
              "DELETE-BREAKPOINT" "DO-BLOCKS"
              "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUN-BLOCKS"
              "DO-DEBUG-FUN-VARIABLES"
              "DELETE-BREAKPOINT" "DO-BLOCKS"
              "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUN-BLOCKS"
              "DO-DEBUG-FUN-VARIABLES"

-             "FORM-NUMBER-TRANSLATIONS" "FRAME" "FRAME-CATCHES"
-             "FRAME-CODE-LOCATION" "FRAME-DEBUG-FUN" "FRAME-DOWN"
+             "FORM-NUMBER-TRANSLATIONS"
+            "FRAME" "FRAME-CATCHES" "FRAME-CODE-LOCATION"
+            "FRAME-DEBUG-FUN" "FRAME-DOWN"

              "FRAME-FUN-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP"
              "FUN-DEBUG-FUN" "FUN-END-COOKIE-VALID-P"
              "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE"
              "FRAME-FUN-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP"
              "FUN-DEBUG-FUN" "FUN-END-COOKIE-VALID-P"
              "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE"

@@ -1706,6 +1707,7 @@ structure representations"
              "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER"
              "CONTEXT-PC" "CONTEXT-REGISTER"
              "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS"
              "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER"
              "CONTEXT-PC" "CONTEXT-REGISTER"
              "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS"

+            "*CURRENT-CATCH-BLOCK*"

              "CURRENT-DYNAMIC-SPACE-START"
              "CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT"
              "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE"
              "CURRENT-DYNAMIC-SPACE-START"
              "CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT"
              "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE"

diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 0a911ff..6f70874 100644 (file)
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -214,13 +214,6 @@
 
   ;; the ANSI-specified initial value of *PACKAGE*
   (setf *package* (find-package "COMMON-LISP-USER"))
 
   ;; the ANSI-specified initial value of *PACKAGE*
   (setf *package* (find-package "COMMON-LISP-USER"))

-  ;; FIXME: I'm not sure where it should be done, but CL-USER really
-  ;; ought to USE-PACKAGE publicly accessible packages like SB-DEBUG
-  ;; (for ARG and VAR), SB-EXT, SB-EXT-C-CALL, and SB-EXT-ALIEN so
-  ;; that the user has a hint about which symbols we consider public.
-  ;; (Perhaps SB-DEBUG wouldn't need to be in the list if ARG and VAR
-  ;; could be typed directly, with no parentheses, at the debug prompt
-  ;; the way that e.g. F or BACKTRACE can be?)

 
   (/show0 "done initializing, setting *COLD-INIT-COMPLETE-P*")
   (setf *cold-init-complete-p* t)
 
   (/show0 "done initializing, setting *COLD-INIT-COMPLETE-P*")
   (setf *cold-init-complete-p* t)

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index db79162..134cd9a 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -666,7 +666,7 @@
 ;;; Return the top frame of the control stack as it was before calling
 ;;; this function.
 (defun top-frame ()
 ;;; Return the top frame of the control stack as it was before calling
 ;;; this function.
 (defun top-frame ()

-  (/show0 "entering TOP-FRAME")
+  (/noshow0 "entering TOP-FRAME")

   (multiple-value-bind (fp pc) (%caller-frame-and-pc)
     (compute-calling-frame (descriptor-sap fp) pc nil)))
 
   (multiple-value-bind (fp pc) (%caller-frame-and-pc)
     (compute-calling-frame (descriptor-sap fp) pc nil)))
 

@@ -682,13 +682,13 @@
 ;;; Return the frame immediately below FRAME on the stack; or when
 ;;; FRAME is the bottom of the stack, return NIL.
 (defun frame-down (frame)
 ;;; Return the frame immediately below FRAME on the stack; or when
 ;;; FRAME is the bottom of the stack, return NIL.
 (defun frame-down (frame)

-  (/show0 "entering FRAME-DOWN")
+  (/noshow0 "entering FRAME-DOWN")

   ;; We have to access the old-fp and return-pc out of frame and pass
   ;; them to COMPUTE-CALLING-FRAME.
   (let ((down (frame-%down frame)))
     (if (eq down :unparsed)
        (let ((debug-fun (frame-debug-fun frame)))
   ;; We have to access the old-fp and return-pc out of frame and pass
   ;; them to COMPUTE-CALLING-FRAME.
   (let ((down (frame-%down frame)))
     (if (eq down :unparsed)
        (let ((debug-fun (frame-debug-fun frame)))

-         (/show0 "in DOWN :UNPARSED case")
+         (/noshow0 "in DOWN :UNPARSED case")

          (setf (frame-%down frame)
                (etypecase debug-fun
                  (compiled-debug-fun
          (setf (frame-%down frame)
                (etypecase debug-fun
                  (compiled-debug-fun

@@ -834,14 +834,14 @@
 #!+x86
 (defun compute-calling-frame (caller ra up-frame)
   (declare (type system-area-pointer caller ra))
 #!+x86
 (defun compute-calling-frame (caller ra up-frame)
   (declare (type system-area-pointer caller ra))

-  (/show0 "entering COMPUTE-CALLING-FRAME")
+  (/noshow0 "entering COMPUTE-CALLING-FRAME")

   (when (cstack-pointer-valid-p caller)
   (when (cstack-pointer-valid-p caller)

-    (/show0 "in WHEN")
+    (/noshow0 "in WHEN")

     ;; First check for an escaped frame.
     (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
     ;; First check for an escaped frame.
     (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)

-      (/show0 "at COND")
+      (/noshow0 "at COND")

       (cond (code
       (cond (code

-            (/show0 "in CODE clause")
+            (/noshow0 "in CODE clause")

             ;; If it's escaped it may be a function end breakpoint trap.
             (when (and (code-component-p code)
                        (eq (%code-debug-info code) :bogus-lra))
             ;; If it's escaped it may be a function end breakpoint trap.
             (when (and (code-component-p code)
                        (eq (%code-debug-info code) :bogus-lra))

@@ -851,7 +851,7 @@
               (setq code (code-header-ref code real-lra-slot))
               (aver code)))
            (t
               (setq code (code-header-ref code real-lra-slot))
               (aver code)))
            (t

-            (/show0 "in T clause")
+            (/noshow0 "in T clause")

             ;; not escaped
             (multiple-value-setq (pc-offset code)
               (compute-lra-data-from-pc ra))
             ;; not escaped
             (multiple-value-setq (pc-offset code)
               (compute-lra-data-from-pc ra))

@@ -872,7 +872,7 @@
                       "bogus stack frame"))
                     (t
                      (debug-fun-from-pc code pc-offset)))))
                       "bogus stack frame"))
                     (t
                      (debug-fun-from-pc code pc-offset)))))

-       (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+       (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")

        (make-compiled-frame caller up-frame d-fun
                             (code-location-from-pc d-fun pc-offset
                                                    escaped)
        (make-compiled-frame caller up-frame d-fun
                             (code-location-from-pc d-fun pc-offset
                                                    escaped)

@@ -882,22 +882,22 @@
 #!+x86
 (defun find-escaped-frame (frame-pointer)
   (declare (type system-area-pointer frame-pointer))
 #!+x86
 (defun find-escaped-frame (frame-pointer)
   (declare (type system-area-pointer frame-pointer))

-  (/show0 "entering FIND-ESCAPED-FRAME")
+  (/noshow0 "entering FIND-ESCAPED-FRAME")

   (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
     (sb!alien:with-alien
        ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
   (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
     (sb!alien:with-alien
        ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))

-      (/show0 "at head of WITH-ALIEN")
+      (/noshow0 "at head of WITH-ALIEN")

       (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
       (let ((context (sb!alien:deref lisp-interrupt-contexts index)))

-       (/show0 "got CONTEXT")
+       (/noshow0 "got CONTEXT")

        (when (= (sap-int frame-pointer)
                 (sb!vm:context-register context sb!vm::cfp-offset))
          (without-gcing
        (when (= (sap-int frame-pointer)
                 (sb!vm:context-register context sb!vm::cfp-offset))
          (without-gcing

-          (/show0 "in WITHOUT-GCING")
+          (/noshow0 "in WITHOUT-GCING")

           (let* ((component-ptr (component-ptr-from-pc
                                  (sb!vm:context-pc context)))
                  (code (unless (sap= component-ptr (int-sap #x0))
                          (component-from-component-ptr component-ptr))))
           (let* ((component-ptr (component-ptr-from-pc
                                  (sb!vm:context-pc context)))
                  (code (unless (sap= component-ptr (int-sap #x0))
                          (component-from-component-ptr component-ptr))))

-            (/show0 "got CODE")
+            (/noshow0 "got CODE")

             (when (null code)
               (return (values code 0 context)))
             (let* ((code-header-len (* (get-header-data code)
             (when (null code)
               (return (values code 0 context)))
             (let* ((code-header-len (* (get-header-data code)

@@ -907,7 +907,7 @@
                        (- (get-lisp-obj-address code)
                           sb!vm:other-pointer-lowtag)
                        code-header-len)))
                        (- (get-lisp-obj-address code)
                           sb!vm:other-pointer-lowtag)
                        code-header-len)))

-              (/show "got PC-OFFSET")
+              (/noshow "got PC-OFFSET")

               (unless (<= 0 pc-offset
                           (* (code-header-ref code sb!vm:code-code-size-slot)
                              sb!vm:n-word-bytes))
               (unless (<= 0 pc-offset
                           (* (code-header-ref code sb!vm:code-code-size-slot)
                              sb!vm:n-word-bytes))

@@ -917,7 +917,7 @@
                 ;; FIXME: Should this be WARN or ERROR or what?
                 (format t "** pc-offset ~S not in code obj ~S?~%"
                         pc-offset code))
                 ;; FIXME: Should this be WARN or ERROR or what?
                 (format t "** pc-offset ~S not in code obj ~S?~%"
                         pc-offset code))

-              (/show0 "returning from FIND-ESCAPED-FRAME")
+              (/noshow0 "returning from FIND-ESCAPED-FRAME")

               (return
                (values code pc-offset context))))))))))
 
               (return
                (values code pc-offset context))))))))))
 

@@ -1042,62 +1042,63 @@
 ;;; CODE-LOCATIONs at which execution would continue with frame as the
 ;;; top frame if someone threw to the corresponding tag.
 (defun frame-catches (frame)
 ;;; CODE-LOCATIONs at which execution would continue with frame as the
 ;;; top frame if someone threw to the corresponding tag.
 (defun frame-catches (frame)

-  (let ((catch (descriptor-sap *current-catch-block*))
-       (res nil)
+  (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+       (reversed-result nil)

        (fp (frame-pointer frame)))
        (fp (frame-pointer frame)))

-    (loop
-      (when (zerop (sap-int catch)) (return (nreverse res)))
-      (when (sap= fp
-                 #!-alpha
-                 (sap-ref-sap catch
-                                     (* sb!vm:catch-block-current-cont-slot
-                                        sb!vm:n-word-bytes))
-                 #!+alpha
-                 (:int-sap
-                  (sap-ref-32 catch
-                                     (* sb!vm:catch-block-current-cont-slot
-                                        sb!vm:n-word-bytes))))
-       (let* (#!-x86
-              (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
-              #!+x86
-              (ra (sap-ref-sap
-                   catch (* sb!vm:catch-block-entry-pc-slot
-                            sb!vm:n-word-bytes)))
-              #!-x86
-              (component
-               (stack-ref catch sb!vm:catch-block-current-code-slot))
-              #!+x86
-              (component (component-from-component-ptr
-                          (component-ptr-from-pc ra)))
-              (offset
-               #!-x86
-               (* (- (1+ (get-header-data lra))
-                     (get-header-data component))
-                  sb!vm:n-word-bytes)
-               #!+x86
-               (- (sap-int ra)
-                  (- (get-lisp-obj-address component)
-                     sb!vm:other-pointer-lowtag)
-                  (* (get-header-data component) sb!vm:n-word-bytes))))
-         (push (cons #!-x86
-                     (stack-ref catch sb!vm:catch-block-tag-slot)
-                     #!+x86
-                     (make-lisp-obj
-                      (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
-                                                  sb!vm:n-word-bytes)))
-                     (make-compiled-code-location
-                      offset (frame-debug-fun frame)))
-               res)))
-      (setf catch
-           #!-alpha
-           (sap-ref-sap catch
-                               (* sb!vm:catch-block-previous-catch-slot
-                                  sb!vm:n-word-bytes))
-           #!+alpha
-           (:int-sap
-            (sap-ref-32 catch
-                               (* sb!vm:catch-block-previous-catch-slot
-                                  sb!vm:n-word-bytes)))))))
+    (loop until (zerop (sap-int catch))
+         finally (return (nreverse reversed-result))
+         do
+         (when (sap= fp
+                     #!-alpha
+                     (sap-ref-sap catch
+                                  (* sb!vm:catch-block-current-cont-slot
+                                     sb!vm:n-word-bytes))
+                     #!+alpha
+                     (int-sap
+                      (sap-ref-32 catch
+                                  (* sb!vm:catch-block-current-cont-slot
+                                     sb!vm:n-word-bytes))))
+           (let* (#!-x86
+                  (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
+                  #!+x86
+                  (ra (sap-ref-sap
+                       catch (* sb!vm:catch-block-entry-pc-slot
+                                sb!vm:n-word-bytes)))
+                  #!-x86
+                  (component
+                   (stack-ref catch sb!vm:catch-block-current-code-slot))
+                  #!+x86
+                  (component (component-from-component-ptr
+                              (component-ptr-from-pc ra)))
+                  (offset
+                   #!-x86
+                   (* (- (1+ (get-header-data lra))
+                         (get-header-data component))
+                      sb!vm:n-word-bytes)
+                   #!+x86
+                   (- (sap-int ra)
+                      (- (get-lisp-obj-address component)
+                         sb!vm:other-pointer-lowtag)
+                      (* (get-header-data component) sb!vm:n-word-bytes))))
+             (push (cons #!-x86
+                         (stack-ref catch sb!vm:catch-block-tag-slot)
+                         #!+x86
+                         (make-lisp-obj
+                          (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
+                                               sb!vm:n-word-bytes)))
+                         (make-compiled-code-location
+                          offset (frame-debug-fun frame)))
+                   reversed-result)))
+         (setf catch
+               #!-alpha
+               (sap-ref-sap catch
+                            (* sb!vm:catch-block-previous-catch-slot
+                               sb!vm:n-word-bytes))
+               #!+alpha
+               (int-sap
+                (sap-ref-32 catch
+                            (* sb!vm:catch-block-previous-catch-slot
+                               sb!vm:n-word-bytes)))))))

 \f
 ;;;; operations on DEBUG-FUNs
 
 \f
 ;;;; operations on DEBUG-FUNs
 

@@ -1961,8 +1962,6 @@
 ;;; GC, and might also arise in debug variable locations when
 ;;; those variables are invalid.)
 (defun make-valid-lisp-obj (val)
 ;;; GC, and might also arise in debug variable locations when
 ;;; those variables are invalid.)
 (defun make-valid-lisp-obj (val)

-  (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
-  #!+sb-show (/hexstr val)

   (if (or
        ;; fixnum
        (zerop (logand val 3))
   (if (or
        ;; fixnum
        (zerop (logand val 3))

@@ -2133,15 +2132,11 @@
 #!+x86
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (declare (type system-area-pointer fp))
 #!+x86
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (declare (type system-area-pointer fp))

-  (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
-  (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)

   (macrolet ((with-escaped-value ((var) &body forms)
               `(if escaped
                    (let ((,var (sb!vm:context-register
                                 escaped
                                 (sb!c:sc-offset-offset sc-offset))))
   (macrolet ((with-escaped-value ((var) &body forms)
               `(if escaped
                    (let ((,var (sb!vm:context-register
                                 escaped
                                 (sb!c:sc-offset-offset sc-offset))))

-                     (/show0 "in escaped case, ,VAR value=..")
-                     (/hexstr ,var)

                      ,@forms)
                    :invalid-value-for-unescaped-register-storage))
             (escaped-float-value (format)
                      ,@forms)
                    :invalid-value-for-unescaped-register-storage))
             (escaped-float-value (format)

@@ -2159,72 +2154,54 @@
                    :invalid-value-for-unescaped-register-storage)))
     (ecase (sb!c:sc-offset-scn sc-offset)
       ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
                    :invalid-value-for-unescaped-register-storage)))
     (ecase (sb!c:sc-offset-scn sc-offset)
       ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)

-       (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")

        (without-gcing
        (with-escaped-value (val)
        (without-gcing
        (with-escaped-value (val)

-         (/show0 "VAL=..")
-         (/hexstr val)

          (make-valid-lisp-obj val))))
       (#.sb!vm:base-char-reg-sc-number
          (make-valid-lisp-obj val))))
       (#.sb!vm:base-char-reg-sc-number

-       (/show0 "case of BASE-CHAR-REG-SC-NUMBER")

        (with-escaped-value (val)
         (code-char val)))
       (#.sb!vm:sap-reg-sc-number
        (with-escaped-value (val)
         (code-char val)))
       (#.sb!vm:sap-reg-sc-number

-       (/show0 "case of SAP-REG-SC-NUMBER")

        (with-escaped-value (val)
         (int-sap val)))
       (#.sb!vm:signed-reg-sc-number
        (with-escaped-value (val)
         (int-sap val)))
       (#.sb!vm:signed-reg-sc-number

-       (/show0 "case of SIGNED-REG-SC-NUMBER")

        (with-escaped-value (val)
         (if (logbitp (1- sb!vm:n-word-bits) val)
             (logior val (ash -1 sb!vm:n-word-bits))
             val)))
       (#.sb!vm:unsigned-reg-sc-number
        (with-escaped-value (val)
         (if (logbitp (1- sb!vm:n-word-bits) val)
             (logior val (ash -1 sb!vm:n-word-bits))
             val)))
       (#.sb!vm:unsigned-reg-sc-number

-       (/show0 "case of UNSIGNED-REG-SC-NUMBER")

        (with-escaped-value (val)
         val))
       (#.sb!vm:single-reg-sc-number
        (with-escaped-value (val)
         val))
       (#.sb!vm:single-reg-sc-number

-       (/show0 "case of SINGLE-REG-SC-NUMBER")

        (escaped-float-value single-float))
       (#.sb!vm:double-reg-sc-number
        (escaped-float-value single-float))
       (#.sb!vm:double-reg-sc-number

-       (/show0 "case of DOUBLE-REG-SC-NUMBER")

        (escaped-float-value double-float))
       #!+long-float
       (#.sb!vm:long-reg-sc-number
        (escaped-float-value double-float))
       #!+long-float
       (#.sb!vm:long-reg-sc-number

-       (/show0 "case of LONG-REG-SC-NUMBER")

        (escaped-float-value long-float))
       (#.sb!vm:complex-single-reg-sc-number
        (escaped-float-value long-float))
       (#.sb!vm:complex-single-reg-sc-number

-       (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")

        (escaped-complex-float-value single-float))
       (#.sb!vm:complex-double-reg-sc-number
        (escaped-complex-float-value single-float))
       (#.sb!vm:complex-double-reg-sc-number

-       (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")

        (escaped-complex-float-value double-float))
       #!+long-float
       (#.sb!vm:complex-long-reg-sc-number
        (escaped-complex-float-value double-float))
       #!+long-float
       (#.sb!vm:complex-long-reg-sc-number

-       (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")

        (escaped-complex-float-value long-float))
       (#.sb!vm:single-stack-sc-number
        (escaped-complex-float-value long-float))
       (#.sb!vm:single-stack-sc-number

-       (/show0 "case of SINGLE-STACK-SC-NUMBER")

        (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                sb!vm:n-word-bytes))))
       (#.sb!vm:double-stack-sc-number
        (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                sb!vm:n-word-bytes))))
       (#.sb!vm:double-stack-sc-number

-       (/show0 "case of DOUBLE-STACK-SC-NUMBER")

        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                sb!vm:n-word-bytes))))
       #!+long-float
       (#.sb!vm:long-stack-sc-number
        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                sb!vm:n-word-bytes))))
       #!+long-float
       (#.sb!vm:long-stack-sc-number

-       (/show0 "case of LONG-STACK-SC-NUMBER")

        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                              sb!vm:n-word-bytes))))
       (#.sb!vm:complex-single-stack-sc-number
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                              sb!vm:n-word-bytes))))
       (#.sb!vm:complex-single-stack-sc-number

-       (/show0 "case of COMPLEX-STACK-SC-NUMBER")

        (complex
        (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                 sb!vm:n-word-bytes)))
        (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                 sb!vm:n-word-bytes)))))
       (#.sb!vm:complex-double-stack-sc-number
        (complex
        (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                 sb!vm:n-word-bytes)))
        (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                 sb!vm:n-word-bytes)))))
       (#.sb!vm:complex-double-stack-sc-number

-       (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")

        (complex
        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                 sb!vm:n-word-bytes)))
        (complex
        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                 sb!vm:n-word-bytes)))

@@ -2232,30 +2209,24 @@
                                 sb!vm:n-word-bytes)))))
       #!+long-float
       (#.sb!vm:complex-long-stack-sc-number
                                 sb!vm:n-word-bytes)))))
       #!+long-float
       (#.sb!vm:complex-long-stack-sc-number

-       (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")

        (complex
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                               sb!vm:n-word-bytes)))
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
                               sb!vm:n-word-bytes)))))
       (#.sb!vm:control-stack-sc-number
        (complex
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                               sb!vm:n-word-bytes)))
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
                               sb!vm:n-word-bytes)))))
       (#.sb!vm:control-stack-sc-number

-       (/show0 "case of CONTROL-STACK-SC-NUMBER")

        (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
       (#.sb!vm:base-char-stack-sc-number
        (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
       (#.sb!vm:base-char-stack-sc-number

-       (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")

        (code-char
        (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                             sb!vm:n-word-bytes)))))
       (#.sb!vm:unsigned-stack-sc-number
        (code-char
        (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                             sb!vm:n-word-bytes)))))
       (#.sb!vm:unsigned-stack-sc-number

-       (/show0 "case of UNSIGNED-STACK-SC-NUMBER")

        (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                            sb!vm:n-word-bytes))))
       (#.sb!vm:signed-stack-sc-number
        (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                            sb!vm:n-word-bytes))))
       (#.sb!vm:signed-stack-sc-number

-       (/show0 "case of SIGNED-STACK-SC-NUMBER")

        (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                   sb!vm:n-word-bytes))))
       (#.sb!vm:sap-stack-sc-number
        (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                   sb!vm:n-word-bytes))))
       (#.sb!vm:sap-stack-sc-number

-       (/show0 "case of SAP-STACK-SC-NUMBER")

        (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                             sb!vm:n-word-bytes)))))))
 
        (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                             sb!vm:n-word-bytes)))))))
 

@@ -3096,10 +3067,10 @@
 
 ;;;; breakpoint handlers (layer between C and exported interface)
 
 
 ;;;; breakpoint handlers (layer between C and exported interface)
 

-;;; This maps components to a mapping of offsets to breakpoint-datas.
+;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.

 (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
 
 (defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
 

-;;; This returns the breakpoint-data associated with component cross
+;;; This returns the BREAKPOINT-DATA object associated with component cross

 ;;; offset. If none exists, this makes one, installs it, and returns it.
 (defun breakpoint-data (component offset &optional (create t))
   (flet ((install-breakpoint-data ()
 ;;; offset. If none exists, this makes one, installs it, and returns it.
 (defun breakpoint-data (component offset &optional (create t))
   (flet ((install-breakpoint-data ()

@@ -3117,7 +3088,7 @@
          (install-breakpoint-data)))))
 
 ;;; We use this when there are no longer any active breakpoints
          (install-breakpoint-data)))))
 
 ;;; We use this when there are no longer any active breakpoints

-;;; corresponding to data.
+;;; corresponding to DATA.

 (defun delete-breakpoint-data (data)
   (let* ((component (breakpoint-data-component data))
         (offsets (delete (breakpoint-data-offset data)
 (defun delete-breakpoint-data (data)
   (let* ((component (breakpoint-data-component data))
         (offsets (delete (breakpoint-data-offset data)

@@ -3129,10 +3100,10 @@
   (values))
 
 ;;; The C handler for interrupts calls this when it has a
   (values))
 
 ;;; The C handler for interrupts calls this when it has a

-;;; debugging-tool break instruction. This does NOT handle all breaks;
-;;; for example, it does not handle breaks for internal errors.
+;;; debugging-tool break instruction. This does *not* handle all
+;;; breaks; for example, it does not handle breaks for internal
+;;; errors.

 (defun handle-breakpoint (offset component signal-context)
 (defun handle-breakpoint (offset component signal-context)

-  (/show0 "entering HANDLE-BREAKPOINT")

   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"

@@ -3156,7 +3127,6 @@
 ;;; This handles code-location and DEBUG-FUN :FUN-START
 ;;; breakpoints.
 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
 ;;; This handles code-location and DEBUG-FUN :FUN-START
 ;;; breakpoints.
 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)

-  (/show0 "entering HANDLE-BREAKPOINT-AUX")

   (unless breakpoints
     (error "internal error: breakpoint that nobody wants"))
   (unless (member data *executing-breakpoint-hooks*)
   (unless breakpoints
     (error "internal error: breakpoint that nobody wants"))
   (unless (member data *executing-breakpoint-hooks*)

@@ -3201,7 +3171,6 @@
                   bpt)))))
 
 (defun handle-fun-end-breakpoint (offset component context)
                   bpt)))))
 
 (defun handle-fun-end-breakpoint (offset component context)

-  (/show0 "entering HANDLE-FUN-END-BREAKPOINT")

   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"

@@ -3216,7 +3185,6 @@
 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
 ;;; [new C code].
 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
 ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
 ;;; [new C code].
 (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)

-  (/show0 "entering HANDLE-FUN-END-BREAKPOINT-AUX")

   (delete-breakpoint-data data)
   (let* ((scp
          (locally
   (delete-breakpoint-data data)
   (let* ((scp
          (locally

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 31cb86c..4569837 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -655,8 +655,7 @@
          (t
           (/noshow0 "default case")
           (let ((file (concatenate 'string directory name)))
          (t
           (/noshow0 "default case")
           (let ((file (concatenate 'string directory name)))

-            (/noshow0 "computed basic FILE=..")
-            (/primitive-print file)
+            (/noshow "computed basic FILE")

             (unless (or (null type) (eq type :unspecific))
               (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
               (setf file (concatenate 'string file "." type)))
             (unless (or (null type) (eq type :unspecific))
               (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
               (setf file (concatenate 'string file "." type)))

@@ -664,8 +663,7 @@
               (/noshow0 "tweaking FILE for more-or-less-:WILD case")
               (setf file (concatenate 'string file "."
                                       (quick-integer-to-string version))))
               (/noshow0 "tweaking FILE for more-or-less-:WILD case")
               (setf file (concatenate 'string file "."
                                       (quick-integer-to-string version))))

-            (/noshow0 "finished possibly tweaking FILE=..")
-            (/primitive-print file)
+            (/noshow0 "finished possibly tweaking FILE")

             (when (or (not verify-existence)
                       (sb!unix:unix-file-kind file t))
               (/noshow0 "calling FUNCTION on FILE")
             (when (or (not verify-existence)
                       (sb!unix:unix-file-kind file t))
               (/noshow0 "calling FUNCTION on FILE")

@@ -787,13 +785,9 @@
         (namestring (unix-namestring defaulted-pathname t)))
     (when (and namestring (sb!unix:unix-file-kind namestring t))
       (let ((trueishname (sb!unix:unix-resolve-links namestring)))
         (namestring (unix-namestring defaulted-pathname t)))
     (when (and namestring (sb!unix:unix-file-kind namestring t))
       (let ((trueishname (sb!unix:unix-resolve-links namestring)))

-       (/show0 "back from UNIX-RESOLVE-LINKS in PROBE-FILE")

        (when trueishname
          (let ((*ignore-wildcards* t))
        (when trueishname
          (let ((*ignore-wildcards* t))

-           (/show0 "calling UNIX-SIMPLIFY-PATHNAME in PROBE-FILE")
-           (prog1
-               (pathname (sb!unix:unix-simplify-pathname trueishname))
-             (/show0 "back from UNIX-SIMPLIFY-PATHNAME in PROBE-FILE"))))))))
+           (pathname (sb!unix:unix-simplify-pathname trueishname))))))))

 \f
 ;;;; miscellaneous other operations
 
 \f
 ;;;; miscellaneous other operations
 

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index cd9463c..b8fc243 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -409,8 +409,6 @@
                                                   'string
                                                   user-home
                                                   "/.sbclrc"))))
                                                   'string
                                                   user-home
                                                   "/.sbclrc"))))

-       (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME")
-

 
        ;; We wrap all the pre-REPL user/system customized startup code 
        ;; in a restart.
 
        ;; We wrap all the pre-REPL user/system customized startup code 
        ;; in a restart.

@@ -484,20 +482,14 @@
      ;; way we can convince the GC to just ignore dead areas of the
      ;; control stack, so that we don't need to rely on this
      ;; half-measure?
      ;; way we can convince the GC to just ignore dead areas of the
      ;; control stack, so that we don't need to rely on this
      ;; half-measure?

-     (/show0 "at head of LOOP")

      (scrub-control-stack)
      (scrub-control-stack)

-     (/show0 "back from SCRUB-CONTROL-STACK")

      (unless noprint
        (fresh-line)
      (unless noprint
        (fresh-line)

-       (/show0 "back from FRESH-LINE")

        (princ (if (functionp *prompt*)
                  (funcall *prompt*)
                  *prompt*))
        (princ (if (functionp *prompt*)
                  (funcall *prompt*)
                  *prompt*))

-       (/show0 "back from PRINC")
-       (flush-standard-output-streams)
-       (/show0 "back from FLUSH-STANDARD-OUTPUT-STREAMS"))
+       (flush-standard-output-streams))

      (let ((form (read *standard-input* nil eof-marker)))
      (let ((form (read *standard-input* nil eof-marker)))

-       (/show0 "back from READ")

        (if (eq form eof-marker)
           (quit)
           (let ((results (multiple-value-list (interactive-eval form))))
        (if (eq form eof-marker)
           (quit)
           (let ((results (multiple-value-list (interactive-eval form))))

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 626a24a..eace65c 100644 (file)
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -697,7 +697,7 @@
 (defun unix-resolve-links (pathname)
   (declare (type simple-string pathname))
   (aver (not (relative-unix-pathname? pathname)))
 (defun unix-resolve-links (pathname)
   (declare (type simple-string pathname))
   (aver (not (relative-unix-pathname? pathname)))

-  (/show "entering UNIX-RESOLVE-LINKS")
+  (/noshow "entering UNIX-RESOLVE-LINKS")

   (loop with previous-pathnames = nil do
        (/noshow pathname previous-pathnames)
        (let ((link (unix-readlink pathname)))
   (loop with previous-pathnames = nil do
        (/noshow pathname previous-pathnames)
        (let ((link (unix-readlink pathname)))

diff --git a/src/compiler/alpha/nlx.lisp b/src/compiler/alpha/nlx.lisp
index 654105c..0578a94 100644 (file)
--- a/src/compiler/alpha/nlx.lisp
+++ b/src/compiler/alpha/nlx.lisp
@@ -1,4 +1,4 @@
-;;;; the definitions of VOPs used for non-local exit (throw, lexical
+;;;; the definitions of VOPs used for non-local exit (THROW, lexical

 ;;;; exit, etc.)
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; exit, etc.)
 
 ;;;; This software is part of the SBCL system. See the README file for

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 405ebba..4960357 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -1136,13 +1136,17 @@
 ;;; intern it.
 (defun finish-symbols ()
 
 ;;; intern it.
 (defun finish-symbols ()
 

-  ;; FIXME: Why use SETQ (setting symbol value) instead of just using
-  ;; the function values for these things?? I.e. why do we need this
-  ;; section at all? Is it because all the FDEFINITION stuff gets in
-  ;; the way of reading function values and is too hairy to rely on at
-  ;; cold boot? FIXME: Most of these are in *STATIC-SYMBOLS* in
-  ;; parms.lisp, but %HANDLE-FUN-END-BREAKPOINT is not. Why?
-  ;; Explain.
+  ;; I think the point of setting these functions into SYMBOL-VALUEs
+  ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
+  ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
+  ;; hairy operation (involving globaldb.lisp etc.) which we don't
+  ;; want to invoke early in cold init. -- WHN 2001-12-05
+  ;;
+  ;; FIXME: So OK, that's a reasonable reason to do something weird like
+  ;; this, but this is still a weird thing to do, and we should change
+  ;; the names to highlight that something weird is going on. Perhaps
+  ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
+  ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...

   (macrolet ((frob (symbol)
               `(cold-set ',symbol
                          (cold-fdefinition-object (cold-intern ',symbol)))))
   (macrolet ((frob (symbol)
               `(cold-set ',symbol
                          (cold-fdefinition-object (cold-intern ',symbol)))))

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 3bd5223..b7fff6f 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1330,7 +1330,6 @@
            (ir2-continuation-locs (continuation-info (second args)))
            nil))
          (nil)))
            (ir2-continuation-locs (continuation-info (second args)))
            nil))
          (nil)))

-

   (move-continuation-result node block () (node-cont node))
   (values))
 
   (move-continuation-result node block () (node-cont node))
   (values))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 87437f6..1796a28 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 

-"0.pre7.86.flaky7.21"
+"0.pre7.86.flaky7.22"