0.6.11.36:

	added support for --noprogrammer command line option
	tweaked tests/*.test.sh stuff to use the most recently built
		SBCL in the current tree (as other tests/* stuff does)
	renamed some FD-STREAM stuff to be more explicit
	PICK-BACKUP-NAME and ENSURE-ONE-OF needn't be so general.
	reduced generality of BEEP too
	ENSURE-ONE-OF should signal a TYPE-ERROR.
	converted some other CERRORs to ERRORs; redid OPEN errors
	rearranged error output to use pretty printer more

diff --git a/BUGS b/BUGS
index 417a40d..ad30c7b 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -893,6 +893,16 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
   Basically, the breakpoint facility wasn incompletely implemented
   in the X86 port of CMU CL, and we haven't fixed it in SBCL.
 
   Basically, the breakpoint facility wasn incompletely implemented
   in the X86 port of CMU CL, and we haven't fixed it in SBCL.
 

+97:
+  FRESH-LINE doesn't seem to work properly within pretty-printed
+  output. E.g. 
+    "~@<unhandled CONDITION (of type ~S): ~2I~_~A~:>~2%"
+  called on a CONDITION whose printer does
+    "~&~@<error in function ~S: ~3I~:_~?~:>"
+  gives two newlines between "unhandled CONDITION" and "error", when
+  (it at least seems as though) correct behavior would be to give one.
+
+

 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 
 (Note: At some point, the pure interpreter (actually a semi-pure
 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 
 (Note: At some point, the pure interpreter (actually a semi-pure

diff --git a/NEWS b/NEWS
index 4c333e8..72937c0 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -696,10 +696,10 @@ changes in sbcl-0.6.12 relative to sbcl-0.6.11:
   complex special functions have been merged from CMU CL sources.
   (When I was first setting up SBCL, I misunderstood a compile-time
   conditional #-OLD-SPECFUN, and so accidentally deleted them.)
   complex special functions have been merged from CMU CL sources.
   (When I was first setting up SBCL, I misunderstood a compile-time
   conditional #-OLD-SPECFUN, and so accidentally deleted them.)

-?? The --noprogrammer command line option is now supported. (Its
+* The --noprogrammer command line option is now supported. (Its

   behavior is slightly different in detail from what the old man
   behavior is slightly different in detail from what the old man

-  page claimed it would do, but it's appropriate under the same
-  circumstances.)
+  page claimed it would do, but it's still appropriate under the
+  same circumstances that the man page talks about.)

 * The :SB-PROPAGATE-FLOAT-TYPE and :SB-PROPAGATE-FUN-TYPE features
   are now supported, and enabled by default. Thus, the compiler can
   handle many floating point and complex operations much less
 * The :SB-PROPAGATE-FLOAT-TYPE and :SB-PROPAGATE-FUN-TYPE features
   are now supported, and enabled by default. Thus, the compiler can
   handle many floating point and complex operations much less

@@ -713,6 +713,10 @@ changes in sbcl-0.6.12 relative to sbcl-0.6.11:
   Lispworks for Windows, following bug reports from Arthur Lemmens)
 * a new workaround to make the cross-compiler portable to CMU CL
   again despite its non-ANSI EVAL-WHEN, thanks to Martin Atzmueller
   Lispworks for Windows, following bug reports from Arthur Lemmens)
 * a new workaround to make the cross-compiler portable to CMU CL
   again despite its non-ANSI EVAL-WHEN, thanks to Martin Atzmueller

+* The compiler now detects type mismatches between DECLAIM FTYPE 
+  and DEFUN better, thanks to patches from Martin Atzmueller.
+* A bug in READ-SEQUENCE for CONCATENATED-STREAM has been fixed
+  thanks to Pierre Mai's CMU CL patch.

 * new fasl file format version number (because of changes in byte
   code opcodes and in internal representation of (OR ..) types)
 
 * new fasl file format version number (because of changes in byte
   code opcodes and in internal representation of (OR ..) types)
 

diff --git a/doc/beyond-ansi.sgml b/doc/beyond-ansi.sgml
index a3d7eea..ff1cce5 100644 (file)
--- a/doc/beyond-ansi.sgml
+++ b/doc/beyond-ansi.sgml
@@ -49,7 +49,7 @@ and call
 
 you will not get the correct result, but an error,
 
 
 you will not get the correct result, but an error,
 

-<screen>debugger invoked on SB-DEBUG::*DEBUG-CONDITION* of type
+<screen>debugger invoked on SB-DEBUG:*DEBUG-CONDITION* of type

 SB-KERNEL:SIMPLE-CONTROL-ERROR:
   A function with declared result type NIL returned:
   FOO-P</screen>
 SB-KERNEL:SIMPLE-CONTROL-ERROR:
   A function with declared result type NIL returned:
   FOO-P</screen>

diff --git a/make.sh b/make.sh
index 4d338db..ea3c12c 100755 (executable)
--- a/make.sh
+++ b/make.sh
@@ -19,13 +19,18 @@
 # The value of SBCL_XC_HOST should be a command to invoke the
 # cross-compilation Lisp system in such a way that it reads commands
 # from standard input, and terminates when it reaches end of file on
 # The value of SBCL_XC_HOST should be a command to invoke the
 # cross-compilation Lisp system in such a way that it reads commands
 # from standard input, and terminates when it reaches end of file on

-# standard input. Suitable values are:
+# standard input. Some suitable values are:

 #   "sbcl"        to use an existing SBCL binary as a cross-compilation host
 #   "sbcl --sysinit /dev/null --userinit /dev/null"
 #                 to use an existing SBCL binary as a cross-compilation host
 #                 even though you have stuff in your initialization files
 #                 which makes it behave in such a non-standard way that
 #                 it keeps the build from working
 #   "sbcl"        to use an existing SBCL binary as a cross-compilation host
 #   "sbcl --sysinit /dev/null --userinit /dev/null"
 #                 to use an existing SBCL binary as a cross-compilation host
 #                 even though you have stuff in your initialization files
 #                 which makes it behave in such a non-standard way that
 #                 it keeps the build from working

+#   "sbcl --noprogrammer"
+#                 to use an existing SBCL binary as a cross-compilation host
+#                 and tell it to handle errors as best it can by itself,
+#                 without trying to use *DEBUG-IO* to ask for help from
+#                 the programmer

 #   "lisp -batch" to use an existing CMU CL binary as a cross-compilation host
 #   "lisp -noinit -batch" 
 #                 to use an existing CMU CL binary as a cross-compilation host
 #   "lisp -batch" to use an existing CMU CL binary as a cross-compilation host
 #   "lisp -noinit -batch" 
 #                 to use an existing CMU CL binary as a cross-compilation host

@@ -42,7 +47,7 @@
 # require a second pass, just testing at build-the-cross-compiler time
 # whether the cross-compilation host returns suitable values from 
 # UPGRADED-ARRAY-ELEMENT-TYPE?)
 # require a second pass, just testing at build-the-cross-compiler time
 # whether the cross-compilation host returns suitable values from 
 # UPGRADED-ARRAY-ELEMENT-TYPE?)

-export SBCL_XC_HOST="${1:-sbcl}"
+export SBCL_XC_HOST="${1:-sbcl --noprogrammer}"

 echo //SBCL_XC_HOST=\"$SBCL_XC_HOST\"
 
 # If you're cross-compiling, you should probably just walk through the
 echo //SBCL_XC_HOST=\"$SBCL_XC_HOST\"
 
 # If you're cross-compiling, you should probably just walk through the

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 499c353..098a02c 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -760,7 +760,7 @@ retained, possibly temporariliy, because it might be used internally."
              "READ-SEQUENCE-OR-DIE"
              "RENAME-KEY-ARGS"
              "REQUIRED-ARGUMENT"
              "READ-SEQUENCE-OR-DIE"
              "RENAME-KEY-ARGS"
              "REQUIRED-ARGUMENT"

-             "UNIX-NAMESTRING" ; FIXME: perhaps belongs in package %UNIX
+             "UNIX-NAMESTRING" ; FIXME: perhaps belongs in package SB!UNIX

              "FEATUREP"
              "FLUSH-STANDARD-OUTPUT-STREAMS"
              "MAKE-GENSYM-LIST"
              "FEATUREP"
              "FLUSH-STANDARD-OUTPUT-STREAMS"
              "MAKE-GENSYM-LIST"

@@ -1386,7 +1386,6 @@ and even SB-VM seem to have become somewhat blurred over the years."
              "%SP-FIND-CHARACTER-WITH-ATTRIBUTE"
              "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE"
              "%STANDARD-CHAR-P"
              "%SP-FIND-CHARACTER-WITH-ATTRIBUTE"
              "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE"
              "%STANDARD-CHAR-P"

-             "*BEEP-FUNCTION*"

              "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*"
              "*STDERR*" "*STDIN*"
              "*STDOUT*" "*TASK-DATA*"
              "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*"
              "*STDERR*" "*STDIN*"
              "*STDOUT*" "*TASK-DATA*"

@@ -1394,8 +1393,7 @@ and even SB-VM seem to have become somewhat blurred over the years."
              "ADD-FD-HANDLER" "ADD-PORT-DEATH-HANDLER"
              "ADD-PORT-OBJECT"
              "ALLOCATE-SYSTEM-MEMORY"
              "ADD-FD-HANDLER" "ADD-PORT-DEATH-HANDLER"
              "ADD-PORT-OBJECT"
              "ALLOCATE-SYSTEM-MEMORY"

-             "BEEP" "BITS" "STRUCTURE!OBJECT"
-             "STRUCTURE!OBJECT-MAKE-LOAD-FORM"
+             "BEEP" "BITS" 

              "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK="
              "COMPILER-VERSION"
              "DEALLOCATE-SYSTEM-MEMORY"
              "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK="
              "COMPILER-VERSION"
              "DEALLOCATE-SYSTEM-MEMORY"

@@ -1430,7 +1428,10 @@ and even SB-VM seem to have become somewhat blurred over the years."
              "SHORT-FLOAT-RADIX"
              "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32"
              "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-8"
              "SHORT-FLOAT-RADIX"
              "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32"
              "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-8"

-             "SINGLE-FLOAT-RADIX" "SYMBOL-MACRO-LET"
+             "SINGLE-FLOAT-RADIX"
+             ;; FIXME: STRUCTURE!OBJECT stuff probably belongs in SB!KERNEL.
+             "STRUCTURE!OBJECT" "STRUCTURE!OBJECT-MAKE-LOAD-FORM"
+             "SYMBOL-MACRO-LET"

              "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" "VECTOR-SAP"
              "WAIT-UNTIL-FD-USABLE" "WITH-ENABLED-INTERRUPTS"
              "WITH-FD-HANDLER"
              "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" "VECTOR-SAP"
              "WAIT-UNTIL-FD-USABLE" "WITH-ENABLED-INTERRUPTS"
              "WITH-FD-HANDLER"

diff --git a/src/code/array.lisp b/src/code/array.lisp
index b8a9fcd..1edce29 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -626,8 +626,7 @@
       (error 'simple-type-error
             :datum vector
             :expected-type '(and vector (satisfies array-has-fill-pointer-p))
       (error 'simple-type-error
             :datum vector
             :expected-type '(and vector (satisfies array-has-fill-pointer-p))

-            :format-control
-            "~S is not an array with a fill-pointer."
+            :format-control "~S is not an array with a fill pointer."

             :format-arguments (list vector))))
 
 (defun %set-fill-pointer (vector new)
             :format-arguments (list vector))))
 
 (defun %set-fill-pointer (vector new)

@@ -641,7 +640,7 @@
       (error 'simple-type-error
             :datum vector
             :expected-type '(and vector (satisfies array-has-fill-pointer-p))
       (error 'simple-type-error
             :datum vector
             :expected-type '(and vector (satisfies array-has-fill-pointer-p))

-            :format-control "~S is not an array with a fill-pointer."
+            :format-control "~S is not an array with a fill pointer."

             :format-arguments (list vector))))
 
 (defun vector-push (new-el array)
             :format-arguments (list vector))))
 
 (defun vector-push (new-el array)

@@ -678,7 +677,7 @@
 
 (defun vector-pop (array)
   #!+sb-doc
 
 (defun vector-pop (array)
   #!+sb-doc

-  "Attempts to decrease the fill-pointer by 1 and return the element
+  "Attempts to decrease the fill pointer by 1 and return the element

    pointer to by the new fill pointer. If the original value of the fill
    pointer is 0, an error occurs."
   (declare (vector array))
    pointer to by the new fill pointer. If the original value of the fill
    pointer is 0, an error occurs."
   (declare (vector array))

@@ -823,7 +822,7 @@
        ((numberp fill-pointer)
         (when (> fill-pointer new-array-size)
           (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
        ((numberp fill-pointer)
         (when (> fill-pointer new-array-size)
           (error "can't supply a value for :FILL-POINTER (~S) that is larger ~

-                 than the new length of the vector (~S)."
+                 than the new length of the vector (~S)"

                  fill-pointer new-array-size))
         fill-pointer)
        ((eq fill-pointer t)
                  fill-pointer new-array-size))
         fill-pointer)
        ((eq fill-pointer t)

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 3186f17..9f71712 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -582,18 +582,6 @@ Function and macro commands:
 (defvar *debug-restarts*)
 (defvar *debug-condition*)
 
 (defvar *debug-restarts*)
 (defvar *debug-condition*)
 

-;;; Print *DEBUG-CONDITION*, taking care to avoid recursive invocation
-;;; of the debugger in case of a problem (e.g. a bug in the PRINT-OBJECT
-;;; method for *DEBUG-CONDITION*).
-(defun princ-debug-condition-carefully (stream)
-  (handler-case (princ *debug-condition* stream)
-    (error (condition)
-          (format stream
-                  "  (caught ~S when trying to print ~S)"
-                  (type-of condition)
-                  '*debug-condition*)))
-  *debug-condition*)
-

 (defun invoke-debugger (condition)
   #!+sb-doc
   "Enter the debugger."
 (defun invoke-debugger (condition)
   #!+sb-doc
   "Enter the debugger."

@@ -645,16 +633,22 @@ reset to ~S."
        ;; the last line of output or so, and get confused.
        (flush-standard-output-streams)
 
        ;; the last line of output or so, and get confused.
        (flush-standard-output-streams)
 

-       ;; The initial output here goes to *ERROR-OUTPUT*, because the
+       ;; (The initial output here goes to *ERROR-OUTPUT*, because the

        ;; initial output is not interactive, just an error message,
        ;; and when people redirect *ERROR-OUTPUT*, they could
        ;; reasonably expect to see error messages logged there,
        ;; initial output is not interactive, just an error message,
        ;; and when people redirect *ERROR-OUTPUT*, they could
        ;; reasonably expect to see error messages logged there,

-       ;; regardless of what the debugger does afterwards.
-       (format *error-output*
-              "~2&debugger invoked on condition of type ~S:~%  "
-              (type-of *debug-condition*))
-       (princ-debug-condition-carefully *error-output*)
-       (terpri *error-output*)
+       ;; regardless of what the debugger does afterwards.)
+       (handler-case
+          (format *error-output*
+                  "~2&~@<debugger invoked on condition of type ~S: ~
+                    ~2I~_~A~:>~%"
+                  (type-of *debug-condition*)
+                  *debug-condition*)
+        (error (condition)
+          (format *error-output*
+                  "~&(caught ~S trying to print ~S when entering debugger)~%"
+                  (type-of condition)
+                  '*debug-condition*)))

 
        ;; After the initial error/condition/whatever announcement to
        ;; *ERROR-OUTPUT*, we become interactive, and should talk on
 
        ;; After the initial error/condition/whatever announcement to
        ;; *ERROR-OUTPUT*, we become interactive, and should talk on

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 0881f04..3d0e8b7 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -302,10 +302,8 @@
           (bytes (- end start))
           (newtail (+ tail bytes)))
       (cond ((minusp bytes) ; error case
           (bytes (- end start))
           (newtail (+ tail bytes)))
       (cond ((minusp bytes) ; error case

-            (cerror "Just go on as if nothing happened."
-                    "~S called with :END before :START!"
-                    'output-raw-bytes))
-           ((zerop bytes)) ; Easy case
+            (error ":END before :START!"))
+           ((zerop bytes)) ; easy case

            ((<= bytes space)
             (if (system-area-pointer-p thing)
                 (system-area-copy thing
            ((<= bytes space)
             (if (system-area-pointer-p thing)
                 (system-area-copy thing

@@ -654,7 +652,7 @@
 ;;; Fill in the various routine slots for the given type. INPUT-P and
 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
 ;;; set prior to calling this routine.
 ;;; Fill in the various routine slots for the given type. INPUT-P and
 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
 ;;; set prior to calling this routine.

-(defun set-routines (stream type input-p output-p buffer-p)
+(defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p)

   (let ((target-type (case type
                       ((:default unsigned-byte)
                        '(unsigned-byte 8))
   (let ((target-type (case type
                       ((:default unsigned-byte)
                        '(unsigned-byte 8))

@@ -667,30 +665,30 @@
        (input-size nil)
        (output-size nil))
 
        (input-size nil)
        (output-size nil))
 

-    (when (fd-stream-obuf-sap stream)
-      (push (fd-stream-obuf-sap stream) *available-buffers*)
-      (setf (fd-stream-obuf-sap stream) nil))
-    (when (fd-stream-ibuf-sap stream)
-      (push (fd-stream-ibuf-sap stream) *available-buffers*)
-      (setf (fd-stream-ibuf-sap stream) nil))
+    (when (fd-stream-obuf-sap fd-stream)
+      (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+      (setf (fd-stream-obuf-sap fd-stream) nil))
+    (when (fd-stream-ibuf-sap fd-stream)
+      (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
+      (setf (fd-stream-ibuf-sap fd-stream) nil))

 
     (when input-p
       (multiple-value-bind (routine type size)
          (pick-input-routine target-type)
        (unless routine
          (error "could not find any input routine for ~S" target-type))
 
     (when input-p
       (multiple-value-bind (routine type size)
          (pick-input-routine target-type)
        (unless routine
          (error "could not find any input routine for ~S" target-type))

-       (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
-       (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
-       (setf (fd-stream-ibuf-tail stream) 0)
+       (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
+       (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
+       (setf (fd-stream-ibuf-tail fd-stream) 0)

        (if (subtypep type 'character)
        (if (subtypep type 'character)

-           (setf (fd-stream-in stream) routine
-                 (fd-stream-bin stream) #'ill-bin)
-           (setf (fd-stream-in stream) #'ill-in
-                 (fd-stream-bin stream) routine))
+           (setf (fd-stream-in fd-stream) routine
+                 (fd-stream-bin fd-stream) #'ill-bin)
+           (setf (fd-stream-in fd-stream) #'ill-in
+                 (fd-stream-bin fd-stream) routine))

        (when (eql size 1)
        (when (eql size 1)

-         (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
+         (setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes)

          (when buffer-p
          (when buffer-p

-           (setf (lisp-stream-in-buffer stream)
+           (setf (lisp-stream-in-buffer fd-stream)

                  (make-array +in-buffer-length+
                              :element-type '(unsigned-byte 8)))))
        (setf input-size size)
                  (make-array +in-buffer-length+
                              :element-type '(unsigned-byte 8)))))
        (setf input-size size)

@@ -698,26 +696,26 @@
 
     (when output-p
       (multiple-value-bind (routine type size)
 
     (when output-p
       (multiple-value-bind (routine type size)

-         (pick-output-routine target-type (fd-stream-buffering stream))
+         (pick-output-routine target-type (fd-stream-buffering fd-stream))

        (unless routine
          (error "could not find any output routine for ~S buffered ~S"
        (unless routine
          (error "could not find any output routine for ~S buffered ~S"

-                (fd-stream-buffering stream)
+                (fd-stream-buffering fd-stream)

                 target-type))
                 target-type))

-       (setf (fd-stream-obuf-sap stream) (next-available-buffer))
-       (setf (fd-stream-obuf-length stream) bytes-per-buffer)
-       (setf (fd-stream-obuf-tail stream) 0)
+       (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
+       (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
+       (setf (fd-stream-obuf-tail fd-stream) 0)

        (if (subtypep type 'character)
        (if (subtypep type 'character)

-         (setf (fd-stream-out stream) routine
-               (fd-stream-bout stream) #'ill-bout)
-         (setf (fd-stream-out stream)
+         (setf (fd-stream-out fd-stream) routine
+               (fd-stream-bout fd-stream) #'ill-bout)
+         (setf (fd-stream-out fd-stream)

                (or (if (eql size 1)
                      (pick-output-routine 'base-char
                (or (if (eql size 1)
                      (pick-output-routine 'base-char

-                                          (fd-stream-buffering stream)))
+                                          (fd-stream-buffering fd-stream)))

                    #'ill-out)
                    #'ill-out)

-               (fd-stream-bout stream) routine))
-       (setf (fd-stream-sout stream)
+               (fd-stream-bout fd-stream) routine))
+       (setf (fd-stream-sout fd-stream)

              (if (eql size 1) #'fd-sout #'ill-out))
              (if (eql size 1) #'fd-sout #'ill-out))

-       (setf (fd-stream-char-pos stream) 0)
+       (setf (fd-stream-char-pos fd-stream) 0)

        (setf output-size size)
        (setf output-type type)))
 
        (setf output-size size)
        (setf output-type type)))
 

@@ -726,10 +724,10 @@
       (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
             input-type input-size
             output-type output-size))
       (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
             input-type input-size
             output-type output-size))

-    (setf (fd-stream-element-size stream)
+    (setf (fd-stream-element-size fd-stream)

          (or input-size output-size))
 
          (or input-size output-size))
 

-    (setf (fd-stream-element-type stream)
+    (setf (fd-stream-element-type fd-stream)

          (cond ((equal input-type output-type)
                 input-type)
                ((null output-type)
          (cond ((equal input-type output-type)
                 input-type)
                ((null output-type)

@@ -745,131 +743,129 @@
                        input-type
                        output-type))))))
 
                        input-type
                        output-type))))))
 

-;;; Handle miscellaneous operations on fd-stream.
-(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
+;;; Handle miscellaneous operations on FD-STREAM.
+(defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2)

   (declare (ignore arg2))
   (declare (ignore arg2))

-  ;; FIXME: Declare TYPE FD-STREAM STREAM?

   (case operation
     (:listen
   (case operation
     (:listen

-     (or (not (eql (fd-stream-ibuf-head stream)
-                  (fd-stream-ibuf-tail stream)))
-        (fd-stream-listen stream)
-        (setf (fd-stream-listen stream)
+     (or (not (eql (fd-stream-ibuf-head fd-stream)
+                  (fd-stream-ibuf-tail fd-stream)))
+        (fd-stream-listen fd-stream)
+        (setf (fd-stream-listen fd-stream)

               (eql (sb!alien:with-alien ((read-fds (sb!alien:struct
                                                     sb!unix:fd-set)))
                      (sb!unix:fd-zero read-fds)
               (eql (sb!alien:with-alien ((read-fds (sb!alien:struct
                                                     sb!unix:fd-set)))
                      (sb!unix:fd-zero read-fds)

-                     (sb!unix:fd-set (fd-stream-fd stream) read-fds)
-                     (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
+                     (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+                     (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))

                                                (sb!alien:addr read-fds)
                                                nil nil 0 0))
                    1))))
     (:unread
                                                (sb!alien:addr read-fds)
                                                nil nil 0 0))
                    1))))
     (:unread

-     (setf (fd-stream-unread stream) arg1)
-     (setf (fd-stream-listen stream) t))
+     (setf (fd-stream-unread fd-stream) arg1)
+     (setf (fd-stream-listen fd-stream) t))

     (:close
      (cond (arg1
            ;; We got us an abort on our hands.
     (:close
      (cond (arg1
            ;; We got us an abort on our hands.

-           (when (fd-stream-handler stream)
-                 (sb!sys:remove-fd-handler (fd-stream-handler stream))
-                 (setf (fd-stream-handler stream) nil))
-           (when (and (fd-stream-file stream)
-                      (fd-stream-obuf-sap stream))
+           (when (fd-stream-handler fd-stream)
+                 (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+                 (setf (fd-stream-handler fd-stream) nil))
+           (when (and (fd-stream-file fd-stream)
+                      (fd-stream-obuf-sap fd-stream))

              ;; We can't do anything unless we know what file were
              ;; dealing with, and we don't want to do anything
              ;; strange unless we were writing to the file.
              ;; We can't do anything unless we know what file were
              ;; dealing with, and we don't want to do anything
              ;; strange unless we were writing to the file.

-             (if (fd-stream-original stream)
+             (if (fd-stream-original fd-stream)

                  ;; We have a handle on the original, just revert.
                  (multiple-value-bind (okay err)
                  ;; We have a handle on the original, just revert.
                  (multiple-value-bind (okay err)

-                     (sb!unix:unix-rename (fd-stream-original stream)
-                                          (fd-stream-file stream))
+                     (sb!unix:unix-rename (fd-stream-original fd-stream)
+                                          (fd-stream-file fd-stream))

                    (unless okay
                    (unless okay

-                     (cerror "Go on as if nothing bad happened."
-                       "could not restore ~S to its original contents: ~A"
-                             (fd-stream-file stream)
-                             (sb!unix:get-unix-error-msg err))))
+                     (error "~@<could not restore ~S to its original ~
+                              contents: ~2I~_~A~:>"
+                            (fd-stream-file fd-stream)
+                            (sb!unix:get-unix-error-msg err))))

                  ;; We can't restore the original, so nuke that puppy.
                  (multiple-value-bind (okay err)
                  ;; We can't restore the original, so nuke that puppy.
                  (multiple-value-bind (okay err)

-                     (sb!unix:unix-unlink (fd-stream-file stream))
+                     (sb!unix:unix-unlink (fd-stream-file fd-stream))

                    (unless okay
                    (unless okay

-                     (cerror "Go on as if nothing bad happened."
-                             "Could not remove ~S: ~A"
-                             (fd-stream-file stream)
-                             (sb!unix:get-unix-error-msg err)))))))
+                     (error "~@<could not remove ~S: ~2I~_~A~:>"
+                            (fd-stream-file fd-stream)
+                            (sb!unix:get-unix-error-msg err)))))))

           (t
           (t

-           (fd-stream-misc-routine stream :finish-output)
-           (when (and (fd-stream-original stream)
-                      (fd-stream-delete-original stream))
+           (fd-stream-misc-routine fd-stream :finish-output)
+           (when (and (fd-stream-original fd-stream)
+                      (fd-stream-delete-original fd-stream))

              (multiple-value-bind (okay err)
              (multiple-value-bind (okay err)

-                 (sb!unix:unix-unlink (fd-stream-original stream))
+                 (sb!unix:unix-unlink (fd-stream-original fd-stream))

                (unless okay
                (unless okay

-                 (cerror "Go on as if nothing bad happened."
-                         "could not delete ~S during close of ~S: ~A"
-                         (fd-stream-original stream)
-                         stream
-                         (sb!unix:get-unix-error-msg err)))))))
+                 (error "~@<could not delete ~S during close ~
+                           of ~S: ~2I~_~A~:>"
+                        (fd-stream-original fd-stream)
+                        fd-stream
+                        (sb!unix:get-unix-error-msg err)))))))

      (when (fboundp 'cancel-finalization)
      (when (fboundp 'cancel-finalization)

-       (cancel-finalization stream))
-     (sb!unix:unix-close (fd-stream-fd stream))
-     (when (fd-stream-obuf-sap stream)
-       (push (fd-stream-obuf-sap stream) *available-buffers*)
-       (setf (fd-stream-obuf-sap stream) nil))
-     (when (fd-stream-ibuf-sap stream)
-       (push (fd-stream-ibuf-sap stream) *available-buffers*)
-       (setf (fd-stream-ibuf-sap stream) nil))
-     (sb!impl::set-closed-flame stream))
+       (cancel-finalization fd-stream))
+     (sb!unix:unix-close (fd-stream-fd fd-stream))
+     (when (fd-stream-obuf-sap fd-stream)
+       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+       (setf (fd-stream-obuf-sap fd-stream) nil))
+     (when (fd-stream-ibuf-sap fd-stream)
+       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
+       (setf (fd-stream-ibuf-sap fd-stream) nil))
+     (sb!impl::set-closed-flame fd-stream))

     (:clear-input
     (:clear-input

-     (setf (fd-stream-unread stream) nil)
-     (setf (fd-stream-ibuf-head stream) 0)
-     (setf (fd-stream-ibuf-tail stream) 0)
+     (setf (fd-stream-unread fd-stream) nil)
+     (setf (fd-stream-ibuf-head fd-stream) 0)
+     (setf (fd-stream-ibuf-tail fd-stream) 0)

      (catch 'eof-input-catcher
        (loop
        (let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct
                                                      sb!unix:fd-set)))
                       (sb!unix:fd-zero read-fds)
      (catch 'eof-input-catcher
        (loop
        (let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct
                                                      sb!unix:fd-set)))
                       (sb!unix:fd-zero read-fds)

-                      (sb!unix:fd-set (fd-stream-fd stream) read-fds)
-                      (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
-                                             (sb!alien:addr read-fds)
-                                             nil
-                                             nil
-                                             0
-                                             0))))
+                      (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+                      (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+                                                (sb!alien:addr read-fds)
+                                                nil
+                                                nil
+                                                0
+                                                0))))

          (cond ((eql count 1)
          (cond ((eql count 1)

-                (do-input stream)
-                (setf (fd-stream-ibuf-head stream) 0)
-                (setf (fd-stream-ibuf-tail stream) 0))
+                (do-input fd-stream)
+                (setf (fd-stream-ibuf-head fd-stream) 0)
+                (setf (fd-stream-ibuf-tail fd-stream) 0))

                (t
                 (return t)))))))
     (:force-output
                (t
                 (return t)))))))
     (:force-output

-     (flush-output-buffer stream))
+     (flush-output-buffer fd-stream))

     (:finish-output
     (:finish-output

-     (flush-output-buffer stream)
+     (flush-output-buffer fd-stream)

      (do ()
      (do ()

-        ((null (fd-stream-output-later stream)))
+        ((null (fd-stream-output-later fd-stream)))

        (sb!sys:serve-all-events)))
     (:element-type
        (sb!sys:serve-all-events)))
     (:element-type

-     (fd-stream-element-type stream))
+     (fd-stream-element-type fd-stream))

     (:interactive-p
       ;; FIXME: sb!unix:unix-isatty is undefined.
     (:interactive-p
       ;; FIXME: sb!unix:unix-isatty is undefined.

-     (sb!unix:unix-isatty (fd-stream-fd stream)))
+     (sb!unix:unix-isatty (fd-stream-fd fd-stream)))

     (:line-length
      80)
     (:charpos
     (:line-length
      80)
     (:charpos

-     (fd-stream-char-pos stream))
+     (fd-stream-char-pos fd-stream))

     (:file-length
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
                           atime mtime ctime blksize blocks)
     (:file-length
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
                           atime mtime ctime blksize blocks)

-        (sb!unix:unix-fstat (fd-stream-fd stream))
+        (sb!unix:unix-fstat (fd-stream-fd fd-stream))

        (declare (ignore ino nlink uid gid rdev
                        atime mtime ctime blksize blocks))
        (unless okay
        (declare (ignore ino nlink uid gid rdev
                        atime mtime ctime blksize blocks))
        (unless okay

-        (error "error fstat'ing ~S: ~A"
-               stream
+        (error "error in Unix fstat(2) on ~S: ~A"
+               fd-stream

                (sb!unix:get-unix-error-msg dev)))
        (if (zerop mode)
           nil
                (sb!unix:get-unix-error-msg dev)))
        (if (zerop mode)
           nil

-          (truncate size (fd-stream-element-size stream)))))
+          (truncate size (fd-stream-element-size fd-stream)))))

     (:file-position
     (:file-position

-     (fd-stream-file-position stream arg1))))
+     (fd-stream-file-position fd-stream arg1))))

 
 (defun fd-stream-file-position (stream &optional newpos)
   (declare (type fd-stream stream)
 
 (defun fd-stream-file-position (stream &optional newpos)
   (declare (type fd-stream stream)

@@ -948,7 +944,23 @@
 \f
 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
 
 \f
 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
 

-;;; Returns a FD-STREAM on the given file.
+;;; Create a stream for the given Unix file descriptor.
+;;;
+;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
+;;; allow output operations. If neither INPUT nor OUTPUT is specified,
+;;; default to allowing input.
+;;;
+;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
+;;;
+;;; BUFFERING indicates the kind of buffering to use.
+;;;
+;;; TIMEOUT (if true) is the number of seconds to wait for input. If
+;;; NIL (the default), then wait forever. When we time out, we signal
+;;; IO-TIMEOUT.
+;;;
+;;; FILE is the name of the file (will be returned by PATHNAME).
+;;;
+;;; NAME is used to identify the stream when printed.

 (defun make-fd-stream (fd
                       &key
                       (input nil input-p)
 (defun make-fd-stream (fd
                       &key
                       (input nil input-p)

@@ -967,17 +979,6 @@
                       auto-close)
   (declare (type index fd) (type (or index null) timeout)
           (type (member :none :line :full) buffering))
                       auto-close)
   (declare (type index fd) (type (or index null) timeout)
           (type (member :none :line :full) buffering))

-  #!+sb-doc
-  "Create a stream for the given unix file descriptor.
-  If input is non-nil, allow input operations.
-  If output is non-nil, allow output operations.
-  If neither input nor output are specified, default to allowing input.
-  Element-type indicates the element type to use (as for open).
-  Buffering indicates the kind of buffering to use.
-  Timeout (if true) is the number of seconds to wait for input. If NIL (the
-    default), then wait forever. When we time out, we signal IO-TIMEOUT.
-  File is the name of the file (will be returned by PATHNAME).
-  Name is used to identify the stream when printed."

   (cond ((not (or input-p output-p))
         (setf input t))
        ((not (or input output))
   (cond ((not (or input-p output-p))
         (setf input t))
        ((not (or input output))

@@ -990,7 +991,7 @@
                                 :pathname pathname
                                 :buffering buffering
                                 :timeout timeout)))
                                 :pathname pathname
                                 :buffering buffering
                                 :timeout timeout)))

-    (set-routines stream element-type input output input-buffer-p)
+    (set-fd-stream-routines stream element-type input output input-buffer-p)

     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                (lambda ()
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                (lambda ()

@@ -1000,54 +1001,35 @@
                          fd))))
     stream))
 
                          fd))))
     stream))
 

-;;; Pick a name to use for the backup file.
-(defvar *backup-extension* ".BAK"
-  #!+sb-doc
-  "This is a string that OPEN tacks on the end of a file namestring to produce
-   a name for the :if-exists :rename-and-delete and :rename options. Also,
-   this can be a function that takes a namestring and returns a complete
-   namestring.")
+;;; Pick a name to use for the backup file for the :IF-EXISTS
+;;; :RENAME-AND-DELETE and :RENAME options.

 (defun pick-backup-name (name)
   (declare (type simple-string name))
 (defun pick-backup-name (name)
   (declare (type simple-string name))

-  (let ((ext *backup-extension*))
-    (etypecase ext
-      (simple-string (concatenate 'simple-string name ext))
-      (function (funcall ext name)))))
-
-;;; Ensure that the given arg is one of the given list of valid things.
-;;; Allow the user to fix any problems.
-;;; FIXME: Why let the user fix any problems?
+  (concatenate 'simple-string name ".bak"))
+
+;;; Ensure that the given arg is one of the given list of valid
+;;; things. Allow the user to fix any problems.

 (defun ensure-one-of (item list what)
   (unless (member item list)
 (defun ensure-one-of (item list what)
   (unless (member item list)

-    (loop
-      (cerror "Enter new value for ~*~S"
-             "~S is invalid for ~S. Must be one of~{ ~S~}"
-             item
-             what
-             list)
-      (format (the stream *query-io*) "Enter new value for ~S: " what)
-      (force-output *query-io*)
-      (setf item (read *query-io*))
-      (when (member item list)
-       (return))))
-  item)
+    (error 'simple-type-error
+          :datum item
+          :expected-type `(member ,@list)
+          :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
+          :format-arguments (list item what list))))

 
 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
 ;;; access, since we don't want to trash unwritable files even if we
 ;;; technically can. We return true if we succeed in renaming.
 (defun do-old-rename (namestring original)
   (unless (sb!unix:unix-access namestring sb!unix:w_ok)
 
 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
 ;;; access, since we don't want to trash unwritable files even if we
 ;;; technically can. We return true if we succeed in renaming.
 (defun do-old-rename (namestring original)
   (unless (sb!unix:unix-access namestring sb!unix:w_ok)

-    (cerror "Try to rename it anyway."
-           "File ~S is not writable."
-           namestring))
+    (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))

   (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
     (cond (okay t)
          (t
   (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
     (cond (okay t)
          (t

-          (cerror "Use :SUPERSEDE instead."
-                  "Could not rename ~S to ~S: ~A."
-                  namestring
-                  original
-                  (sb!unix:get-unix-error-msg err))
+          (error "~@<could not rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
+                 namestring
+                 original
+                 (sb!unix:get-unix-error-msg err))

           nil))))
 
 (defun open (filename
           nil))))
 
 (defun open (filename

@@ -1062,28 +1044,22 @@
             (if-does-not-exist if-does-not-exist)
             (if-exists if-exists))
   #!+sb-doc
             (if-does-not-exist if-does-not-exist)
             (if-exists if-exists))
   #!+sb-doc

-  "Return a stream which reads from or writes to Filename.
+  "Return a stream which reads from or writes to FILENAME.

   Defined keywords:
   Defined keywords:

-   :direction - one of :input, :output, :io, or :probe
-   :element-type - Type of object to read or write, default BASE-CHAR
-   :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
-                      :overwrite, :append, :supersede or nil
-   :if-does-not-exist - one of :error, :create or nil
+   :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
+   :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
+   :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
+                      :OVERWRITE, :APPEND, :SUPERSEDE or NIL
+   :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or nil

   See the manual for details."
 
   (unless (eq external-format :default)
   See the manual for details."
 
   (unless (eq external-format :default)

-    (error 'simple-error
-          :format-control
-          "Any external format other than :DEFAULT isn't recognized."))
-
-  ;; First, make sure that DIRECTION is valid. Allow it to be changed
-  ;; if not.
-  ;;
-  ;; FIXME: Why allow it to be changed if not?
-  (setf direction
-       (ensure-one-of direction
-                      '(:input :output :io :probe)
-                      :direction))
+    (error "Any external format other than :DEFAULT isn't recognized."))
+
+  ;; First, make sure that DIRECTION is valid.
+  (ensure-one-of direction
+                '(:input :output :io :probe)
+                :direction)

 
   ;; Calculate useful stuff.
   (multiple-value-bind (input output mask)
 
   ;; Calculate useful stuff.
   (multiple-value-bind (input output mask)

@@ -1105,12 +1081,11 @@
                     (if (eq (pathname-version pathname) :newest)
                         :new-version
                         :error)))
                     (if (eq (pathname-version pathname) :newest)
                         :new-version
                         :error)))

-            (setf if-exists ; FIXME: should just die, not allow resetting
-                  (ensure-one-of if-exists
-                                 '(:error :new-version :rename
-                                   :rename-and-delete :overwrite
-                                   :append :supersede nil)
-                                 :if-exists))
+            (ensure-one-of if-exists
+                           '(:error :new-version :rename
+                                    :rename-and-delete :overwrite
+                                    :append :supersede nil)
+                           :if-exists)

             (case if-exists
               ((:error nil)
                (setf mask (logior mask sb!unix:o_excl)))
             (case if-exists
               ((:error nil)
                (setf mask (logior mask sb!unix:o_excl)))

@@ -1133,10 +1108,9 @@
                     nil)
                    (t
                     :create))))
                     nil)
                    (t
                     :create))))

-      (setf if-does-not-exist ; FIXME: should just die, not allow resetting
-           (ensure-one-of if-does-not-exist
-                          '(:error :create nil)
-                          :if-does-not-exist))
+      (ensure-one-of if-does-not-exist
+                    '(:error :create nil)
+                    :if-does-not-exist)

       (if (eq if-does-not-exist :create)
        (setf mask (logior mask sb!unix:o_creat)))
 
       (if (eq if-does-not-exist :create)
        (setf mask (logior mask sb!unix:o_creat)))
 

@@ -1183,87 +1157,67 @@
                              sb!unix:o_trunc)))
              (setf if-exists :supersede))))
        
                              sb!unix:o_trunc)))
              (setf if-exists :supersede))))
        

-       ;; Okay, now we can try the actual open.
-       (loop
-         (multiple-value-bind (fd errno)
-             (if namestring
-                 (sb!unix:unix-open namestring mask mode)
-                 (values nil sb!unix:enoent))
+       ;; Now we can try the actual Unix open(2).
+       (multiple-value-bind (fd errno)
+           (if namestring
+               (sb!unix:unix-open namestring mask mode)
+               (values nil sb!unix:enoent))
+         (labels ((open-error (format-control &rest format-arguments)
+                    (error 'simple-file-error
+                           :pathname pathname
+                           :format-control format-control
+                           :format-arguments format-arguments))
+                  (vanilla-open-error ()
+                    (open-error "~@<error opening ~S: ~2I~_~A~:>"
+                                pathname
+                                (sb!unix:get-unix-error-msg errno))))

            (cond ((numberp fd)
            (cond ((numberp fd)

-                  (return
-                   (case direction
-                     ((:input :output :io)
-                      (make-fd-stream fd
-                                      :input input
-                                      :output output
-                                      :element-type element-type
-                                      :file namestring
-                                      :original original
-                                      :delete-original delete-original
-                                      :pathname pathname
-                                      :input-buffer-p t
-                                      :auto-close t))
-                     (:probe
-                      (let ((stream
-                             (%make-fd-stream :name namestring :fd fd
-                                              :pathname pathname
-                                              :element-type element-type)))
-                        (close stream)
-                        stream)))))
+                  (case direction
+                    ((:input :output :io)
+                     (make-fd-stream fd
+                                     :input input
+                                     :output output
+                                     :element-type element-type
+                                     :file namestring
+                                     :original original
+                                     :delete-original delete-original
+                                     :pathname pathname
+                                     :input-buffer-p t
+                                     :auto-close t))
+                    (:probe
+                     (let ((stream
+                            (%make-fd-stream :name namestring
+                                             :fd fd
+                                             :pathname pathname
+                                             :element-type element-type)))
+                       (close stream)
+                       stream))))

                  ((eql errno sb!unix:enoent)
                   (case if-does-not-exist
                  ((eql errno sb!unix:enoent)
                   (case if-does-not-exist

-                    (:error
-                     (cerror "Return NIL."
-                             'simple-file-error
-                             :pathname pathname
-                             :format-control "error opening ~S: ~A"
-                             :format-arguments
-                             (list pathname
-                                   (sb!unix:get-unix-error-msg errno))))
+                    (:error (vanilla-open-error))

                     (:create
                     (:create

-                     (cerror "Return NIL."
-                             'simple-error
-                             :format-control
-                             "error creating ~S: Path does not exist."
-                             :format-arguments
-                             (list pathname))))
-                  (return nil))
-                 ((eql errno sb!unix:eexist)
-                  (unless (eq nil if-exists)
-                    (cerror "Return NIL."
-                            'simple-file-error
-                            :pathname pathname
-                            :format-control "error opening ~S: ~A"
-                            :format-arguments
-                            (list pathname
-                                  (sb!unix:get-unix-error-msg errno))))
-                  (return nil))
-                 ((eql errno sb!unix:eacces)
-                  (cerror "Try again."
-                          "error opening ~S: ~A"
-                          pathname
-                          (sb!unix:get-unix-error-msg errno)))
+                     (open-error
+                      "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+                      pathname))
+                    (t nil)))
+                 ((and (eql errno sb!unix:eexist) if-exists)
+                  nil)

                  (t
                  (t

-                  (cerror "Return NIL."
-                          "error opening ~S: ~A"
-                          pathname
-                          (sb!unix:get-unix-error-msg errno))
-                  (return nil)))))))))
+                  (vanilla-open-error)))))))))

 \f
 ;;;; initialization
 
 \f
 ;;;; initialization
 

-(defvar *tty* nil
-  #!+sb-doc
-  "The stream connected to the controlling terminal or NIL if there is none.")
-(defvar *stdin* nil
-  #!+sb-doc
-  "The stream connected to the standard input (file descriptor 0).")
-(defvar *stdout* nil
-  #!+sb-doc
-  "The stream connected to the standard output (file descriptor 1).")
-(defvar *stderr* nil
-  #!+sb-doc
-  "The stream connected to the standard error output (file descriptor 2).")
+;;; the stream connected to the controlling terminal, or NIL if there is none
+(defvar *tty*)
+
+;;; the stream connected to the standard input (file descriptor 0)
+(defvar *stdin*)
+
+;;; the stream connected to the standard output (file descriptor 1)
+(defvar *stdout*)
+
+;;; the stream connected to the standard error output (file descriptor 2)
+(defvar *stderr*)

 
 ;;; This is called when the cold load is first started up, and may also
 ;;; be called in an attempt to recover from nested errors.
 
 ;;; This is called when the cold load is first started up, and may also
 ;;; be called in an attempt to recover from nested errors.

@@ -1273,8 +1227,8 @@
   (setf *standard-output* (make-synonym-stream '*stdout*))
   (setf *standard-input*
        (#!-high-security
   (setf *standard-output* (make-synonym-stream '*stdout*))
   (setf *standard-input*
        (#!-high-security

-        ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says it's
-        ;; an input stream.
+        ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says
+        ;; it's an input stream.

         make-two-way-stream
         #!+high-security
         %make-two-way-stream (make-synonym-stream '*stdin*)
         make-two-way-stream
         #!+high-security
         %make-two-way-stream (make-synonym-stream '*stdin*)

@@ -1283,7 +1237,7 @@
   (setf *query-io* (make-synonym-stream '*terminal-io*))
   (setf *debug-io* *query-io*)
   (setf *trace-output* *standard-output*)
   (setf *query-io* (make-synonym-stream '*terminal-io*))
   (setf *debug-io* *query-io*)
   (setf *trace-output* *standard-output*)

-  nil)
+  (values))

 
 ;;; This is called whenever a saved core is restarted.
 (defun stream-reinit ()
 
 ;;; This is called whenever a saved core is restarted.
 (defun stream-reinit ()

@@ -1304,21 +1258,15 @@
                              :buffering :line
                              :auto-close t))
        (setf *tty* (make-two-way-stream *stdin* *stdout*))))
                              :buffering :line
                              :auto-close t))
        (setf *tty* (make-two-way-stream *stdin* *stdout*))))

-  nil)
+  (values))

 \f
 \f

-;;;; beeping
+;;;; miscellany

 
 

-(defun default-beep-function (stream)
+;;; the Unix way to beep
+(defun beep (stream)

   (write-char (code-char bell-char-code) stream)
   (finish-output stream))
 
   (write-char (code-char bell-char-code) stream)
   (finish-output stream))
 

-(defvar *beep-function* #'default-beep-function
-  #!+sb-doc
-  "This is called in BEEP to feep the user. It takes a stream.")
-
-(defun beep (&optional (stream *terminal-io*))
-  (funcall *beep-function* stream))
-\f

 ;;; This is kind of like FILE-POSITION, but is an internal hack used
 ;;; by the filesys stuff to get and set the file name.
 (defun file-name (stream &optional new-name)
 ;;; This is kind of like FILE-POSITION, but is an internal hack used
 ;;; by the filesys stuff to get and set the file name.
 (defun file-name (stream &optional new-name)

@@ -1342,7 +1290,7 @@
   (declare (type (or string character) object) (type file-stream stream))
   #!+sb-doc
   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
   (declare (type (or string character) object) (type file-stream stream))
   #!+sb-doc
   "Return the delta in STREAM's FILE-POSITION that would be caused by writing

-   Object to Stream. Non-trivial only in implementations that support
+   OBJECT to STREAM. Non-trivial only in implementations that support

    international character sets."
   (declare (ignore stream))
   (etypecase object
    international character sets."
   (declare (ignore stream))
   (etypecase object

diff --git a/src/code/globals.lisp b/src/code/globals.lisp
index 2ca7e36..c6f9f36 100644 (file)
--- a/src/code/globals.lisp
+++ b/src/code/globals.lisp
@@ -26,7 +26,7 @@
                  *software-interrupt-vector* *load-verbose*
                  *load-print-stuff* *in-compilation-unit*
                  *aborted-compilation-unit-count* *char-name-alist*
                  *software-interrupt-vector* *load-verbose*
                  *load-print-stuff* *in-compilation-unit*
                  *aborted-compilation-unit-count* *char-name-alist*

-                 *beep-function* *gc-notify-before* *gc-notify-after*
+                 *gc-notify-before* *gc-notify-after*

                  *posix-argv*))
 
 (declaim (ftype (function * *)
                  *posix-argv*))
 
 (declaim (ftype (function * *)

diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp
index 0a303b4..4a89b6b 100644 (file)
--- a/src/code/late-target-error.lisp
+++ b/src/code/late-target-error.lisp
@@ -547,8 +547,10 @@
 (define-condition style-warning (warning) ())
 
 (defun simple-condition-printer (condition stream)
 (define-condition style-warning (warning) ())
 
 (defun simple-condition-printer (condition stream)

-  (apply #'format stream (simple-condition-format-control condition)
-                        (simple-condition-format-arguments condition)))
+  (apply #'format
+        stream
+        (simple-condition-format-control condition)
+        (simple-condition-format-arguments condition)))

 
 (define-condition simple-condition ()
   ((format-control :reader simple-condition-format-control
 
 (define-condition simple-condition ()
   ((format-control :reader simple-condition-format-control

@@ -562,7 +564,13 @@
 
 (defun print-simple-error (condition stream)
   (format stream
 
 (defun print-simple-error (condition stream)
   (format stream

-         "~&~@<error in function ~S: ~3I~:_~?~:>"
+         ;; FIXME: It seems reasonable to display the "in function
+         ;; ~S" information, but doesn't the logic to display it
+         ;; belong in the debugger or someplace like that instead of
+         ;; in the format string for this particular family of
+         ;; conditions? Then this printer might look more
+         ;; ("~@<~S: ~2I~:_~?~:>" (TYPE-OF C) ..) instead.
+         "~@<error in function ~S: ~2I~:_~?~:>"

          (condition-function-name condition)
          (simple-condition-format-control condition)
          (simple-condition-format-arguments condition)))
          (condition-function-name condition)
          (simple-condition-format-control condition)
          (simple-condition-format-arguments condition)))

@@ -584,7 +592,7 @@
   (:report
    (lambda (condition stream)
      (format stream
   (:report
    (lambda (condition stream)
      (format stream

-            "~@<TYPE-ERROR in ~S: ~3I~:_~S is not of type ~S~:>."
+            "~@<TYPE-ERROR in ~S: ~2I~:_~S is not of type ~S~:>."

             (condition-function-name condition)
             (type-error-datum condition)
             (type-error-expected-type condition)))))
             (condition-function-name condition)
             (type-error-datum condition)
             (type-error-expected-type condition)))))

@@ -607,7 +615,7 @@
   (:report
    (lambda (condition stream)
      (format stream
   (:report
    (lambda (condition stream)
      (format stream

-            "~&~@<FILE-ERROR in function ~S: ~3i~:_~?~:>"
+            "~@<FILE-ERROR in function ~S: ~2I~:_~?~:>"

             (condition-function-name condition)
             (serious-condition-format-control condition)
             (serious-condition-format-arguments condition)))))
             (condition-function-name condition)
             (serious-condition-format-control condition)
             (serious-condition-format-arguments condition)))))

diff --git a/src/code/query.lisp b/src/code/query.lisp
index aa6dab7..c3836e5 100644 (file)
--- a/src/code/query.lisp
+++ b/src/code/query.lisp
@@ -44,8 +44,6 @@
             (apply #'format *query-io* format-string arguments))
           (force-output *query-io*)))))))
 
             (apply #'format *query-io* format-string arguments))
           (force-output *query-io*)))))))
 

-;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and
-;;; uses READ-LINE to get "YES" or "NO".

 (defun yes-or-no-p (&optional format-string &rest arguments)
   #!+sb-doc
   "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the
 (defun yes-or-no-p (&optional format-string &rest arguments)
   #!+sb-doc
   "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index cd1c923..47a1efe 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -233,6 +233,8 @@
 \f
 ;;;; the default toplevel function
 
 \f
 ;;;; the default toplevel function
 

+;;; FIXME: Most stuff below here can probably be byte-compiled.
+

 (defvar / nil
   #!+sb-doc
   "a list of all the values returned by the most recent top-level EVAL")
 (defvar / nil
   #!+sb-doc
   "a list of all the values returned by the most recent top-level EVAL")

@@ -298,10 +300,13 @@
 
     (/show0 "done with outer LET in TOPLEVEL-INIT")
   
 
     (/show0 "done with outer LET in TOPLEVEL-INIT")
   

-    ;; FIXME: There are lots of ways for errors to happen around here (e.g. bad
-    ;; command line syntax, or READ-ERROR while trying to READ an --eval
-    ;; string). Make sure that they're handled reasonably.
-
+    ;; FIXME: There are lots of ways for errors to happen around here
+    ;; (e.g. bad command line syntax, or READ-ERROR while trying to
+    ;; READ an --eval string). Make sure that they're handled
+    ;; reasonably. Also, perhaps all errors while parsing the command
+    ;; line should cause the system to QUIT, instead of trying to go
+    ;; into the Lisp debugger.
+    

     ;; Parse command line options.
     (loop while options do
          (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
     ;; Parse command line options.
     (loop while options do
          (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")

@@ -352,19 +357,27 @@
                     ;; because we didn't recognize an option as a
                     ;; toplevel option, then the option we gave up on
                     ;; must have been an error. (E.g. in
                     ;; because we didn't recognize an option as a
                     ;; toplevel option, then the option we gave up on
                     ;; must have been an error. (E.g. in

-                    ;;   sbcl --eval '(a)' --evl '(b)' --end-toplevel-options
-                    ;; this test will let us detect that "--evl" is
-                    ;; an error.)
+                    ;;  "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
+                    ;; this test will let us detect that the string
+                    ;; "--eval(b)" is an error.)

                     (if (find "--end-toplevel-options" options
                               :test #'string=)
                         (error "bad toplevel option: ~S" (first options))
                         (return)))))))
     (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
 
                     (if (find "--end-toplevel-options" options
                               :test #'string=)
                         (error "bad toplevel option: ~S" (first options))
                         (return)))))))
     (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
 

-    ;; Excise all the options that we processed, so that only user-level
-    ;; options are left visible to user code.
+    ;; Excise all the options that we processed, so that only
+    ;; user-level options are left visible to user code.

     (setf (rest *posix-argv*) options)
 
     (setf (rest *posix-argv*) options)
 

+    ;; Handle --noprogrammer option. We intentionally do this
+    ;; early so that it will affect the handling of initialization
+    ;; files and --eval options.
+    (/show0 "handling --noprogrammer option in TOPLEVEL-INIT")
+    (when noprogrammer
+      (setf *debugger-hook* 'noprogrammer-debugger-hook-fun
+           *debug-io* *error-output*))
+

     ;; FIXME: Verify that errors in init files and/or --eval operations
     ;; lead to reasonable behavior.
 
     ;; FIXME: Verify that errors in init files and/or --eval operations
     ;; lead to reasonable behavior.
 

@@ -416,15 +429,6 @@
        (eval eval)
        (flush-standard-output-streams))
 
        (eval eval)
        (flush-standard-output-streams))
 

-      ;; Handle stream binding controlled by --noprogrammer option.
-      ;;
-      ;; FIXME: When we do actually implement this, shouldn't it go
-      ;; earlier in the sequence, so that its stream bindings will
-      ;; affect the behavior of init files and --eval options?
-      (/show0 "handling --noprogrammer option in TOPLEVEL-INIT")
-      (when noprogrammer
-       (warn "stub: --noprogrammer option unimplemented")) ; FIXME
-

       (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
       (toplevel-repl noprint))))
 
       (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
       (toplevel-repl noprint))))
 

@@ -474,6 +478,36 @@
                     (dolist (result results)
                       (fresh-line)
                       (prin1 result)))))))))))))
                     (dolist (result results)
                       (fresh-line)
                       (prin1 result)))))))))))))

+
+(defun noprogrammer-debugger-hook-fun (condition old-debugger-hook)
+  (declare (ignore old-debugger-hook))
+  (flet ((failure-quit (&key recklessly-p)
+          (quit :unix-status 1 :recklessly-p recklessly-p)))
+    ;; This HANDLER-CASE is here mostly to stop output immediately
+    ;; (and fall through to QUIT) when there's an I/O error. Thus,
+    ;; when we're run under a Perl script or something, we can die
+    ;; cleanly when the script dies (and our pipes are cut), instead
+    ;; of falling into ldb or something messy like that.
+    (handler-case
+       (progn
+         (format *error-output*
+                 "~@<unhandled CONDITION (of type ~S): ~2I~_~A~:>~2%"
+                 (type-of condition)
+                 condition)
+         ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
+         ;; even if we hit an error within BACKTRACE we'll at least
+         ;; have the CONDITION printed out before we die.
+         (finish-output *error-output*)
+         ;; (Where to truncate the BACKTRACE is of course arbitrary, but
+         ;; it seems as though we should at least truncate it somewhere.)
+         (sb!debug:backtrace 128 *error-output*)
+         (finish-output *error-output*)
+         (format *error-output*
+                 "~%unhandled CONDITION in --noprogrammer mode, quitting~%")
+         (failure-quit))
+      (condition ()
+        (%primitive print "Argh! error within --noprogrammer error handling")
+       (failure-quit :recklessly-p t)))))

 \f
 ;;; a convenient way to get into the assembly-level debugger
 (defun %halt ()
 \f
 ;;; a convenient way to get into the assembly-level debugger
 (defun %halt ()

diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh
index ae735b2..cdab547 100644 (file)
--- a/tests/foreign.test.sh
+++ b/tests/foreign.test.sh
@@ -13,15 +13,13 @@
 # absolutely no warranty. See the COPYING and CREDITS files for
 # more information.
 
 # absolutely no warranty. See the COPYING and CREDITS files for
 # more information.
 

-sbcl="$1"
-

 testfilestem=$TMPDIR/sbcl-foreign-test-$$
 
 echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c
 make $testfilestem.o
 ld -shared -o $testfilestem.so $testfilestem.o
 
 testfilestem=$TMPDIR/sbcl-foreign-test-$$
 
 echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c
 make $testfilestem.o
 ld -shared -o $testfilestem.so $testfilestem.o
 

-$sbcl <<EOF
+${SBCL:-sbcl} <<EOF

   (load-foreign '("$testfilestem.so"))
   (def-alien-routine summish int (x int) (y int))
   (assert (= (summish 10 20) 31))
   (load-foreign '("$testfilestem.so"))
   (def-alien-routine summish int (x int) (y int))
   (assert (= (summish 10 20) 31))

diff --git a/tests/run-program.test.sh b/tests/run-program.test.sh
index 12d9fa4..133198e 100644 (file)
--- a/tests/run-program.test.sh
+++ b/tests/run-program.test.sh
@@ -17,9 +17,7 @@
 # one of the tests below).
 export SOMETHING_IN_THE_ENVIRONMENT='yes there is'
 
 # one of the tests below).
 export SOMETHING_IN_THE_ENVIRONMENT='yes there is'
 

-sbcl="$1"
-
-$sbcl <<EOF
+${SBCL:-sbcl} <<EOF

   (let ((string (with-output-to-string (stream)
                   (sb-ext:run-program "/bin/echo"
                                       '("foo" "bar")
   (let ((string (with-output-to-string (stream)
                   (sb-ext:run-program "/bin/echo"
                                       '("foo" "bar")

diff --git a/tests/run-tests.sh b/tests/run-tests.sh
index 7eeaf51..7e96014 100644 (file)
--- a/tests/run-tests.sh
+++ b/tests/run-tests.sh
@@ -14,7 +14,7 @@
 # more information.
 
 # how we invoke SBCL
 # more information.
 
 # how we invoke SBCL

-sbcl=${1:-../src/runtime/sbcl --core ../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --noprogrammer}
+export SBCL="${1:-../src/runtime/sbcl --core ../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --noprogrammer}"

 
 # "Ten four" is the closest numerical slang I can find to "OK", so
 # it's the Unix status value that we expect from a successful test.
 
 # "Ten four" is the closest numerical slang I can find to "OK", so
 # it's the Unix status value that we expect from a successful test.

@@ -45,7 +45,7 @@ for f in *.pure.lisp; do
     fi
 done
 echo "  (sb-ext:quit :unix-status 104)) ; Return status=success."
     fi
 done
 echo "  (sb-ext:quit :unix-status 104)) ; Return status=success."

-) | $sbcl ; tenfour
+) | $SBCL ; tenfour

 
 # *.impure.lisp files are Lisp code with side effects (e.g. doing
 # DEFSTRUCT or DEFTYPE or DEFVAR, or messing with the read table).
 
 # *.impure.lisp files are Lisp code with side effects (e.g. doing
 # DEFSTRUCT or DEFTYPE or DEFVAR, or messing with the read table).

@@ -56,7 +56,7 @@ echo //running '*.impure.lisp' tests
 for f in *.impure.lisp; do
     if [ -f $f ]; then
         echo //running $f test
 for f in *.impure.lisp; do
     if [ -f $f ]; then
         echo //running $f test

-        echo "(load \"$f\")" | $sbcl ; tenfour
+        echo "(load \"$f\")" | $SBCL ; tenfour

     fi
 done
 
     fi
 done
 

@@ -68,7 +68,7 @@ echo //running '*.test.sh' tests
 for f in *.test.sh; do
     if [ -f $f ]; then
        echo //running $f test
 for f in *.test.sh; do
     if [ -f $f ]; then
        echo //running $f test

-       sh $f "$sbcl"; tenfour
+       sh $f "$SBCL"; tenfour

     fi
 done
 
     fi
 done
 

@@ -78,7 +78,7 @@ echo //running '*.assertoids' tests
 for f in *.assertoids; do
     if [ -f $f ]; then
        echo //running $f test
 for f in *.assertoids; do
     if [ -f $f ]; then
        echo //running $f test

-       echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' ; tenfour
+       echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour

     fi
 done
 
     fi
 done
 

@@ -91,7 +91,7 @@ for f in *.pure-cload.lisp; do
     # to LOAD them all into the same Lisp.)
     if [ -f $f ]; then
        echo //running $f test
     # to LOAD them all into the same Lisp.)
     if [ -f $f ]; then
        echo //running $f test

-       $sbcl <<EOF ; tenfour
+       $SBCL <<EOF ; tenfour

                (compile-file "$f")
                (progn (load *) (sb-ext:quit :unix-status 104))
 EOF
                (compile-file "$f")
                (progn (load *) (sb-ext:quit :unix-status 104))
 EOF

@@ -105,7 +105,7 @@ echo //running '*.impure-cload.lisp' tests
 for f in *.impure-cload.lisp; do
     if [ -f $f ]; then
        echo //running $f test
 for f in *.impure-cload.lisp; do
     if [ -f $f ]; then
        echo //running $f test

-       $sbcl <<EOF ; tenfour
+       $SBCL <<EOF ; tenfour

                (compile-file "$f")
                (progn (load *) (sb-ext:quit :unix-status 104))
 EOF
                (compile-file "$f")
                (progn (load *) (sb-ext:quit :unix-status 104))
 EOF

diff --git a/tests/side-effectful-pathnames.test.sh b/tests/side-effectful-pathnames.test.sh
index 4dc3d8a..c104f52 100644 (file)
--- a/tests/side-effectful-pathnames.test.sh
+++ b/tests/side-effectful-pathnames.test.sh
@@ -1,7 +1,5 @@
 #!/bin/sh
 
 #!/bin/sh
 

-sbcl="$1"
-

 # LOADing and COMPILEing files with logical pathnames
 testdir=`pwd`"/side-effectful-pathnames-test-$$"
 testfilestem="load-test"
 # LOADing and COMPILEing files with logical pathnames
 testdir=`pwd`"/side-effectful-pathnames-test-$$"
 testfilestem="load-test"

@@ -12,7 +10,7 @@ cat >$testfilename <<EOF
   (in-package :cl-user)
   (defparameter *loaded* :yes)
 EOF
   (in-package :cl-user)
   (defparameter *loaded* :yes)
 EOF

-$sbcl <<EOF
+${SBCL:-sbcl} <<EOF

   (in-package :cl-user)
   (setf (logical-pathname-translations "TEST")
         (list (list "**;*.*.*" "$testdir/**/*.*")))
   (in-package :cl-user)
   (setf (logical-pathname-translations "TEST")
         (list (list "**;*.*.*" "$testdir/**/*.*")))

diff --git a/version.lisp-expr b/version.lisp-expr
index 2689ec3..f32bc69 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 

-"0.6.11.35"
+"0.6.11.36"