From f0338f6fa732b21daa4405e19465bd460e0526d9 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 15 Apr 2001 00:24:44 +0000 Subject: [PATCH] 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 --- BUGS | 10 + NEWS | 10 +- doc/beyond-ansi.sgml | 2 +- make.sh | 9 +- package-data-list.lisp-expr | 11 +- src/code/array.lisp | 9 +- src/code/debug.lisp | 32 +-- src/code/fd-stream.lisp | 482 ++++++++++++++------------------ src/code/globals.lisp | 2 +- src/code/late-target-error.lisp | 18 +- src/code/query.lisp | 2 - src/code/toplevel.lisp | 70 +++-- tests/foreign.test.sh | 4 +- tests/run-program.test.sh | 4 +- tests/run-tests.sh | 14 +- tests/side-effectful-pathnames.test.sh | 4 +- version.lisp-expr | 2 +- 17 files changed, 340 insertions(+), 345 deletions(-) diff --git a/BUGS b/BUGS index 417a40d..ad30c7b 100644 --- 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. +97: + FRESH-LINE doesn't seem to work properly within pretty-printed + output. E.g. + "~@~2%" + called on a CONDITION whose printer does + "~&~@" + 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 diff --git a/NEWS b/NEWS index 4c333e8..72937c0 100644 --- 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.) -?? 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 - 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 @@ -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 +* 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) diff --git a/doc/beyond-ansi.sgml b/doc/beyond-ansi.sgml index a3d7eea..ff1cce5 100644 --- 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, -debugger invoked on SB-DEBUG::*DEBUG-CONDITION* of type +debugger invoked on SB-DEBUG:*DEBUG-CONDITION* of type SB-KERNEL:SIMPLE-CONTROL-ERROR: A function with declared result type NIL returned: FOO-P diff --git a/make.sh b/make.sh index 4d338db..ea3c12c 100755 --- 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 -# 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 --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 @@ -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?) -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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 499c353..098a02c 100644 --- 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" - "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" @@ -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" - "*BEEP-FUNCTION*" "*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" - "BEEP" "BITS" "STRUCTURE!OBJECT" - "STRUCTURE!OBJECT-MAKE-LOAD-FORM" + "BEEP" "BITS" "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" - "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" diff --git a/src/code/array.lisp b/src/code/array.lisp index b8a9fcd..1edce29 100644 --- 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)) - :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) @@ -641,7 +640,7 @@ (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) @@ -678,7 +677,7 @@ (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)) @@ -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 ~ - 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) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 3186f17..9f71712 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -582,18 +582,6 @@ Function and macro commands: (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." @@ -645,16 +633,22 @@ reset to ~S." ;; 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, - ;; 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&~@~%" + (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 diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 0881f04..3d0e8b7 100644 --- 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 - (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 @@ -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. -(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)) @@ -667,30 +665,30 @@ (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)) - (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) - (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) - (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 - (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) @@ -698,26 +696,26 @@ (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" - (fd-stream-buffering stream) + (fd-stream-buffering fd-stream) 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) - (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 - (fd-stream-buffering stream))) + (fd-stream-buffering fd-stream))) #'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)) - (setf (fd-stream-char-pos stream) 0) + (setf (fd-stream-char-pos fd-stream) 0) (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)) - (setf (fd-stream-element-size stream) + (setf (fd-stream-element-size fd-stream) (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) @@ -745,131 +743,129 @@ 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)) - ;; FIXME: Declare TYPE FD-STREAM STREAM? (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) - (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 - (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. - (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. - (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) - (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 - (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 "~@" + (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) - (sb!unix:unix-unlink (fd-stream-file stream)) + (sb!unix:unix-unlink (fd-stream-file fd-stream)) (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 "~@" + (fd-stream-file fd-stream) + (sb!unix:get-unix-error-msg err))))))) (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) - (sb!unix:unix-unlink (fd-stream-original stream)) + (sb!unix:unix-unlink (fd-stream-original fd-stream)) (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 "~@" + (fd-stream-original fd-stream) + fd-stream + (sb!unix:get-unix-error-msg err))))))) (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 - (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) - (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) - (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 - (flush-output-buffer stream)) + (flush-output-buffer fd-stream)) (:finish-output - (flush-output-buffer stream) + (flush-output-buffer fd-stream) (do () - ((null (fd-stream-output-later stream))) + ((null (fd-stream-output-later fd-stream))) (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. - (sb!unix:unix-isatty (fd-stream-fd stream))) + (sb!unix:unix-isatty (fd-stream-fd fd-stream))) (: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) - (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 - (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 - (truncate size (fd-stream-element-size stream))))) + (truncate size (fd-stream-element-size fd-stream))))) (: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) @@ -948,7 +944,23 @@ ;;;; 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) @@ -967,17 +979,6 @@ 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)) @@ -990,7 +991,7 @@ :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 () @@ -1000,54 +1001,35 @@ 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)) - (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) - (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) - (cerror "Try to rename it anyway." - "File ~S is not writable." - namestring)) + (error "~@" namestring)) (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 "~@" + namestring + original + (sb!unix:get-unix-error-msg err)) nil)))) (defun open (filename @@ -1062,28 +1044,22 @@ (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: - :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) - (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) @@ -1105,12 +1081,11 @@ (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))) @@ -1133,10 +1108,9 @@ 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))) @@ -1183,87 +1157,67 @@ 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 "~@" + pathname + (sb!unix:get-unix-error-msg errno)))) (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 - (: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 - (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 + "~@" + pathname)) + (t nil))) + ((and (eql errno sb!unix:eexist) if-exists) + nil) (t - (cerror "Return NIL." - "error opening ~S: ~A" - pathname - (sb!unix:get-unix-error-msg errno)) - (return nil))))))))) + (vanilla-open-error))))))))) ;;;; 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. @@ -1273,8 +1227,8 @@ (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*) @@ -1283,7 +1237,7 @@ (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 () @@ -1304,21 +1258,15 @@ :buffering :line :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) - nil) + (values)) -;;;; 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)) -(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)) - ;;; 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 - 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 diff --git a/src/code/globals.lisp b/src/code/globals.lisp index 2ca7e36..c6f9f36 100644 --- 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* - *beep-function* *gc-notify-before* *gc-notify-after* + *gc-notify-before* *gc-notify-after* *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 --- 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) - (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 @@ -562,7 +564,13 @@ (defun print-simple-error (condition stream) (format stream - "~&~@" + ;; 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. + "~@" (condition-function-name condition) (simple-condition-format-control condition) (simple-condition-format-arguments condition))) @@ -584,7 +592,7 @@ (:report (lambda (condition stream) (format stream - "~@." + "~@." (condition-function-name condition) (type-error-datum condition) (type-error-expected-type condition))))) @@ -607,7 +615,7 @@ (:report (lambda (condition stream) (format stream - "~&~@" + "~@" (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 --- 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*))))))) -;;; 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 diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index cd1c923..47a1efe 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -233,6 +233,8 @@ ;;;; 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") @@ -298,10 +300,13 @@ (/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") @@ -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 - ;; 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") - ;; 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) + ;; 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. @@ -416,15 +429,6 @@ (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)))) @@ -474,6 +478,36 @@ (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* + "~@~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))))) ;;; 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 --- 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. -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 -$sbcl <$testfilename <