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:
* 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.
(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))))))))))
\f
;;;; 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
(: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))
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))
(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)
(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
(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)
(: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))
"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))
(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)))
(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)))
(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)
(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))
(* 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))
(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)
;; 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.
\f
;;;; 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)
(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)
"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
(: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)
(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))))
(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)
(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)
(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."
(defun beep (&optional (stream *terminal-io*))
(funcall *beep-function* stream))
\f
-;;; 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
;;;; 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))
(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)) #\*))
(/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))
(t
(pieces "/"))))
(:relative
- ;; Nothing special.
+ ;; nothing special
))
(dolist (dir directory)
(typecase dir
(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))
(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")
(/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
,@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)
(: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))
;; 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)
(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))))))))
\f
;;;; TRUENAME and PROBE-FILE
(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)))))))))
\f
(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)
(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))
(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))
(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)
(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)))))
\f
;;;; 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)
((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))
(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
;;; 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
(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))))))
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)))
\f
-;;; 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))
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
: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)))
;; Stuff's available.
(return t))
(t
- ;; Nothing available yet.
+ ;; Nothing is available yet.
(return nil))))))
(:close
(set-closed-flame stream))
(in-package "SB!C")
\f
-;;;; 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
(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)
\f
;;;; 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
;;; 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
;;; 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.)
;;; 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)))
;;; 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)
) ; EVAL-WHEN
\f
-;;;; 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,
(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)
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
;;; 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))
(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
: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))
\f
;;;; 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)
(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)
;;; 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
(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))
: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
#+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
: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
: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
#!-sb-fluid (declaim (freeze-type info-env))
\f
-;;; 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)
*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*))))
;;;; ..)
;;;; (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
--- /dev/null
+;;;; 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)))
(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/")))
;;; 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"
projects / sbcl.git / commitdiff