From: William Harold Newman Date: Tue, 19 Dec 2000 14:13:04 +0000 (+0000) Subject: 0.6.9.8: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a8f2656f635d81ec326303f47e0612fb1f35fd91;p=sbcl.git 0.6.9.8: MNA logical pathname patch (sbcl-devel Dec 12), lightly subbed added most MNA logical pathname regression tests to tests/ belatedly bumped fasl file version because package SB-CONDITIONS is gone --- diff --git a/NEWS b/NEWS index e128109..4a2a5f1 100644 --- a/NEWS +++ b/NEWS @@ -623,6 +623,9 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: and there's no compelling reason to try to stretch the standard to allow two different extensions.) Instead, byte-compiled files default to the same extension as native-compiled files. +* 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. ?? #'(SETF DOCUMENTATION) is now defined. * Bug #17 (differing COMPILE-FILE behavior between logical and physical pathnames) has been fixed, and some related misbehavior too, diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index e025c0d..47eb5f6 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -155,7 +155,7 @@ "*BACKEND-T-PRIMITIVE-TYPE*" "*CODE-SEGMENT*" - "*COMPILING-FOR-INTERPRETER*" "*CONVERTING-FOR-INTERPRETER*" + "*CONVERTING-FOR-INTERPRETER*" "*COUNT-VOP-USAGES*" "*ELSEWHERE*" "*FASL-HEADER-STRING-START-STRING*" "*FASL-HEADER-STRING-STOP-CHAR-CODE*" @@ -1186,7 +1186,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." ;; newly exported from former SB!CONDITIONS "*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*" "SHOW-CONDITION" "CASE-FAILURE" - "NAMESTRING-PARSE-ERROR" + "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET" "DESCRIBE-CONDITION" "!COLD-INIT" diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 5fd60a3..7c28116 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -730,7 +730,14 @@ :initform nil) (namestring :reader namestring-parse-error-namestring :initarg :namestring) (offset :reader namestring-parse-error-offset :initarg :offset)) - (:report %print-namestring-parse-error)) + (:report + (lambda (condition stream) + (format stream + "parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-arguments condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) (define-condition simple-package-error (simple-condition package-error) ()) diff --git a/src/code/load.lisp b/src/code/load.lisp index aa12429..75fe074 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -291,18 +291,21 @@ ;; could probably be shared with the read-a-keyword fop. (version (read-arg 4))) (declare (ignore ignore)) - (flet ((check-version (impl vers) - (when (string= impl implementation) - (unless (= version vers) - (error "~S was compiled for fasl file format version ~S, ~ - but we need version ~S." + (flet ((check-version (variant possible-implementation needed-version) + (when (string= possible-implementation implementation) + (unless (= version needed-version) + (error "~S was compiled for ~A fasl file format version ~ + ~S, but we need version ~S." stream + variant version - vers)) + needed-version)) t))) - (or (check-version #.sb!c:*backend-fasl-file-implementation* + (or (check-version "native code" + #.sb!c:*backend-fasl-file-implementation* #.sb!c:*backend-fasl-file-version*) - (check-version #.(sb!c:backend-byte-fasl-file-implementation) + (check-version "byte code" + #.(sb!c:backend-byte-fasl-file-implementation) sb!c:byte-fasl-file-version) (error "~S was compiled for implementation ~A, but this is a ~A." stream diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index ee6c496..6815d1d 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -34,7 +34,7 @@ (logical-host-name (%pathname-host x)))) (:unparse-directory #'unparse-logical-directory) (:unparse-file #'unparse-unix-file) - (:unparse-enough #'identity) + (:unparse-enough #'unparse-enough-namestring) (:customary-case :upper))) (name "" :type simple-base-string) (translations nil :type list) diff --git a/src/code/save.lisp b/src/code/save.lisp index 7f0abb0..55d2897 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -104,8 +104,8 @@ ;;;; functions used by worldload.lisp in CMU CL bootstrapping -;;; If Name has been byte-compiled, and :RUNTIME is a feature, then load the -;;; byte-compiled version, otherwise just do normal load. +;;; If NAME has been byte-compiled, and :RUNTIME is a feature, then +;;; load the byte-compiled version, otherwise just do normal load. #+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814 (defun maybe-byte-load (name &optional (load-native t)) (let ((bname (make-pathname diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 1fdf1d7..1c5b5c4 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -41,10 +41,12 @@ (def!method make-load-form ((pathname pathname) &optional environment) (make-load-form-saving-slots pathname :environment environment)) -;;; The potential conflict with search-lists requires isolating the printed -;;; representation to use the i/o macro #.(logical-pathname ). +;;; The potential conflict with search lists requires isolating the +;;; printed representation to use the i/o macro #.(logical-pathname +;;; ). ;;; -;;; FIXME: We don't use search lists any more, so that comment is stale, right? +;;; FIXME: We don't use search lists any more, so that comment is +;;; stale, right? (def!method print-object ((pathname logical-pathname) stream) (let ((namestring (handler-case (namestring pathname) (error nil)))) @@ -59,16 +61,25 @@ (%pathname-type pathname) (%pathname-version pathname)))))) -;;; A pathname is logical if the host component is a logical-host. +;;; A pathname is logical if the host component is a logical host. ;;; This constructor is used to make an instance of the correct type ;;; from parsed arguments. (defun %make-pathname-object (host device directory name type version) - (if (typep host 'logical-host) - (%make-logical-pathname host :unspecific directory name type version) - (%make-pathname host device directory name type version))) - -;;; Hash table searching maps a logical-pathname's host to their physical -;;; pathname translation. + ;; We canonicalize logical pathname components to uppercase. ANSI + ;; doesn't strictly require this, leaving it up to the implementor; + ;; but the arguments given in the X3J13 cleanup issue + ;; PATHNAME-LOGICAL:ADD seem compelling: we should canonicalize the + ;; case, and uppercase is the ordinary way to do that. + (flet ((upcase-maybe (x) (typecase x (string (string-upcase x)) (t x)))) + (if (typep host 'logical-host) + (%make-logical-pathname + host :unspecific + (mapcar #'upcase-maybe directory) + (upcase-maybe name) (upcase-maybe type) version) + (%make-pathname host device directory name type version)))) + +;;; Hash table searching maps a logical pathname's host to its +;;; physical pathname translation. (defvar *logical-hosts* (make-hash-table :test 'equal)) ;;;; patterns @@ -157,10 +168,16 @@ (matches (pattern-pieces pattern) 0 nil nil nil) (values won (reverse subs)))))) -;;; Pathname-match-p for directory components. +;;; PATHNAME-MATCH-P for directory components (defun directory-components-match (thing wild) (or (eq thing wild) (eq wild :wild) + ;; If THING has a null directory, assume that it matches + ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS). + (and (consp wild) + (null thing) + (member (first wild) '(:absolute :relative)) + (eq (second wild) :wild-inferiors)) (and (consp wild) (let ((wild1 (first wild))) (if (eq wild1 :wild-inferiors) @@ -574,20 +591,15 @@ a host-structure or string." ;;;; namestrings -(defun %print-namestring-parse-error (condition stream) - (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^" - (namestring-parse-error-complaint condition) - (namestring-parse-error-arguments condition) - (namestring-parse-error-namestring condition) - (namestring-parse-error-offset condition))) - ;;; Handle the case where PARSE-NAMESTRING is actually parsing a ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to ;;; use for parsing, call the parser, then check whether the host ;;; matches. (defun %parse-namestring (namestr host defaults start end junk-allowed) - (declare (type (or host null) host) (type string namestr) - (type index start) (type (or index null) end)) + (declare (type (or host null) host) + (type string namestr) + (type index start) + (type (or index null) end)) (if junk-allowed (handler-case (%parse-namestring namestr host defaults start end nil) @@ -598,22 +610,22 @@ a host-structure or string." (extract-logical-host-prefix namestr start end) (pathname-host defaults)))) (unless parse-host - (error "When HOST argument is not supplied, DEFAULTS arg must ~ - have a non-null PATHNAME-HOST.")) + (error "When no HOST argument is supplied, the DEFAULTS argument ~ + must have a non-null PATHNAME-HOST.")) (multiple-value-bind (new-host device directory file type version) (funcall (host-parse parse-host) namestr start end) (when (and host new-host (not (eq new-host host))) (error "The host in the namestring, ~S,~@ - does not match explicit host argument: ~S" + does not match the explicit host argument: ~S" host)) (let ((pn-host (or new-host parse-host))) (values (%make-pathname-object pn-host device directory file type version) end)))))) -;;; If namestr begins with a colon-terminated, defined, logical host, then -;;; return that host, otherwise return NIL. +;;; If namestr begins with a colon-terminated, defined, logical host, +;;; then return that host, otherwise return NIL. (defun extract-logical-host-prefix (namestr start end) (declare (type simple-base-string namestr) (type index start end) @@ -629,35 +641,73 @@ a host-structure or string." host (defaults *default-pathname-defaults*) &key (start 0) end junk-allowed) - #!+sb-doc - "Converts pathname, a pathname designator, into a pathname structure, - for a physical pathname, returns the printed representation. Host may be - a physical host structure or host namestring." (declare (type pathname-designator thing) - (type (or null host) host) + (type (or null host string list (member :unspecific)) host) (type pathname defaults) (type index start) (type (or index null) end) (type (or t null) junk-allowed) (values (or null pathname) (or null index))) + ;; Generally, redundant specification of information in software, + ;; whether in code or in comments, is bad. However, the ANSI spec + ;; for this is messy enough that it's hard to hold in short-term + ;; memory, so I've recorded these redundant notes on the + ;; implications of the ANSI spec. + ;; + ;; According to the ANSI spec, HOST can be a valid pathname host, or + ;; a logical host, or NIL. + ;; + ;; A valid pathname host can be a valid physical pathname host or a + ;; valid logical pathname host. + ;; + ;; A valid physical pathname host is "any of a string, a list of + ;; strings, or the symbol :UNSPECIFIC, that is recognized by the + ;; implementation as the name of a host". In SBCL as of 0.6.9.8, + ;; that means :UNSPECIFIC: though someday we might want to + ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like + ;; '("RTFM" "MIT" "EDU"), that's not supported now. + ;; + ;; A valid logical pathname host is a string which has been defined as + ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. + ;; + ;; A logical host is an object of implementation-dependent nature. In + ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). + (let ((found-host (etypecase host + (string + ;; In general ANSI-compliant Common Lisps, a + ;; string might also be a physical pathname host, + ;; but ANSI leaves this up to the implementor, + ;; and in SBCL we don't do it, so it must be a + ;; logical host. + (find-logical-host host)) + ((or null (member :unspecific)) + ;; CLHS says that HOST=:UNSPECIFIC has + ;; implementation-defined behavior. We + ;; just turn it into NIL. + nil) + (host + host)))) + (declare (type (or null host) found-host)) (typecase thing (simple-string - (%parse-namestring thing host defaults start end junk-allowed)) + (%parse-namestring thing found-host defaults start end junk-allowed)) (string (%parse-namestring (coerce thing 'simple-string) - host defaults start end junk-allowed)) + found-host defaults start end junk-allowed)) (pathname - (let ((host (if host host (%pathname-host defaults)))) - (unless (eq host (%pathname-host thing)) - (error "Hosts do not match: ~S and ~S." - host (%pathname-host thing)))) + (let ((defaulted-host (or found-host (%pathname-host defaults)))) + (declare (type host defaulted-host)) + (unless (eq defaulted-host (%pathname-host thing)) + (error "The HOST argument doesn't match the pathname host:~% ~ + ~S and ~S." + defaulted-host (%pathname-host thing)))) (values thing start)) (stream (let ((name (file-name thing))) (unless name (error "can't figure out the file associated with stream:~% ~S" thing)) - name)))) + name))))) (defun namestring (pathname) #!+sb-doc @@ -912,16 +962,21 @@ a host-structure or string." (didnt-match-error orig-source orig-from))))) (subs)))) -;;; Called by TRANSLATE-PATHNAME on the directory components of its argument -;;; pathanames to produce the result directory component. If any leaves the -;;; directory NIL, we return the source directory. The :RELATIVE or :ABSOLUTE -;;; is always taken from the source directory. +;;; This is called by TRANSLATE-PATHNAME on the directory components +;;; of its argument pathnames to produce the result directory +;;; component. If this leaves the directory NIL, we return the source +;;; directory. The :RELATIVE or :ABSOLUTE is taken from the source +;;; directory, except if TO is :ABSOLUTE, in which case the result +;;; will be :ABSOLUTE. (defun translate-directories (source from to diddle-case) (if (not (and source to from)) - (or to - (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source)) + (or (and to (null source) (remove :wild-inferiors to)) + (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source)) (collect ((res)) - (res (first source)) + ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE. + (res (if (eq (first to) :absolute) + :absolute + (first source))) (let ((subs-left (compute-directory-substitutions (rest source) (rest from)))) (dolist (to-part (rest to)) @@ -930,7 +985,7 @@ a host-structure or string." (assert subs-left) (let ((match (pop subs-left))) (when (listp match) - (error ":WILD-INFERIORS not paired in from and to ~ + (error ":WILD-INFERIORS is not paired in from and to ~ patterns:~% ~S ~S" from to)) (res (maybe-diddle-case match diddle-case)))) ((member :wild-inferiors) @@ -942,7 +997,8 @@ a host-structure or string." (dolist (x match) (res (maybe-diddle-case x diddle-case))))) (pattern - (multiple-value-bind (new new-subs-left) + (multiple-value-bind + (new new-subs-left) (substitute-into to-part subs-left diddle-case) (setf subs-left new-subs-left) (res new))) @@ -1170,8 +1226,8 @@ a host-structure or string." :namestring word :offset i)))) word)) -;;; Given a logical host or string, return a logical host. If Error-p is -;;; NIL, then return NIL when no such host exists. +;;; Given a logical host or string, return a logical host. If ERROR-P +;;; is NIL, then return NIL when no such host exists. (defun find-logical-host (thing &optional (errorp t)) (etypecase thing (string @@ -1179,14 +1235,21 @@ a host-structure or string." *logical-hosts*))) (if (or found (not errorp)) found - (error 'simple-file-error - :pathname thing + ;; This is the error signalled from e.g. + ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined + ;; host, and ANSI specifies that that's a TYPE-ERROR. + (error 'simple-type-error + :datum thing + ;; God only knows what ANSI expects us to use for + ;; the EXPECTED-TYPE here. Maybe this will be OK.. + :expected-type + '(and string (satisfies logical-pathname-translations)) :format-control "logical host not yet defined: ~S" :format-arguments (list thing))))) (logical-host thing))) -;;; Given a logical host name or host, return a logical host, creating a new -;;; one if necessary. +;;; Given a logical host name or host, return a logical host, creating +;;; a new one if necessary. (defun intern-logical-host (thing) (declare (values logical-host)) (or (find-logical-host thing nil) @@ -1265,7 +1328,7 @@ a host-structure or string." (unless (and chunks (simple-string-p (caar chunks))) (error 'namestring-parse-error :complaint "expecting ~A, got ~:[nothing~;~S~]." - :arguments (list what (caar chunks)) + :arguments (list what (caar chunks) (caar chunks)) :namestring namestr :offset (if chunks (cdar chunks) end))) (caar chunks)) @@ -1399,6 +1462,36 @@ a host-structure or string." (t (error "invalid keyword: ~S" piece)))))) (apply #'concatenate 'simple-string (strings)))))) +;;; Unparse a logical pathname string. +(defun unparse-enough-namestring (pathname defaults) + (let* ((path-dir (pathname-directory pathname)) + (def-dir (pathname-directory defaults)) + (enough-dir + ;; Go down the directory lists to see what matches. What's + ;; left is what we want, more or less. + (cond ((and (eq (first path-dir) (first def-dir)) + (eq (first path-dir) :absolute)) + ;; Both paths are :absolute, so find where the common + ;; parts end and return what's left + (do* ((p (rest path-dir) (rest p)) + (d (rest def-dir) (rest d))) + ((or (endp p) (endp d) + (not (equal (first p) (first d)))) + `(:relative ,@p)))) + (t + ;; At least one path is :relative, so just return the + ;; original path. If the original path is :relative, + ;; then that's the right one. If PATH-DIR is + ;; :absolute, we want to return that except when + ;; DEF-DIR is :absolute, as handled above. so return + ;; the original directory. + path-dir)))) + (make-pathname :host (pathname-host pathname) + :directory enough-dir + :name (pathname-name pathname) + :type (pathname-type pathname) + :version (pathname-version pathname)))) + (defun unparse-logical-namestring (pathname) (declare (type logical-pathname pathname)) (concatenate 'simple-string @@ -1446,30 +1539,6 @@ a host-structure or string." (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) -;;; The search mechanism for loading pathname translations uses the CMU CL -;;; extension of search-lists. The user can add to the "library:" search-list -;;; using setf. The file for translations should have the name defined by -;;; the hostname (a string) and with type component "translations". - -(defun load-logical-pathname-translations (host) - #!+sb-doc - "Search for a logical pathname named host, if not already defined. If already - defined no attempt to find or load a definition is attempted and NIL is - returned. If host is not already defined, but definition is found and loaded - successfully, T is returned, else error." - (declare (type string host) - (values (member t nil))) - (unless (find-logical-host host nil) - (with-open-file (in-str (make-pathname :defaults "library:" - :name host - :type "translations")) - (if *load-verbose* - (format *error-output* - ";; loading pathname translations from ~A~%" - (namestring (truename in-str)))) - (setf (logical-pathname-translations host) (read in-str))) - t)) - (defun translate-logical-pathname (pathname &key) #!+sb-doc "Translates pathname to a physical pathname, which is returned." @@ -1497,3 +1566,14 @@ a host-structure or string." nil nil nil)) + +(defun load-logical-pathname-translations (host) + #!+sb-doc + (declare (type string host) + (values (member t nil))) + (if (find-logical-host host nil) + ;; This host is already defined, all is well and good. + t + ;; ANSI: "The specific nature of the search is + ;; implementation-defined." SBCL: doesn't search at all + (error "logical host ~S not found" host))) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index 644b6df..25b72f1 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -13,7 +13,9 @@ (in-package "SB!C") ;;;; the fasl file format that we use -(defconstant byte-fasl-file-version 1) +(defconstant byte-fasl-file-version 2) +;;; 1 = before about sbcl-0.6.9.8 +;;; 2 = merged package SB-CONDITIONS into SB-KERNEL around sbcl-0.6.9.8 ;;; ### remaining work: ;;; diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 8386703..5c8df94 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1028,14 +1028,22 @@ pathname (flushable)) -;;; KLUDGE: There was a comment from CMU CL here, "We need to add the -;;; logical pathname stuff here." -- WHN 19991213 +;;; FIXME: What about logical pathname stuff? +;;; LOGICAL-PATHNAME +;;; TRANSLATE-LOGICAL-PATHNAME +;;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS +;;; LOGICAL-PATHNAME-TRANSLATIONS (defknown pathname (pathname-designator) pathname (flushable)) (defknown truename (pathname-designator) pathname ()) (defknown parse-namestring - (pathname-designator &optional pathname-host pathname-designator + (pathname-designator &optional + ;; ANSI also allows LIST here, but leaves its + ;; interpretation implementation-defined. Our + ;; interpretation is that it's unsupported.:-| + (or pathname-host string (member :unspecific)) + pathname-designator &key (:start index) (:end sequence-end) diff --git a/src/compiler/x86/backend-parms.lisp b/src/compiler/x86/backend-parms.lisp index ba1fda3..3c912ab 100644 --- a/src/compiler/x86/backend-parms.lisp +++ b/src/compiler/x86/backend-parms.lisp @@ -19,7 +19,7 @@ (setf *backend-fasl-file-type* "x86f") (setf *backend-fasl-file-implementation* :x86) -(setf *backend-fasl-file-version* 6) +(setf *backend-fasl-file-version* 7) ;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC. ;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot. ;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET @@ -31,6 +31,7 @@ ;;; 5 = sbcl-0.6.8 has rearranged static symbols. ;;; 6 = sbcl-0.6.9, got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff ;;; and deleted a slot from DEBUG-SOURCE structure. +;;; 7 = around sbcl-0.6.9.8, merged SB-CONDITIONS package into SB-KERNEL (setf *backend-register-save-penalty* 3) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 949e5b7..703fdb0 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -16,17 +16,111 @@ (in-package "CL-USER") -(setf (logical-pathname-translations "foo") - '(("REL;*.*.*" "/tmp/") - ("MAIL;**;*.MAIL" "/tmp/subdir/") - ("PROGGIES;*" "/tmp/"))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro grab-condition (&body body) + `(nth-value 1 + (ignore-errors ,@body)))) -(assert (string= (format nil - "~S" - (translate-logical-pathname "foo:proggies;save")) - "#P\"/tmp/save\"")) +(setf (logical-pathname-translations "demo0") + '(("**;*.*.*" "/tmp/"))) -(compile-file-pathname "foo:proggies;save") +;;; In case of a parse error we want to get a condition of type +;;; CL:PARSE-ERROR (or more specifically, of type +;;; SB-KERNEL:NAMESTRING-PARSE-ERROR). +(assert + (typep (grab-condition (translate-logical-pathname "demo0::bla;file.lisp")) + 'parse-error)) + +;;; some things SBCL-0.6.9 used not to parse correctly: +;;; +;;; SBCL used to throw an error saying there's no translation. +(assert (equal (namestring (translate-logical-pathname "demo0:file.lisp")) + "/tmp/file.lisp")) +;;; We do not match a null directory to every wild path: +(assert (not (pathname-match-p "demo0:file.lisp" + (logical-pathname "demo0:tmp;**;*.*.*")))) +;;; Remove "**" from our resulting pathname when the source-dir is NIL: +(setf (logical-pathname-translations "demo1") + '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*"))) +(assert (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp")) + "/tmp/**/foo.lisp"))) +;;; That should be correct: +(assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp")) + "/tmp/foo.lisp")) +;;; Check for absolute/relative path confusion: +(assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) + "tmp/rel/foo.lisp"))) +(assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) + "/tmp/rel/foo.lisp")) + +;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to +;;; handle the following case exactly (otherwise we get an error: +;;; "#'IDENTITY CALLED WITH 2 ARGS." +(setf (logical-pathname-translations "demo2") + '(("test;**;*.*" "/tmp/demo2/test/"))) +(enough-namestring "demo2:test;foo.lisp") + +;;; When a pathname comes from a logical host, it should be in upper +;;; case. (This doesn't seem to be specifically required in the ANSI +;;; spec, but it's left up to the implementors, and the arguments made +;;; in the cleanup issue PATHNAME-LOGICAL:ADD seem to be a pretty +;;; compelling reason for the implementors to choose case +;;; insensitivity and a canonical case.) +(setf (logical-pathname-translations "FOO") + '(("**;*.*.*" "/full/path/to/foo/**/*.*.*"))) +(let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" + :type "conf")) + (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" + :type "CONF")) + (pn3 (read-from-string (prin1-to-string pn1)))) + (assert (equal pn1 pn2)) + (assert (equal pn1 pn3))) + +;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The +;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC +;;; without actually requiring the system to signal an error (apart +;;; from host mismatches). +(assert (equal (namestring (parse-namestring "" "FOO")) "FOO:")) +(assert (equal (namestring (parse-namestring "" :unspecific)) "")) + +;;; The third would work if the call were (and it should continue to +;;; work ...) +(parse-namestring "" + (pathname-host + (translate-logical-pathname + "FOO:"))) + +;;; ANSI, in its wisdom, specifies that it's an error (specifically a +;;; TYPE-ERROR) to query the system about the translations of a string +;;; which doesn't have any translations. It's not clear why we don't +;;; just return NIL in that case, but they make the rules.. +(let ((cond (grab-condition (logical-pathname-translations "unregistered-host")))) + (assert (typep cond 'type-error))) + +;;; examples from CLHS: Section 19.4, Logical Pathname Translations +;;; (sometimes converted to the Un*x way of things) +(setf (logical-pathname-translations "test0") + '(("**;*.*.*" "/library/foo/**/"))) +(assert (equal (namestring (translate-logical-pathname + "test0:foo;bar;baz;mum.quux.3")) + "/library/foo/foo/bar/baz/mum.quux.3")) +(setf (logical-pathname-translations "prog") + '(("RELEASED;*.*.*" "MY-UNIX:/sys/bin/my-prog/") + ("RELEASED;*;*.*.*" "MY-UNIX:/sys/bin/my-prog/*/") + ("EXPERIMENTAL;*.*.*" "MY-UNIX:/usr/Joe/development/prog/") + ("EXPERIMENTAL;*;*.*.*" "MY-UNIX:/usr/Joe/development/prog/*/"))) +(setf (logical-pathname-translations "prog") + '(("CODE;*.*.*" "/lib/prog/"))) +(assert (equal (namestring (translate-logical-pathname + "prog:code;documentation.lisp")) + "/lib/prog/documentation.lisp")) +(setf (logical-pathname-translations "prog") + '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*") + ("CODE;*.*.*" "/lib/prog/"))) +(assert (equal (namestring (translate-logical-pathname + "prog:code;documentation.lisp")) + "/lib/prog/docum.lisp")) ;;; success (quit :unix-status 104) +(in-package :cl-user) diff --git a/tests/side-effectful-pathnames.test.sh b/tests/side-effectful-pathnames.test.sh new file mode 100644 index 0000000..29f3596 --- /dev/null +++ b/tests/side-effectful-pathnames.test.sh @@ -0,0 +1,31 @@ +#!/bin/sh + +# FIXME: MNA wrote the tests below to work with the new +# lp-test-file.lisp file in place. It'd be good to replace them either +# with code which uses an existing distribution file instead, or with +# code which creates a new file in $TMPDIR and uses that. Meanwhile, +# we just return success immediately instead of doing anything. +exit 104 + +;;; loading files w/ logical pathnames +(setf (logical-pathname-translations "TEST") + '(("**;*.*.*" + #.(concatenate 'string + (namestring (sb-int:default-directory)) + "**/*.*")) + ("**;*.*.*" + #.(concatenate 'string + (namestring (sb-int:default-directory)) + "**/*.*.*")))) +(assert (equal (namestring (translate-logical-pathname + "test:lp-test-file.lisp")) + #.(concatenate 'string + (namestring (sb-int:default-directory)) + "lp-test-file.lisp"))) +(load "TEST:LP-TEST-FILE") +(let ((compiled-file-name (namestring (compile-file "TEST:LP-TEST-FILE"))) + (should-be-file-name + #.(concatenate 'string + (namestring (sb-int:default-directory)) + "lp-test-file.x86f"))) + (assert (equal compiled-file-name should-be-file-name))) diff --git a/version.lisp-expr b/version.lisp-expr index 0cc74c2..aabb7f2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.9.7" +"0.6.9.8"