From be6abfb75a76eb69a417ff09fd6b0f41e708f8c3 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 18 May 2009 20:38:44 +0000 Subject: [PATCH] 1.0.28.59: give UNIX-NAMESTRING the chop Use PROBE-FILE and NATIVE-NAMESTRING instead as appropriate. --- contrib/sb-simple-streams/file.lisp | 2 +- contrib/sb-simple-streams/impl.lisp | 4 +-- contrib/sb-simple-streams/internal.lisp | 13 +++++--- contrib/sb-simple-streams/iodefs.lisp | 3 ++ package-data-list.lisp-expr | 1 - src/code/fd-stream.lisp | 18 ++++++----- src/code/filesys.lisp | 51 +++---------------------------- src/code/save.lisp | 31 ++++++++++--------- version.lisp-expr | 2 +- 9 files changed, 47 insertions(+), 78 deletions(-) diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp index 9dbe8f8..4cfacd4 100644 --- a/contrib/sb-simple-streams/file.lisp +++ b/contrib/sb-simple-streams/file.lisp @@ -267,6 +267,6 @@ (let ((pathname (getf options :filename))) (with-stream-class (probe-simple-stream stream) (add-stream-instance-flags stream :simple) - (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok) + (when (sb-unix:unix-access (file-namestring pathname) sb-unix:f_ok) (setf (sm pathname stream) pathname) t)))) diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index d3e3293..014c852 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -126,7 +126,7 @@ (if (typep stream 'file-simple-stream) (with-stream-class (file-simple-stream stream) (setf (sm pathname stream) new-name) - (setf (sm filename stream) (sb-int:unix-namestring new-name nil)) + (setf (sm filename stream) (file-namestring new-name)) t) nil)) @@ -1097,7 +1097,7 @@ is supported only on simple-streams." (cond (new-name (setf (sb-impl::fd-stream-pathname stream) new-name) (setf (sb-impl::fd-stream-file stream) - (sb-int:unix-namestring new-name nil)) + (file-namestring new-name)) t) (t (sb-impl::fd-stream-pathname stream)))))) diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp index 4a846a8..6f956e9 100644 --- a/contrib/sb-simple-streams/internal.lisp +++ b/contrib/sb-simple-streams/internal.lisp @@ -473,11 +473,14 @@ (:io (values t t sb-unix:o_rdwr)) (:probe (values t nil sb-unix:o_rdonly))) (declare (type sb-int:index mask)) - (let ((name (cond ((sb-int:unix-namestring pathname input)) - ((and input (eq if-does-not-exist :create)) - (sb-int:unix-namestring pathname nil)) - ((and (eq direction :io) (not if-does-not-exist-given)) - (sb-int:unix-namestring pathname nil))))) + (let* ((phys (sb-int:physicalize-pathname (merge-pathnames pathname))) + (true (probe-file phys)) + (name (cond (true + (sb-ext:native-namestring true :as-file t)) + ((or (not input) + (and input (eq if-does-not-exist :create)) + (and (eq direction :io) (not if-does-not-exist-given))) + (sb-ext:native-namestring phys :as-file t))))) ;; Process if-exists argument if we are doing any output. (cond (output (unless if-exists-given diff --git a/contrib/sb-simple-streams/iodefs.lisp b/contrib/sb-simple-streams/iodefs.lisp index daff1a9..43314f8 100644 --- a/contrib/sb-simple-streams/iodefs.lisp +++ b/contrib/sb-simple-streams/iodefs.lisp @@ -14,6 +14,9 @@ (in-package "SB-SIMPLE-STREAMS") +(defun file-namestring (pathname) + (sb-ext:native-namestring (sb-int:physicalize-pathname pathnane) :as-file t)) + (defmacro def-stream-class (name superclasses slots &rest options) `(defclass ,name ,superclasses ,slots ,@options)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 81e1fd1..8debd87 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1100,7 +1100,6 @@ possibly temporariliy, because it might be used internally." "READ-SEQUENCE-OR-DIE" "RENAME-KEY-ARGS" "MISSING-ARG" - "UNIX-NAMESTRING" ; FIXME: perhaps belongs in package SB!UNIX "FEATUREP" "FLUSH-STANDARD-OUTPUT-STREAMS" "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 825933b..7ca75d8 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -2405,13 +2405,14 @@ (:io (values t t sb!unix:o_rdwr)) (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) - (let* ((pathname (merge-pathnames filename)) - (namestring - (cond ((unix-namestring pathname input)) - ((and input (eq if-does-not-exist :create)) - (unix-namestring pathname nil)) - ((and (eq direction :io) (not if-does-not-exist-given)) - (unix-namestring pathname nil))))) + (let* ((pathname (physicalize-pathname (merge-pathnames filename))) + (truename (probe-file pathname)) + (namestring (cond (truename + (native-namestring truename :as-file t)) + ((or (not input) + (and input (eq if-does-not-exist :create)) + (and (eq direction :io) (not if-does-not-exist-given))) + (native-namestring pathname :as-file t))))) ;; Process if-exists argument if we are doing any output. (cond (output (unless if-exists-given @@ -2629,7 +2630,8 @@ (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream) - (unix-namestring new-name nil)) + (native-namestring (physicalize-pathname new-name) + :as-file t)) t) (t (fd-stream-pathname stream))))) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 4c2c053..520fa92 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -437,49 +437,6 @@ (multiple-value-setq (q r) (truncate q 10)) (setf (schar res i) (schar "0123456789" r)))))) -;;;; UNIX-NAMESTRING - -(defun empty-relative-pathname-spec-p (x) - (or (equal x "") - (and (pathnamep x) - (or (equal (pathname-directory x) '(:relative)) - ;; KLUDGE: I'm not sure this second check should really - ;; have to be here. But on sbcl-0.6.12.7, - ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and - ;; (PATHNAME "") seems to act like an empty relative - ;; pathname, so in order to work with that, I test - ;; for NIL here. -- WHN 2001-05-18 - (null (pathname-directory x))) - (null (pathname-name x)) - (null (pathname-type x))) - ;; (The ANSI definition of "pathname specifier" has - ;; other cases, but none of them seem to admit the possibility - ;; of being empty and relative.) - )) - -;;; Convert PATHNAME into a string that can be used with UNIX system -;;; calls, or return NIL if no match is found. Wild-cards are expanded. -;;; -;;; FIXME: apart from the error checking (for wildness and for -;;; existence) and conversion to physical pathanme, this is redundant -;;; with UNPARSE-NATIVE-UNIX-NAMESTRING; one should probably be -;;; written in terms of the other. -;;; -;;; FIXME: actually this (I think) works not just for Unix. -(defun unix-namestring (pathname-spec &optional (for-input t)) - (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec))) - (matches nil)) ; an accumulator for actual matches - (when (wild-pathname-p namestring) - (error 'simple-file-error - :pathname namestring - :format-control "bad place for a wild pathname")) - (!enumerate-matches (match namestring nil :verify-existence for-input) - (push match matches)) - (case (length matches) - (0 nil) - (1 (first matches)) - (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname"))))) - ;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. ;;; Rewritten in 12/2007 by RMK, replacing 13+ year old CMU code that @@ -686,9 +643,9 @@ or if PATHSPEC is a wild pathname." "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a file, then the associated file is renamed." (let* ((original (truename file)) - (original-namestring (unix-namestring original t)) + (original-namestring (native-namestring original :as-file t)) (new-name (merge-pathnames new-name original)) - (new-namestring (unix-namestring new-name nil))) + (new-namestring (native-namestring new-name :as-file t))) (unless new-namestring (error 'simple-file-error :pathname new-name @@ -709,7 +666,9 @@ or if PATHSPEC is a wild pathname." (defun delete-file (file) #!+sb-doc "Delete the specified FILE." - (let ((namestring (unix-namestring file t))) + (let* ((truename (probe-file file)) + (namestring (when truename + (native-namestring truename :as-file t)))) (when (streamp file) (close file :abort t)) (unless namestring diff --git a/src/code/save.lisp b/src/code/save.lisp index 059f132..709743c 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -132,20 +132,23 @@ sufficiently motivated to do lengthy fixes." (foreign-bool (value) (if value 1 0)) (save-core (gc) - (when gc - #!-gencgc (gc) - ;; Do a destructive non-conservative GC, and then save a core. - ;; A normal GC will leave huge amounts of storage unreclaimed - ;; (over 50% on x86). This needs to be done by a single function - ;; since the GC will invalidate the stack. - #!+gencgc (gc-and-save (unix-namestring core-file-name nil) - (foreign-bool executable) - (foreign-bool save-runtime-options))) - (without-gcing - (save (unix-namestring core-file-name nil) - (get-lisp-obj-address #'restart-lisp) - (foreign-bool executable) - (foreign-bool save-runtime-options))))) + (let ((name (native-namestring + (physicalize-pathname core-file-name) + :as-file t))) + (when gc + #!-gencgc (gc) + ;; Do a destructive non-conservative GC, and then save a core. + ;; A normal GC will leave huge amounts of storage unreclaimed + ;; (over 50% on x86). This needs to be done by a single function + ;; since the GC will invalidate the stack. + #!+gencgc (gc-and-save name + (foreign-bool executable) + (foreign-bool save-runtime-options))) + (without-gcing + (save name + (get-lisp-obj-address #'restart-lisp) + (foreign-bool executable) + (foreign-bool save-runtime-options)))))) ;; Save the restart function into a static symbol, to allow GC-AND-SAVE ;; access to it even after the GC has moved it. #!+gencgc diff --git a/version.lisp-expr b/version.lisp-expr index 639ca72..019c8f6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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".) -"1.0.28.58" +"1.0.28.59" -- 1.7.10.4