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
* 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.
"BLOCK-NUMBER"
"BACKEND"
"BACKEND-BYTE-FASL-FILE-IMPLEMENTATION"
- "BACKEND-BYTE-FASL-FILE-TYPE"
"IR2-BLOCK-BLOCK"
"DISASSEM-BYTE-COMPONENT"
"FUNCALLABLE-INSTANCE-LEXENV"
;; 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"
(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
(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
(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.
;;;
(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))
(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)))
(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))))
(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)))))
(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)
(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)
(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
(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)))))
\f
;;;; wild pathnames
(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)))
(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)))))))
(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")
(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))))
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)))
(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
(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))
(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)))
(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)))
(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
(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)))
(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)))
\f
((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)
(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)
(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)
(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)
(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")))
;; 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
;; 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))))
--- /dev/null
+;;;; 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)
;;; 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"
projects / sbcl.git / commitdiff