core, and restored on startup.
* improvement: GET-INTERNAL-REAL-TIME now reports the time since
startup, not time since first call to GET-INTERNAL-REAL-TIME.
+ * bug fix: compiler bug triggered by a (non-standard) VALUES
+ declaration in a LET* was fixed.
* improvements to the Windows port:
** floating point exceptions are now reported correctly.
** stack exhaustion detection works partially.
** more accurate GET-INTERNAL-REAL-TIME.
** better RUN-PROGRAM behaviour in case of errors in the child
process.
+ ** PROBE-FILE now simplifies pathnames correctly.
+ ** DIRECTORY now works correctly with :WILD-INFERIORS.
changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.17:
* enhancement: SB-POSIX now supports cfsetispeed(3), cfsetospeed(3),
:name "SB!INT"
:doc
"private: miscellaneous unsupported extensions to the ANSI spec. Much of
-the stuff in here originated in CMU CL's EXTENSIONS package and is
-retained, possibly temporariliy, because it might be used internally."
+the stuff in here originated in CMU CL's EXTENSIONS package and is retained,
+possibly temporariliy, because it might be used internally."
:use ("CL" "SB!ALIEN" "SB!GRAY" "SB!FASL" "SB!SYS")
:export (;; lambda list keyword extensions
"&MORE"
"PHYSICALIZE-PATHNAME"
"SANE-DEFAULT-PATHNAME-DEFAULTS"
"SBCL-HOMEDIR-PATHNAME"
+ "SIMPLIFY-NAMESTRING"
;; PCOUNTERs
"FASTBIG-INCF-PCOUNTER-OR-FIXNUM"
"UNIX-FILE-KIND" "UNIX-KILL" "CODESET"
"TCSETPGRP" "FD-ZERO" "FD-CLR" "CHECK" "UNIX-RESOLVE-LINKS"
"FD-SETSIZE" "TCGETPGRP" "UNIX-FAST-GETRUSAGE"
- "UNIX-SIMPLIFY-PATHNAME" "UNIX-KILLPG"
+ "UNIX-KILLPG"
"TIOCSIGSEND"
"C-IFLAG" "C-LFLAG" "C-OFLAG"
"C-CFLAG" "TCSAFLUSH" "C-CC" "SIOCSPGRP" "TERMIOS"
follow-links nodes function
&aux (host (pathname-host pathname)))
(declare (simple-string head))
+ #!+win32
+ (setf follow-links nil)
(macrolet ((unix-xstat (name)
`(if follow-links
(sb!unix:unix-stat ,name)
sb!unix:s-ifdir))
(unless (dolist (dir nodes nil)
(when (and (eql (car dir) dev)
+ #!+win32 ;; KLUDGE
+ (not (zerop ino))
(eql (cdr dir) ino))
(return t)))
(let ((nodes (cons (cons dev ino) nodes))
(defun truename (pathname)
#!+sb-doc
"Return the pathname for the actual file described by PATHNAME.
- An error of type FILE-ERROR is signalled if no such file exists,
- or the pathname is wild.
+An error of type FILE-ERROR is signalled if no such file exists, or the
+pathname is wild.
- Under Unix, the TRUENAME of a broken symlink is considered to be
- the name of the broken symlink itself."
+Under Unix, the TRUENAME of a broken symlink is considered to be the name of
+the broken symlink itself."
(let ((result (probe-file pathname)))
(unless result
(error 'simple-file-error
(defun probe-file (pathname)
#!+sb-doc
"Return a pathname which is the truename of the file if it exists, or NIL
- otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
+otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
(let* ((defaulted-pathname (merge-pathnames
pathname
(sane-default-pathname-defaults)))
(let ((trueishname (sb!unix:unix-resolve-links namestring)))
(when trueishname
(let* ((*ignore-wildcards* t)
- (name (sb!unix:unix-simplify-pathname trueishname)))
+ (name (simplify-namestring
+ trueishname
+ (pathname-host defaulted-pathname))))
(if (eq (sb!unix:unix-file-kind name) :directory)
;; FIXME: this might work, but it's ugly.
(pathname (concatenate 'string name "/"))
;; grounds that the implementation should have repeatable
;; behavior when possible.
(sort (loop for name being each hash-key in truenames
- using (hash-value truename)
- collect (cons name truename))
+ using (hash-value truename)
+ collect (cons name truename))
#'string<
:key #'car))))
\f
(unparse-file (missing-arg) :type function)
(unparse-enough (missing-arg) :type function)
(unparse-directory-separator (missing-arg) :type simple-string)
+ (simplify-namestring (missing-arg) :type function)
(customary-case (missing-arg) :type (member :upper :lower)))
(def!method print-object ((host host) stream)
(unparse-file #'unparse-logical-file)
(unparse-enough #'unparse-enough-namestring)
(unparse-directory-separator ";")
+ (simplify-namestring #'identity)
(customary-case :upper)))
(name "" :type simple-string)
(translations nil :type list)
(unparse-file #'unparse-unix-file)
(unparse-enough #'unparse-unix-enough)
(unparse-directory-separator "/")
+ (simplify-namestring #'simplify-unix-namestring)
(customary-case :lower))))
(defvar *unix-host* (make-unix-host))
(defun make-unix-host-load-form (host)
(unparse-file #'unparse-win32-file)
(unparse-enough #'unparse-win32-enough)
(unparse-directory-separator "\\")
+ (simplify-namestring #'simplify-win32-namestring)
(customary-case :upper))))
-(defvar *win32-host* (make-win32-host))
+(defparameter *win32-host* (make-win32-host))
(defun make-win32-host-load-form (host)
(declare (ignore host))
'*win32-host*)
(error "~S is not allowed as a directory component." piece))))
(results)))
(simple-string
- `(:absolute
- ,(maybe-diddle-case directory diddle-case)))
+ `(:absolute ,(maybe-diddle-case directory diddle-case)))
(string
`(:absolute
- ,(maybe-diddle-case (coerce directory 'simple-string)
- diddle-case)))))
+ ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case)))))
(defun make-pathname (&key host
(device nil devp)
(let* ((end (%check-vector-sequence-bounds namestr start end)))
(multiple-value-bind (new-host device directory file type version)
(cond
- (host (funcall (host-parse-native host) namestr start end))
+ (host
+ (funcall (host-parse-native host) namestr start end))
((pathname-host defaults)
(funcall (host-parse-native (pathname-host defaults))
namestr
;;;; utilities
+(defun simplify-namestring (namestring &optional host)
+ (funcall (host-simplify-namestring
+ (or host
+ (pathname-host (sane-default-pathname-defaults))))
+ namestring))
+
;;; Canonicalize a logical pathname word by uppercasing it checking that it
;;; contains only legal characters.
(defun logical-word-or-lose (word)
;; FIXME: now that we have a SYS host that the system uses, it
;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
(error "logical host ~S not found" host)))
+
(defun sysinit-pathname ()
(or (let ((sbcl-homedir (sbcl-homedir-pathname)))
(when sbcl-homedir
- (probe-file (merge-pathnames sbcl-homedir "sbclrc"))))
+ (probe-file (merge-pathnames "sbclrc" sbcl-homedir))))
#!+win32
(merge-pathnames "sbcl\\sbclrc"
(sb!win32::get-folder-pathname
(strings ".")
(strings (unparse-unix-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
+
+(defun simplify-unix-namestring (src)
+ (declare (type simple-string src))
+ (let* ((src-len (length src))
+ (dst (make-string src-len :element-type 'character))
+ (dst-len 0)
+ (dots 0)
+ (last-slash nil))
+ (macrolet ((deposit (char)
+ `(progn
+ (setf (schar dst dst-len) ,char)
+ (incf dst-len))))
+ (dotimes (src-index src-len)
+ (let ((char (schar src src-index)))
+ (cond ((char= char #\.)
+ (when dots
+ (incf dots))
+ (deposit char))
+ ((char= char #\/)
+ (case dots
+ (0
+ ;; either ``/...' or ``...//...'
+ (unless last-slash
+ (setf last-slash dst-len)
+ (deposit char)))
+ (1
+ ;; either ``./...'' or ``..././...''
+ (decf dst-len))
+ (2
+ ;; We've found ..
+ (cond
+ ((and last-slash (not (zerop last-slash)))
+ ;; There is something before this ..
+ (let ((prev-prev-slash
+ (position #\/ dst :end last-slash :from-end t)))
+ (cond ((and (= (+ (or prev-prev-slash 0) 2)
+ last-slash)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (char= (schar dst (1- last-slash)) #\.))
+ ;; The something before this .. is another ..
+ (deposit char)
+ (setf last-slash dst-len))
+ (t
+ ;; The something is some directory or other.
+ (setf dst-len
+ (if prev-prev-slash
+ (1+ prev-prev-slash)
+ 0))
+ (setf last-slash prev-prev-slash)))))
+ (t
+ ;; There is nothing before this .., so we need to keep it
+ (setf last-slash dst-len)
+ (deposit char))))
+ (t
+ ;; something other than a dot between slashes
+ (setf last-slash dst-len)
+ (deposit char)))
+ (setf dots 0))
+ (t
+ (setf dots nil)
+ (setf (schar dst dst-len) char)
+ (incf dst-len))))))
+ (when (and last-slash (not (zerop last-slash)))
+ (case dots
+ (1
+ ;; We've got ``foobar/.''
+ (decf dst-len))
+ (2
+ ;; We've got ``foobar/..''
+ (unless (and (>= last-slash 2)
+ (char= (schar dst (1- last-slash)) #\.)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (or (= last-slash 2)
+ (char= (schar dst (- last-slash 3)) #\/)))
+ (let ((prev-prev-slash
+ (position #\/ dst :end last-slash :from-end t)))
+ (if prev-prev-slash
+ (setf dst-len (1+ prev-prev-slash))
+ (return-from simplify-unix-namestring
+ (coerce "./" 'simple-string))))))))
+ (cond ((zerop dst-len)
+ "./")
+ ((= dst-len src-len)
+ dst)
+ (t
+ (subseq dst 0 dst-len)))))
(if (null link)
(return pathname)
(let ((new-pathname
- (unix-simplify-pathname
+ (simplify-namestring
(if (relative-unix-pathname? link)
(let* ((dir-len (1+ (position #\/
pathname
(if (member pathname previous-pathnames :test #'string=)
(return pathname)
(push pathname previous-pathnames))))
-
-(defun unix-simplify-pathname (src)
- (declare (type simple-string src))
- (let* ((src-len (length src))
- (dst (make-string src-len :element-type 'character))
- (dst-len 0)
- (dots 0)
- (last-slash nil))
- (macrolet ((deposit (char)
- `(progn
- (setf (schar dst dst-len) ,char)
- (incf dst-len))))
- (dotimes (src-index src-len)
- (let ((char (schar src src-index)))
- (cond ((char= char #\.)
- (when dots
- (incf dots))
- (deposit char))
- ((char= char #\/)
- (case dots
- (0
- ;; either ``/...' or ``...//...'
- (unless last-slash
- (setf last-slash dst-len)
- (deposit char)))
- (1
- ;; either ``./...'' or ``..././...''
- (decf dst-len))
- (2
- ;; We've found ..
- (cond
- ((and last-slash (not (zerop last-slash)))
- ;; There is something before this ..
- (let ((prev-prev-slash
- (position #\/ dst :end last-slash :from-end t)))
- (cond ((and (= (+ (or prev-prev-slash 0) 2)
- last-slash)
- (char= (schar dst (- last-slash 2)) #\.)
- (char= (schar dst (1- last-slash)) #\.))
- ;; The something before this .. is another ..
- (deposit char)
- (setf last-slash dst-len))
- (t
- ;; The something is some directory or other.
- (setf dst-len
- (if prev-prev-slash
- (1+ prev-prev-slash)
- 0))
- (setf last-slash prev-prev-slash)))))
- (t
- ;; There is nothing before this .., so we need to keep it
- (setf last-slash dst-len)
- (deposit char))))
- (t
- ;; something other than a dot between slashes
- (setf last-slash dst-len)
- (deposit char)))
- (setf dots 0))
- (t
- (setf dots nil)
- (setf (schar dst dst-len) char)
- (incf dst-len))))))
- (when (and last-slash (not (zerop last-slash)))
- (case dots
- (1
- ;; We've got ``foobar/.''
- (decf dst-len))
- (2
- ;; We've got ``foobar/..''
- (unless (and (>= last-slash 2)
- (char= (schar dst (1- last-slash)) #\.)
- (char= (schar dst (- last-slash 2)) #\.)
- (or (= last-slash 2)
- (char= (schar dst (- last-slash 3)) #\/)))
- (let ((prev-prev-slash
- (position #\/ dst :end last-slash :from-end t)))
- (if prev-prev-slash
- (setf dst-len (1+ prev-prev-slash))
- (return-from unix-simplify-pathname
- (coerce "./" 'simple-string))))))))
- (cond ((zerop dst-len)
- "./")
- ((= dst-len src-len)
- dst)
- (t
- (subseq dst 0 dst-len)))))
-
\f
;;; UNIX specific code, that has been cleanly separated from the
;;; Windows build.
;; Next, split the remainder into slash-separated chunks.
(collect ((pieces))
(loop
- (let ((slash (position-if (lambda (c)
- (or (char= c #\/)
- (char= c #\\)))
- namestr :start start :end end)))
- (pieces (cons start (or slash end)))
- (unless slash
- (return))
- (setf start (1+ slash))))
+ (let ((slash (position-if (lambda (c)
+ (or (char= c #\/)
+ (char= c #\\)))
+ namestr :start start :end end)))
+ (pieces (cons start (or slash end)))
+ (unless slash
+ (return))
+ (setf start (1+ slash))))
(values absolute (pieces)))))
(defun parse-win32-namestring (namestring start end)
for piece = (subseq namestring start end)
collect (if (and (string= piece "..") rest)
:up
- piece)))
+ piece)))
(name-and-type
(let* ((end (first (last components)))
(dot (position #\. end :from-end t)))
(unless directory (go :done))
:subdir
(let ((piece (pop directory)))
- (typecase piece
+ (typecase piece
((member :up) (write-string ".." s))
(string (write-string piece s))
- (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))))
+ (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+ (when (or directory name type)
+ (write-char #\\ s)))
(when directory
- (write-char #\\ s)
(go :subdir))
:done)
(when name
(unless (stringp name)
(error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
- (write-char #\\ s)
(write-string name s)
(when type
(unless (stringp type)
(strings ".")
(strings (unparse-unix-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
+
+;; FIXME: This has been converted rather blindly from the Unix
+;; version, with no reference to any Windows docs what so ever.
+(defun simplify-win32-namestring (src)
+ (declare (type simple-string src))
+ (let* ((src-len (length src))
+ (dst (make-string src-len :element-type 'character))
+ (dst-len 0)
+ (dots 0)
+ (last-slash nil))
+ (flet ((deposit (char)
+ (setf (schar dst dst-len) char)
+ (incf dst-len))
+ (slashp (char)
+ (find char "\\/")))
+ (dotimes (src-index src-len)
+ (let ((char (schar src src-index)))
+ (cond ((char= char #\.)
+ (when dots
+ (incf dots))
+ (deposit char))
+ ((slashp char)
+ (case dots
+ (0
+ ;; either ``/...' or ``...//...'
+ (unless last-slash
+ (setf last-slash dst-len)
+ (deposit char)))
+ (1
+ ;; either ``./...'' or ``..././...''
+ (decf dst-len))
+ (2
+ ;; We've found ..
+ (cond
+ ((and last-slash (not (zerop last-slash)))
+ ;; There is something before this ..
+ (let ((prev-prev-slash
+ (position-if #'slashp dst :end last-slash :from-end t)))
+ (cond ((and (= (+ (or prev-prev-slash 0) 2)
+ last-slash)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (char= (schar dst (1- last-slash)) #\.))
+ ;; The something before this .. is another ..
+ (deposit char)
+ (setf last-slash dst-len))
+ (t
+ ;; The something is some directory or other.
+ (setf dst-len
+ (if prev-prev-slash
+ (1+ prev-prev-slash)
+ 0))
+ (setf last-slash prev-prev-slash)))))
+ (t
+ ;; There is nothing before this .., so we need to keep it
+ (setf last-slash dst-len)
+ (deposit char))))
+ (t
+ ;; something other than a dot between slashes
+ (setf last-slash dst-len)
+ (deposit char)))
+ (setf dots 0))
+ (t
+ (setf dots nil)
+ (setf (schar dst dst-len) char)
+ (incf dst-len)))))
+ ;; ...finish off
+ (when (and last-slash (not (zerop last-slash)))
+ (case dots
+ (1
+ ;; We've got ``foobar/.''
+ (decf dst-len))
+ (2
+ ;; We've got ``foobar/..''
+ (unless (and (>= last-slash 2)
+ (char= (schar dst (1- last-slash)) #\.)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (or (= last-slash 2)
+ (slashp (schar dst (- last-slash 3)))))
+ (let ((prev-prev-slash
+ (position-if #'slashp dst :end last-slash :from-end t)))
+ (if prev-prev-slash
+ (setf dst-len (1+ prev-prev-slash))
+ (return-from simplify-win32-namestring
+ (coerce ".\\" 'simple-string)))))))))
+ (cond ((zerop dst-len)
+ ".\\")
+ ((= dst-len src-len)
+ dst)
+ (t
+ (subseq dst 0 dst-len)))))
;; 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"
+ (search #-win32 "tests/filesys.pure.lisp"
+ #+win32 "tests\\filesys.pure.lisp"
(namestring pathname)))
dir)))
;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
(assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
'type-error))
+;;; A few cases Windows does have enough marbles to pass right now
+#+win32
+(progn
+ (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
+ (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
+ (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
+ ;; FIXME: Other platforms don't do this: either fix Windows
+ ;; so that it works even with the same logic others use, or
+ ;; make this official. (Currently just a kludge.)
+ (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\"))))
+
;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
;;;
;;; given only safe characters in the namestring, NATIVE-PATHNAME will
;;; never error, and NATIVE-NAMESTRING on the result will return the
;;; original namestring.
-(let ((safe-chars
- ;; for WIN32, we might want to remove #\: here
- (coerce
- (cons #\Newline
- (loop for x from 32 to 127 collect (code-char x)))
- 'simple-base-string))
- (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
- "[]" "*" "**" "/**" "**/" "/**/" "?"
- "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
- (loop repeat 1000
- for length = (random 32)
- for native-namestring = (coerce
- (loop repeat length
- collect
- (char safe-chars
- (random (length safe-chars))))
- 'simple-base-string)
- for pathname = (native-pathname native-namestring)
- for nnn = (native-namestring pathname)
- do (assert (string= nnn native-namestring)))
- (loop repeat 1000
- for native-namestring = (with-output-to-string (s)
- (loop
+(with-test (:name :random-native-namestrings)
+ (let ((safe-chars
+ (coerce
+ (cons #\Newline
+ (loop for x from 32 to 127 collect (code-char x)))
+ 'simple-base-string))
+ (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
+ "[]" "*" "**" "/**" "**/" "/**/" "?"
+ "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
+ (loop repeat 1000
+ for length = (random 32)
+ for native-namestring = (coerce
+ (loop repeat length
+ collect
+ (char safe-chars
+ (random (length safe-chars))))
+ 'simple-base-string)
+ for pathname = (native-pathname native-namestring)
+ for nnn = (native-namestring pathname)
+ do (assert (string= nnn native-namestring)))
+ (loop repeat 1000
+ for native-namestring = (with-output-to-string (s)
+ (loop
(let ((r (random 1.0)))
(cond
((< r 1/20) (return))
(random
(length tricky-sequences)))
s))))))
- for pathname = (native-pathname native-namestring)
- for nnn = (native-namestring pathname)
- do (assert (string= nnn native-namestring))))
+ for pathname = (native-pathname native-namestring)
+ for tricky-nnn = (native-namestring pathname)
+ do (assert (string= tricky-nnn native-namestring)))))
(assert (not (special-operator-p 'declare)))
;;; WITH-TIMEOUT should accept more than one form in its body.
-(handler-bind ((sb-ext:timeout #'continue))
- (sb-ext:with-timeout 3
- (sleep 2)
- (sleep 2)))
+(with-test (:name :with-timeout-forms)
+ (handler-bind ((sb-ext:timeout #'continue))
+ (sb-ext:with-timeout 3
+ (sleep 2)
+ (sleep 2))))
;;; DOCUMENTATION should return nil, not signal slot-unbound
(documentation 'fixnum 'type)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.18.8"
+"0.9.18.9"
projects / sbcl.git / commitdiff