From: William Harold Newman Date: Fri, 5 Jan 2001 17:10:00 +0000 (+0000) Subject: 0.6.9.18: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=sidebyside;h=1ff04b3ba4e6f3a0fc6ceea524e98720ecea7888;hp=fa8962d732057015fbb9a2f8a08ea8d5299b50dd;p=sbcl.git 0.6.9.18: fixed stupid wrong-stream bug in %DESCRIBE-COMPILED-FROM MNA's filesys patches (from sbcl-devel 26 Dec 2000) added DEFTRANSFORM for %WITH-ARRAY-DATA en route to speeding up SORT, FIND, and other things --- diff --git a/BUGS b/BUGS index 2add6a7..a87dc33 100644 --- a/BUGS +++ b/BUGS @@ -405,12 +405,6 @@ returning an array as first value always. make sense to add another flag (CHECKED?) to DEFKNOWN to identify functions which *do* check their argument types.) -36: - As pointed out by Martin Cracauer on the CMU CL mailing list - 13 Jun 2000, the :FILE-LENGTH operation for - FD-STREAM-MISC-ROUTINE is broken for large files: it says - (THE INDEX SIZE) even though SIZE can be larger than INDEX. - 38: DEFMETHOD doesn't check the syntax of &REST argument lists properly, accepting &REST even when it's not followed by an argument name: diff --git a/NEWS b/NEWS index 4130634..b7bf019 100644 --- a/NEWS +++ b/NEWS @@ -626,12 +626,14 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: * Fasl file format version numbers have increased again, because a rearrangement of internal implementation packages made some dumped symbols in old fasl files unreadable in new cores. -?? (DECLAIM (OPTIMIZE ..)) now works. * DECLARE/DECLAIM/PROCLAIM logic is more nearly ANSI in general, with many fewer weird special cases. * Bug #17 (differing COMPILE-FILE behavior between logical and physical pathnames) has been fixed, and some related misbehavior too, thanks to a patch from Martin Atzmueller. +?? Martin Atzmueller fixed several filesystem-related problems, + including bug #36, in part by porting CMU CL patches, which were + written in part by Paul Werkowski. ?? #'(SETF DOCUMENTATION) is now defined. * More compiler warnings in src/runtime/ are gone, thanks to patches from Martin Atzmueller. diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 333aa33..8a97208 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -172,7 +172,7 @@ (ecase (sb-c::debug-source-from source) (:file (format s "~@:_~A~@:_ Created: " (namestring name)) - (sb-int:format-universal-time t (sb-c::debug-source-created + (sb-int:format-universal-time s (sb-c::debug-source-created source))) (:lisp (format s "~@:_~S" name)))))))))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 41d8d97..2832898 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -21,7 +21,8 @@ ;;;; buffer manipulation routines -;;; FIXME: Is it really good to maintain this pool separate from the GC? +;;; FIXME: Is it really good to maintain this pool separate from the +;;; GC and the C malloc logic? (defvar *available-buffers* () #!+sb-doc "List of available buffers. Each buffer is an sap pointing to @@ -45,40 +46,45 @@ (:include lisp-stream (misc #'fd-stream-misc-routine))) - (name nil) ; The name of this stream - (file nil) ; The file this stream is for - ;; The backup file namestring for the old file, for :if-exists :rename or - ;; :rename-and-delete. + ;; the name of this stream + (name nil) + ;; the file this stream is for + (file nil) + ;; the backup file namestring for the old file, for :IF-EXISTS + ;; :RENAME or :RENAME-AND-DELETE. (original nil :type (or simple-string null)) (delete-original nil) ; for :if-exists :rename-and-delete - ;;; Number of bytes per element. + ;;; the number of bytes per element (element-size 1 :type index) - (element-type 'base-char) ; The type of element being transfered. - (fd -1 :type fixnum) ; The file descriptor - ;; Controls when the output buffer is flushed. + ;; the type of element being transfered + (element-type 'base-char) + ;; the Unix file descriptor + (fd -1 :type fixnum) + ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) - ;; Character position if known. + ;; character position (if known) (char-pos nil :type (or index null)) ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) - ;; The input buffer. + + ;; the input buffer (unread nil) (ibuf-sap nil :type (or system-area-pointer null)) (ibuf-length nil :type (or index null)) (ibuf-head 0 :type index) (ibuf-tail 0 :type index) - ;; The output buffer. + ;; the output buffer (obuf-sap nil :type (or system-area-pointer null)) (obuf-length nil :type (or index null)) (obuf-tail 0 :type index) - ;; Output flushed, but not written due to non-blocking io. + ;; output flushed, but not written due to non-blocking io? (output-later nil) (handler nil) - ;; Timeout specified for this stream, or NIL if none. + ;; timeout specified for this stream, or NIL if none (timeout nil :type (or index null)) - ;; Pathname of the file this stream is opened to (returned by PATHNAME.) + ;; pathname of the file this stream is opened to (returned by PATHNAME) (pathname nil :type (or pathname null))) (def!method print-object ((fd-stream fd-stream) stream) (declare (type stream stream)) @@ -93,9 +99,10 @@ element-type output, the kind of buffering, the function name, and the number of bytes per element.") -;;; Called by the server when we can write to the given file descriptor. -;;; Attempt to write the data again. If it worked, remove the data from the -;;; output-later list. If it didn't work, something is wrong. +;;; This is called by the server when we can write to the given file +;;; descriptor. Attempt to write the data again. If it worked, remove +;;; the data from the OUTPUT-LATER list. If it didn't work, something +;;; is wrong. (defun do-output-later (stream) (let* ((stuff (pop (fd-stream-output-later stream))) (base (car stuff)) @@ -146,9 +153,9 @@ (setf (fd-stream-obuf-sap stream) new-buffer) (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) -;;; Output the given noise. Check to see whether there are any pending writes. -;;; If so, just queue this one. Otherwise, try to write it. If this would -;;; block, queue it. +;;; Output the given noise. Check to see whether there are any pending +;;; writes. If so, just queue this one. Otherwise, try to write it. If +;;; this would block, queue it. (defun do-output (stream base start end reuse-sap) (declare (type fd-stream stream) (type (or system-area-pointer (simple-array * (*))) base) @@ -275,11 +282,12 @@ (fd-stream-obuf-tail stream)) byte)) -;;; Does the actual output. If there is space to buffer the string, buffer -;;; it. If the string would normally fit in the buffer, but doesn't because -;;; of other stuff in the buffer, flush the old noise out of the buffer and -;;; put the string in it. Otherwise we have a very long string, so just -;;; send it directly (after flushing the buffer, of course). +;;; Do the actual output. If there is space to buffer the string, +;;; buffer it. If the string would normally fit in the buffer, but +;;; doesn't because of other stuff in the buffer, flush the old noise +;;; out of the buffer and put the string in it. Otherwise we have a +;;; very long string, so just send it directly (after flushing the +;;; buffer, of course). (defun output-raw-bytes (fd-stream thing &optional start end) #!+sb-doc "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If @@ -336,14 +344,14 @@ (flush-output-buffer fd-stream) (do-output fd-stream thing start end nil)))))) -;;; Routine to use to output a string. If the stream is unbuffered, slam -;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to -;;; buffer the string. Update charpos by checking to see where the last newline -;;; was. +;;; the routine to use to output a string. If the stream is +;;; unbuffered, slam the string down the file descriptor, otherwise +;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by +;;; checking to see where the last newline was. ;;; -;;; Note: some bozos (the FASL dumper) call write-string with things other -;;; than strings. Therefore, we must make sure we have a string before calling -;;; position on it. +;;; Note: some bozos (the FASL dumper) call write-string with things +;;; other than strings. Therefore, we must make sure we have a string +;;; before calling POSITION on it. ;;; KLUDGE: It would be better to fix the bozos instead of trying to ;;; cover for them here. -- WHN 20000203 (defun fd-sout (stream thing start end) @@ -377,9 +385,9 @@ (:none (do-output stream thing start end nil)))))) -;;; Find an output routine to use given the type and buffering. Return as -;;; multiple values the routine, the real type transfered, and the number of -;;; bytes per element. +;;; Find an output routine to use given the type and buffering. Return +;;; as multiple values the routine, the real type transfered, and the +;;; number of bytes per element. (defun pick-output-routine (type buffering) (dolist (entry *output-routines*) (when (and (subtypep type (car entry)) @@ -395,9 +403,9 @@ "List of all available input routines. Each element is a list of the element-type input, the function name, and the number of bytes per element.") -;;; Fills the input buffer, and returns the first character. Throws to -;;; eof-input-catcher if the eof was reached. Drops into system:server if -;;; necessary. +;;; Fill the input buffer, and return the first character. Throw to +;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER +;;; if necessary. (defun do-input (stream) (let ((fd (fd-stream-fd stream)) (ibuf-sap (fd-stream-ibuf-sap stream)) @@ -469,8 +477,8 @@ (t (incf (fd-stream-ibuf-tail stream) count)))))) -;;; Makes sure there are at least ``bytes'' number of bytes in the input -;;; buffer. Keeps calling do-input until that condition is met. +;;; Make sure there are at least BYTES number of bytes in the input +;;; buffer. Keep calling DO-INPUT until that condition is met. (defmacro input-at-least (stream bytes) (let ((stream-var (gensym)) (bytes-var (gensym))) @@ -483,9 +491,7 @@ (return)) (do-input ,stream-var))))) -;;; INPUT-WRAPPER -- intenal -;;; -;;; Macro to wrap around all input routines to handle eof-error noise. +;;; a macro to wrap around all input routines to handle EOF-ERROR noise (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms) (let ((stream-var (gensym)) (element-var (gensym))) @@ -505,7 +511,6 @@ (t (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) -;;; Defines an input routine. (defmacro def-input-routine (name (type size sap head) &rest body) @@ -519,43 +524,44 @@ (nconc *input-routines* (list (list ',type ',name ',size)))))) -;;; Routine to use in stream-in slot for reading string chars. +;;; STREAM-IN routine for reading a string char (def-input-routine input-character (character 1 sap head) (code-char (sap-ref-8 sap head))) -;;; Routine to read in an unsigned 8 bit number. +;;; STREAM-IN routine for reading an unsigned 8 bit number (def-input-routine input-unsigned-8bit-byte ((unsigned-byte 8) 1 sap head) (sap-ref-8 sap head)) -;;; Routine to read in a signed 8 bit number. +;;; STREAM-IN routine for reading a signed 8 bit number (def-input-routine input-signed-8bit-number ((signed-byte 8) 1 sap head) (signed-sap-ref-8 sap head)) -;;; Routine to read in an unsigned 16 bit number. +;;; STREAM-IN routine for reading an unsigned 16 bit number (def-input-routine input-unsigned-16bit-byte ((unsigned-byte 16) 2 sap head) (sap-ref-16 sap head)) -;;; Routine to read in a signed 16 bit number. +;;; STREAM-IN routine for reading a signed 16 bit number (def-input-routine input-signed-16bit-byte ((signed-byte 16) 2 sap head) (signed-sap-ref-16 sap head)) -;;; Routine to read in a unsigned 32 bit number. +;;; STREAM-IN routine for reading a unsigned 32 bit number (def-input-routine input-unsigned-32bit-byte ((unsigned-byte 32) 4 sap head) (sap-ref-32 sap head)) -;;; Routine to read in a signed 32 bit number. +;;; STREAM-IN routine for reading a signed 32 bit number (def-input-routine input-signed-32bit-byte ((signed-byte 32) 4 sap head) (signed-sap-ref-32 sap head)) -;;; Find an input routine to use given the type. Return as multiple values -;;; the routine, the real type transfered, and the number of bytes per element. +;;; Find an input routine to use given the type. Return as multiple +;;; values the routine, the real type transfered, and the number of +;;; bytes per element. (defun pick-input-routine (type) (dolist (entry *input-routines*) (when (subtypep type (car entry)) @@ -573,109 +579,9 @@ (* length sb!vm:byte-bits)) string)) -;;; old version, not good for implementing READ-SEQUENCE (and just complex) -;;; FIXME: Remove once new FD-STREAM-READ-N-BYTES (below) is stable. -#+nil -(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) - (declare (type stream stream) (type index start requested)) - (let* ((sap (fd-stream-ibuf-sap stream)) - (offset start) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (available (- tail head)) - (copy (min requested available))) - (declare (type index offset head tail available copy)) - (unless (zerop copy) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap (* head sb!vm:byte-bits) - buffer (* offset sb!vm:byte-bits) - (* copy sb!vm:byte-bits)) - (copy-from-system-area sap (* head sb!vm:byte-bits) - buffer (+ (* offset sb!vm:byte-bits) - (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* copy sb!vm:byte-bits))) - (incf (fd-stream-ibuf-head stream) copy)) - (cond - ((or (= copy requested) - (and (not eof-error-p) (/= copy 0))) - copy) - (t - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - (setf (fd-stream-listen stream) nil) - (let ((now-needed (- requested copy)) - (len (fd-stream-ibuf-length stream))) - (declare (type index now-needed len)) - (cond - ((> now-needed len) - ;; If the desired amount is greater than the stream buffer size, then - ;; read directly into the destination, incrementing the start - ;; accordingly. In this case, we never leave anything in the stream - ;; buffer. - (sb!sys:without-gcing - (loop - (multiple-value-bind (count err) - (sb!unix:unix-read (fd-stream-fd stream) - (sap+ (if (typep buffer - 'system-area-pointer) - buffer - (vector-sap buffer)) - (+ offset copy)) - now-needed) - (declare (type (or index null) count)) - (unless count - (error "error reading ~S: ~A" - stream - (sb!unix:get-unix-error-msg err))) - (if eof-error-p - (when (zerop count) - (error 'end-of-file :stream stream)) - (return (- requested now-needed))) - (decf now-needed count) - (when (zerop now-needed) - (return requested)) - (incf offset count))))) - (t - ;; If we want less than the buffer size, then loop trying to fill the - ;; stream buffer and copying what we get into the destination. When - ;; we have enough, we leave what's left in the stream buffer. - (loop - (multiple-value-bind (count err) - (sb!unix:unix-read (fd-stream-fd stream) sap len) - (declare (type (or index null) count)) - (unless count - (error "error reading ~S: ~A" - stream - (sb!unix:get-unix-error-msg err))) - (when (and eof-error-p (zerop count)) - (error 'end-of-file :stream stream)) - - (let* ((copy (min now-needed count)) - (copy-bits (* copy sb!vm:byte-bits)) - (buffer-start-bits - (* (+ offset available) sb!vm:byte-bits))) - (declare (type index copy copy-bits buffer-start-bits)) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap 0 - buffer buffer-start-bits - copy-bits) - (copy-from-system-area sap 0 - buffer (+ buffer-start-bits - (* sb!vm:vector-data-offset - sb!vm:word-bits)) - copy-bits)) - - (decf now-needed copy) - (when (or (zerop now-needed) (not eof-error-p)) - (setf (fd-stream-ibuf-head stream) copy) - (setf (fd-stream-ibuf-tail stream) count) - (return (- requested now-needed))) - (incf offset copy))))))))))) - -;;; the N-BIN method for FD-STREAMs. This blocks in UNIX-READ. It is generally -;;; used where there is a definite amount of reading to be done, so blocking -;;; isn't too problematical. +;;; the N-BIN method for FD-STREAMs. This blocks in UNIX-READ. It is +;;; generally used where there is a definite amount of reading to be +;;; done, so blocking isn't too problematical. (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type fd-stream stream)) (declare (type index start requested)) @@ -691,13 +597,6 @@ (sap (fd-stream-ibuf-sap stream))) (declare (type index remaining-request head tail available)) (declare (type index this-copy)) - #+nil - (format t - "/TOTAL-COPIED=~D HEAD=~D TAIL=~D THIS-COPY=~D~%" - total-copied - head - tail - this-copy) ;; Copy data from stream buffer into user's buffer. (if (typep buffer 'system-area-pointer) (system-area-copy sap (* head sb!vm:byte-bits) @@ -713,22 +612,18 @@ ;; Maybe we need to refill the stream buffer. (cond (;; If there were enough data in the stream buffer, we're done. (= total-copied requested) - #+nil - (format t "/enough data~%") (return total-copied)) (;; If EOF, we're done in another way. (zerop (refill-fd-stream-buffer stream)) - #+nil - (format t "/end of file~%") (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) - ;; Otherwise we refilled the stream buffer, so fall through into - ;; another pass of the loop. + ;; Otherwise we refilled the stream buffer, so fall + ;; through into another pass of the loop. )))) -;;; Try to refill the stream buffer. Return the number of bytes read. (For EOF, -;;; the return value will be zero, otherwise positive.) +;;; Try to refill the stream buffer. Return the number of bytes read. +;;; (For EOF, the return value will be zero, otherwise positive.) (defun refill-fd-stream-buffer (stream) ;; We don't have any logic to preserve leftover bytes in the buffer, ;; so we should only be called when the buffer is empty. @@ -755,9 +650,9 @@ ;;;; utility functions (misc routines, etc) -;;; 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) (let ((target-type (case type ((:default unsigned-byte) @@ -878,9 +773,9 @@ (setf (fd-stream-handler stream) nil)) (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream)) - ;; 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) ;; We have a handle on the original, just revert. (multiple-value-bind (okay err) @@ -891,7 +786,7 @@ "could not restore ~S to its original contents: ~A" (fd-stream-file stream) (sb!unix:get-unix-error-msg err)))) - ;; Can't restore the orignal, so nuke that puppy. + ;; We can't restore the orignal, so nuke that puppy. (multiple-value-bind (okay err) (sb!unix:unix-unlink (fd-stream-file stream)) (unless okay @@ -953,6 +848,7 @@ (:element-type (fd-stream-element-type stream)) (:interactive-p + ;; FIXME: sb!unix:unix-isatty is undefined. (sb!unix:unix-isatty (fd-stream-fd stream))) (:line-length 80) @@ -968,11 +864,9 @@ (error "error fstat'ing ~S: ~A" stream (sb!unix:get-unix-error-msg dev))) - (if (zerop (the index mode)) + (if (zerop mode) nil - ;; FIXME: It's not safe to assume that SIZE is an INDEX, there - ;; are files bigger than that. - (truncate (the index size) (fd-stream-element-size stream))))) + (truncate size (fd-stream-element-size stream))))) (:file-position (fd-stream-file-position stream arg1)))) @@ -987,20 +881,20 @@ (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr) (declare (type (or index null) posn)) (cond ((fixnump posn) - ;; Adjust for buffered output: - ;; If there is any output buffered, the *real* file position - ;; will be larger than reported by lseek because lseek - ;; obviously cannot take into account output we have not - ;; sent yet. + ;; Adjust for buffered output: If there is any output + ;; buffered, the *real* file position will be larger + ;; than reported by lseek because lseek obviously + ;; cannot take into account output we have not sent + ;; yet. (dolist (later (fd-stream-output-later stream)) (incf posn (- (the index (caddr later)) (the index (cadr later))))) (incf posn (fd-stream-obuf-tail stream)) - ;; Adjust for unread input: - ;; If there is any input read from UNIX but not supplied to - ;; the user of the stream, the *real* file position will - ;; smaller than reported, because we want to look like the - ;; unread stuff is still available. + ;; Adjust for unread input: If there is any input + ;; read from UNIX but not supplied to the user of the + ;; stream, the *real* file position will smaller than + ;; reported, because we want to look like the unread + ;; stuff is still available. (decf posn (- (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (when (fd-stream-unread stream) @@ -1016,15 +910,15 @@ (sb!unix:get-unix-error-msg errno))))))) (let ((offset 0) origin) (declare (type index offset)) - ;; Make sure we don't have any output pending, because if we move the - ;; file pointer before writing this stuff, it will be written in the - ;; wrong location. + ;; Make sure we don't have any output pending, because if we + ;; move the file pointer before writing this stuff, it will be + ;; written in the wrong location. (flush-output-buffer stream) (do () ((null (fd-stream-output-later stream))) (sb!sys:serve-all-events)) - ;; Clear out any pending input to force the next read to go to the - ;; disk. + ;; Clear out any pending input to force the next read to go to + ;; the disk. (setf (fd-stream-unread stream) nil) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) @@ -1137,9 +1031,9 @@ (return)))) item) -;;; 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. +;;; 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." @@ -1424,8 +1318,8 @@ (defun beep (&optional (stream *terminal-io*)) (funcall *beep-function* stream)) -;;; Kind of like FILE-POSITION, but is an internal hack used by the filesys -;;; stuff to get and set the file 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) (when (typep stream 'fd-stream) (cond (new-name @@ -1439,8 +1333,9 @@ ;;;; international character support (which is trivial for our simple ;;;; character sets) -;;;; (Those who do Lisp only in English might not remember that ANSI requires -;;;; these functions to be exported from package COMMON-LISP.) +;;;; (Those who do Lisp only in English might not remember that ANSI +;;;; requires these functions to be exported from package +;;;; COMMON-LISP.) (defun file-string-length (stream object) (declare (type (or string character) object) (type file-stream stream)) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index f48f9cb..af41bd5 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -166,8 +166,8 @@ (position #\. namestr :start (1+ start) :end last-dot :from-end t))) (version :newest)) - ;; If there is a second-to-last dot, check to see whether there is a valid - ;; version after the last dot. + ;; If there is a second-to-last dot, check to see whether there is + ;; a valid version after the last dot. (when second-to-last-dot (cond ((and (= (+ last-dot 2) end) (char= (schar namestr (1+ last-dot)) #\*)) @@ -199,7 +199,8 @@ (/show0 "filesys.lisp 200") ;;; Take a string and return a list of cons cells that mark the char -;;; separated subseq. The first value t if absolute directories location. +;;; separated subseq. The first value is true if absolute directories +;;; location. (defun split-at-slashes (namestr start end) (declare (type simple-base-string namestr) (type index start end)) @@ -358,7 +359,7 @@ (t (pieces "/")))) (:relative - ;; Nothing special. + ;; nothing special )) (dolist (dir directory) (typecase dir @@ -373,7 +374,8 @@ (pieces "/")) (t (error "invalid directory component: ~S" dir))))) - (apply #'concatenate 'simple-string (pieces)))) + (unless (null (pieces)) + (apply #'concatenate 'simple-string (pieces))))) (defun unparse-unix-directory (pathname) (declare (type pathname pathname)) @@ -400,7 +402,8 @@ (strings (if (eq version :wild) ".*" (format nil ".~D" version))))) - (apply #'concatenate 'simple-string (strings)))) + (unless (null (strings)) + (apply #'concatenate 'simple-string (strings))))) (/show0 "filesys.lisp 406") @@ -494,8 +497,10 @@ (/show0 "filesys.lisp 498") ;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL) + (defmacro enumerate-matches ((var pathname &optional result - &key (verify-existence t)) + &key (verify-existence t) + (follow-links t)) &body body) (let ((body-name (gensym))) `(block nil @@ -503,12 +508,13 @@ ,@body)) (%enumerate-matches (pathname ,pathname) ,verify-existence + ,follow-links #',body-name) ,result)))) (/show0 "filesys.lisp 500") -(defun %enumerate-matches (pathname verify-existence function) +(defun %enumerate-matches (pathname verify-existence follow-links function) (/show0 "entering %ENUMERATE-MATCHES") (when (pathname-type pathname) (unless (pathname-name pathname) @@ -523,46 +529,95 @@ (:absolute (/show0 "absolute directory") (%enumerate-directories "/" (cdr directory) pathname - verify-existence function)) + verify-existence follow-links + nil function)) (:relative (/show0 "relative directory") (%enumerate-directories "" (cdr directory) pathname - verify-existence function))) + verify-existence follow-links + nil function))) (%enumerate-files "" pathname verify-existence function)))) -(defun %enumerate-directories (head tail pathname verify-existence function) +(defun %enumerate-directories (head tail pathname verify-existence + follow-links nodes function) (declare (simple-string head)) - (if tail - (let ((piece (car tail))) - (etypecase piece - (simple-string - (%enumerate-directories (concatenate 'string head piece "/") - (cdr tail) pathname verify-existence - function)) - ((or pattern (member :wild :wild-inferiors)) - (let ((dir (sb!unix:open-dir head))) + (macrolet ((unix-xstat (name) + `(if follow-links + (sb!unix:unix-stat ,name) + (sb!unix:unix-lstat ,name))) + (with-directory-node-noted ((head) &body body) + `(multiple-value-bind (res dev ino mode) + (unix-xstat ,head) + (when (and res (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (let ((nodes (cons (cons dev ino) nodes))) + ,@body)))) + (do-directory-entries ((name directory) &body body) + `(let ((dir (sb!unix:open-dir ,directory))) (when dir (unwind-protect (loop - (let ((name (sb!unix:read-dir dir))) - (cond ((null name) + (let ((,name (sb!unix:read-dir dir))) + (cond ((null ,name) (return)) - ((string= name ".")) - ((string= name "..")) - ((pattern-matches piece name) - (let ((subdir (concatenate 'string - head name "/"))) - (when (eq (sb!unix:unix-file-kind subdir) - :directory) - (%enumerate-directories - subdir (cdr tail) pathname verify-existence - function))))))) - (sb!unix:close-dir dir))))) + ((string= ,name ".")) + ((string= ,name "..")) + (t + ,@body)))) + (sb!unix:close-dir dir)))))) + (if tail + (let ((piece (car tail))) + (etypecase piece + (simple-string + (let ((head (concatenate 'string head piece))) + (with-directory-node-noted (head) + (%enumerate-directories (concatenate 'string head "/") + (cdr tail) pathname + verify-existence follow-links + nodes function)))) + ((member :wild-inferiors) + (%enumerate-directories head (rest tail) pathname + verify-existence follow-links + nodes function) + (do-directory-entries (name head) + (let ((subdir (concatenate 'string head name))) + (multiple-value-bind (res dev ino mode) + (unix-xstat subdir) + (declare (type (or fixnum null) mode)) + (when (and res (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (unless (dolist (dir nodes nil) + (when (and (eql (car dir) dev) + (eql (cdr dir) ino)) + (return t))) + (let ((nodes (cons (cons dev ino) nodes)) + (subdir (concatenate 'string subdir "/"))) + (%enumerate-directories subdir tail pathname + verify-existence follow-links + nodes function)))))))) + ((or pattern (member :wild)) + (do-directory-entries (name head) + (when (or (eq piece :wild) (pattern-matches piece name)) + (let ((subdir (concatenate 'string head name))) + (multiple-value-bind (res dev ino mode) + (unix-xstat subdir) + (declare (type (or fixnum null) mode)) + (when (and res + (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (let ((nodes (cons (cons dev ino) nodes)) + (subdir (concatenate 'string subdir "/"))) + (%enumerate-directories subdir (rest tail) pathname + verify-existence follow-links + nodes function)))))))) ((member :up) - (%enumerate-directories (concatenate 'string head "../") - (cdr tail) pathname verify-existence - function)))) - (%enumerate-files head pathname verify-existence function))) + (let ((head (concatenate 'string head ".."))) + (with-directory-node-noted (head) + (%enumerate-directories (concatenate 'string head "/") + (rest tail) pathname + verify-existence follow-links + nodes function)))))) + (%enumerate-files head pathname verify-existence function)))) (defun %enumerate-files (directory pathname verify-existence function) (declare (simple-string directory)) @@ -660,16 +715,13 @@ ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical ;; pathnames too. ;; FIXME: What does this ^ mean? A bug? A remark on a change already made? - (/show0 "entering UNIX-NAMESTRING") (let ((path (let ((lpn (pathname pathname))) (if (typep lpn 'logical-pathname) (namestring (translate-logical-pathname lpn)) pathname)))) - (/show0 "PATH computed, enumerating search list") (enumerate-search-list (pathname path) (collect ((names)) - (/show0 "collecting NAMES") (enumerate-matches (name pathname nil :verify-existence for-input) (when (or (not executable-only) (and (eq (sb!unix:unix-file-kind name) @@ -677,16 +729,12 @@ (sb!unix:unix-access name sb!unix:x_ok))) (names name))) - (/show0 "NAMES collected") (let ((names (names))) (when names - (/show0 "NAMES is true.") (when (cdr names) - (/show0 "Alas! CDR NAMES") (error 'simple-file-error :format-control "~S is ambiguous:~{~% ~A~}" :format-arguments (list pathname names))) - (/show0 "returning from UNIX-NAMESTRING") (return (car names)))))))) ;;;; TRUENAME and PROBE-FILE @@ -713,22 +761,17 @@ (defun probe-file (pathname) #!+sb-doc "Return a pathname which is the truename of the file if it exists, NIL - otherwise. An error of type file-error is signaled if pathname is wild." - (/show0 "entering PROBE-FILE") + otherwise. An error of type FILE-ERROR is signaled if pathname is wild." (if (wild-pathname-p pathname) (error 'simple-file-error :pathname pathname :format-control "bad place for a wild pathname") (let ((namestring (unix-namestring pathname t))) - (/show0 "NAMESTRING computed") (when (and namestring (sb!unix:unix-file-kind namestring)) - (/show0 "NAMESTRING is promising.") (let ((truename (sb!unix:unix-resolve-links (sb!unix:unix-maybe-prepend-current-directory namestring)))) - (/show0 "TRUENAME computed") (when truename - (/show0 "TRUENAME is true.") (let ((*ignore-wildcards* t)) (pathname (sb!unix:unix-simplify-pathname truename))))))))) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index ecaaa1a..dbb9603 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -319,7 +319,7 @@ (warn "preserving current definition of redefined function ~S" name))) (t - (warn "~S is not a profiled function.")))) + (warn "~S is not a profiled function." name)))) (values)) (defmacro profile (&rest names) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index b397990..7db3ff5 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -515,11 +515,9 @@ (process-wait proc)) proc)) -;;; COPY-DESCRIPTOR-TO-STREAM -- internal -;;; -;;; Installs a handler for any input that shows up on the file descriptor. -;;; The handler reads the data and writes it to the stream. -;;; +;;; Install a handler for any input that shows up on the file +;;; descriptor. The handler reads the data and writes it to the +;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) (let ((string (make-string 256)) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 19f2aa1..2371a80 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -441,9 +441,9 @@ (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-mumble)) -;;; REPLACE cannot default end arguments to the length of sequence since it -;;; is not an error to supply nil for their values. We must test for ends -;;; being nil in the body of the function. +;;; REPLACE cannot default END arguments to the length of SEQUENCE since it +;;; is not an error to supply NIL for their values. We must test for ENDs +;;; being NIL in the body of the function. (defun replace (target-sequence source-sequence &key ((:start1 target-start) 0) ((:end1 target-end)) diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 1a674ea..443f83e 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -13,8 +13,8 @@ (defun sort (sequence predicate &key key) #!+sb-doc - "Destructively sorts sequence. Predicate should return non-Nil if - Arg1 is to precede Arg2." + "Destructively sort SEQUENCE. PREDICATE should return non-NIL if + ARG1 is to precede ARG2." (typecase sequence (simple-vector (if (> (the fixnum (length (the simple-vector sequence))) 0) @@ -30,12 +30,12 @@ (error 'simple-type-error :datum sequence :expected-type 'sequence - :format-control "~S is not a sequence." + :format-control "~S is not a SEQUENCE." :format-arguments (list sequence))))) ;;;; sorting vectors -;;; Make simple-vector and miscellaneous vector sorting functions. +;;; Make sorting functions for SIMPLE-VECTOR and miscellaneous other VECTORs. (macrolet (;; BUILD-HEAP rearranges seq elements into a heap to start heap ;; sorting. (build-heap (seq type len-1 pred key) @@ -44,12 +44,13 @@ ((minusp ,i) ,seq) (declare (fixnum ,i)) (heapify ,seq ,type ,i ,len-1 ,pred ,key)))) - ;; HEAPIFY, assuming both sons of root are heaps, percolates the - ;; root element through the sons to form a heap at root. Root and - ;; max are zero based coordinates, but the heap algorithm only works - ;; on arrays indexed from 1 through N (not 0 through N-1); This is - ;; because a root at I has sons at 2*I and 2*I+1 which does not work - ;; for a root at 0. Because of this, boundaries, roots, and + ;; HEAPIFY, assuming both sons of root are heaps, + ;; percolates the root element through the sons to form a + ;; heap at root. Root and max are zero based coordinates, + ;; but the heap algorithm only works on arrays indexed from + ;; 1 through N (not 0 through N-1); This is because a root + ;; at I has sons at 2*I and 2*I+1 which does not work for a + ;; root at 0. Because of this, boundaries, roots, and ;; termination are computed using 1..N indexes. (heapify (seq vector-ref root max pred key) (let ((heap-root (gensym)) @@ -90,11 +91,11 @@ (setf ,one-son ,heap-l-son) (setf ,one-son-ele ,r-son-ele) (setf ,one-son-key ,r-son-key)))) - ;; If greater son is less than root, then we've formed a - ;; heap again.. + ;; If greater son is less than root, then we've + ;; formed a heap again.. (if (funcall ,pred ,one-son-key ,root-key) (return)) - ;; ..else put greater son at root and make greater son - ;; node be the root. + ;; ..else put greater son at root and make + ;; greater son node be the root. (setf (,vector-ref ,seq ,var-root) ,one-son-ele) (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates) (setf ,var-root ,one-son))) ; actual index into vector for root ele @@ -137,18 +138,19 @@ ;;; stable sort of lists -;;; SORT-LIST uses a bottom up merge sort. First a pass is made over the list -;;; grabbing one element at a time and merging it with the next one form pairs -;;; of sorted elements. Then n is doubled, and elements are taken in runs of -;;; two, merging one run with the next to form quadruples of sorted elements. -;;; This continues until n is large enough that the inner loop only runs for -;;; one iteration; that is, there are only two runs that can be merged, the -;;; first run starting at the beginning of the list, and the second being the +;;; SORT-LIST uses a bottom up merge sort. First a pass is made over +;;; the list grabbing one element at a time and merging it with the +;;; next one form pairs of sorted elements. Then n is doubled, and +;;; elements are taken in runs of two, merging one run with the next +;;; to form quadruples of sorted elements. This continues until n is +;;; large enough that the inner loop only runs for one iteration; that +;;; is, there are only two runs that can be merged, the first run +;;; starting at the beginning of the list, and the second being the ;;; remaining elements. (defun sort-list (list pred key) (let ((head (cons :header list)) ; head holds on to everything - (n 1) ; bottom-up size of lists to be merged + (n 1) ; bottom-up size of lists to be merged unsorted ; unsorted is the remaining list to be ; broken into n size lists and merged list-1 ; list-1 is one length n list to be merged @@ -184,9 +186,10 @@ (t (setf (cdr last) list-1) (return))))) (setf n (ash n 1)) ; (+ n n) - ;; If the inner loop only executed once, then there were only enough - ;; elements for two runs given n, so all the elements have been merged - ;; into one list. This may waste one outer iteration to realize. + ;; If the inner loop only executed once, then there were only + ;; enough elements for two runs given n, so all the elements + ;; have been merged into one list. This may waste one outer + ;; iteration to realize. (if (eq list-1 (cdr head)) (return list-1)))))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 6f87f0b..2daa1af 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -613,20 +613,25 @@ nil) (defun write-byte (integer stream) - (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte)) - integer) + (with-out-stream stream + ;; FIXME: CMU CL had + ;; (stream-write-byte integer) + ;; which was broken unless Gray streams were installed. + ;; In order to make this work again, MNA replaced it with + ;; bare (LISP-STREAM-BOUT). Something more complicated will + ;; probably be required when Gray stream support is restored, + ;; in order to make those work too; but I dunno what it will be. + (lisp-stream-bout integer))) -;;; Stream-misc-dispatch -;;; -;;; Called from lisp-steam routines that encapsulate CLOS streams to -;;; handle the misc routines and dispatch to the appropriate Gray -;;; stream functions. +;;; This is called from lisp-steam routines that encapsulate CLOS +;;; streams to handle the misc routines and dispatch to the +;;; appropriate Gray stream functions. (defun stream-misc-dispatch (stream operation &optional arg1 arg2) (declare (type fundamental-stream stream) (ignore arg2)) (case operation (:listen - ;; Return true is input available, :eof for eof-of-file, otherwise Nil. + ;; Return true if input available, :EOF for end-of-file, otherwise NIL. (let ((char (stream-read-char-no-hang stream))) (when (characterp char) (stream-unread-char stream char)) @@ -665,7 +670,7 @@ make-broadcast-stream #!+high-security-support %make-broadcast-stream (&rest streams))) - ;; This is a list of all the streams we broadcast to. + ;; a list of all the streams we broadcast to (streams () :type list :read-only t)) #!+high-security-support @@ -949,7 +954,7 @@ :listen) (stream-misc-dispatch current :listen)))) (cond ((eq stuff :eof) - ;; Advance current, and try again. + ;; Advance CURRENT, and try again. (pop (concatenated-stream-current stream)) (setf current (car (concatenated-stream-current stream))) @@ -960,7 +965,7 @@ ;; Stuff's available. (return t)) (t - ;; Nothing available yet. + ;; Nothing is available yet. (return nil)))))) (:close (set-closed-flame stream)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 98d26db..2e22234 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -11,10 +11,10 @@ (in-package "SB!C") -;;;; Derive-Type Optimizers +;;;; DERIVE-TYPE optimizers -;;; Array operations that use a specific number of indices implicitly assert -;;; that the array is of that rank. +;;; Array operations that use a specific number of indices implicitly +;;; assert that the array is of that rank. (defun assert-array-rank (array rank) (assert-continuation-type array @@ -45,8 +45,8 @@ (assert-continuation-type new-value (array-type-element-type type)))) (continuation-type new-value)) -;;; Return true if Arg is NIL, or is a constant-continuation whose value is -;;; NIL, false otherwise. +;;; Return true if Arg is NIL, or is a constant-continuation whose +;;; value is NIL, false otherwise. (defun unsupplied-or-nil (arg) (declare (type (or continuation null) arg)) (or (not arg) @@ -425,11 +425,60 @@ ;;;; array accessors -;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR, -;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET -;;; -- source transforms. -;;; -;;; We convert all typed array accessors into aref and %aset with type +;;; Handle the 1-dimensional case of %WITH-ARRAY-DATA specially. It's +;;; important to do this efficiently if we want people to be able to +;;; use vectors with fill pointers anywhere near inner loops, and +;;; hence it's important to do this efficiently if we want people to +;;; be able to use sequence functions anywhere near inner loops. +(deftransform %with-array-data ((array start end) + (vector index index) + * + :important t + :node node + :policy (> speed space)) + "avoid full call to %WITH-ARRAY-DATA at runtime" + (let* ((element-ctype (extract-upgraded-element-type array)) + (element-type-specifier (type-specifier element-ctype)) + (simple-array-type `(simple-array ,element-type-specifier 1))) + (declare (type ctype element-ctype)) + #| + (when (eq element-type-specifier '*) + (give-up-ir1-transform + "upgraded array element type not known at compile time")) + |# + `(let* (;; FIXME: Instead of doing this hairy expression for SIZE, + ;; it should just be (ARRAY-DIMENSION ARRAY 0), and there + ;; should be a DEFTRANSFORM for ARRAY-DIMENSION which + ;; expands that way. + (size (if (array-header-p array) + (%array-dimension array 0) + (length (the ,simple-array-type array)))) + (end (if end + (if (or ,(policy node (= safety 0)) + (<= (the index end) size)) + end + (vector-data-start-out-of-range)) + size))) + (declare (type index end)) + (unless (or ,(policy node (= safety 0)) + (<= start end)) + (vector-data-end-out-of-range)) + (do (;; cumulative displacement + (d 0 (truly-the index (+ d (%array-displacement array)))) + ;; eventually becomes bare data vector + (v array (%array-data-vector v))) + ((not (array-header-p v)) + (values (the ,simple-array-type v) + (truly-the index (+ d start)) + (truly-the index (+ d end)) + (the index d))) + (declare (type index d)))))) +(defun vector-data-start-out-of-range () + (error "The start of vector data was out of range.")) +(defun vector-data-end-out-of-range () + (error "The end of vector data was out of range.")) + +;;; We convert all typed array accessors into AREF and %ASET with type ;;; assertions on the array. (macrolet ((define-frob (reffer setter type) `(progn diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index ad7d732..7204f6f 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -31,11 +31,12 @@ ;;; FIXME: centralize (declaim (special *universal-type*)) -;;; This is sorta semantically equivalent to SXHASH, but optimized for legal -;;; function names. Note: semantically equivalent does *not* mean that it -;;; always returns the same value as SXHASH, just that it satisfies the formal -;;; definition of SXHASH. The ``sorta'' is because SYMBOL-HASH will not -;;; necessarily return the same value in different lisp images. +;;; This is sorta semantically equivalent to SXHASH, but optimized for +;;; legal function names. Note: semantically equivalent does *not* +;;; mean that it always returns the same value as SXHASH, just that it +;;; satisfies the formal definition of SXHASH. The ``sorta'' is +;;; because SYMBOL-HASH will not necessarily return the same value in +;;; different lisp images. ;;; ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary ;;; SXHASH, because @@ -54,7 +55,7 @@ ;;; to hold all manner of things, e.g. (INFO :TYPE :BUILTIN ..) ;;; which is called on values like (UNSIGNED-BYTE 29). Falling through ;;; to SXHASH lets us support all manner of things (as long as they -;;; aren't used too early in cold boot). +;;; aren't used too early in cold boot for SXHASH to run). #!-sb-fluid (declaim (inline globaldb-sxhashoid)) (defun globaldb-sxhashoid (x) (cond #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.) @@ -72,13 +73,14 @@ ;;; Given any non-negative integer, return a prime number >= to it. ;;; -;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in hash-table.lisp. -;;; Perhaps the merged logic should be PRIMIFY-HASH-TABLE-SIZE, implemented as -;;; a lookup table of primes after integral powers of two: +;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in +;;; hash-table.lisp. Perhaps the merged logic should be +;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes +;;; after integral powers of two: ;;; #(17 37 67 131 ..) -;;; (Or, if that's too coarse, after half-integral powers of two.) By thus -;;; getting rid of any need for primality testing at runtime, we could -;;; punt POSITIVE-PRIMEP, too. +;;; (Or, if that's too coarse, after half-integral powers of two.) By +;;; thus getting rid of any need for primality testing at runtime, we +;;; could punt POSITIVE-PRIMEP, too. (defun primify (x) (declare (type unsigned-byte x)) (do ((n (logior x 1) (+ n 2))) @@ -128,9 +130,9 @@ ;;; a map from type numbers to TYPE-INFO objects. There is one type ;;; number for each defined CLASS/TYPE pair. ;;; -;;; We build its value at compile time (with calls to DEFINE-INFO-TYPE), then -;;; generate code to recreate the compile time value, and arrange for that -;;; code to be called in cold load. +;;; We build its value at compile time (with calls to +;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time +;;; value, and arrange for that code to be called in cold load. (defvar *info-types*) (declaim (type simple-vector *info-types*)) (eval-when (:compile-toplevel :execute) @@ -188,8 +190,8 @@ ) ; EVAL-WHEN -;;;; info classes, info types, and type numbers, part II: what's needed only at -;;;; compile time, not at run time +;;;; info classes, info types, and type numbers, part II: what's +;;;; needed only at compile time, not at run time ;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS ;;; and the calls to it) could/should go in a separate file, @@ -197,10 +199,10 @@ (eval-when (:compile-toplevel :execute) -;;; Set up the data structures to support an info class. We make sure that -;;; the class exists at compile time so that macros can use it, but don't -;;; actually store the init function until load time so that we don't break the -;;; running compiler. +;;; Set up the data structures to support an info class. We make sure +;;; that the class exists at compile time so that macros can use it, +;;; but don't actually store the init function until load time so that +;;; we don't break the running compiler. (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro define-info-class (class) @@ -209,25 +211,26 @@ Define a new class of global information." (declare (type keyword class)) `(progn - ;; (We don't need to evaluate this at load time, compile time is enough. - ;; There's special logic elsewhere which deals with cold load - ;; initialization by inspecting the info class data structures at compile - ;; time and generating code to recreate those data structures.) + ;; (We don't need to evaluate this at load time, compile time is + ;; enough. There's special logic elsewhere which deals with cold + ;; load initialization by inspecting the info class data + ;; structures at compile time and generating code to recreate + ;; those data structures.) (eval-when (:compile-toplevel :execute) (unless (gethash ,class *info-classes*) (setf (gethash ,class *info-classes*) (make-class-info ,class)))) ,class)) -;;; Find a type number not already in use by looking for a null entry in -;;; *INFO-TYPES*. +;;; Find a type number not already in use by looking for a null entry +;;; in *INFO-TYPES*. (defun find-unused-type-number () (or (position nil *info-types*) (error "no more INFO type numbers available"))) -;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO objects, -;;; accumulated during compilation and eventually converted into a function to -;;; be called at cold load time after the appropriate TYPE-INFO objects have -;;; been created +;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO +;;; objects, accumulated during compilation and eventually converted +;;; into a function to be called at cold load time after the +;;; appropriate TYPE-INFO objects have been created ;;; ;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but ;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery @@ -238,9 +241,9 @@ ;;; cold load time. (defparameter *reversed-type-info-init-forms* nil) -;;; The main thing we do is determine the type's number. We need to do this -;;; at macroexpansion time, since both the COMPILE and LOAD time calls to -;;; %DEFINE-INFO-TYPE must use the same type number. +;;; The main thing we do is determine the type's number. We need to do +;;; this at macroexpansion time, since both the COMPILE and LOAD time +;;; calls to %DEFINE-INFO-TYPE must use the same type number. (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro define-info-type (&key (class (required-argument)) @@ -259,10 +262,11 @@ (declare (type keyword class type)) `(progn (eval-when (:compile-toplevel :execute) - ;; At compile time, ensure that the type number exists. It will need - ;; to be forced to exist at cold load time, too, but that's not handled - ;; here; it's handled by later code which looks at the compile time - ;; state and generates code to replicate it at cold load time. + ;; At compile time, ensure that the type number exists. It will + ;; need to be forced to exist at cold load time, too, but + ;; that's not handled here; it's handled by later code which + ;; looks at the compile time state and generates code to + ;; replicate it at cold load time. (let* ((class-info (class-info-or-lose ',class)) (old-type-info (find-type-info ',type class-info))) (unless old-type-info @@ -273,21 +277,23 @@ :number new-type-number))) (setf (aref *info-types* new-type-number) new-type-info) (push new-type-info (class-info-types class-info))))) - ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set at cold - ;; load time. (They can't very well be set at cross-compile time, since - ;; they differ between the cross-compiler and the target. The - ;; DEFAULT slot values differ because they're compiled closures, and - ;; the TYPE slot values differ in the use of SB!XC symbols instead - ;; of CL symbols.) + ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set + ;; at cold load time. (They can't very well be set at + ;; cross-compile time, since they differ between the + ;; cross-compiler and the target. The DEFAULT slot values + ;; differ because they're compiled closures, and the TYPE slot + ;; values differ in the use of SB!XC symbols instead of CL + ;; symbols.) (push `(let ((type-info (type-info-or-lose ,',class ,',type))) (setf (type-info-default type-info) - ;; FIXME: This code is sort of nasty. It would be - ;; cleaner if DEFAULT accepted a real function, instead - ;; of accepting a statement which will be turned into a - ;; lambda assuming that the argument name is NAME. It - ;; might even be more microefficient, too, since many - ;; DEFAULTs could be implemented as (CONSTANTLY NIL) - ;; instead of full-blown (LAMBDA (X) NIL). + ;; FIXME: This code is sort of nasty. It would + ;; be cleaner if DEFAULT accepted a real + ;; function, instead of accepting a statement + ;; which will be turned into a lambda assuming + ;; that the argument name is NAME. It might + ;; even be more microefficient, too, since many + ;; DEFAULTs could be implemented as (CONSTANTLY + ;; NIL) instead of full-blown (LAMBDA (X) NIL). (lambda (name) (declare (ignorable name)) ,',default)) @@ -299,13 +305,14 @@ ;;;; generic info environments -;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping -;;; reasons. If we access with accessors for the exact type, then the inline -;;; type check will win. If the inline check didn't win, we would try to use -;;; the type system before it was properly initialized. +;;; Note: the CACHE-NAME slot is deliberately not shared for +;;; bootstrapping reasons. If we access with accessors for the exact +;;; type, then the inline type check will win. If the inline check +;;; didn't win, we would try to use the type system before it was +;;; properly initialized. (defstruct (info-env (:constructor nil)) - ;; Some string describing what is in this environment, for printing purposes - ;; only. + ;; some string describing what is in this environment, for + ;; printing/debugging purposes only (name (required-argument) :type string)) (def!method print-object ((x info-env) stream) (print-unreadable-object (x stream :type t) @@ -435,12 +442,12 @@ (defun clear-invalid-info-cache () ;; Unless the cache is valid.. (unless (eq *info-environment* *cached-info-environment*) - (;; In the target Lisp, this should be done without interrupts, but in the - ;; host Lisp when cross-compiling, we don't need to sweat it, since no - ;; affected-by-GC hashes should be used when running under the host Lisp - ;; (since that's non-portable) and since only one thread should be used - ;; when running under the host Lisp (because multiple threads are - ;; non-portable too). + (;; In the target Lisp, this should be done without interrupts, + ;; but in the host Lisp when cross-compiling, we don't need to + ;; sweat it, since no affected-by-GC hashes should be used when + ;; running under the host Lisp (since that's non-portable) and + ;; since only one thread should be used when running under the + ;; host Lisp (because multiple threads are non-portable too). #-sb-xc-host without-interrupts #+sb-xc-host progn (info-cache-clear) @@ -455,27 +462,28 @@ ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO (deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits))) -;;; This is an open hashtable with rehashing. Since modification is not -;;; allowed, we don't have to worry about deleted entries. We indirect through -;;; a parallel vector to find the index in the ENTRIES at which the entries for -;;; a given name starts. +;;; This is an open hashtable with rehashing. Since modification is +;;; not allowed, we don't have to worry about deleted entries. We +;;; indirect through a parallel vector to find the index in the +;;; ENTRIES at which the entries for a given name starts. (defstruct (compact-info-env (:include info-env) #-sb-xc-host (:pure :substructure)) - ;; If this value is EQ to the name we want to look up, then the cache hit - ;; function can be called instead of the lookup function. + ;; If this value is EQ to the name we want to look up, then the + ;; cache hit function can be called instead of the lookup function. (cache-name 0) - ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no - ;; entries. + ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has + ;; no entries. (cache-index nil :type (or compact-info-entries-index null)) - ;; Hashtable of the names in this environment. If a bucket is unused, it is - ;; 0. + ;; hashtable of the names in this environment. If a bucket is + ;; unused, it is 0. (table (required-argument) :type simple-vector) - ;; Indirection vector parallel to TABLE, translating indices in TABLE to the - ;; start of the ENTRIES for that name. Unused entries are undefined. + ;; an indirection vector parallel to TABLE, translating indices in + ;; TABLE to the start of the ENTRIES for that name. Unused entries + ;; are undefined. (index (required-argument) :type (simple-array compact-info-entries-index (*))) - ;; Vector contining in contiguous ranges the values of for all the types of - ;; info for each name. + ;; a vector contining in contiguous ranges the values of for all the + ;; types of info for each name. (entries (required-argument) :type simple-vector) ;; Vector parallel to ENTRIES, indicating the type number for the value ;; stored in that location and whether this location is the last type of info @@ -933,17 +941,18 @@ (define-info-class :function) -;;; The kind of functional object being described. If null, Name isn't a known -;;; functional object. +;;; the kind of functional object being described. If null, NAME isn't +;;; a known functional object. (define-info-type :class :function :type :kind :type-spec (member nil :function :macro :special-form) - ;; I'm a little confused what the correct behavior of this default is. It's - ;; not clear how to generalize the FBOUNDP expression to the cross-compiler. - ;; As far as I can tell, NIL is a safe default -- it might keep the compiler - ;; from making some valid optimization, but it shouldn't produce incorrect - ;; code. -- WHN 19990330 + ;; I'm a little confused what the correct behavior of this default + ;; is. It's not clear how to generalize the FBOUNDP expression to + ;; the cross-compiler. As far as I can tell, NIL is a safe default + ;; -- it might keep the compiler from making some valid + ;; optimization, but it shouldn't produce incorrect code. -- WHN + ;; 19990330 :default #+sb-xc-host nil #-sb-xc-host (if (fboundp name) :function nil)) @@ -953,31 +962,32 @@ :class :function :type :type :type-spec ctype - ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's not clear - ;; how to generalize the FBOUNDP expression to the cross-compiler. - ;; -- WHN 19990330 + ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's + ;; not clear how to generalize the FBOUNDP expression to the + ;; cross-compiler. -- WHN 19990330 :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) (extract-function-type (fdefinition name)) (specifier-type 'function))) -;;; The Assumed-Type for this function, if we have to infer the type due to not -;;; having a declaration or definition. +;;; the ASSUMED-TYPE for this function, if we have to infer the type +;;; due to not having a declaration or definition (define-info-type :class :function :type :assumed-type :type-spec (or approximate-function-type null)) -;;; Where this information came from: +;;; where this information came from: ;;; :DECLARED = from a declaration. ;;; :ASSUMED = from uses of the object. ;;; :DEFINED = from examination of the definition. -;;; FIXME: The :DEFINED assumption that the definition won't change isn't ANSI. -;;; KLUDGE: CMU CL uses function type information in a way which violates -;;; its "type declarations are assertions" principle, and SBCL has inherited -;;; that behavior. It would be really good to fix the compiler so that it -;;; tests the return types of functions.. -- WHN ca. 19990801 +;;; FIXME: The :DEFINED assumption that the definition won't change +;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way +;;; which violates its "type declarations are assertions" principle, +;;; and SBCL has inherited that behavior. It would be really good to +;;; fix the compiler so that it tests the return types of functions.. +;;; -- WHN ca. 19990801 (define-info-type :class :function :type :where-from @@ -989,65 +999,66 @@ #+sb-xc-host :assumed #-sb-xc-host (if (fboundp name) :defined :assumed)) -;;; Lambda used for inline expansion of this function. +;;; lambda used for inline expansion of this function (define-info-type :class :function :type :inline-expansion :type-spec list) -;;; Specifies whether this function may be expanded inline. If null, we -;;; don't care. +;;; This specifies whether this function may be expanded inline. If +;;; null, we don't care. (define-info-type :class :function :type :inlinep :type-spec inlinep :default nil) -;;; A macro-like function which transforms a call to this function +;;; a macro-like function which transforms a call to this function ;;; into some other Lisp form. This expansion is inhibited if inline -;;; expansion is inhibited. +;;; expansion is inhibited (define-info-type :class :function :type :source-transform :type-spec (or function null)) -;;; The macroexpansion function for this macro. +;;; the macroexpansion function for this macro (define-info-type :class :function :type :macro-function :type-spec (or function null) :default nil) -;;; The compiler-macroexpansion function for this macro. +;;; the compiler-macroexpansion function for this macro (define-info-type :class :function :type :compiler-macro-function :type-spec (or function null) :default nil) -;;; A function which converts this special form into IR1. +;;; a function which converts this special form into IR1 (define-info-type :class :function :type :ir1-convert :type-spec (or function null)) -;;; A function which gets a chance to do stuff to the IR1 for any call to this -;;; function. +;;; a function which gets a chance to do stuff to the IR1 for any call +;;; to this function. (define-info-type :class :function :type :ir1-transform :type-spec (or function null)) -;;; If a function is a slot accessor or setter, then this is the class that it -;;; accesses slots of. +;;; If a function is a slot accessor or setter, then this is the class +;;; that it accesses slots of. (define-info-type :class :function :type :accessor-for :type-spec (or sb!xc:class null) :default nil) -;;; If a function is "known" to the compiler, then this is FUNCTION-INFO -;;; structure containing the info used to special-case compilation. +;;; If a function is "known" to the compiler, then this is a +;;; FUNCTION-INFO structure containing the info used to special-case +;;; compilation. (define-info-type :class :function :type :info @@ -1137,36 +1148,37 @@ :type :documentation :type-spec (or string null)) -;;; Function that parses type specifiers into CTYPE structures. +;;; function that parses type specifiers into CTYPE structures (define-info-type :class :type :type :translator :type-spec (or function null) :default nil) -;;; If true, then the type coresponding to this name. Note that if this is a -;;; built-in class with a translation, then this is the translation, not the -;;; class object. This info type keeps track of various atomic types (NIL etc.) -;;; and also serves as a cache to ensure that common standard types (atomic and -;;; otherwise) are only consed once. +;;; If true, then the type coresponding to this name. Note that if +;;; this is a built-in class with a translation, then this is the +;;; translation, not the class object. This info type keeps track of +;;; various atomic types (NIL etc.) and also serves as a cache to +;;; ensure that common standard types (atomic and otherwise) are only +;;; consed once. (define-info-type :class :type :type :builtin :type-spec (or ctype null) :default nil) -;;; If this is a class name, then the value is a cons (Name . Class), where -;;; Class may be null if the class hasn't been defined yet. Note that for -;;; built-in classes, the kind may be :PRIMITIVE and not :INSTANCE. The -;;; the name is in the cons so that we can signal a meaningful error if we only -;;; have the cons. +;;; If this is a class name, then the value is a cons (NAME . CLASS), +;;; where CLASS may be null if the class hasn't been defined yet. Note +;;; that for built-in classes, the kind may be :PRIMITIVE and not +;;; :INSTANCE. The the name is in the cons so that we can signal a +;;; meaningful error if we only have the cons. (define-info-type :class :type :type :class :type-spec (or sb!kernel::class-cell null) :default nil) -;;; Layout for this type being used by the compiler. +;;; layout for this type being used by the compiler (define-info-type :class :type :type :compiler-layout @@ -1239,8 +1251,8 @@ :type-spec (or function null) :default nil) -;;; Used for storing miscellaneous documentation types. The stuff is an alist -;;; translating documentation kinds to values. +;;; This is used for storing miscellaneous documentation types. The +;;; stuff is an alist translating documentation kinds to values. (define-info-class :random-documentation) (define-info-type :class :random-documentation @@ -1250,18 +1262,13 @@ #!-sb-fluid (declaim (freeze-type info-env)) -;;; Now that we have finished initializing *INFO-CLASSES* and *INFO-TYPES* (at -;;; compile time), generate code to set them at cold load time to the same -;;; state they have currently. +;;; Now that we have finished initializing *INFO-CLASSES* and +;;; *INFO-TYPES* (at compile time), generate code to set them at cold +;;; load time to the same state they have currently. (!cold-init-forms (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE") (setf *info-classes* - (make-hash-table :size #.(hash-table-size *info-classes*) - ;; FIXME: These remaining arguments are only here - ;; for debugging, to try track down weird cold - ;; boot problems. - #|:rehash-size 1.5 - :rehash-threshold 1|#)) + (make-hash-table :size #.(hash-table-size *info-classes*))) (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init") (dolist (class-info-name '#.(let ((result nil)) (maphash (lambda (key value) @@ -1295,8 +1302,8 @@ *info-types*))) (/show0 "done with *INFO-TYPES* initialization")) -;;; At cold load time, after the INFO-TYPE objects have been created, we can -;;; set their DEFAULT and TYPE slots. +;;; At cold load time, after the INFO-TYPE objects have been created, +;;; we can set their DEFAULT and TYPE slots. (macrolet ((frob () `(!cold-init-forms ,@(reverse *reversed-type-info-init-forms*)))) @@ -1309,11 +1316,11 @@ ;;;; ..) ;;;; (DEFSETF BAR SET-BAR) ; can't influence previous compilation ;;;; -;;;; KLUDGE: Arguably it should be another class/type combination in the -;;;; globaldb. However, IMHO the whole globaldb/fdefinition treatment of setf -;;;; functions is a mess which ought to be rewritten, and I'm not inclined to -;;;; mess with it short of that. So I just put this bag on the side of it -;;;; instead.. +;;;; KLUDGE: Arguably it should be another class/type combination in +;;;; the globaldb. However, IMHO the whole globaldb/fdefinition +;;;; treatment of SETF functions is a mess which ought to be +;;;; rewritten, and I'm not inclined to mess with it short of that. So +;;;; I just put this bag on the side of it instead.. ;;; true for symbols FOO which have been assumed to have '(SETF FOO) ;;; bound to a function diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp new file mode 100644 index 0000000..24c1dfb --- /dev/null +++ b/tests/filesys.pure.lisp @@ -0,0 +1,36 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "CL-USER") + +;;; In sbcl-0.6.9 FOO-NAMESTRING functions returned "" instead of NIL. +(let ((pathname0 (make-pathname :host nil + :directory + (pathname-directory + *default-pathname-defaults*) + :name "getty")) + (pathname1 (make-pathname :host nil + :directory nil + :name nil))) + (assert (equal (file-namestring pathname0) "getty")) + (assert (null (directory-namestring pathname0))) + (assert (null (file-namestring pathname1))) + (assert (null (directory-namestring pathname1)))) + +;;; In sbcl-0.6.9 DIRECTORY failed on paths with :WILD or +;;; :WILD-INFERIORS in their directory components. +(let ((dir (directory "../**/*"))) + ;; We know a little bit about the structure of this result; + ;; let's test to make sure that this test file is in it. + (assert (find-if (lambda (pathname) + (search "tests/filesys.pure.lisp" + (namestring pathname))) + dir2))) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 7fd7e3a..e9867e8 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -16,11 +16,9 @@ (in-package "CL-USER") -;;(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro grab-condition (&body body) - `(nth-value 1 - (ignore-errors ,@body))) -;;) +(defmacro grab-condition (&body body) + `(nth-value 1 + (ignore-errors ,@body))) (setf (logical-pathname-translations "demo0") '(("**;*.*.*" "/tmp/"))) diff --git a/version.lisp-expr b/version.lisp-expr index 9e9adf0..b19bbb7 100644 --- 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. -"0.6.9.17" +"0.6.9.18"