common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

1.0.28.59: give UNIX-NAMESTRING the chop

Browse source 
Use PROBE-FILE and NATIVE-NAMESTRING instead as appropriate.
This commit is contained in:
Nikodemus Siivola 2009-05-18 20:38:44 +00:00
parent e4c6f7338e
commit be6abfb75a
9 changed files with 47 additions and 78 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
contrib/sb-simple-streams/file.lisp
View file

@ -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))))

4
contrib/sb-simple-streams/impl.lisp
View file

@ -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))))))

13
contrib/sb-simple-streams/internal.lisp
View file

@ -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

3
contrib/sb-simple-streams/iodefs.lisp
View file

@ -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))

1
package-data-list.lisp-expr
View file

@ -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"

18
src/code/fd-stream.lisp
View file

@ -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)))))

51
src/code/filesys.lisp
View file

@ -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

31
src/code/save.lisp
View file

@ -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

2
version.lisp-expr
View file

@ -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"