Commit 861ae22a authored by Raymond Toy's avatar Raymond Toy
Browse files

Update to ASDF 3.0.3.

parent 61218b92
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 3.0.2: Another System Definition Facility.
;;; This is ASDF 3.0.3: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -54,7 +54,7 @@
(declaim (optimize (speed 1) (safety 3) (debug 3)))
(setf ext:*gc-verbose* nil))
#+(or abcl clisp clozure cmu ecl xcl)
#+(or abcl clisp clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*)
(let* ((existing-version
......@@ -71,7 +71,7 @@
(existing-version-number (and existing-version (read-from-string existing-major-minor)))
(away (format nil "~A-~A" :asdf existing-version)))
(when (and existing-version
(< existing-version-number #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))
(< existing-version-number 2.27))
(rename-package :asdf away)
(when *load-verbose*
(format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
......@@ -86,7 +86,7 @@
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; This package definition MUST NOT change unless its name too changes;
;; if/when it changes, don't forget to add new functions missing from below.
;; Until then, asdf/package is frozen to forever
;; Until then, uiop/package is frozen to forever
;; import and export the same exact symbols as for ASDF 2.27.
;; Any other symbol must be import-from'ed and re-export'ed in a different package.
(:use :common-lisp)
......@@ -562,7 +562,14 @@ or when loading the package is optional."
(home-package-p existing to-package) (symbol-package-name existing)))
(t
(ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
(defun recycle-symbol (name recycle exported)
;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
;; packages, and a hash-table of names (strings) of symbols scheduled to be
;; EXPORTED from the package being defined. It returns two values, the
;; symbol found (if any, or else NIL), and a boolean flag indicating whether
;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
;; re-homing of the symbol, etc.
(check-type name string)
(check-type recycle list)
(check-type exported hash-table)
......@@ -776,6 +783,28 @@ or when loading the package is optional."
:mix ,mix :reexport ,reexport :unintern ,unintern)))))
(defmacro define-package (package &rest clauses)
"DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
\(KEYWORD . ARGS\).
DEFINE-PACKAGE supports the following keywords:
USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
RECYCLE -- Recycle the package's exported symbols from the specified packages,
in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
one of the :RECYCLE packages, the first such symbol is re-homed to the package
being defined.
For the sake of idempotence, it is important that the package being defined
should appear in first position if it already exists, and even if it doesn't,
ahead of any package that is not going to be deleted afterwards and never
created again. In short, except for special cases, always make it the first
package on the list if the list is not empty.
MIX -- Takes a list of package designators. MIX behaves like
\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
resolve conflicts in favor of the first found symbol. It may still yield
an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol.
REEXPORT -- Takes a list of package designators. For each package, p, in the list,
export symbols with the same name as those exported from p. Note that in the case
of shadowing, etc. the symbols with the same name may not be the same symbols.
UNINTERN -- Remove symbols here from PACKAGE."
(let ((ensure-form
`(apply 'ensure-package ',(parse-define-package-form package clauses))))
`(progn
......@@ -846,10 +875,14 @@ or when loading the package is optional."
;;;; Early meta-level tweaks
#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
clozure lispworks (and sbcl sb-unicode) scl)
#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl)
(eval-when (:load-toplevel :compile-toplevel :execute)
(pushnew :asdf-unicode *features*))
;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
(when (and #+allegro (member :ics *features*)
#+(or clisp cmu ecl mkcl) (member :unicode *features*)
#+sbcl (member :sb-unicode *features*))
(pushnew :asdf-unicode *features*)))
#+allegro
(eval-when (:load-toplevel :compile-toplevel :execute)
......@@ -860,6 +893,20 @@ or when loading the package is optional."
(setf excl:*warn-on-nested-reader-conditionals* nil))
(setf *print-readably* nil))
#+clozure (in-package :ccl)
#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (fboundp 'external-process-wait)
(in-development-mode
(defun external-process-wait (proc)
(when (and (external-process-pid proc) (eq (external-process-%status proc) :running))
(with-interrupts-enabled
(wait-on-semaphore (external-process-completed proc))))
(values (external-process-%exit-code proc)
(external-process-%status proc))))))
#+clozure (in-package :uiop/common-lisp)
#+cormanlisp
(eval-when (:load-toplevel :compile-toplevel :execute)
(deftype logical-pathname () nil)
......@@ -962,6 +1009,12 @@ or when loading the package is optional."
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun frob-substrings (string substrings &optional frob)
"for each substring in SUBSTRINGS, find occurrences of it within STRING
that don't use parts of matched occurrences of previous strings, and
FROB them, that is to say, remove them if FROB is NIL,
replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
call FROB with the match and a function that emits a string in the output.
Return a string made of the parts not omitted or emitted by FROB."
(declare (optimize (speed 0) (safety 3) (debug 3)))
(let ((length (length string)) (stream nil))
(labels ((emit-string (x &optional (start 0) (end (length x)))
......@@ -998,8 +1051,6 @@ or when loading the package is optional."
#+(or gcl genera)
(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format))
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities for ASDF
......@@ -1007,7 +1058,7 @@ or when loading the package is optional."
(:nicknames :asdf/utility)
(:recycle :uiop/utility :asdf/utility :asdf)
(:use :uiop/common-lisp :uiop/package)
;; import and reexport a few things defined in :asdf/common-lisp
;; import and reexport a few things defined in :uiop/common-lisp
(:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
......@@ -1021,14 +1072,15 @@ or when loading the package is optional."
#:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
#:+non-base-chars-exist-p+ ;; characters
#:+max-character-type-index+ #:character-type-index #:+character-types+
#:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string
#:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
#:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
#:list-to-hash-set ;; hash-table
#:list-to-hash-set #:ensure-gethash ;; hash-table
#:ensure-function #:access-at #:access-at-count ;; functions
#:call-function #:call-functions #:register-hook-function
#:match-condition-p #:match-any-condition-p ;; conditions
......@@ -1070,9 +1122,9 @@ or when loading the package is optional."
;; undefining the previous function is the portable way
;; of overriding any incompatible previous gf, except on CLISP.
;; We usually try to do it only for the functions that need it,
;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
;; which happens in asdf/upgrade - however, for ECL, we need this hammer
;; (which causes issues in clisp)
,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
,@(when (or #-clisp supersede #+(or ecl gcl2.7) t)
`((undefine-function ',name)))
#-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
......@@ -1188,23 +1240,54 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters
(with-upgradability ()
(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
(defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
(with-upgradability ()
(defparameter +character-types+ ;; assuming a simple hierarchy
#(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character))
(defparameter +max-character-type-index+ (1- (length +character-types+))))
(with-upgradability ()
(defun character-type-index (x)
(declare (ignorable x))
#.(case +max-character-type-index+
(0 0)
(1 '(etypecase x
(character (if (typep x 'base-char) 0 1))
(symbol (if (subtypep x 'base-char) 0 1))))
(otherwise
'(or (position-if (etypecase x
(character #'(lambda (type) (typep x type)))
(symbol #'(lambda (type) (subtypep x type))))
+character-types+)
(error "Not a character or character type: ~S" x))))))
;;; Strings
(with-upgradability ()
(defun base-string-p (string)
"Does the STRING only contain BASE-CHARs?"
(declare (ignorable string))
(and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
(defun strings-common-element-type (strings)
"What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
(declare (ignorable strings))
#-non-base-chars-exist-p 'character
#+non-base-chars-exist-p
(if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
'base-char 'character))
#.(if +non-base-chars-exist-p+
`(aref +character-types+
(loop :with index = 0 :for s :in strings :do
(cond
((= index ,+max-character-type-index+) (return index))
((emptyp s)) ;; NIL or empty string
((characterp s) (setf index (max index (character-type-index s))))
((stringp s) (unless (>= index (character-type-index (array-element-type s)))
(setf index (reduce 'max s :key #'character-type-index
:initial-value index))))
(t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))
:finally (return index)))
''character))
(defun reduce/strcat (strings &key key start end)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
......@@ -1222,12 +1305,16 @@ NIL is interpreted as an empty string. A character is interpreted as a string of
:finally (return output)))
(defun strcat (&rest strings)
"Concatenate strings.
NIL is interpreted as an empty string, a character as a string of length one."
(reduce/strcat strings))
(defun first-char (s)
"Return the first character of a non-empty string S, or NIL"
(and (stringp s) (plusp (length s)) (char s 0)))
(defun last-char (s)
"Return the last character of a non-empty string S, or NIL"
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
(defun split-string (string &key max (separator '(#\Space #\Tab)))
......@@ -1238,6 +1325,7 @@ starting the separation from the end, e.g. when called with arguments
\"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
(block ()
(let ((list nil) (words 0) (end (length string)))
(when (zerop end) (return nil))
(flet ((separatorp (char) (find char separator))
(done () (return (cons (subseq string 0 end) list))))
(loop
......@@ -1270,6 +1358,22 @@ starting the separation from the end, e.g. when called with arguments
(and (string-prefix-p prefix string)
(string-suffix-p string suffix))))
(defvar +cr+ (coerce #(#\Return) 'string))
(defvar +lf+ (coerce #(#\Linefeed) 'string))
(defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))
(defun stripln (x)
"Strip a string X from any ending CR, LF or CRLF.
Return two values, the stripped string and the ending that was stripped,
or the original value and NIL if no stripping took place.
Since our STRCAT accepts NIL as empty string designator,
the two results passed to STRCAT always reconstitute the original string"
(check-type x string)
(block nil
(flet ((c (end) (when (string-suffix-p x end)
(return (values (subseq x 0 (- (length x) (length end))) end)))))
(when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
;;; CLOS
(with-upgradability ()
......@@ -1280,7 +1384,7 @@ starting the separation from the end, e.g. when called with arguments
(symbol (find-class x errorp environment)))))
;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
(deftype stamp () '(or real boolean)))
(with-upgradability ()
......@@ -1304,12 +1408,6 @@ starting the separation from the end, e.g. when called with arguments
(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
;;; Hash-tables
(with-upgradability ()
(defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
(dolist (x list h) (setf (gethash x h) t))))
;;; Function designators
(with-upgradability ()
(defun ensure-function (fun &key (package :cl))
......@@ -1320,14 +1418,17 @@ If the FUN is a non-sequence literal constant, return constantly that,
i.e. for a boolean keyword character number or pathname.
Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
If FUN is a CONS, return the function that applies its CAR
to the appended list of the rest of its CDR and the arguments.
to the appended list of the rest of its CDR and the arguments,
unless the CAR is LAMBDA, in which case the expression is evaluated.
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
(etypecase fun
(function fun)
((or boolean keyword character number pathname) (constantly fun))
((or function symbol) fun)
(cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
(symbol fun)
(cons (if (eq 'lambda (car fun))
(eval fun)
#'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
(string (eval `(function ,(with-standard-io-syntax
(let ((*package* (find-package package)))
(read-from-string fun))))))))
......@@ -1357,7 +1458,7 @@ instead of a list."
(defun access-at-count (at)
"From an AT specification, extract a COUNT of maximum number
of sub-objects to read as per ACCESS-AT"
of sub-objects to read as per ACCESS-AT"
(cond
((integerp at)
(1+ at))
......@@ -1365,16 +1466,38 @@ instead of a list."
(1+ (first at)))))
(defun call-function (function-spec &rest arguments)
"Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
with the given ARGUMENTS"
(apply (ensure-function function-spec) arguments))
(defun call-functions (function-specs)
"For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
(map () 'call-function function-specs))
(defun register-hook-function (variable hook &optional call-now-p)
(pushnew hook (symbol-value variable))
"Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
When CALL-NOW-P is true, also call the function immediately."
(pushnew hook (symbol-value variable) :test 'equal)
(when call-now-p (call-function hook))))
;;; Hash-tables
(with-upgradability ()
(defun ensure-gethash (key table default)
"Lookup the TABLE for a KEY as by gethash, but if not present,
call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
set the corresponding entry to the result in the table, and return that result."
(multiple-value-bind (value foundp) (gethash key table)
(if foundp
value
(setf (gethash key table) (values (call-function default))))))
(defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
"Convert a LIST into hash-table that has the same elements when viewed as a set,
up to the given equality TEST"
(dolist (x list h) (setf (gethash x h) t))))
;;; Version handling
(with-upgradability ()
(defun unparse-version (version-list)
......@@ -1471,6 +1594,7 @@ or a string describing the format-control of a simple-condition."
(loop :for x :in conditions :thereis (match-condition-p x condition)))
(defun call-with-muffled-conditions (thunk conditions)
"calls the THUNK in a context where the CONDITIONS are muffled"
(handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
(muffle-warning c)))))
(funcall thunk)))
......@@ -1478,7 +1602,6 @@ or a string describing the format-control of a simple-condition."
(defmacro with-muffled-conditions ((conditions) &body body)
`(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
;;;; ---------------------------------------------------------------------------
;;;; Access to the Operating System
......@@ -1487,7 +1610,7 @@ or a string describing the format-control of a simple-condition."
(:recycle :uiop/os :asdf/os :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility)
(:export
#:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
#:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
#:getenv #:getenvp ;; environment variables
#:implementation-identifier ;; implementation identifier
#:implementation-type #:*implementation-type*
......@@ -1501,6 +1624,11 @@ or a string describing the format-control of a simple-condition."
;;; Features
(with-upgradability ()
(defun featurep (x &optional (*features* *features*))
"Checks whether a feature expression X is true with respect to the *FEATURES* set,
as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
your reader will not have magically used the KEYWORD package, so you need specify
keywords explicitly."
(cond
((atom x) (and (member x *features*) t))
((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
......@@ -1509,22 +1637,38 @@ or a string describing the format-control of a simple-condition."
(t (error "Malformed feature specification ~S" x))))
(defun os-unix-p ()
"Is the underlying operating system some Unix variant?"
(or #+abcl (featurep :unix)
#+(and (not abcl) (or unix cygwin darwin)) t))
(defun os-macosx-p ()
"Is the underlying operating system MacOS X?"
;; OS-MACOSX is not mutually exclusive with OS-UNIX,
;; in fact the former implies the latter.
(or
#+allegro (featurep :macosx)
#+clisp (featurep :macos)
(featurep :darwin)))
(defun os-windows-p ()
"Is the underlying operating system Microsoft Windows?"
(or #+abcl (featurep :windows)
#+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
(defun os-genera-p ()
"Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
(or #+genera t))
(defun os-oldmac-p ()
"Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
(or #+mcl t))
(defun detect-os ()
"Detects the current operating system. Only needs be run at compile-time,
except on ABCL where it might change between FASL compilation and runtime."
(loop* :with o
:for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
(:os-macosx . os-macosx-p)
(:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
:when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
:else :do (setf *features* (remove feature *features*))
......@@ -1538,6 +1682,9 @@ that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port
(with-upgradability ()
(defun getenv (x)
"Query the environment, as in C getenv.
Beware: may return empty string if a variable is present but empty;
use getenvp to return NIL in such a case."
(declare (ignorable x))
#+(or abcl clisp ecl xcl) (ext:getenv x)
#+allegro (sys:getenv x)
......@@ -1579,6 +1726,7 @@ then returning the non-empty string value of the variable"
(with-upgradability ()
(defun first-feature (feature-sets)
"A helper for various feature detection functions"
(dolist (x feature-sets)
(multiple-value-bind (short long feature-expr)
(if (consp x)
......@@ -1588,15 +1736,18 @@ then returning the non-empty string value of the variable"
(return (values short long))))))
(defun implementation-type ()
"The type of Lisp implementation used, as a short UIOP-standardized keyword"
(first-feature
'(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
(:cmu :cmucl :cmu) :ecl :gcl
(:lwpe :lispworks-personal-edition) (:lw :lispworks)
:mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
(defvar *implementation-type* (implementation-type))
(defvar *implementation-type* (implementation-type)
"The type of Lisp implementation used, as a short UIOP-standardized keyword")
(defun operating-system ()
"The operating system of the current host"
(first-feature
'(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
(:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
......@@ -1605,6 +1756,7 @@ then returning the non-empty string value of the variable"
:genera)))
(defun architecture ()
"The CPU architecture of the current host"
(first-feature
'((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
(:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
......@@ -1625,6 +1777,7 @@ then returning the non-empty string value of the variable"
(error "Can't determine fasl version.")))
(defun lisp-version-string ()
"return a string that identifies the current Lisp implementation version"
(let ((s (lisp-implementation-version)))
(car ; as opposed to OR, this idiom prevents some unreachable code warning
(list
......@@ -1660,6 +1813,8 @@ then returning the non-empty string value of the variable"
s))))
(defun implementation-identifier ()
"Return a string that identifies the ABI of the current implementation,
suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
(substitute-if
#\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
(format nil "~(~a~@{~@[-~a~]~}~)"
......@@ -1673,6 +1828,7 @@ then returning the non-empty string value of the variable"
(with-upgradability ()
(defun hostname ()
"return the hostname of the current host"
;; Note: untested on RMCL
#+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
#+cormanlisp "localhost" ;; is there a better way? Does it matter?
......@@ -1686,6 +1842,7 @@ then returning the non-empty string value of the variable"
#+cmu
(defun parse-unix-namestring* (unix-namestring)
"variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
(multiple-value-bind (host device directory name type version)
(lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
(make-pathname :host (or host lisp::*unix-host*) :device device
......@@ -1735,22 +1892,27 @@ then returning the non-empty string value of the variable"
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
(with-upgradability ()
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun read-null-terminated-string (s)
"Read a null-terminated string from an octet stream S"
;; note: doesn't play well with UNICODE
(with-output-to-string (out)
(loop :for code = (read-byte s)
:until (zerop code)
:do (write-char (code-char code) out))))
(defun read-little-endian (s &optional (bytes 4))
"Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
(loop :for i :from 0 :below bytes
:sum (ash (read-byte s) (* 8 i))))
(defun parse-file-location-info (s)
"helper to parse-windows-shortcut"
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
......@@ -1774,6 +1936,8 @@ then returning the non-empty string value of the variable"
(read-null-terminated-string s))))))
(defun parse-windows-shortcut (pathname)
"From a .lnk windows shortcut, extract the pathname linked to"
;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
(when (and (= (read-little-endian s) *link-initial-dword*)
......@@ -1822,7 +1986,7 @@ then returning the non-empty string value of the variable"
#:merge-pathnames*
#:nil-pathname #:*nil-pathname* #:with-pathname-defaults
;; Predicates
#:pathname-equal #:logical-pathname-p #:physical-pathname-p
#:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname
#:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
;; Directories
#:pathname-directory-pathname #:pathname-parent-directory-pathname
......@@ -1835,7 +1999,7 @@ then returning the non-empty string value of the variable"
#:subpathname #:subpathname*
#:ensure-absolute-pathname
#:pathname-root #:pathname-host-pathname
#:subpathp
#:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname
;; Checking constraints
#:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
;; Wildcard pathnames
......@@ -1851,7 +2015,9 @@ then returning the non-empty string value of the variable"
(with-upgradability ()
(defun normalize-pathname-directory-component (directory)
"Given a pathname directory component, return an equivalent form that is a list"
"Convert the DIRECTORY component from a format usable by the underlying
implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
that is a list and not a string."
#+gcl2.6 (setf directory (substitute :back :parent directory))
(cond
#-(or cmu sbcl scl) ;; these implementations already normalize directory components.
......@@ -1869,6 +2035,8 @@ then returning the non-empty string value of the variable"
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
(defun denormalize-pathname-directory-component (directory-component)
"Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
by the underlying implementation's MAKE-PATHNAME and other primitives"
#-gcl2.6 directory-component
#+gcl2.6
(let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
......@@ -1879,7 +2047,7 @@ then returning the non-empty string value of the variable"
(t d))))
(defun merge-pathname-directory-components (specified defaults)
;; Helper for merge-pathnames* that handles directory components.
"Helper for MERGE-PATHNAMES* that handles directory components"
(let ((directory (normalize-pathname-directory-component specified)))
(ecase (first directory)
((nil) defaults)
......@@ -1906,7 +2074,8 @@ then returning the non-empty string value of the variable"
;; This will be :unspecific if supported, or NIL if not.
(defparameter *unspecific-pathname-type*
#+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
#+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
#+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
(defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
host (device () #+allegro devicep) name type version defaults
......@@ -1947,11 +2116,11 @@ and make a new pathname with corresponding components and specified logical HOST
if the SPECIFIED pathname does not have an absolute directory,
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
then the HOST and DEVICE both come from the SPECIFIED.
then the HOST and DEVICE both come from the SPECIFIED pathname.
This is what users want on a modern Unix or Windows operating system,
unlike the MERGE-PATHNAME behavior.
unlike the MERGE-PATHNAMES behavior.
Also, if either argument is NIL, then the other argument is returned unmodified;