From: William Harold Newman <william.newman@airmail.net>
Date: Wed, 14 Nov 2001 16:28:30 +0000 (+0000)
Subject: 0.pre7.86.flaky7.8:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=718b3ccc610d1255f928fa75059f035638b57f94;p=sbcl.git

0.pre7.86.flaky7.8:
	found that suppressing the pretty printer lets the system limp
		into warm init (then die around assem-rtns.lisp)
---

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index d36f8c9..31cb86c 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -787,9 +787,13 @@
 	 (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))
-	    (pathname (sb!unix:unix-simplify-pathname trueishname))))))))
+	    (/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"))))))))
 
 ;;;; miscellaneous other operations
 
diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 77521d3..b5e3b7c 100644
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -457,9 +457,26 @@
        (/hexstr error-number)
        (/show0 "cold/low ARGUMENTS=..")
        (/hexstr arguments)
-       (/show (mapcar #'type-of arguments))
+
+       ;; REMOVEME
+       (/show0 "cold/low (LENGTH ARGUMENTS)=..")
+       (/hexstr (length arguments))
        (dolist (argument arguments)
-	 (/show argument))
+	 (/show0 "cold/low ARGUMENT=..")
+	 (/hexstr argument)
+	 (if (symbolp argument)
+	     (progn
+	       (/show0 "Argument is a SYMBOL..")
+	       (/primitive-print (symbol-name argument)))
+	     (let ((argument-type (type-of argument)))
+	       (cond ((symbolp argument-type)
+		      (/show0 "Argument type is a SYMBOL..")
+		      (/primitive-print (symbol-name argument-type)))
+		     ((listp argument-type)
+		      (/primitive-print "Argument type is a LIST."))
+		     (t
+		      (/primitive-print "Argument type is not a SYMBOL or LIST."))))))
+
        (multiple-value-bind (name sb!debug:*stack-top-hint*)
 	   (find-interrupted-name)
 	 (/show0 "back from FIND-INTERRUPTED-NAME")
diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 2067b07..a6ccaa7 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -905,6 +905,7 @@
 
 (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
   (declare (type (or pprint-dispatch-table null) table))
+  (/show0 "entering PPRINT-DISPATCH")
   (let* ((table (or table *initial-pprint-dispatch*))
 	 (cons-entry
 	  (and (consp object)
@@ -1251,6 +1252,7 @@
 ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
 ;;; bound to T.
 (defun output-pretty-object (object stream)
+  (/show0 "entering OUTPUT-PRETTY-OBJECT")
   (with-pretty-stream (stream)
     (funcall (pprint-dispatch object) stream object)))
 
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 205afbe..9b1f551 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -388,7 +388,9 @@
 
 ;;; Output OBJECT to STREAM observing all printer control variables.
 (defun output-object (object stream)
+  (/show0 "entering OUTPUT-OBJECT")
   (labels ((print-it (stream)
+	     (/show0 "entering PRINT-IT")
 	     (if *print-pretty*
 		 (if *pretty-printer*
 		     (funcall *pretty-printer* object stream)
@@ -396,6 +398,7 @@
 		       (output-ugly-object object stream)))
 		 (output-ugly-object object stream)))
 	   (check-it (stream)
+	     (/show0 "entering CHECK-IT")
 	     (let ((marker (check-for-circularity object t)))
 	       (case marker
 		 (:initiate
@@ -412,6 +415,7 @@
     (cond (;; Maybe we don't need to bother with circularity detection.
 	   (or (not *print-circle*)
 	       (uniquely-identified-by-print-p object))
+	   (/show0 "in obviously-don't-bother case")
 	   (print-it stream))
 	  (;; If we have already started circularity detection, this
 	   ;; object might be a shared reference. If we have not, then
@@ -419,8 +423,10 @@
 	   ;; reference to itself or multiple shared references.
 	   (or *circularity-hash-table*
 	       (compound-object-p object))
+	   (/show0 "in CHECK-IT case")
 	   (check-it stream))
 	  (t
+	   (/show0 "in don't-bother-after-all case")
 	   (print-it stream)))))
 
 ;;; Output OBJECT to STREAM observing all printer control variables
@@ -428,6 +434,7 @@
 ;;; then the pretty printer will be used for any components of OBJECT,
 ;;; just not for OBJECT itself.
 (defun output-ugly-object (object stream)
+  (/show0 "entering OUTPUT-UGLY-OBJECT")
   (typecase object
     ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
     ;; PRINT-OBJECT says it provides printing and we're supposed to provide
@@ -492,6 +499,7 @@
     (fdefn
      (output-fdefn object stream))
     (t
+     (/show0 "in OUTPUT-RANDOM case")
      (output-random object stream))))
 
 ;;;; symbols
diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 5897b71..e8097e3 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -386,6 +386,10 @@
 	   ;; return its truename.
 	   (probe-init-files (&rest possible-init-file-names)
 	     (/show0 "entering PROBE-INIT-FILES")
+
+	     ;; REMOVEME: commented out while compiler has problems
+	     #+nil
+
 	     (prog1
 		 (find-if (lambda (x)
 			    (and (stringp x) (probe-file x)))
@@ -459,8 +463,7 @@
   (let ((* nil) (** nil) (*** nil)
 	(- nil)
 	(+ nil) (++ nil) (+++ nil)
-	(/// nil) (// nil) (/ nil)
-	(eof-marker (cons :eof nil)))
+	(/// nil) (// nil) (/ nil))
     (/show0 "about to set up restarts in TOPLEVEL-REPL")
     ;; There should only be one TOPLEVEL restart, and it's here, so
     ;; restarting at TOPLEVEL always bounces you all the way out here.
@@ -478,27 +481,39 @@
 
 (defun repl (noprint)
   (/show0 "entering REPL")
-  (loop
-   ;; FIXME: It seems bad to have GC behavior depend on scrubbing the
-   ;; control stack before each interactive command. Isn't there some
-   ;; 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?
-   (scrub-control-stack)
-   (unless noprint
-     (fresh-line)
-     (princ (if (functionp *prompt*)
-		(funcall *prompt*)
-		*prompt*))
-     (flush-standard-output-streams))
-   (let ((form (read *standard-input* nil eof-marker)))
-     (if (eq form eof-marker)
-	 (quit)
-	 (let ((results (multiple-value-list (interactive-eval form))))
-	   (unless noprint
-	     (dolist (result results)
-	       (fresh-line)
-	       (prin1 result))))))))
+
+
+  ;; REMOVEME after debugging
+  (setf *print-pretty* nil)
+
+  (let ((eof-marker (cons :eof nil)))
+    (loop
+     ;; FIXME: It seems bad to have GC behavior depend on scrubbing the
+     ;; control stack before each interactive command. Isn't there some
+     ;; 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)
+     (/show0 "back from SCRUB-CONTROL-STACK")
+     (unless noprint
+       (fresh-line)
+       (/show0 "back from FRESH-LINE")
+       (princ (if (functionp *prompt*)
+		  (funcall *prompt*)
+		  *prompt*))
+       (/show0 "back from PRINC")
+       (flush-standard-output-streams)
+       (/show0 "back from FLUSH-STANDARD-OUTPUT-STREAMS"))
+     (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))))
+	     (unless noprint
+	       (dolist (result results)
+		 (fresh-line)
+		 (prin1 result)))))))))
 
 (defun noprogrammer-debugger-hook-fun (condition old-debugger-hook)
   (declare (ignore old-debugger-hook))
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 7149082..626a24a 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -699,9 +699,9 @@
   (aver (not (relative-unix-pathname? pathname)))
   (/show "entering UNIX-RESOLVE-LINKS")
   (loop with previous-pathnames = nil do
-	(/show pathname previous-pathnames)
+	(/noshow pathname previous-pathnames)
 	(let ((link (unix-readlink pathname)))
-	  (/show link)
+	  (/noshow link)
 	  ;; Unlike the old CMU CL code, we handle a broken symlink by
 	  ;; returning the link itself. That way, CL:TRUENAME on a
 	  ;; broken link returns the link itself, so that CL:DIRECTORY
@@ -720,7 +720,7 @@
 							pathname
 							:from-end t)))
 				 (dir (subseq pathname 0 dir-len)))
-			    (/show dir)
+			    (/noshow dir)
 			    (concatenate 'string dir link))
 			  link))))
 		(if (unix-file-kind new-pathname)
diff --git a/version.lisp-expr b/version.lisp-expr
index bab9913..88e5200 100644
--- 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".)
 
-"0.pre7.86.flaky7.7"
+"0.pre7.86.flaky7.8"