From 8eb659eee63e989f2f3da5673c3ac00a6712f567 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 12 Dec 2000 23:59:40 +0000 Subject: [PATCH] 0.6.9.5: BACKEND-BYTE-FASL-FILE-TYPE goes away as per 0.6.9.4. Simplify TRY-DEFAULT-TYPES and friends by using single default types instead of lists of default types. more work on bug #17, loosely based on MNA's patch; still broke started tests/pathnames.impure.lisp failed to fix cross-compilation under CMU CL --- NEWS | 18 ++++++++---- package-data-list.lisp-expr | 3 +- src/code/target-load.lisp | 65 ++++++++++++++++------------------------- src/code/target-pathname.lisp | 53 ++++++++++++++++----------------- src/compiler/backend.lisp | 5 ---- src/compiler/ir1tran.lisp | 9 ++++-- tests/pathnames.impure.lisp | 32 ++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 105 insertions(+), 82 deletions(-) create mode 100644 tests/pathnames.impure.lisp diff --git a/NEWS b/NEWS index c4d0a33..e128109 100644 --- a/NEWS +++ b/NEWS @@ -615,14 +615,20 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: * A patch from Martin Atzmueller seems to have solved the SIGINT problem, and as far as we know, signal-handling now works cleanly. (If you find any new bugs, please report them!) -* More compiler warnings in src/runtime/ are gone, thanks to - patches from Martin Atzmueller. -* The compiler no longer uses special file extensions for +* The system no longer defaults Lisp source file names to types + ".l", ".cl", or ".lsp", but only to ".lisp". +* The compiler no longer uses special default file extensions for byte-compiled code. (The ANSI definition of COMPILE-FILE-PATHNAME - seems to require a single default extension for compiled code, + seems to expect a single default extension for all compiled code, and there's no compelling reason to try to stretch the standard - to allow two different extensions.) -* #'(SETF DOCUMENTATION) is now defined. + to allow two different extensions.) Instead, byte-compiled files + default to the same extension as native-compiled files. +?? #'(SETF DOCUMENTATION) is now defined. +* 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. +* More compiler warnings in src/runtime/ are gone, thanks to + patches from Martin Atzmueller. planned incompatible changes in 0.7.x: * The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index e291d4b..1674468 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -256,7 +256,6 @@ "BLOCK-NUMBER" "BACKEND" "BACKEND-BYTE-FASL-FILE-IMPLEMENTATION" - "BACKEND-BYTE-FASL-FILE-TYPE" "IR2-BLOCK-BLOCK" "DISASSEM-BYTE-COMPONENT" "FUNCALLABLE-INSTANCE-LEXENV" @@ -731,7 +730,7 @@ retained, possibly temporariliy, because it might be used internally." ;; various internal defaults "*DEFAULT-PACKAGE-USE-LIST*" "DEFAULT-INIT-CHAR" - "*LOAD-SOURCE-TYPES*" "*LOAD-OBJECT-TYPES*" + "*LOAD-SOURCE-DEFAULT-TYPE*" ;; hash caches "DEFINE-HASH-CACHE" diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index c928da9..654a6a7 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -13,18 +13,9 @@ (in-package "SB!IMPL") -(defvar *load-source-types* '("lisp" "l" "cl" "lsp") +(defvar *load-source-default-type* "lisp" #!+sb-doc - "The source file types which LOAD recognizes.") - -(defvar *load-object-types* - '(#.sb!c:*backend-fasl-file-type* - #.(sb!c:backend-byte-fasl-file-type) - "fasl") - #!+sb-doc - "A list of the object file types recognized by LOAD.") - -(declaim (list *load-source-types* *load-object-types*)) + "The source file types which LOAD looks for by default.") (defvar *load-truename* nil #!+sb-doc @@ -91,41 +82,34 @@ (internal-load pathname truename if-does-not-exist verbose print :binary)) (t - (when (member (pathname-type truename) - *load-object-types* - :test #'string=) + (when (string= (pathname-type truename) + sb!c:*backend-fasl-file-type*) (error "File has a fasl file type, but no fasl file header:~% ~S" (namestring truename))) (internal-load pathname truename if-does-not-exist verbose print :source)))))))) -;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE -(defun try-default-types (pathname types lp-type) - ;; Modified 18-Jan-97/pw for logical-pathname support. - ;; - ;; FIXME: How does logical-pathname support interact with - ;; *LOAD-SOURCE-TYPES* and *LOAD-OBJECT-TYPES*? - (flet ((frob (pathname type) - (let* ((pn (make-pathname :type type :defaults pathname)) - (tn (probe-file pn))) - (values pn tn)))) - (if (typep pathname 'logical-pathname) - (frob pathname lp-type) - (dolist (type types (values nil nil)) - (multiple-value-bind (pn tn) (frob pathname type) - (when tn - (return (values pn tn)))))))) +;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE: Try the default +;;; file type TYPE and return (VALUES PATHNAME TRUENAME) for a match, +;;; or (VALUES PATHNAME NIL) if the file doesn't exist. +;;; +;;; This is analogous to CMU CL's TRY-DEFAULT-TYPES, but we only try a +;;; single type. By avoiding CMU CL's generality here, we avoid having +;;; to worry about some annoying ambiguities. (E.g. what if the +;;; possible types are ".lisp" and ".cl", and both "foo.lisp" and +;;; "foo.cl" exist?) +(defun try-default-type (pathname type) + (let ((pn (make-pathname :type type :defaults pathname))) + (values pn (probe-file pn)))) -;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where the file -;;; does not exist. +;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where +;;; the file does not exist. (defun internal-load-default-type (pathname if-does-not-exist verbose print) (declare (type (member nil :error) if-does-not-exist)) - ;; FIXME: How do the fixed "LISP" and "FASL" types interact with the - ;; *LOAD-SOURCE-TYPES* and *LOAD-OBJECT-TYPES* values? (multiple-value-bind (src-pn src-tn) - (try-default-types pathname *load-source-types* "LISP") + (try-default-type pathname *load-source-default-type*) (multiple-value-bind (obj-pn obj-tn) - (try-default-types pathname *load-object-types* "FASL") + (try-default-type pathname sb!c:*backend-fasl-file-type*) (cond ((and obj-tn src-tn @@ -152,10 +136,11 @@ (t (internal-load pathname nil if-does-not-exist verbose print nil)))))) -;;; This function mainly sets up special bindings and then calls sub-functions. -;;; We conditionally bind the switches with PROGV so that people can set them -;;; in their init files and have the values take effect. If the compiler is -;;; loaded, we make the compiler-policy local to LOAD by binding it to itself. +;;; This function mainly sets up special bindings and then calls +;;; sub-functions. We conditionally bind the switches with PROGV so +;;; that people can set them in their init files and have the values +;;; take effect. If the compiler is loaded, we make the +;;; compiler-policy local to LOAD by binding it to itself. ;;; ;;; FIXME: ANSI specifies an EXTERNAL-FORMAT keyword argument. ;;; diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 00dd420..1fdf1d7 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -581,9 +581,10 @@ a host-structure or string." (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. +;;; 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)) @@ -603,7 +604,7 @@ a host-structure or string." (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 "Host in namestring: ~S~@ + (error "The host in the namestring, ~S,~@ does not match explicit host argument: ~S" host)) (let ((pn-host (or new-host parse-host))) @@ -654,7 +655,7 @@ a host-structure or string." (stream (let ((name (file-name thing))) (unless name - (error "Can't figure out the file associated with stream:~% ~S" + (error "can't figure out the file associated with stream:~% ~S" thing)) name)))) @@ -667,7 +668,7 @@ a host-structure or string." (when pathname (let ((host (%pathname-host pathname))) (unless host - (error "Cannot determine the namestring for pathnames with no ~ + (error "can't determine the namestring for pathnames with no ~ host:~% ~S" pathname)) (funcall (host-unparse host) pathname))))) @@ -681,7 +682,7 @@ a host-structure or string." (if host (funcall (host-unparse-host host) pathname) (error - "Cannot determine the namestring for pathnames with no host:~% ~S" + "can't determine the namestring for pathnames with no host:~% ~S" pathname))))) (defun directory-namestring (pathname) @@ -694,7 +695,7 @@ a host-structure or string." (if host (funcall (host-unparse-directory host) pathname) (error - "Cannot determine the namestring for pathnames with no host:~% ~S" + "can't determine the namestring for pathnames with no host:~% ~S" pathname))))) (defun file-namestring (pathname) @@ -707,7 +708,7 @@ a host-structure or string." (if host (funcall (host-unparse-file host) pathname) (error - "Cannot determine the namestring for pathnames with no host:~% ~S" + "can't determine the namestring for pathnames with no host:~% ~S" pathname))))) (defun enough-namestring (pathname @@ -723,7 +724,7 @@ a host-structure or string." (with-pathname (defaults defaults) (funcall (host-unparse-enough host) pathname defaults)) (error - "Cannot determine the namestring for pathnames with no host:~% ~S" + "can't determine the namestring for pathnames with no host:~% ~S" pathname))))) ;;;; wild pathnames @@ -790,7 +791,7 @@ a host-structure or string." (t (setf in-wildcard t) (unless subs - (error "Not enough wildcards in FROM pattern to match ~ + (error "not enough wildcards in FROM pattern to match ~ TO pattern:~% ~S" pattern)) (let ((sub (pop subs))) @@ -805,7 +806,7 @@ a host-structure or string." (simple-string (push sub strings)) (t - (error "Can't substitute this into the middle of a word:~ + (error "can't substitute this into the middle of a word:~ ~% ~S" sub))))))) @@ -1132,7 +1133,7 @@ a host-structure or string." (funcall function pathname)) ((not (search-list-defined search-list)) (/show0 "undefined search list") - (error "Undefined search list: ~A" + (error "undefined search list: ~A" (search-list-name search-list))) (t (/show0 "general case") @@ -1163,7 +1164,7 @@ a host-structure or string." (let ((ch (schar word i))) (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)) (error 'namestring-parse-error - :complaint "Logical namestring character ~ + :complaint "logical namestring character which ~ is not alphanumeric or hyphen:~% ~S" :arguments (list ch) :namestring word :offset i)))) @@ -1180,7 +1181,7 @@ a host-structure or string." found (error 'simple-file-error :pathname thing - :format-control "Logical host not yet defined: ~S" + :format-control "logical host not yet defined: ~S" :format-arguments (list thing))))) (logical-host thing))) @@ -1209,7 +1210,7 @@ a host-structure or string." (if (= pos last-pos) (when (pattern) (error 'namestring-parse-error - :complaint "Double asterisk inside of logical ~ + :complaint "double asterisk inside of logical ~ word: ~S" :arguments (list chunk) :namestring namestring @@ -1244,7 +1245,7 @@ a host-structure or string." (setq prev (1+ i)) (unless (member ch '(#\; #\: #\.)) (error 'namestring-parse-error - :complaint "Illegal character for logical pathname:~% ~S" + :complaint "illegal character for logical pathname:~% ~S" :arguments (list ch) :namestring namestr :offset i)) @@ -1263,7 +1264,7 @@ a host-structure or string." (labels ((expecting (what chunks) (unless (and chunks (simple-string-p (caar chunks))) (error 'namestring-parse-error - :complaint "Expecting ~A, got ~:[nothing~;~S~]." + :complaint "expecting ~A, got ~:[nothing~;~S~]." :arguments (list what (caar chunks)) :namestring namestr :offset (if chunks (cdar chunks) end))) @@ -1305,7 +1306,7 @@ a host-structure or string." (when chunks (unless (eql (caar chunks) #\.) (error 'namestring-parse-error - :complaint "Expecting a dot, got ~S." + :complaint "expecting a dot, got ~S." :arguments (list (caar chunks)) :namestring namestr :offset (cdar chunks))) @@ -1327,7 +1328,7 @@ a host-structure or string." (parse-integer str :junk-allowed t) (unless (and res (plusp res)) (error 'namestring-parse-error - :complaint "Expected a positive integer, ~ + :complaint "expected a positive integer, ~ got ~S" :arguments (list str) :namestring namestr @@ -1335,7 +1336,7 @@ a host-structure or string." (setq version res))))) (when (cdr chunks) (error 'namestring-parse-error - :complaint "Extra stuff after end of file name." + :complaint "extra stuff after end of file name" :namestring namestr :offset (cdadr chunks))))) (parse-host (logical-chunkify namestr start end))) @@ -1356,7 +1357,7 @@ a host-structure or string." (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*))) (when (eq (%pathname-host res) (%pathname-host *logical-pathname-defaults*)) - (error "Logical namestring does not specify a host:~% ~S" + (error "This logical namestring does not specify a host:~% ~S" pathspec)) res))) @@ -1379,7 +1380,7 @@ a host-structure or string." ((eq dir :wild-inferiors) (pieces "**;")) (t - (error "Invalid directory component: ~S" dir)))))) + (error "invalid directory component: ~S" dir)))))) (apply #'concatenate 'simple-string (pieces)))) (defun unparse-logical-piece (thing) @@ -1395,7 +1396,7 @@ a host-structure or string." (strings "**")) ((eq piece :multi-char-wild) (strings "*")) - (t (error "Invalid keyword: ~S" piece)))))) + (t (error "invalid keyword: ~S" piece)))))) (apply #'concatenate 'simple-string (strings)))))) (defun unparse-logical-namestring (pathname) @@ -1416,7 +1417,7 @@ a host-structure or string." (collect ((res)) (dolist (tr transl-list) (unless (and (consp tr) (= (length tr) 2)) - (error "Logical pathname translation is not a two-list:~% ~S" + (error "This logical pathname translation is not a two-list:~% ~S" tr)) (let ((from (first tr))) (res (list (if (typep from 'logical-pathname) @@ -1479,7 +1480,7 @@ a host-structure or string." (dolist (x (logical-host-canon-transls (%pathname-host pathname)) (error 'simple-file-error :pathname pathname - :format-control "No translation for ~S" + :format-control "no translation for ~S" :format-arguments (list pathname))) (destructuring-bind (from to) x (when (pathname-match-p pathname from) diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index ef13dc7..0752e42 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -247,8 +247,3 @@ (defun backend-byte-fasl-file-implementation () *backend-byte-order*) - -(defun backend-byte-fasl-file-type () - (ecase *backend-byte-order* - (:big-endian "bytef") - (:little-endian "lbytef"))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 692712b..d0f010f 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -2079,7 +2079,7 @@ ;; host. When we go from the cross-compiler (where we bound ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL - ;; would go and executes nested EVAL-WHENs even when they're not + ;; would go and execute nested EVAL-WHENs even when they're not ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes ;; the cross-compilation host to bind its own ;; *ALREADY-EVALED-THIS* variable, so that the problem is @@ -2090,7 +2090,12 @@ ;; conditional on #+CMU.) #+(and sb-xc-host (or sbcl cmu)) (let (#+sbcl (sb-eval::*already-evaled-this* t) - #+cmu (stub:probably similar but has not been tested)) + ;; KLUDGE: I thought this would be the right workaround + ;; for CMUCL, but at least on cmucl-2.4.19 and + ;; sbcl-0.6.9.5, it doesn't seem to work, at least + ;; not for Martin Atzmueller and me. -- WHN 2000-12-12 + ;;#+cmu (common-lisp::*already-evaled-this* t) + #+cmu (oops still do not know how to make this work)) (eval `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)))) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp new file mode 100644 index 0000000..949e5b7 --- /dev/null +++ b/tests/pathnames.impure.lisp @@ -0,0 +1,32 @@ +;;;; miscellaneous tests of pathname-related stuff + +;;;; This file is naturally impure because we mess with +;;;; LOGICAL-PATHNAME-TRANSLATIONS. + +;;;; 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") + +(setf (logical-pathname-translations "foo") + '(("REL;*.*.*" "/tmp/") + ("MAIL;**;*.MAIL" "/tmp/subdir/") + ("PROGGIES;*" "/tmp/"))) + +(assert (string= (format nil + "~S" + (translate-logical-pathname "foo:proggies;save")) + "#P\"/tmp/save\"")) + +(compile-file-pathname "foo:proggies;save") + +;;; success +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 0370fd3..5bcadb0 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.4" +"0.6.9.5" -- 1.7.10.4