;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.21: Another System Definition Facility.
+;;; This is ASDF 2.23: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
- (asdf-version "2.21")
+ (asdf-version "2.23")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
#:coerce-name
#:directory-pathname-p #:ensure-directory-pathname
#:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
- #:getenv
+ #:getenv #:getenv-pathname #:getenv-pathname
+ #:getenv-absolute-directory #:getenv-absolute-directories
#:probe-file*
#:find-symbol* #:strcat
#:make-pathname-component-logical #:make-pathname-logical
:initarg :if-component-dep-fails
:accessor module-if-component-dep-fails)
(default-component-class
- :initform *default-component-class*
+ :initform nil
:initarg :default-component-class
:accessor module-default-component-class)))
(*compile-file-failure-behaviour* (operation-on-failure operation)))
(multiple-value-bind (output warnings-p failure-p)
(call-with-around-compile-hook
- c #'(lambda ()
+ c #'(lambda (&rest flags)
(apply *compile-op-compile-file-function* source-file
:output-file output-file
:external-format (component-external-format c)
- (compile-op-flags operation))))
+ (append flags (compile-op-flags operation)))))
(unless output
(error 'compile-error :component c :operation operation))
(when failure-p
directory-pathname
(default-directory))))
+(defun* find-class* (x &optional (errorp t) environment)
+ (etypecase x
+ ((or standard-class built-in-class) x)
+ (symbol (find-class x errorp environment))))
+
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
type
class (find-class 'component)))
:return class)
(and (eq type :file)
- (or (and parent (module-default-component-class parent))
- (find-class *default-component-class*)))
+ (find-class*
+ (or (loop :for module = parent :then (component-parent module) :while module
+ :thereis (module-default-component-class module))
+ *default-component-class*) nil))
(sysdef-error "don't recognize component type ~A" type)))
(defun* maybe-add-tree (tree op1 op2 c)
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
- components pathname default-component-class
+ components pathname
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to
do-first
:pathname pathname
:parent parent
(remove-keys
- '(components pathname default-component-class
+ '(components pathname
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to)
rest)))
(setf ret (apply 'make-instance (class-for-type parent type) args)))
(component-pathname ret) ; eagerly compute the absolute pathname
(when (typep ret 'module)
- (setf (module-default-component-class ret)
- (or default-component-class
- (and (typep parent 'module)
- (module-default-component-class parent))))
(let ((*serial-depends-on* nil))
(setf (module-components ret)
(loop
#+mcl (current-user-homedir-pathname)
#-mcl (user-homedir-pathname))))
-(defun* ensure-absolute-pathname* (x fmt &rest args)
- (and (plusp (length x))
- (or (absolute-pathname-p x)
- (cerror "ignore relative pathname"
- "Invalid relative pathname ~A~@[ ~?~]" x fmt args))
- x))
-(defun* split-absolute-pathnames (x fmt &rest args)
+(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
+ (when (plusp (length x))
+ (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
+ (when want-absolute
+ (unless (absolute-pathname-p p)
+ (cerror "ignore relative pathname"
+ "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
+ (return-from ensure-pathname* nil)))
+ p)))
+(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
(loop :for dir :in (split-string
x :separator (string (inter-directory-separator)))
- :do (apply 'ensure-absolute-pathname* dir fmt args)
- :collect dir))
-(defun getenv-absolute-pathname (x &aux (s (getenv x)))
- (ensure-absolute-pathname* s "from (getenv ~S)" x))
-(defun getenv-absolute-pathnames (x &aux (s (getenv x)))
+ :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
+(defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
+ (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
+(defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
(and (plusp (length s))
- (split-absolute-pathnames s "from (getenv ~S) = ~S" x s)))
+ (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
+(defun getenv-absolute-directory (x)
+ (getenv-pathname x :want-absolute t :want-directory t))
+(defun getenv-absolute-directories (x)
+ (getenv-pathnames x :want-absolute t :want-directory t))
+
(defun* user-configuration-directories ()
(let ((dirs
`(,@(when (os-unix-p)
(cons
- (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/")
- (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS")
+ (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
+ (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
:collect (subpathname* dir "common-lisp/"))))
,@(when (os-windows-p)
`(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv-absolute-pathname "LOCALAPPDATA"))
+ (getenv-absolute-directory "LOCALAPPDATA"))
"common-lisp/config/")
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
- (getenv-absolute-pathname "APPDATA"))
+ (getenv-absolute-directory "APPDATA"))
"common-lisp/config/")))
,(subpathname (user-homedir) ".config/common-lisp/"))))
(remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
(aif
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
(subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv-absolute-pathname "ALLUSERSAPPDATA")
- (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))
+ (getenv-absolute-directory "ALLUSERSAPPDATA")
+ (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))
"common-lisp/config/")
(list it)))))
(defvar *user-cache*
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
- (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation)
+ (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
(when (os-windows-p)
(try (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv-absolute-pathname "LOCALAPPDATA")
+ (getenv-absolute-directory "LOCALAPPDATA")
#+lispworks (sys:get-folder-path :appdata)
- (getenv-absolute-pathname "APPDATA"))
+ (getenv-absolute-directory "APPDATA"))
"common-lisp" "cache" :implementation))
'(:home ".cache" "common-lisp" :implementation))))
`(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
- #+sbcl ,(let ((h (getenv "SBCL_HOME")))
- (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
+ #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
+ (when h `((,(truenamize h) ,*wild-inferiors*) ())))
;; The below two are not needed: no precompiled ASDF system there
- ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
;; All-import, here is where we want user stuff to be:
:inherit-configuration
(when (and x (probe-file* x))
(delete-file x)))
-(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
- (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
+(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
+ (let* ((keywords (remove-keyword :compile-check keys))
+ (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
(tmp-file (tmpize-pathname output-file))
(status :error))
(multiple-value-bind (output-truename warnings-p failure-p)
- (apply 'compile-file input-file :output-file tmp-file keys)
+ (apply 'compile-file input-file :output-file tmp-file keywords)
(cond
(failure-p
(setf status *compile-file-failure-behaviour*))
(setf status *compile-file-warnings-behaviour*))
(t
(setf status :success)))
- (ecase status
- ((:success :warn :ignore)
+ (cond
+ ((and (ecase status
+ ((:success :warn :ignore) t)
+ ((:error nil)))
+ (or (not compile-check)
+ (apply compile-check input-file :output-file tmp-file keywords)))
(delete-file-if-exists output-file)
(when output-truename
(rename-file output-truename output-file)
(setf output-truename output-file)))
- (:error
+ (t ;; error or failed check
(delete-file-if-exists output-truename)
- (setf output-truename nil)))
+ (setf output-truename nil failure-p t)))
(values output-truename warnings-p failure-p))))
#+abcl
entries))
(defun* directory-files (directory &optional (pattern *wild-file*))
- (setf directory (pathname directory))
- (when (wild-pathname-p directory)
- (error "Invalid wild in ~S" directory))
- (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
- (error "Invalid file pattern ~S" pattern))
- (when (typep directory 'logical-pathname)
- (setf pattern (make-pathname-logical pattern (pathname-host directory))))
- (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
- (filter-logical-directory-results
- directory entries
- #'(lambda (f)
- (make-pathname :defaults directory
- :name (pathname-name f)
- :type (make-pathname-component-logical (pathname-type f))
- :version (make-pathname-component-logical (pathname-version f)))))))
+ (let ((dir (pathname directory)))
+ (when (typep dir 'logical-pathname)
+ ;; Because of the filtering we do below,
+ ;; logical pathnames have restrictions on wild patterns.
+ ;; Not that the results are very portable when you use these patterns on physical pathnames.
+ (when (wild-pathname-p dir)
+ (error "Invalid wild pattern in logical directory ~S" directory))
+ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+ (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
+ (filter-logical-directory-results
+ directory entries
+ #'(lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical (pathname-name f))
+ :type (make-pathname-component-logical (pathname-type f))
+ :version (make-pathname-component-logical (pathname-version f))))))))
(defun* directory-asd-files (directory)
(directory-files directory *wild-asd*))
(defun* wrapping-source-registry ()
`(:source-registry
- #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
+ #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
:inherit-configuration
#+cmu (:tree #p"modules:")
#+scl (:tree #p"file://modules/")))
(:directory ,(default-directory))
,@(loop :for dir :in
`(,@(when (os-unix-p)
- `(,(or (getenv-absolute-pathname "XDG_DATA_HOME")
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
(subpathname (user-homedir) ".local/share/"))
- ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS")
+ ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
'("/usr/local/share" "/usr/share"))))
,@(when (os-windows-p)
`(,(or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv-absolute-pathname "LOCALAPPDATA"))
+ (getenv-absolute-directory "LOCALAPPDATA"))
,(or #+lispworks (sys:get-folder-path :appdata)
- (getenv-absolute-pathname "APPDATA"))
+ (getenv-absolute-directory "APPDATA"))
,(or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv-absolute-pathname "ALLUSERSAPPDATA")
- (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")))))
+ (getenv-absolute-directory "ALLUSERSAPPDATA")
+ (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))
:collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
:collect `(:tree ,(subpathname* dir "common-lisp/source/")))
:inherit-configuration))
(let ((*verbose-out* (make-broadcast-stream))
(system (find-system (string-downcase name) nil)))
(when system
- (operate *require-asdf-operator* system :verbose nil)
+ (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems))
t))))
#+(or abcl clisp clozure cmu ecl sbcl)
projects / sbcl.git / commitdiff