-;;; -*- mode: common-lisp; package: asdf; -*-
-;;; This is ASDF: Another System Definition Facility.
+;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.015: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
-;;; bugs. There are usually two "supported" revisions - the git HEAD
-;;; is the latest development version, whereas the revision tagged
-;;; RELEASE may be slightly older but is considered `stable'
+;;; bugs. There are usually two "supported" revisions - the git master
+;;; branch is the latest development version, whereas the git release
+;;; branch may be slightly older but is considered `stable'
;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
-;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
#+xcvb (module ())
-(cl:in-package :cl-user)
+(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
+
+#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+(error "ASDF is not supported on your implementation. Please help us with it.")
+
+#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
(eval-when (:compile-toplevel :load-toplevel :execute)
- ;;; make package if it doesn't exist yet.
- ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
- (unless (find-package :asdf)
- (make-package :asdf :use '(:cl)))
;;; Implementation-dependent tweaks
;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
#+allegro
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
- :test 'equalp :key 'car))
- #+ecl (require :cmp))
+ :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
+ #+(and ecl (not ecl-bytecmp)) (require :cmp)
+ #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
+ #+(or unix cygwin) (pushnew :asdf-unix *features*)
+ ;;; make package if it doesn't exist yet.
+ ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
+ (unless (find-package :asdf)
+ (make-package :asdf :use '(:common-lisp))))
(in-package :asdf)
;;;; Create packages in a way that is compatible with hot-upgrade.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more at the end of the file.
+;;;; See more near the end of the file.
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
- (let* ((asdf-version "2.010") ;; same as 2.146
+ (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
+ ;; Strip out formatting that is not supported on Genera.
+ ;; Has to be inside the eval-when to make Lispworks happy (!)
+ (defmacro compatfmt (format)
+ #-genera format
+ #+genera
+ (loop :for (unsupported . replacement) :in
+ '(("~@<" . "")
+ ("; ~@;" . "; ")
+ ("~3i~_" . "")
+ ("~@:>" . "")
+ ("~:>" . "")) :do
+ (loop :for found = (search unsupported format) :while found :do
+ (setf format
+ (concatenate 'simple-string
+ (subseq format 0 found) replacement
+ (subseq format (+ found (length unsupported)))))))
+ format)
+ (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
+ ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
+ ;; can help you do these changes in synch (look at the source for documentation).
+ ;; Relying on its automation, the version is now redundantly present on top of this file.
+ ;; "2.345" would be an official release
+ ;; "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.015")
(existing-asdf (fboundp 'find-system))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
- (when existing-asdf
- (format *error-output*
- "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
+ (when (and existing-asdf *asdf-verbose*)
+ (format *trace-output*
+ (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version))
(labels
- ((unlink-package (package)
+ ((present-symbol-p (symbol package)
+ (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
+ (present-symbols (package)
+ ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
+ (let (l)
+ (do-symbols (s package)
+ (when (present-symbol-p s package) (push s l)))
+ (reverse l)))
+ (unlink-package (package)
(let ((u (find-package package)))
(when u
- (ensure-unintern u
- (loop :for s :being :each :present-symbol :in u :collect s))
+ (ensure-unintern u (present-symbols u))
(loop :for p :in (package-used-by-list u) :do
(unuse-package u p))
(delete-package u))))
(remove-symbol (symbol package)
(let ((sym (find-sym symbol package)))
(when sym
- (unexport sym package)
+ #-cormanlisp (unexport sym package)
(unintern sym package)
sym)))
(ensure-unintern (package symbols)
(let ((formerly-exported-symbols nil)
(bothly-exported-symbols nil)
(newly-exported-symbols nil))
- (loop :for sym :being :each :external-symbol :in package :do
+ (do-external-symbols (sym package)
(if (member sym export :test 'string-equal)
(push sym bothly-exported-symbols)
(push sym formerly-exported-symbols)))
(#:perform #:explain #:output-files #:operation-done-p
#:perform-with-restarts #:component-relative-pathname
#:system-source-file #:operate #:find-component #:find-system
- #:apply-output-translations #:translate-pathname* #:resolve-location)
+ #:apply-output-translations #:translate-pathname* #:resolve-location
+ #:compile-file* #:source-file-type)
:unintern
(#:*asdf-revision* #:around #:asdf-method-combination
- #:split #:make-collector)
+ #:split #:make-collector
+ #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
:fmakunbound
(#:system-source-file
#:component-relative-pathname #:system-relative-pathname
#:inherit-source-registry #:process-source-registry-directive)
:export
(#:defsystem #:oos #:operate #:find-system #:run-shell-command
- #:system-definition-pathname #:find-component ; miscellaneous
+ #:system-definition-pathname
+ #:search-for-system-definition #:find-component ; miscellaneous
#:compile-system #:load-system #:test-system #:clear-system
#:compile-op #:load-op #:load-source-op
#:test-op
#:feature ; sort-of operation
#:version ; metaphorically sort-of an operation
#:version-satisfies
+ #:upgrade-asdf
+ #:implementation-identifier #:implementation-type
#:input-files #:output-files #:output-file #:perform ; operation methods
#:operation-done-p #:explain
#:component #:source-file
#:c-source-file #:cl-source-file #:java-source-file
+ #:cl-source-file.cl #:cl-source-file.lsp
#:static-file
#:doc-file
#:html-file
#:system-relative-pathname
#:map-systems
+ #:operation-description
#:operation-on-warnings
#:operation-on-failure
#:component-visited-p
#:remove-entry-from-registry
#:clear-configuration
+ #:*output-translations-parameter*
#:initialize-output-translations
#:disable-output-translations
#:clear-output-translations
#:compile-file-pathname*
#:enable-asdf-binary-locations-compatibility
#:*default-source-registries*
+ #:*source-registry-parameter*
#:initialize-source-registry
#:compute-source-registry
#:clear-source-registry
#:getenv
;; #:get-uid
;; #:length=n-p
+ ;; #:find-symbol*
#:merge-pathnames*
+ #:coerce-pathname
#:pathname-directory-pathname
#:read-file-forms
;; #:remove-keys
#:subdirectories
#:truenamize
#:while-collecting)))
+ #+genera (import 'scl:boolean :asdf)
(setf *asdf-version* asdf-version
*upgraded-p* (if existing-version
(cons existing-version *upgraded-p*)
*upgraded-p*))))))
-;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
-(when *upgraded-p*
- #+ecl
- (when (find-class 'compile-op nil)
- (defmethod update-instance-for-redefined-class :after
- ((c compile-op) added deleted plist &key)
- (declare (ignore added deleted))
- (let ((system-p (getf plist 'system-p)))
- (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
- (when (find-class 'module nil)
- (eval
- '(progn
- (defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable deleted plist))
- (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
- (when (member 'components-by-name added)
- (compute-module-components-by-name m)))
- (defmethod update-instance-for-redefined-class :after
- ((s system) added deleted plist &key)
- (declare (ignorable deleted plist))
- (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
- (when (member 'source-file added)
- (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
-
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
*asdf-version*)
(defvar *resolve-symlinks* t
(defvar *verbose-out* nil)
-(defvar *asdf-verbose* t)
-
(defparameter +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(setf excl:*warn-on-nested-reader-conditionals* nil)))
;;;; -------------------------------------------------------------------------
-;;;; ASDF Interface, in terms of generic functions.
+;;;; Resolve forward references
+
+(declaim (ftype (function (t) t)
+ format-arguments format-control
+ error-name error-pathname error-condition
+ duplicate-names-name
+ error-component error-operation
+ module-components module-components-by-name
+ circular-dependency-components
+ condition-arguments condition-form
+ condition-format condition-location
+ coerce-name)
+ #-cormanlisp
+ (ftype (function (t t) t) (setf module-components-by-name)))
+
+;;;; -------------------------------------------------------------------------
+;;;; Compatibility with Corman Lisp
+#+cormanlisp
+(progn
+ (deftype logical-pathname () nil)
+ (defun make-broadcast-stream () *error-output*)
+ (defun file-namestring (p)
+ (setf p (pathname p))
+ (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
+ (defparameter *count* 3)
+ (defun dbg (&rest x)
+ (format *error-output* "~S~%" x)))
+#+cormanlisp
+(defun maybe-break ()
+ (decf *count*)
+ (unless (plusp *count*)
+ (setf *count* 3)
+ (break)))
+
+;;;; -------------------------------------------------------------------------
+;;;; General Purpose Utilities
+
(macrolet
((defdef (def* def)
`(defmacro ,def* (name formals &rest rest)
`(progn
#+(or ecl gcl) (fmakunbound ',name)
- ,(when (and #+ecl (symbolp name))
- `(declaim (notinline ,name))) ; fails for setf functions on ecl
+ #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
+ ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
+ `(declaim (notinline ,name)))
(,',def ,name ,formals ,@rest)))))
(defdef defgeneric* defgeneric)
(defdef defun* defun))
-(defgeneric* find-system (system &optional error-p))
-(defgeneric* perform-with-restarts (operation component))
-(defgeneric* perform (operation component))
-(defgeneric* operation-done-p (operation component))
-(defgeneric* explain (operation component))
-(defgeneric* output-files (operation component))
-(defgeneric* input-files (operation component))
-(defgeneric* component-operation-time (operation component))
-(defgeneric* operation-description (operation component)
- (:documentation "returns a phrase that describes performing this operation
-on this component, e.g. \"loading /a/b/c\".
-You can put together sentences using this phrase."))
-
-(defgeneric* system-source-file (system)
- (:documentation "Return the source file in which system is defined."))
-
-(defgeneric* component-system (component)
- (:documentation "Find the top-level system containing COMPONENT"))
-
-(defgeneric* component-pathname (component)
- (:documentation "Extracts the pathname applicable for a particular component."))
-
-(defgeneric* component-relative-pathname (component)
- (:documentation "Returns a pathname for the component argument intended to be
-interpreted relative to the pathname of that component's parent.
-Despite the function's name, the return value may be an absolute
-pathname, because an absolute pathname may be interpreted relative to
-another pathname in a degenerate way."))
-
-(defgeneric* component-property (component property))
-
-(defgeneric* (setf component-property) (new-value component property))
-
-(defgeneric* version-satisfies (component version))
-
-(defgeneric* find-component (base path)
- (:documentation "Finds the component with PATH starting from BASE module;
-if BASE is nil, then the component is assumed to be a system."))
-
-(defgeneric* source-file-type (component system))
-
-(defgeneric* operation-ancestor (operation)
- (:documentation
- "Recursively chase the operation's parent pointer until we get to
-the head of the tree"))
-
-(defgeneric* component-visited-p (operation component)
- (:documentation "Returns the value stored by a call to
-VISIT-COMPONENT, if that has been called, otherwise NIL.
-This value stored will be a cons cell, the first element
-of which is a computed key, so not interesting. The
-CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as (cdr (component-visited-p op c)).
- In the current form of ASDF, the DATA value retrieved is
-effectively a boolean, indicating whether some operations are
-to be performed in order to do OPERATION X COMPONENT. If the
-data value is NIL, the combination had been explored, but no
-operations needed to be performed."))
-
-(defgeneric* visit-component (operation component data)
- (:documentation "Record DATA as being associated with OPERATION
-and COMPONENT. This is a side-effecting function: the association
-will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
-OPERATION\).
- No evidence that DATA is ever interesting, beyond just being
-non-NIL. Using the data field is probably very risky; if there is
-already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded.
- Starting with 2.006, TRAVERSE will store an integer in data,
-so that nodes can be sorted in decreasing order of traversal."))
-
-
-(defgeneric* (setf visiting-component) (new-value operation component))
-
-(defgeneric* component-visiting-p (operation component))
-
-(defgeneric* component-depends-on (operation component)
- (:documentation
- "Returns a list of dependencies needed by the component to perform
- the operation. A dependency has one of the following forms:
-
- (<operation> <component>*), where <operation> is a class
- designator and each <component> is a component
- designator, which means that the component depends on
- <operation> having been performed on each <component>; or
-
- (FEATURE <feature>), which means that the component depends
- on <feature>'s presence in *FEATURES*.
-
- Methods specialized on subclasses of existing component types
- should usually append the results of CALL-NEXT-METHOD to the
- list."))
-
-(defgeneric* component-self-dependencies (operation component))
-
-(defgeneric* traverse (operation component)
- (:documentation
-"Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; General Purpose Utilities
-
(defmacro while-collecting ((&rest collectors) &body body)
"COLLECTORS should be a list of names for collections. A collector
defines a function that, when applied to an argument inside BODY, will
(when pathname
(make-pathname :name nil :type nil :version nil :defaults pathname)))
+(defun* normalize-pathname-directory-component (directory)
+ (cond
+ #-(or cmu sbcl scl)
+ ((stringp directory) `(:absolute ,directory) directory)
+ #+gcl
+ ((and (consp directory) (stringp (first directory)))
+ `(:absolute ,@directory))
+ ((or (null directory)
+ (and (consp directory) (member (first directory) '(:absolute :relative))))
+ directory)
+ (t
+ (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
+
+(defun* merge-pathname-directory-components (specified defaults)
+ (let ((directory (normalize-pathname-directory-component specified)))
+ (ecase (first directory)
+ ((nil) defaults)
+ (:absolute specified)
+ (:relative
+ (let ((defdir (normalize-pathname-directory-component defaults))
+ (reldir (cdr directory)))
+ (cond
+ ((null defdir)
+ directory)
+ ((not (eq :back (first reldir)))
+ (append defdir reldir))
+ (t
+ (loop :with defabs = (first defdir)
+ :with defrev = (reverse (rest defdir))
+ :while (and (eq :back (car reldir))
+ (or (and (eq :absolute defabs) (null defrev))
+ (stringp (car defrev))))
+ :do (pop reldir) (pop defrev)
+ :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
+
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
"MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
Also, if either argument is NIL, then the other argument is returned unmodified."
(when (null specified) (return-from merge-pathnames* defaults))
(when (null defaults) (return-from merge-pathnames* specified))
+ #+scl
+ (ext:resolve-pathname specified defaults)
+ #-scl
(let* ((specified (pathname specified))
(defaults (pathname defaults))
- (directory (pathname-directory specified))
- (directory
- (cond
- #-(or sbcl cmu)
- ((stringp directory) `(:absolute ,directory) directory)
- #+gcl
- ((and (consp directory) (stringp (first directory)))
- `(:absolute ,@directory))
- ((or (null directory)
- (and (consp directory) (member (first directory) '(:absolute :relative))))
- directory)
- (t
- (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
+ (directory (normalize-pathname-directory-component (pathname-directory specified)))
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
(ecase (first directory)
- ((nil)
- (values (pathname-host defaults)
- (pathname-device defaults)
- (pathname-directory defaults)
- (unspecific-handler defaults)))
((:absolute)
(values (pathname-host specified)
(pathname-device specified)
directory
(unspecific-handler specified)))
- ((:relative)
+ ((nil :relative)
(values (pathname-host defaults)
(pathname-device defaults)
- (if (pathname-directory defaults)
- (append (pathname-directory defaults) (cdr directory))
- directory)
+ (merge-pathname-directory-components directory (pathname-directory defaults))
(unspecific-handler defaults))))
(make-pathname :host host :device device :directory directory
:name (funcall unspecific-handler name)
:type (funcall unspecific-handler type)
:version (funcall unspecific-handler version))))))
+(defun* pathname-parent-directory-pathname (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+ (when pathname
+ (make-pathname :name nil :type nil :version nil
+ :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
+ :defaults pathname)))
+
+
(define-modify-macro appendf (&rest args)
append "Append onto list") ;; only to be used on short lists.
(defun* last-char (s)
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+
(defun* asdf-message (format-string &rest format-args)
(declare (dynamic-extent format-args))
- (apply #'format *verbose-out* format-string format-args))
+ (apply 'format *verbose-out* format-string format-args))
(defun* split-string (string &key max (separator '(#\Space #\Tab)))
"Split STRING into a list of components separated by
If MAX is specified, then no more than max(1,MAX) components will be returned,
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 nil
+ (catch nil
(let ((list nil) (words 0) (end (length string)))
(flet ((separatorp (char) (find char separator))
- (done () (return (cons (subseq string 0 end) list))))
+ (done () (throw nil (cons (subseq string 0 end) list))))
(loop
:for start = (if (and max (>= words (1- max)))
(done)
;; Giving :unspecific as argument to make-pathname is not portable.
;; See CLHS make-pathname and 19.2.2.2.3.
;; We only use it on implementations that support it.
- (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
+ (or #+(or clozure gcl lispworks sbcl) :unspecific)))
(destructuring-bind (name &optional (type unspecific))
(split-string filename :max 2 :separator ".")
(if (equal name "")
pathnames."
(check-type s string)
(when (find #\: s)
- (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
+ (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
(let* ((components (split-string s :separator "/"))
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first-char s) #\/)
(progn
(when force-relative
- (error "absolute pathname designator not allowed: ~S" s))
+ (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
(values :absolute (cdr components)))
(values :relative nil))
(values :relative components))
- (setf components (remove "" components :test #'equal))
+ (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
+ (setf components (substitute :back ".." components :test #'equal))
(cond
((equal last-comp "")
(values relative components nil)) ; "" already removed
:unless (eq k key)
:append (list k v)))
+#+mcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
+
(defun* getenv (x)
- (#+abcl ext:getenv
- #+allegro sys:getenv
- #+clisp ext:getenv
- #+clozure ccl:getenv
- #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
- #+ecl si:getenv
- #+gcl system:getenv
- #+lispworks lispworks:environment-variable
- #+sbcl sb-ext:posix-getenv
- x))
+ (declare (ignorable x))
+ #+(or abcl clisp xcl) (ext:getenv x)
+ #+allegro (sys:getenv x)
+ #+clozure (ccl:getenv x)
+ #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
+ #+cormanlisp
+ (let* ((buffer (ct:malloc 1))
+ (cname (ct:lisp-string-to-c-string x))
+ (needed-size (win:getenvironmentvariable cname buffer 0))
+ (buffer1 (ct:malloc (1+ needed-size))))
+ (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
+ nil
+ (ct:c-string-to-lisp-string buffer1))
+ (ct:free buffer)
+ (ct:free buffer1)))
+ #+ecl (si:getenv x)
+ #+gcl (system:getenv x)
+ #+genera nil
+ #+lispworks (lispworks:environment-variable x)
+ #+mcl (ccl:with-cstrs ((name x))
+ (let ((value (_getenv name)))
+ (unless (ccl:%null-ptr-p value)
+ (ccl:%get-cstring value))))
+ #+sbcl (sb-ext:posix-getenv x)
+ #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+ (error "~S is not supported on your implementation" 'getenv))
(defun* directory-pathname-p (pathname)
"Does PATHNAME represent a directory?
((stringp pathspec)
(ensure-directory-pathname (pathname pathspec)))
((not (pathnamep pathspec))
- (error "Invalid pathname designator ~S" pathspec))
+ (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
((wild-pathname-p pathspec)
- (error "Can't reliably convert wild pathname ~S" pathspec))
+ (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
((directory-pathname-p pathspec)
pathspec)
(t
:name nil :type nil :version nil
:defaults pathspec))))
+#+genera
+(unless (fboundp 'ensure-directories-exist)
+ (defun ensure-directories-exist (path)
+ (fs:create-directories-recursively (pathname path))))
+
(defun* absolute-pathname-p (pathspec)
- (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
+ (and (typep pathspec '(or pathname string))
+ (eq :absolute (car (pathname-directory (pathname pathspec))))))
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
(check-type n (integer 0 *))
:until (eq form eof)
:collect form)))
-#-(and (or win32 windows mswindows mingw32) (not cygwin))
+#+asdf-unix
(progn
#+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
'(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
(defun* get-uid ()
#+allegro (excl.osi:getuid)
+ #+ccl (ccl::getuid)
#+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
:for f = (ignore-errors (read-from-string s))
:when f :return (funcall f))
'(ffi:c-inline () () :int "getuid()" :one-liner t)
'(ext::getuid))
#+sbcl (sb-unix:unix-getuid)
- #-(or allegro clisp cmu ecl sbcl scl)
+ #-(or allegro ccl clisp cmu ecl sbcl scl)
(let ((uid-string
(with-output-to-string (*verbose-out*)
(run-shell-command "id -ur"))))
(error () (error "Unable to find out user ID")))))))
(defun* pathname-root (pathname)
- (make-pathname :host (pathname-host pathname)
- :device (pathname-device pathname)
- :directory '(:absolute)
- :name nil :type nil :version nil))
+ (make-pathname :directory '(:absolute)
+ :name nil :type nil :version nil
+ :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
+ . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
+
+(defun* find-symbol* (s p)
+ (find-symbol (string s) p))
(defun* probe-file* (p)
"when given a pathname P, probes the filesystem for a file or directory
with given pathname and if it exists return its truename."
(etypecase p
- (null nil)
- (string (probe-file* (parse-namestring p)))
- (pathname (unless (wild-pathname-p p)
- #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
- #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
- '(ignore-errors (truename p)))))))
+ (null nil)
+ (string (probe-file* (parse-namestring p)))
+ (pathname (unless (wild-pathname-p p)
+ #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
+ #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
+ '(ignore-errors (truename p)))))))
(defun* truenamize (p)
"Resolve as much of a pathname as possible"
(block nil
- (when (typep p 'logical-pathname) (return p))
+ (when (typep p '(or null logical-pathname)) (return p))
(let* ((p (merge-pathnames* p))
(directory (pathname-directory p)))
(when (typep p 'logical-pathname) (return p))
(let ((found (probe-file* p)))
(when found (return found)))
- #-(or sbcl cmu) (when (stringp directory) (return p))
+ #-(or cmu sbcl scl) (when (stringp directory) (return p))
(when (not (eq :absolute (car directory))) (return p))
(let ((sofar (probe-file* (pathname-root p))))
(unless sofar (return p))
(defun* resolve-symlinks (path)
#-allegro (truenamize path)
- #+allegro (excl:pathname-resolve-symbolic-links path))
+ #+allegro (if (typep path 'logical-pathname)
+ path
+ (excl:pathname-resolve-symbolic-links path)))
+
+(defun* resolve-symlinks* (path)
+ (if *resolve-symlinks*
+ (and path (resolve-symlinks path))
+ path))
+
+(defun ensure-pathname-absolute (path)
+ (cond
+ ((absolute-pathname-p path) path)
+ ((stringp path) (ensure-pathname-absolute (pathname path)))
+ ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
+ (t (let ((resolved (resolve-symlinks path)))
+ (assert (absolute-pathname-p resolved))
+ resolved))))
(defun* default-directory ()
(truenamize (pathname-directory-pathname *default-pathname-defaults*)))
(defun* lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file))
+(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
+(defparameter *wild-file*
+ (make-pathname :name *wild* :type *wild* :version *wild* :directory nil))
+(defparameter *wild-directory*
+ (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+ (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
(defparameter *wild-path*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type :wild :version :wild))
+ (merge-pathnames *wild-file* *wild-inferiors*))
(defun* wilden (path)
(merge-pathnames* *wild-path* path))
+#-scl
+(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+ (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
+ (last-char (namestring foo))))
+
+#-scl
(defun* directorize-pathname-host-device (pathname)
(let* ((root (pathname-root pathname))
(wild-root (wilden root))
(absolute-pathname (merge-pathnames* pathname root))
- (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
- (separator (last-char (namestring foo)))
+ (separator (directory-separator-for-host root))
(root-namestring (namestring root))
(root-string
(substitute-if #\/
- (lambda (x) (or (eql x #\:)
- (eql x separator)))
+ #'(lambda (x) (or (eql x #\:)
+ (eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
(component-name-to-pathname-components root-string :force-directory t)
:directory `(:absolute ,@path))))
(translate-pathname absolute-pathname wild-root (wilden new-base))))))
+#+scl
+(defun* directorize-pathname-host-device (pathname)
+ (let ((scheme (ext:pathname-scheme pathname))
+ (host (pathname-host pathname))
+ (port (ext:pathname-port pathname))
+ (directory (pathname-directory pathname)))
+ (flet ((not-unspecific (component)
+ (and (not (eq component :unspecific)) component)))
+ (cond ((or (not-unspecific port)
+ (and (not-unspecific host) (plusp (length host)))
+ (not-unspecific scheme))
+ (let ((prefix ""))
+ (when (not-unspecific port)
+ (setf prefix (format nil ":~D" port)))
+ (when (and (not-unspecific host) (plusp (length host)))
+ (setf prefix (concatenate 'string host prefix)))
+ (setf prefix (concatenate 'string ":" prefix))
+ (when (not-unspecific scheme)
+ (setf prefix (concatenate 'string scheme prefix)))
+ (assert (and directory (eq (first directory) :absolute)))
+ (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+ :defaults pathname)))
+ (t
+ pathname)))))
+
+;;;; -------------------------------------------------------------------------
+;;;; ASDF Interface, in terms of generic functions.
+(defgeneric* find-system (system &optional error-p))
+(defgeneric* perform-with-restarts (operation component))
+(defgeneric* perform (operation component))
+(defgeneric* operation-done-p (operation component))
+(defgeneric* explain (operation component))
+(defgeneric* output-files (operation component))
+(defgeneric* input-files (operation component))
+(defgeneric* component-operation-time (operation component))
+(defgeneric* operation-description (operation component)
+ (:documentation "returns a phrase that describes performing this operation
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
+
+(defgeneric* system-source-file (system)
+ (:documentation "Return the source file in which system is defined."))
+
+(defgeneric* component-system (component)
+ (:documentation "Find the top-level system containing COMPONENT"))
+
+(defgeneric* component-pathname (component)
+ (:documentation "Extracts the pathname applicable for a particular component."))
+
+(defgeneric* component-relative-pathname (component)
+ (:documentation "Returns a pathname for the component argument intended to be
+interpreted relative to the pathname of that component's parent.
+Despite the function's name, the return value may be an absolute
+pathname, because an absolute pathname may be interpreted relative to
+another pathname in a degenerate way."))
+
+(defgeneric* component-property (component property))
+
+(defgeneric* (setf component-property) (new-value component property))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defgeneric* (setf module-components-by-name) (new-value module)))
+
+(defgeneric* version-satisfies (component version))
+
+(defgeneric* find-component (base path)
+ (:documentation "Finds the component with PATH starting from BASE module;
+if BASE is nil, then the component is assumed to be a system."))
+
+(defgeneric* source-file-type (component system))
+
+(defgeneric* operation-ancestor (operation)
+ (:documentation
+ "Recursively chase the operation's parent pointer until we get to
+the head of the tree"))
+
+(defgeneric* component-visited-p (operation component)
+ (:documentation "Returns the value stored by a call to
+VISIT-COMPONENT, if that has been called, otherwise NIL.
+This value stored will be a cons cell, the first element
+of which is a computed key, so not interesting. The
+CDR wil be the DATA value stored by VISIT-COMPONENT; recover
+it as (cdr (component-visited-p op c)).
+ In the current form of ASDF, the DATA value retrieved is
+effectively a boolean, indicating whether some operations are
+to be performed in order to do OPERATION X COMPONENT. If the
+data value is NIL, the combination had been explored, but no
+operations needed to be performed."))
+
+(defgeneric* visit-component (operation component data)
+ (:documentation "Record DATA as being associated with OPERATION
+and COMPONENT. This is a side-effecting function: the association
+will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
+OPERATION\).
+ No evidence that DATA is ever interesting, beyond just being
+non-NIL. Using the data field is probably very risky; if there is
+already a record for OPERATION X COMPONENT, DATA will be quietly
+discarded instead of recorded.
+ Starting with 2.006, TRAVERSE will store an integer in data,
+so that nodes can be sorted in decreasing order of traversal."))
+
+
+(defgeneric* (setf visiting-component) (new-value operation component))
+
+(defgeneric* component-visiting-p (operation component))
+
+(defgeneric* component-depends-on (operation component)
+ (:documentation
+ "Returns a list of dependencies needed by the component to perform
+ the operation. A dependency has one of the following forms:
+
+ (<operation> <component>*), where <operation> is a class
+ designator and each <component> is a component
+ designator, which means that the component depends on
+ <operation> having been performed on each <component>; or
+
+ (FEATURE <feature>), which means that the component depends
+ on <feature>'s presence in *FEATURES*.
+
+ Methods specialized on subclasses of existing component types
+ should usually append the results of CALL-NEXT-METHOD to the
+ list."))
+
+(defgeneric* component-self-dependencies (operation component))
+
+(defgeneric* traverse (operation component)
+ (:documentation
+"Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
+
+
+;;;; -------------------------------------------------------------------------
+;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
+(when *upgraded-p*
+ (when (find-class 'module nil)
+ (eval
+ '(defmethod update-instance-for-redefined-class :after
+ ((m module) added deleted plist &key)
+ (declare (ignorable deleted plist))
+ (when *asdf-verbose*
+ (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
+ m (asdf-version)))
+ (when (member 'components-by-name added)
+ (compute-module-components-by-name m))
+ (when (typep m 'system)
+ (when (member 'source-file added)
+ (%set-system-source-file
+ (probe-asd (component-name m) (component-pathname m)) m)
+ (when (equal (component-name m) "asdf")
+ (setf (component-version m) *asdf-version*))))))))
+
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmu (:report print-object))
-(declaim (ftype (function (t) t)
- format-arguments format-control
- error-name error-pathname error-condition
- duplicate-names-name
- error-component error-operation
- module-components module-components-by-name
- circular-dependency-components)
- (ftype (function (t t) t) (setf module-components-by-name)))
-
-
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
(:report (lambda (c s)
- (apply #'format s (format-control c) (format-arguments c)))))
+ (apply 'format s (format-control c) (format-arguments c)))))
(define-condition load-system-definition-error (system-definition-error)
((name :initarg :name :reader error-name)
(pathname :initarg :pathname :reader error-pathname)
(condition :initarg :condition :reader error-condition))
(:report (lambda (c s)
- (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
+ (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
(error-name c) (error-pathname c) (error-condition c)))))
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components))
(:report (lambda (c s)
- (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
+ (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
+ (circular-dependency-components c)))))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
- (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
+ (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
(duplicate-names-name c)))))
(define-condition missing-component (system-definition-error)
((component :reader error-component :initarg :component)
(operation :reader error-operation :initarg :operation))
(:report (lambda (c s)
- (format s "~@<erred while invoking ~A on ~A~@:>"
- (error-operation c) (error-component c)))))
+ (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
+ (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
+(define-condition invalid-configuration ()
+ ((form :reader condition-form :initarg :form)
+ (location :reader condition-location :initarg :location)
+ (format :reader condition-format :initarg :format)
+ (arguments :reader condition-arguments :initarg :arguments :initform nil))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<~? (will be skipped)~@:>")
+ (condition-format c)
+ (list* (condition-form c) (condition-location c)
+ (condition-arguments c))))))
+(define-condition invalid-source-registry (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
+(define-condition invalid-output-translation (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
+
(defclass component ()
- ((name :accessor component-name :initarg :name :documentation
+ ((name :accessor component-name :initarg :name :type string :documentation
"Component name: designator for a string composed of portable pathname characters")
- (version :accessor component-version :initarg :version)
- ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
- ;; POIU is a parallel (multi-process build) extension of ASDF. See
- ;; http://www.cliki.net/poiu
+ (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly!
+ (description :accessor component-description :initarg :description)
+ (long-description :accessor component-long-description :initarg :long-description)
+ ;; This one below is used by POIU - http://www.cliki.net/poiu
+ ;; a parallelizing extension of ASDF that compiles in multiple parallel
+ ;; slave processes (forked on demand) and loads in the master process.
+ ;; Maybe in the future ASDF may use it internally instead of in-order-to.
(load-dependencies :accessor component-load-dependencies :initform nil)
;; In the ASDF object model, dependencies exist between *actions*
;; (an action is a pair of operation and component). They are represented
;; it needn't be recompiled just because one of these dependencies
;; hasn't yet been loaded in the current image (do-first).
;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
+ ;; See our ASDF 2 paper for more complete explanations.
(in-order-to :initform nil :initarg :in-order-to
:accessor component-in-order-to)
(do-first :initform nil :initarg :do-first
(defmethod print-object ((c component) stream)
(print-unreadable-object (c stream :type t :identity nil)
- (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
+ (format stream "~{~S~^ ~}" (component-find-path c))))
;;;; methods: conditions
(defmethod print-object ((c missing-dependency) s)
- (format s "~@<~A, required by ~A~@:>"
+ (format s (compatfmt "~@<~A, required by ~A~@:>")
(call-next-method c nil) (missing-required-by c)))
(defun* sysdef-error (format &rest arguments)
;;;; methods: components
(defmethod print-object ((c missing-component) s)
- (format s "~@<component ~S not found~@[ in ~A~]~@:>"
+ (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
(missing-requires c)
(when (missing-parent c)
- (component-name (missing-parent c)))))
+ (coerce-name (missing-parent c)))))
(defmethod print-object ((c missing-component-of-version) s)
- (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
+ (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
(missing-requires c)
(missing-version c)
(when (missing-parent c)
- (component-name (missing-parent c)))))
+ (coerce-name (missing-parent c)))))
(defmethod component-system ((component component))
(aif (component-parent component)
(component-relative-pathname component)
(pathname-directory-pathname (component-parent-pathname component)))))
(unless (or (null pathname) (absolute-pathname-p pathname))
- (error "Invalid relative pathname ~S for component ~S"
+ (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
pathname (component-find-path component)))
(setf (slot-value component 'absolute-pathname) pathname)
pathname)))
new-value)
(defclass system (module)
- ((description :accessor system-description :initarg :description)
- (long-description
- :accessor system-long-description :initarg :long-description)
+ (;; description and long-description are now available for all component's,
+ ;; but now also inherited from component, but we add the legacy accessor
+ (description :accessor system-description :initarg :description)
+ (long-description :accessor system-long-description :initarg :long-description)
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
(defmethod version-satisfies ((c component) version)
(unless (and version (slot-boundp c 'version))
+ (when version
+ (warn "Requested version ~S but component ~S has no version" version c))
(return-from version-satisfies t))
(version-satisfies (component-version c) version))
+(defun parse-version (string &optional on-error)
+ "Parse a version string as a series of natural integers separated by dots.
+Return a (non-null) list of integers if the string is valid, NIL otherwise.
+If on-error is error, warn, or designates a function of compatible signature,
+the function is called with an explanation of what is wrong with the argument.
+NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
+ (and
+ (or (stringp string)
+ (when on-error
+ (funcall on-error "~S: ~S is not a string"
+ 'parse-version string)) nil)
+ (or (loop :for prev = nil :then c :for c :across string
+ :always (or (digit-char-p c)
+ (and (eql c #\.) prev (not (eql prev #\.))))
+ :finally (return (and c (digit-char-p c))))
+ (when on-error
+ (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
+ 'parse-version string)) nil)
+ (mapcar #'parse-integer (split-string string :separator "."))))
+
(defmethod version-satisfies ((cver string) version)
- (let ((x (mapcar #'parse-integer
- (split-string cver :separator ".")))
- (y (mapcar #'parse-integer
- (split-string version :separator "."))))
+ (let ((x (parse-version cver 'warn))
+ (y (parse-version version 'warn)))
(labels ((bigger (x y)
(cond ((not y) t)
((not x) nil)
((> (car x) (car y)) t)
((= (car x) (car y))
(bigger (cdr x) (cdr y))))))
- (and (= (car x) (car y))
+ (and x y (= (car x) (car y))
(or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
;;;; -------------------------------------------------------------------------
(component (component-name name))
(symbol (string-downcase (symbol-name name)))
(string name)
- (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+ (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
(defun* system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
+(defun* register-system (system)
+ (check-type system system)
+ (let ((name (component-name system)))
+ (check-type name string)
+ (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
+ (unless (eq system (cdr (gethash name *defined-systems*)))
+ (setf (gethash name *defined-systems*)
+ (cons (get-universal-time) system)))))
+
(defun* clear-system (name)
"Clear the entry for a system in the database of systems previously loaded.
Note that this does NOT in any way cause the code of the system to be unloaded."
- ;; There is no "unload" operation in Common Lisp, and a general such operation
- ;; cannot be portably written, considering how much CL relies on side-effects
- ;; of global data structures.
- ;; Note that this does a setf gethash instead of a remhash
- ;; this way there remains a hint in the *defined-systems* table
- ;; that the system was loaded at some point.
- (setf (gethash (coerce-name name) *defined-systems*) nil))
+ ;; There is no "unload" operation in Common Lisp, and
+ ;; a general such operation cannot be portably written,
+ ;; considering how much CL relies on side-effects to global data structures.
+ (remhash (coerce-name name) *defined-systems*))
(defun* map-systems (fn)
"Apply FN to each defined system.
FN should be a function of one argument. It will be
called with an object of type asdf:system."
- (maphash (lambda (_ datum)
- (declare (ignore _))
- (destructuring-bind (_ . def) datum
+ (maphash #'(lambda (_ datum)
(declare (ignore _))
- (funcall fn def)))
+ (destructuring-bind (_ . def) datum
+ (declare (ignore _))
+ (funcall fn def)))
*defined-systems*))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
(defparameter *system-definition-search-functions*
- '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
+ '(sysdef-central-registry-search
+ sysdef-source-registry-search
+ sysdef-find-asdf))
-(defun* system-definition-pathname (system)
+(defun* search-for-system-definition (system)
(let ((system-name (coerce-name system)))
- (or
- (some (lambda (x) (funcall x system-name))
- *system-definition-search-functions*)
- (let ((system-pair (system-registered-p system-name)))
- (and system-pair
- (system-source-file (cdr system-pair)))))))
+ (some #'(lambda (x) (funcall x system-name))
+ *system-definition-search-functions*)))
(defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems.
:defaults defaults :version :newest :case :local
:name name
:type "asd")))
- (when (probe-file file)
+ (when (probe-file* file)
(return file)))
- #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+ #+(and asdf-windows (not clisp))
(let ((shortcut
(make-pathname
:defaults defaults :version :newest :case :local
:name (concatenate 'string name ".asd")
:type "lnk")))
- (when (probe-file shortcut)
+ (when (probe-file* shortcut)
(let ((target (parse-windows-shortcut shortcut)))
(when target
(return (pathname target)))))))))
(let* ((*print-circle* nil)
(message
(format nil
- "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
+ (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
system dir defaults)))
(error message))
(remove-entry-from-registry ()
(push dir to-remove))
(coerce-entry-to-directory ()
:report (lambda (s)
- (format s "Coerce entry to ~a, replace ~a and continue."
+ (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
(ensure-directory-pathname defaults) dir))
(push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
;; cleanup
;; and we can survive and we will continue the planning
;; as if the file were very old.
;; (or should we treat the case in a different, special way?)
- (or (and pathname (probe-file pathname) (file-write-date pathname))
+ (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
(progn
(when (and pathname *asdf-verbose*)
- (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
+ (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
pathname))
0)))
+(defmethod find-system ((name null) &optional (error-p t))
+ (when error-p
+ (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
+
(defmethod find-system (name &optional (error-p t))
(find-system (coerce-name name) error-p))
+(defun load-sysdef (name pathname)
+ ;; Tries to load system definition with canonical NAME from PATHNAME.
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (handler-bind
+ ((error #'(lambda (condition)
+ (error 'load-system-definition-error
+ :name name :pathname pathname
+ :condition condition))))
+ (let ((*package* package))
+ (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
+ pathname package)
+ (load pathname)))
+ (delete-package package))))
+
(defmethod find-system ((name string) &optional (error-p t))
- (catch 'find-system
- (let* ((in-memory (system-registered-p name))
- (on-disk (system-definition-pathname name)))
- (when (and on-disk
- (or (not in-memory)
- (< (car in-memory) (safe-file-write-date on-disk))))
- (let ((package (make-temporary-package)))
- (unwind-protect
- (handler-bind
- ((error (lambda (condition)
- (error 'load-system-definition-error
- :name name :pathname on-disk
- :condition condition))))
- (let ((*package* package))
- (asdf-message
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
- on-disk *package*)
- (load on-disk)))
- (delete-package package))))
- (let ((in-memory (system-registered-p name)))
- (cond
- (in-memory
- (when on-disk
- (setf (car in-memory) (safe-file-write-date on-disk)))
- (cdr in-memory))
- (error-p
- (error 'missing-component :requires name)))))))
-
-(defun* register-system (name system)
- (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
- (setf (gethash (coerce-name name) *defined-systems*)
- (cons (get-universal-time) system)))
+ (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+ (previous (cdr in-memory))
+ (previous (and (typep previous 'system) previous))
+ (previous-time (car in-memory))
+ (found (search-for-system-definition name))
+ (found-system (and (typep found 'system) found))
+ (pathname (or (and (typep found '(or pathname string)) (pathname found))
+ (and found-system (system-source-file found-system))
+ (and previous (system-source-file previous)))))
+ (setf pathname (resolve-symlinks* pathname))
+ (when (and pathname (not (absolute-pathname-p pathname)))
+ (setf pathname (ensure-pathname-absolute pathname))
+ (when found-system
+ (%set-system-source-file pathname found-system)))
+ (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
+ (system-source-file previous) pathname)))
+ (%set-system-source-file pathname previous)
+ (setf previous-time nil))
+ (when (and found-system (not previous))
+ (register-system found-system))
+ (when (and pathname
+ (or (not previous-time)
+ ;; don't reload if it's already been loaded,
+ ;; or its filestamp is in the future which means some clock is skewed
+ ;; and trying to load might cause an infinite loop.
+ (< previous-time (safe-file-write-date pathname) (get-universal-time))))
+ (load-sysdef name pathname))
+ (let ((in-memory (system-registered-p name))) ; try again after loading from disk
+ (cond
+ (in-memory
+ (when pathname
+ (setf (car in-memory) (safe-file-write-date pathname)))
+ (cdr in-memory))
+ (error-p
+ (error 'missing-component :requires name))))))
(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
(setf fallback (coerce-name fallback)
- source-file (or source-file *compile-file-truename* *load-truename*)
requested (coerce-name requested))
(when (equal requested fallback)
- (let* ((registered (cdr (gethash fallback *defined-systems*)))
- (system (or registered
- (apply 'make-instance 'system
- :name fallback :source-file source-file keys))))
- (unless registered
- (register-system fallback system))
- (throw 'find-system system))))
+ (let ((registered (cdr (gethash fallback *defined-systems*))))
+ (or registered
+ (apply 'make-instance 'system
+ :name fallback :source-file source-file keys)))))
(defun* sysdef-find-asdf (name)
- (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
+ ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
+ (find-system-fallback name "asdf" :version *asdf-version*))
;;;; -------------------------------------------------------------------------
(defclass cl-source-file (source-file)
((type :initform "lisp")))
+(defclass cl-source-file.cl (cl-source-file)
+ ((type :initform "cl")))
+(defclass cl-source-file.lsp (cl-source-file)
+ ((type :initform "lsp")))
(defclass c-source-file (source-file)
((type :initform "c")))
(defclass java-source-file (source-file)
(declare (ignorable s))
(source-file-explicit-type component))
-(defun* merge-component-name-type (name &key type defaults)
+(defun* coerce-pathname (name &key type defaults)
+ "coerce NAME into a PATHNAME.
+When given a string, portably decompose it into a relative pathname:
+#\\/ separates subdirectories. The last #\\/-separated string is as follows:
+if TYPE is NIL, its last #\\. if any separates name and type from from type;
+if TYPE is a string, it is the type, and the whole string is the name;
+if TYPE is :DIRECTORY, the string is a directory component;
+if the string is empty, it's a directory.
+Any directory named .. is read as :BACK.
+Host, device and version components are taken from DEFAULTS."
;; The defaults are required notably because they provide the default host
;; to the below make-pathname, which may crucially matter to people using
;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
;; NOTE that the host and device slots will be taken from the defaults,
- ;; but that should only matter if you either (a) use absolute pathnames, or
- ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
- ;; ASDF:MERGE-PATHNAMES*
+ ;; but that should only matter if you later merge relative pathnames with
+ ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
(etypecase name
- (pathname
+ ((or null pathname)
name)
(symbol
- (merge-component-name-type (string-downcase name) :type type :defaults defaults))
+ (coerce-pathname (string-downcase name) :type type :defaults defaults))
(string
(multiple-value-bind (relative path filename)
(component-name-to-pathname-components name :force-directory (eq type :directory)
(values filename type))
(t
(split-name-type filename)))
- (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
- (host (pathname-host defaults))
- (device (pathname-device defaults)))
- (make-pathname :directory `(,relative ,@path)
- :name name :type type
- :host host :device device)))))))
+ (apply 'make-pathname :directory (cons relative path) :name name :type type
+ ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL.
+ (when defaults `(:defaults ,defaults))))))))
+
+(defun* merge-component-name-type (name &key type defaults)
+ ;; For backwards compatibility only, for people using internals.
+ ;; Will be removed in a future release, e.g. 2.016.
+ (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
+ (coerce-pathname name :type type :defaults defaults))
(defmethod component-relative-pathname ((component component))
- (merge-component-name-type
+ (coerce-pathname
(or (slot-value component 'relative-pathname)
(component-name component))
:type (source-file-type component (component-system component))
;;; one of these is instantiated whenever #'operate is called
(defclass operation ()
- (
- ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
- ;; T to force the inside of existing system,
+ (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
+ ;; T to force the inside of the specified system,
;; but not recurse to other systems we depend on.
;; :ALL (or any other atom) to force all systems
;; including other systems we depend on.
;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
;; to force systems named in a given list
- ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
+ ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
(forced :initform nil :initarg :force :accessor operation-forced)
(original-initargs :initform nil :initarg :original-initargs
:accessor operation-original-initargs)
(not (eql c dep-c)))
(when (eql force-p t)
(setf (getf args :force) nil))
- (apply #'make-instance dep-o
+ (apply 'make-instance dep-o
:parent o
:original-initargs args args))
((subtypep (type-of o) dep-o)
o)
(t
- (apply #'make-instance dep-o
+ (apply 'make-instance dep-o
:parent o :original-initargs args args)))))
(gethash node (operation-visiting-nodes (operation-ancestor o)))))
(defmethod component-depends-on ((op-spec symbol) (c component))
+ ;; Note: we go from op-spec to operation via make-instance
+ ;; to allow for specialization through defmethod's, even though
+ ;; it's a detour in the default case below.
(component-depends-on (make-instance op-spec) c))
(defmethod component-depends-on ((o operation) (c component))
- (cdr (assoc (class-name (class-of o))
- (component-in-order-to c))))
+ (cdr (assoc (type-of o) (component-in-order-to c))))
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
- (remove-if-not (lambda (x)
- (member (component-name c) (cdr x) :test #'string=))
+ (remove-if-not #'(lambda (x)
+ (member (component-name c) (cdr x) :test #'string=))
all-deps)))
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
(self-deps (component-self-dependencies operation c)))
(if self-deps
- (mapcan (lambda (dep)
- (destructuring-bind (op name) dep
- (output-files (make-instance op)
- (find-component parent name))))
+ (mapcan #'(lambda (dep)
+ (destructuring-bind (op name) dep
+ (output-files (make-instance op)
+ (find-component parent name))))
self-deps)
;; no previous operations needed? I guess we work with the
;; original source file, then
;; than one second of filesystem time (or just crosses the
;; second). So that's cool.
(and
- (every #'probe-file in-files)
- (every #'probe-file out-files)
+ (every #'probe-file* in-files)
+ (every #'probe-file* out-files)
(>= (earliest-out) (latest-in))))))))
required-op required-c required-v))
(retry ()
:report (lambda (s)
- (format s "~@<Retry loading component ~S.~@:>"
- (component-find-path required-c)))
+ (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
:test
(lambda (c)
(or (null c)
(when (find (second d) *features* :test 'string-equal)
(dep op (third d) nil)))
(t
- (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
+ (error (compatfmt "~@<Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
flag))))
(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
(funcall collect x))
(defmethod do-traverse ((operation operation) (c component) collect)
- (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
+ (let ((*forcing* *forcing*)
+ (flag nil)) ;; return value: must we rebuild this and its dependencies?
(labels
((update-flag (x)
- (when x
- (setf flag t)))
+ (orf flag x))
(dep (op comp)
(update-flag (do-dep operation c collect op comp))))
;; Have we been visited yet? If so, just process the result.
(setf (visiting-component operation c) t)
(unwind-protect
(progn
+ (let ((f (operation-forced
+ (operation-ancestor operation))))
+ (when (and f (or (not (consp f)) ;; T or :ALL
+ (and (typep c 'system) ;; list of names of systems to force
+ (member (component-name c) f
+ :test #'string=))))
+ (setf *forcing* t)))
;; first we check and do all the dependencies for the module.
;; Operations planned in this loop will show up
;; in the results, and are consumed below.
:try-next)
(not at-least-one))
(error error)))))))
- (update-flag
- (or
- *forcing*
- (not (operation-done-p operation c))
+ (update-flag (or *forcing* (not (operation-done-p operation c))))
;; For sub-operations, check whether
;; the original ancestor operation was forced,
;; or names us amongst an explicit list of things to force...
;; except that this check doesn't distinguish
;; between all the things with a given name. Sigh.
;; BROKEN!
- (let ((f (operation-forced
- (operation-ancestor operation))))
- (and f (or (not (consp f)) ;; T or :ALL
- (and (typep c 'system) ;; list of names of systems to force
- (member (component-name c) f
- :test #'string=)))))))
(when flag
(let ((do-first (cdr (assoc (class-name (class-of operation))
(component-do-first c)))))
(r* l))))
(defmethod traverse ((operation operation) (c component))
- ;; cerror'ing a feature that seems to have NEVER EVER worked
- ;; ever since danb created it in his 2003-03-16 commit e0d02781.
- ;; It was both fixed and disabled in the 1.700 rewrite.
(when (consp (operation-forced operation))
- (cerror "Continue nonetheless."
- "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
(setf (operation-forced operation)
(mapcar #'coerce-name (operation-forced operation))))
(flatten-tree
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
- "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
+ (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
nil)
(defmethod explain ((operation operation) (component component))
- (asdf-message "~&;;; ~A~%" (operation-description operation component)))
+ (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
+ (operation-description operation component)))
(defmethod operation-description (operation component)
- (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
+ (format nil (compatfmt "~@<~A on ~A~@:>")
+ (class-of operation) component))
;;;; -------------------------------------------------------------------------
;;;; compile-op
(on-failure :initarg :on-failure :accessor operation-on-failure
:initform *compile-file-failure-behaviour*)
(flags :initarg :flags :accessor compile-op-flags
- :initform #-ecl nil #+ecl '(:system-p t))))
+ :initform nil)))
(defun output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(first files)))
(defmethod perform :before ((operation compile-op) (c source-file))
- (map nil #'ensure-directories-exist (output-files operation c)))
-
-#+ecl
-(defmethod perform :after ((o compile-op) (c cl-source-file))
- ;; Note how we use OUTPUT-FILES to find the binary locations
- ;; This allows the user to override the names.
- (let* ((files (output-files o c))
- (object (first files))
- (fasl (second files)))
- (c:build-fasl fasl :lisp-files (list object))))
+ (loop :for file :in (asdf:output-files operation c)
+ :for pathname = (if (typep file 'logical-pathname)
+ (translate-logical-pathname file)
+ file)
+ :do (ensure-directories-exist pathname)))
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
(get-universal-time)))
-(declaim (ftype (function ((or pathname string)
- &rest t &key (:output-file t) &allow-other-keys)
- (values t t t))
- compile-file*))
+(defvar *compile-op-compile-file-function* 'compile-file*
+ "Function used to compile lisp files.")
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(*compile-file-warnings-behaviour* (operation-on-warnings operation))
(*compile-file-failure-behaviour* (operation-on-failure operation)))
(multiple-value-bind (output warnings-p failure-p)
- (apply #'compile-file* source-file :output-file output-file
+ (apply *compile-op-compile-file-function* source-file :output-file output-file
(compile-op-flags operation))
(when warnings-p
(case (operation-on-warnings operation)
(:warn (warn
- "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
+ (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
operation c))
(:error (error 'compile-warned :component c :operation operation))
(:ignore nil)))
(when failure-p
(case (operation-on-failure operation)
(:warn (warn
- "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
+ (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
operation c))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))
(defmethod output-files ((operation compile-op) (c cl-source-file))
(declare (ignorable operation))
(let ((p (lispize-pathname (component-pathname c))))
- #-:broken-fasl-loader
- (list (compile-file-pathname p #+ecl :type #+ecl :object)
- #+ecl (compile-file-pathname p :type :fasl))
- #+:broken-fasl-loader (list p)))
+ #-broken-fasl-loader (list (compile-file-pathname p))
+ #+broken-fasl-loader (list p)))
(defmethod perform ((operation compile-op) (c static-file))
(declare (ignorable operation c))
(defmethod operation-description ((operation compile-op) component)
(declare (ignorable operation))
- (format nil "compiling component ~S" (component-find-path component)))
+ (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
+
+(defmethod operation-description ((operation compile-op) (component module))
+ (declare (ignorable operation))
+ (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
+
;;;; -------------------------------------------------------------------------
;;;; load-op
(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load
- #-ecl (input-files o c)
- #+ecl (loop :for i :in (input-files o c)
- :unless (string= (pathname-type i) "fas")
- :collect (compile-file-pathname (lispize-pathname i)))))
+ (map () #'load (input-files o c)))
(defmethod perform-with-restarts (operation component)
+ ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
(perform operation component))
(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
(setf state :success))
(:failed-load
(setf state :recompiled)
- (perform (make-instance 'compile-op) c))
+ (perform (make-sub-operation c o c 'compile-op) c))
(t
(with-simple-restart
(try-recompiling "Recompile ~a and try loading it again"
(defmethod operation-description ((operation load-op) component)
(declare (ignorable operation))
- (format nil "loading component ~S" (component-find-path component)))
+ (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
+ component))
+(defmethod operation-description ((operation load-op) (component cl-source-file))
+ (declare (ignorable operation))
+ (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
+ component))
+
+(defmethod operation-description ((operation load-op) (component module))
+ (declare (ignorable operation))
+ (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
+ component))
;;;; -------------------------------------------------------------------------
;;;; load-source-op
;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
(declare (ignorable o))
- (let ((what-would-load-op-do (cdr (assoc 'load-op
- (component-in-order-to c)))))
- (mapcar (lambda (dep)
- (if (eq (car dep) 'load-op)
- (cons 'load-source-op (cdr dep))
- dep))
- what-would-load-op-do)))
+ (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
+ :for (op co) :in what-would-load-op-do
+ :when (eq op 'load-op) :collect (cons 'load-source-op co)))
(defmethod operation-done-p ((o load-source-op) (c source-file))
(declare (ignorable o))
(defmethod operation-description ((operation load-source-op) component)
(declare (ignorable operation))
- (format nil "loading component ~S" (component-find-path component)))
+ (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
+ component))
+
+(defmethod operation-description ((operation load-source-op) (component module))
+ (declare (ignorable operation))
+ (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
(defgeneric* operate (operation-class system &key &allow-other-keys))
+(defgeneric* perform-plan (plan &key))
+
+;;;; Try to upgrade of ASDF. If a different version was used, return T.
+;;;; We need do that before we operate on anything that depends on ASDF.
+(defun* upgrade-asdf ()
+ (let ((version (asdf:asdf-version)))
+ (handler-bind (((or style-warning warning) #'muffle-warning))
+ (operate 'load-op :asdf :verbose nil))
+ (let ((new-version (asdf:asdf-version)))
+ (block nil
+ (cond
+ ((equal version new-version)
+ (return nil))
+ ((version-satisfies new-version version)
+ (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+ version new-version))
+ ((version-satisfies version new-version)
+ (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
+ version new-version))
+ (t
+ (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+ version new-version)))
+ (let ((asdf (find-system :asdf)))
+ ;; invalidate all systems but ASDF itself
+ (setf *defined-systems* (make-defined-systems-table))
+ (register-system asdf)
+ t)))))
+
+(defmethod perform-plan ((steps list) &key)
+ (let ((*package* *package*)
+ (*readtable* *readtable*))
+ (with-compilation-unit ()
+ (loop :for (op . component) :in steps :do
+ (loop
+ (restart-case
+ (progn
+ (perform-with-restarts op component)
+ (return))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s (compatfmt "~@<Retry ~A.~@:>")
+ (operation-description op component))))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
+ (operation-description op component)))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return))))))))
(defmethod operate (operation-class system &rest args
&key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
&allow-other-keys)
(declare (ignore force))
- (let* ((*package* *package*)
- (*readtable* *readtable*)
- (op (apply #'make-instance operation-class
+ (let* ((op (apply 'make-instance operation-class
:original-initargs args
args))
(*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system))))
+ (system (etypecase system
+ (system system)
+ ((or string symbol) (find-system system)))))
(unless (version-satisfies system version)
(error 'missing-component-of-version :requires system :version version))
(let ((steps (traverse op system)))
- (with-compilation-unit ()
- (loop :for (op . component) :in steps :do
- (loop
- (restart-case
- (progn
- (perform-with-restarts op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s "~@<Retry ~A.~@:>" (operation-description op component))))
- (accept ()
- :report
- (lambda (s)
- (format s "~@<Continue, treating ~A as having been successful.~@:>"
- (operation-description op component)))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return))))))
+ (when (and (not (equal '("asdf") (component-find-path system)))
+ (find-if #'(lambda (x) (equal '("asdf")
+ (component-find-path (cdr x))))
+ steps)
+ (upgrade-asdf))
+ ;; If we needed to upgrade ASDF to achieve our goal,
+ ;; then do it specially as the first thing, then
+ ;; invalidate all existing system
+ ;; retry the whole thing with the new OPERATE function,
+ ;; which on some implementations
+ ;; has a new symbol shadowing the current one.
+ (return-from operate
+ (apply (find-symbol* 'operate :asdf) operation-class system args)))
+ (perform-plan steps)
(values op steps))))
(defun* oos (operation-class system &rest args &key force verbose version
&allow-other-keys)
(declare (ignore force verbose version))
- (apply #'operate operation-class system args))
+ (apply 'operate operation-class system args))
(let ((operate-docstring
"Operate does three things:
(setf (documentation 'operate 'function)
operate-docstring))
-(defun* load-system (system &rest args &key force verbose version
- &allow-other-keys)
- "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
-details."
+(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
+ "Shorthand for `(operate 'asdf:load-op system)`.
+See OPERATE for details."
(declare (ignore force verbose version))
- (apply #'operate 'load-op system args)
+ (apply 'operate 'load-op system args)
t)
(defun* compile-system (system &rest args &key force verbose version
"Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
for details."
(declare (ignore force verbose version))
- (apply #'operate 'compile-op system args)
+ (apply 'operate 'compile-op system args)
t)
(defun* test-system (system &rest args &key force verbose version
"Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
details."
(declare (ignore force verbose version))
- (apply #'operate 'test-op system args)
+ (apply 'operate 'test-op system args)
t)
;;;; -------------------------------------------------------------------------
;;;; Defsystem
(defun* load-pathname ()
- (let ((pn (or *load-pathname* *compile-file-pathname*)))
- (if *resolve-symlinks*
- (and pn (resolve-symlinks pn))
- pn)))
+ (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
(defun* determine-system-pathname (pathname pathname-supplied-p)
;; The defsystem macro calls us to determine
;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
- (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
+ (or (and pathname-supplied-p
+ (merge-pathnames* (coerce-pathname pathname :type :directory)
+ directory-pathname))
directory-pathname
(default-directory))))
(defmacro defsystem (name &body options)
+ (setf name (coerce-name name))
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
defsystem-depends-on &allow-other-keys)
options
;; we recur when trying to find an existing system of the same name
;; to reuse options (e.g. pathname) from
,@(loop :for system :in defsystem-depends-on
- :collect `(load-system ,system))
+ :collect `(load-system ',(coerce-name system)))
(let ((s (system-registered-p ',name)))
(cond ((and s (eq (type-of (cdr s)) ',class))
(setf (car s) (get-universal-time)))
(s
(change-class (cdr s) ',class))
(t
- (register-system (quote ,name)
- (make-instance ',class :name ',name))))
+ (register-system (make-instance ',class :name ',name))))
(%set-system-source-file (load-pathname)
(cdr (system-registered-p ',name))))
(parse-component-form
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
- (unless (keywordp type) type)
- (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type) :asdf))
+ type
+ (find-symbol* type *package*)
+ (find-symbol* type :asdf))
:for class = (and symbol (find-class symbol nil))
- :when (and class (subtypep class 'component))
+ :when (and class
+ (#-cormanlisp subtypep #+cormanlisp cl::subclassp
+ class (find-class 'component)))
:return class)
(and (eq type :file)
(or (module-default-component-class parent)
(find-class *default-component-class*)))
- (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
+ (sysdef-error "don't recognize component type ~A" type)))
(defun* maybe-add-tree (tree op1 op2 c)
"Add the node C at /OP1/OP2 in TREE, unless it's there already.
(defun* sysdef-error-component (msg type name value)
(sysdef-error (concatenate 'string msg
- "~&The value specified for ~(~A~) ~A is ~S")
+ (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
(defun* check-component-input (type name weakly-depends-on
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
- (lambda (m)
- (remove-method (symbol-function name) m))
+ #'(lambda (m)
+ (remove-method (symbol-function name) m))
(component-inline-methods component)))
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
perform explain output-files operation-done-p
weakly-depends-on
depends-on serial in-order-to
+ (version nil versionp)
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p))
(class-for-type parent type))))
(error 'duplicate-names :name name))
+ (when versionp
+ (unless (parse-version version nil)
+ (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
+ version name parent)))
+
(let* ((other-args (remove-keys
'(components pathname default-component-class
perform explain output-files operation-done-p
(appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
(when *serial-depends-on*
(push *serial-depends-on* depends-on))
- (apply #'reinitialize-instance ret
+ (apply 'reinitialize-instance ret
:name (coerce-name name)
:pathname pathname
:parent parent
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code."
- (let ((command (apply #'format nil control-string args)))
+ (let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
#+abcl
#+mswindows "sh" #-mswindows "/bin/sh" command)
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
- (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
- (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
+ (asdf-message "~{~&; ~a~%~}~%" stderr)
+ (asdf-message "~{~&; ~a~%~}~%" stdout)
exit-code)
- #+clisp ;XXX not exactly *verbose-out*, I know
- (ext:run-shell-command command :output :terminal :wait t)
+ #+clisp ;XXX not exactly *verbose-out*, I know
+ (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
#+clozure
(nth-value 1
#+sbcl
(sb-ext:process-exit-code
- (apply #'sb-ext:run-program
+ (apply 'sb-ext:run-program
#+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
:input nil :output *verbose-out*
(list "-c" command)
:input nil :output *verbose-out*))
- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
+ #+xcl
+ (ext:run-shell-command command)
+
+ #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")))
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
+(defun* system-definition-pathname (x)
+ ;; As of 2.014.8, we mean to make this function obsolete,
+ ;; but that won't happen until all clients have been updated.
+ ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+ "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+ (system-source-file x))
+
(defmethod system-source-file ((system-name string))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
(defun* system-relative-pathname (system name &key type)
(merge-pathnames*
- (merge-component-name-type name :type type)
+ (coerce-pathname name :type type)
(system-source-directory system)))
;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features*
- '((:acl :allegro)
- (:lw :lispworks)
- (:digitool) ; before clozure, so it won't get preempted by ccl
+ '((:abcl :armedbear)
+ (:acl :allegro)
+ (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
(:ccl :clozure)
(:corman :cormanlisp)
- (:abcl :armedbear)
- :sbcl :cmu :clisp :gcl :ecl :scl))
+ (:lw :lispworks)
+ :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
(defparameter *os-features*
'((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
(:linux :linux-target) ;; for GCL at least, must appear before :bsd.
(:macosx :darwin :darwin-target :apple)
:freebsd :netbsd :openbsd :bsd
- :unix))
+ :unix
+ :genera))
(defparameter *architecture-features*
'((:amd64 :x86-64 :x86_64 :x8664-target)
(:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
- :hppa64
- :hppa
- (:ppc64 :ppc64-target)
- (:ppc32 :ppc32-target :ppc :powerpc)
- :sparc64
- (:sparc32 :sparc)
+ :hppa64 :hppa
+ (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
+ :sparc64 (:sparc32 :sparc)
(:arm :arm-target)
- (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
+ (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
+ :mipsel :mipseb :mips
+ :alpha
+ :imach))
(defun* lisp-version-string ()
(let ((s (lisp-implementation-version)))
(:+ics ""))
(if (member :64bit *features*) "-64bit" ""))
#+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
- #+clisp (subseq s 0 (position #\space s))
+ #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
#+clozure (format nil "~d.~d-f~d" ; shorten for windows
ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*
(logand ccl::fasl-version #xFF))
#+cmu (substitute #\- #\/ s)
- #+digitool (subseq s 8)
#+ecl (format nil "~A~@[-~A~]" s
(let ((vcs-id (ext:lisp-implementation-vcs-id)))
(when (>= (length vcs-id) 8)
(subseq vcs-id 0 8))))
#+gcl (subseq s (1+ (position #\space s)))
+ #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
+ (format nil "~D.~D" major minor))
#+lispworks (format nil "~A~@[~A~]" s
(when (member :lispworks-64bit *features*) "-64bit"))
;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
- #+(or cormanlisp mcl sbcl scl) s
- #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
- ecl gcl lispworks mcl sbcl scl) s))
+ #+mcl (subseq s 8) ; strip the leading "Version "
+ #+(or cormanlisp sbcl scl) s
+ #-(or allegro armedbear clisp clozure cmu cormanlisp
+ ecl gcl genera lispworks mcl sbcl scl) s))
(defun* first-feature (features)
(labels
(labels
((maybe-warn (value fstring &rest args)
(cond (value)
- (t (apply #'warn fstring args)
+ (t (apply 'warn fstring args)
"unknown"))))
(let ((lisp (maybe-warn (implementation-type)
- "No implementation feature found in ~a."
+ (compatfmt "~@<No implementation feature found in ~a.~@:>")
*implementation-features*))
(os (maybe-warn (first-feature *os-features*)
- "No os feature found in ~a." *os-features*))
- (arch (maybe-warn (first-feature *architecture-features*)
- "No architecture feature found in ~a."
- *architecture-features*))
+ (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
+ (arch (or #-clisp
+ (maybe-warn (first-feature *architecture-features*)
+ (compatfmt "~@<No architecture feature found in ~a.~@:>")
+ *architecture-features*)))
(version (maybe-warn (lisp-version-string)
"Don't know how to get Lisp implementation version.")))
(substitute-if
- #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
- (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
-
+ #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
+ (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files
(defparameter *inter-directory-separator*
- #+(or unix cygwin) #\:
- #-(or unix cygwin) #\;)
+ #+asdf-unix #\:
+ #-asdf-unix #\;)
(defun* user-homedir ()
- (truename (user-homedir-pathname)))
+ (truenamize (pathname-directory-pathname (user-homedir-pathname))))
(defun* try-directory-subpath (x sub &key type)
(let* ((p (and x (ensure-directory-pathname x)))
(tp (and p (probe-file* p)))
- (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
+ (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
(ts (and sp (probe-file* sp))))
(and ts (values sp ts))))
(defun* user-configuration-directories ()
,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
:for dir :in (split-string dirs :separator ":")
:collect (try dir "common-lisp/"))
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-windows
,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
,(try (getenv "APPDATA") "common-lisp/config/"))
(remove-if
#'null
(append
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-windows
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+ #+asdf-unix
(list #p"/etc/common-lisp/"))))
(defun* in-first-directory (dirs x)
(loop :for dir :in dirs
(or (member x kw)
(and (length=n-p x 1) (member (car x) kw)))))
+(defun* report-invalid-form (reporter &rest args)
+ (etypecase reporter
+ (null
+ (apply 'error 'invalid-configuration args))
+ (function
+ (apply reporter args))
+ ((or symbol string)
+ (apply 'error reporter args))
+ (cons
+ (apply 'apply (append reporter args)))))
+
+(defvar *ignored-configuration-form* nil)
+
(defun* validate-configuration-form (form tag directive-validator
- &optional (description tag))
+ &key location invalid-form-reporter)
(unless (and (consp form) (eq (car form) tag))
- (error "Error: Form doesn't specify ~A ~S~%" description form))
- (loop :with inherit = 0
- :for directive :in (cdr form) :do
- (if (configuration-inheritance-directive-p directive)
- (incf inherit)
- (funcall directive-validator directive))
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form form :location location)
+ (return-from validate-configuration-form nil))
+ (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
+ :for directive :in (cdr form)
+ :when (cond
+ ((configuration-inheritance-directive-p directive)
+ (incf inherit) t)
+ ((eq directive :ignore-invalid-entries)
+ (setf ignore-invalid-p t) t)
+ ((funcall directive-validator directive)
+ t)
+ (ignore-invalid-p
+ nil)
+ (t
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form directive :location location)
+ nil))
+ :do (push directive x)
:finally
(unless (= inherit 1)
- (error "One and only one of ~S or ~S is required"
- :inherit-configuration :ignore-inherited-configuration)))
- form)
+ (report-invalid-form invalid-form-reporter
+ :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
+ :inherit-configuration :ignore-inherited-configuration)))
+ (return (nreverse x))))
-(defun* validate-configuration-file (file validator description)
+(defun* validate-configuration-file (file validator &key description)
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
- (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
- (funcall validator (car forms))))
+ (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
+ description forms))
+ (funcall validator (car forms) :location file)))
(defun* hidden-file-p (pathname)
(equal (first-char (pathname-name pathname)) #\.))
-(defun* validate-configuration-directory (directory tag validator)
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+clozure '(:follow-links nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
+
+(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
+ "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
+be applied to the results to yield a configuration form. Current
+values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors
(remove-if
'hidden-file-p
- (directory (make-pathname :name :wild :type "conf" :defaults directory)
- #+sbcl :resolve-symlinks #+sbcl nil)))
+ (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
- (mapcar validator (read-file-forms file)))
+ (loop :with ignore-invalid-p = nil
+ :for form :in (read-file-forms file)
+ :when (eq form :ignore-invalid-entries)
+ :do (setf ignore-invalid-p t)
+ :else
+ :when (funcall validator form)
+ :collect form
+ :else
+ :when ignore-invalid-p
+ :do (setf *ignored-configuration-form* t)
+ :else
+ :do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
(try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-windows
(try (getenv "APPDATA") "common-lisp" "cache" :implementation)
'(:home ".cache" "common-lisp" :implementation))))
(defvar *system-cache*
(setf *output-translations*
(list
(stable-sort (copy-list new-value) #'>
- :key (lambda (x)
- (etypecase (car x)
- ((eql t) -1)
- (pathname
- (length (pathname-directory (car x)))))))))
+ :key #'(lambda (x)
+ (etypecase (car x)
+ ((eql t) -1)
+ (pathname
+ (let ((directory (pathname-directory (car x))))
+ (if (listp directory) (length directory) 0))))))))
new-value)
(defun* output-translations-initialized-p ()
(merge-pathnames* cdr car)))))
((eql :default-directory)
(relativize-pathname-directory (default-directory)))
+ ((eql :*/) *wild-directory*)
+ ((eql :**/) *wild-inferiors*)
+ ((eql :*.*.*) *wild-file*)
((eql :implementation) (implementation-identifier))
((eql :implementation-type) (string-downcase (implementation-type)))
- #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-unix
((eql :uid) (princ-to-string (get-uid)))))
(d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
(s (if (or (pathnamep x) (not wilden)) d (wilden d))))
(when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
- (error "pathname ~S is not relative to ~S" s super))
+ (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
(merge-pathnames* s super)))
+(defvar *here-directory* nil
+ "This special variable is bound to the currect directory during calls to
+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
+directive.")
+
(defun* resolve-absolute-location-component (x &key directory wilden)
(let* ((r
(etypecase x
(let ((p (make-pathname :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
+ ((eql :here)
+ (resolve-location (or *here-directory*
+ ;; give semantics in the case of use interactively
+ :default-directory)
+ :directory t :wilden nil))
((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
((eql :default-directory) (default-directory))))
(wilden r)
r)))
(unless (absolute-pathname-p s)
- (error "Not an absolute pathname ~S" s))
+ (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
s))
(defun* resolve-location (x &key directory wilden)
:finally (return path))))
(defun* location-designator-p (x)
- (flet ((componentp (c) (typep c '(or string pathname keyword))))
- (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+ (flet ((absolute-component-p (c)
+ (typep c '(or string pathname
+ (member :root :home :here :user-cache :system-cache :default-directory))))
+ (relative-component-p (c)
+ (typep c '(or string pathname
+ (member :default-directory :*/ :**/ :*.*.*
+ :implementation :implementation-type
+ #+asdf-unix :uid)))))
+ (or (typep x 'boolean)
+ (absolute-component-p x)
+ (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
(defun* location-function-p (x)
(and
(length=n-p (second x) 2)))))
(defun* validate-output-translations-directive (directive)
- (unless
- (or (member directive '(:inherit-configuration
- :ignore-inherited-configuration
- :enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive))))))
- (error "Invalid directive ~S~%" directive))
- directive)
-
-(defun* validate-output-translations-form (form)
+ (or (member directive '(:enable-user-cache :disable-cache nil))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive)))))))
+
+(defun* validate-output-translations-form (form &key location)
(validate-configuration-form
form
:output-translations
'validate-output-translations-directive
- "output translations"))
+ :location location :invalid-form-reporter 'invalid-output-translation))
(defun* validate-output-translations-file (file)
(validate-configuration-file
- file 'validate-output-translations-form "output translations"))
+ file 'validate-output-translations-form :description "output translations"))
(defun* validate-output-translations-directory (directory)
(validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive))
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
-(defun* parse-output-translations-string (string)
+(defun* parse-output-translations-string (string &key location)
(cond
((or (null string) (equal string ""))
'(:output-translations :inherit-configuration))
((not (stringp string))
- (error "environment string isn't: ~S" string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string)))
+ (parse-output-translations-string (read-from-string string) :location location))
((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string)))
+ (validate-output-translations-form (read-from-string string) :location location))
(t
(loop
:with inherit = nil
(setf source nil))
((equal "" s)
(when inherit
- (error "only one inherited configuration allowed: ~S" string))
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
(setf inherit t)
(push :inherit-configuration directives))
(t
(setf start (1+ i))
(when (> start end)
(when source
- (error "Uneven number of components in source to destination mapping ~S" string))
+ (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+ string))
(unless inherit
(push :ignore-inherited-configuration directives))
(return `(:output-translations ,@(nreverse directives)))))))))
`(: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)) `(,h ())))
+ #+sbcl ,(let ((h (getenv "SBCL_HOME")))
+ (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
#+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
;; All-import, here is where we want user stuff to be:
;; We enable the user cache by default, and here is the place we do:
:enable-user-cache))
-(defparameter *output-translations-file* #p"asdf-output-translations.conf")
-(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
+(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
+(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
(defun* user-output-translations-pathname ()
- (in-user-configuration-directory *output-translations-file* ))
+ (in-user-configuration-directory *output-translations-file*))
(defun* system-output-translations-pathname ()
(in-system-configuration-directory *output-translations-file*))
(defun* user-output-translations-directory-pathname ()
((directory-pathname-p pathname)
(process-output-translations (validate-output-translations-directory pathname)
:inherit inherit :collect collect))
- ((probe-file pathname)
+ ((probe-file* pathname)
(process-output-translations (validate-output-translations-file pathname)
:inherit inherit :collect collect))
(t
(process-output-translations-directive '(t t) :collect collect))
((:inherit-configuration)
(inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration nil)
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
nil))
(let ((src (first directive))
(dst (second directive)))
(t
(let* ((trudst (make-pathname
:defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
- (wilddst (make-pathname
- :name :wild :type :wild :version :wild
- :defaults trudst)))
+ (wilddst (merge-pathnames* *wild-file* trudst)))
(funcall collect (list wilddst t))
(funcall collect (list trusrc trudst)))))))))))
`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
:test 'equal :from-end t))
-(defun* initialize-output-translations (&optional parameter)
+(defvar *output-translations-parameter* nil)
+
+(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
"read the configuration, initialize the internal configuration variable,
return the configuration"
- (setf (output-translations) (compute-output-translations parameter)))
+ (setf *output-translations-parameter* parameter
+ (output-translations) (compute-output-translations parameter)))
(defun* disable-output-translations ()
"Initialize output translations in a way that maps every file to itself,
((eq destination t)
path)
((not (pathnamep destination))
- (error "invalid destination"))
+ (error "Invalid destination"))
((not (absolute-pathname-p destination))
(translate-pathname path absolute-source (merge-pathnames* destination root)))
(root
(defun* apply-output-translations (path)
(etypecase path
+ #+cormanlisp (t (truenamize path))
(logical-pathname
path)
((or pathname string)
:defaults x))
(defun* delete-file-if-exists (x)
- (when (and x (probe-file x))
+ (when (and x (probe-file* x))
(delete-file x)))
(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
;;;; -----------------------------------------------------------------
;;;; Compatibility mode for ASDF-Binary-Locations
+(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+ (declare (ignorable operation-class system args))
+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
+ (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
+call that function where you would otherwise have loaded and configured A-B-L.")))
+
(defun* enable-asdf-binary-locations-compatibility
(&key
(centralize-lisp-binaries nil)
(when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
- (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
- (mapped-files (make-pathname
- :name :wild :version :wild
- :type (if map-all-source-files :wild fasl-type)))
+ (mapped-files (if map-all-source-files *wild-file*
+ (make-pathname :name :wild :version :wild :type fasl-type)))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
- :implementation ,wild-inferiors)
- `(:root ,wild-inferiors :implementation))))
+ :implementation ,*wild-inferiors*)
+ `(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
`(:output-translations
,@source-to-target-mappings
- ((:root ,wild-inferiors ,mapped-files)
+ ((:root ,*wild-inferiors* ,mapped-files)
(,@destination-directory ,mapped-files))
(t t)
:ignore-inherited-configuration))))
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
-#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+#+(and asdf-windows (not clisp))
(progn
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
-(defvar *source-registry* ()
- "Either NIL (for uninitialized), or a list of one element,
-said element itself being a list of directory pathnames where to look for .asd files")
-
-(defun* source-registry ()
- (car *source-registry*))
-
-(defun* (setf source-registry) (new-value)
- (setf *source-registry* (list new-value))
- new-value)
+(defvar *source-registry* nil
+ "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")
(defun* source-registry-initialized-p ()
- (and *source-registry* t))
+ (typep *source-registry* 'hash-table))
(defun* clear-source-registry ()
"Undoes any initialization of the source registry.
You might want to call that before you dump an image that would be resumed
with a different configuration, so the configuration would be re-read then."
- (setf *source-registry* '())
+ (setf *source-registry* nil)
(values))
(defparameter *wild-asd*
- (make-pathname :directory nil :name :wild :type "asd" :version :newest))
+ (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
-(defun directory-has-asd-files-p (directory)
- (and (ignore-errors
- (directory (merge-pathnames* *wild-asd* directory)
- #+sbcl #+sbcl :resolve-symlinks nil
- #+ccl #+ccl :follow-links nil
- #+clisp #+clisp :circle t))
- t))
+(defun directory-asd-files (directory)
+ (ignore-errors
+ (directory* (merge-pathnames* *wild-asd* directory))))
(defun subdirectories (directory)
(let* ((directory (ensure-directory-pathname directory))
- #-cormanlisp
+ #-(or cormanlisp genera xcl)
(wild (merge-pathnames*
- #-(or abcl allegro lispworks scl)
- (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
- #+(or abcl allegro lispworks scl) "*.*"
+ #-(or abcl allegro cmu lispworks scl xcl)
+ *wild-directory*
+ #+(or abcl allegro cmu lispworks scl xcl) "*.*"
directory))
(dirs
- #-cormanlisp
+ #-(or cormanlisp genera xcl)
(ignore-errors
- (directory wild .
- #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
- #+ccl '(:follow-links nil :directories t :files nil)
- #+clisp '(:circle t :if-does-not-exist :ignore)
- #+(or cmu scl) '(:follow-links nil :truenamep nil)
- #+digitool '(:directories t)
- #+sbcl '(:resolve-symlinks nil))))
- #+cormanlisp (cl::directory-subdirs directory))
- #+(or abcl allegro lispworks scl)
- (dirs (remove-if-not #+abcl #'extensions:probe-directory
- #+allegro #'excl:probe-directory
- #+lispworks #'lw:file-directory-p
- #-(or abcl allegro lispworks) #'directory-pathname-p
- dirs)))
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+cormanlisp (cl::directory-subdirs directory)
+ #+genera (fs:directory-list directory)
+ #+xcl (system:list-directory directory))
+ #+(or abcl allegro cmu genera lispworks scl xcl)
+ (dirs (loop :for x :in dirs
+ :for d = #+(or abcl xcl) (extensions:probe-directory x)
+ #+allegro (excl:probe-directory x)
+ #+(or cmu scl) (directory-pathname-p x)
+ #+genera (getf (cdr x) :directory)
+ #+lispworks (lw:file-directory-p x)
+ :when d :collect #+(or abcl allegro xcl) d
+ #+genera (ensure-directory-pathname (first x))
+ #+(or cmu lispworks scl) x)))
dirs))
+(defun collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
+
(defun collect-sub*directories (directory collectp recursep collector)
(when (funcall collectp directory)
(funcall collector directory))
(when (funcall recursep subdir)
(collect-sub*directories subdir collectp recursep collector))))
-(defun collect-sub*directories-with-asd
+(defun collect-sub*directories-asd-files
(directory &key
(exclude *default-source-registry-exclusions*)
collect)
(collect-sub*directories
directory
- #'directory-has-asd-files-p
+ (constantly t)
#'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
- collect))
+ #'(lambda (dir) (collect-asds-in-directory dir collect))))
(defun* validate-source-registry-directive (directive)
- (unless
- (or (member directive '(:default-registry (:default-registry)) :test 'equal)
- (destructuring-bind (kw &rest rest) directive
- (case kw
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- (null rest))))
- (error "Invalid directive ~S~%" directive))
- directive)
-
-(defun* validate-source-registry-form (form)
+ (or (member directive '(:default-registry))
+ (and (consp directive)
+ (let ((rest (rest directive)))
+ (case (first directive)
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ ((:default-registry)
+ (null rest)))))))
+
+(defun* validate-source-registry-form (form &key location)
(validate-configuration-form
- form :source-registry 'validate-source-registry-directive "a source registry"))
+ form :source-registry 'validate-source-registry-directive
+ :location location :invalid-form-reporter 'invalid-source-registry))
(defun* validate-source-registry-file (file)
(validate-configuration-file
- file 'validate-source-registry-form "a source registry"))
+ file 'validate-source-registry-form :description "a source registry"))
(defun* validate-source-registry-directory (directory)
(validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive))
+ directory :source-registry 'validate-source-registry-directive
+ :invalid-form-reporter 'invalid-source-registry))
-(defun* parse-source-registry-string (string)
+(defun* parse-source-registry-string (string &key location)
(cond
((or (null string) (equal string ""))
'(:source-registry :inherit-configuration))
((not (stringp string))
- (error "environment string isn't: ~S" string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string)))
+ (validate-source-registry-form (read-from-string string) :location location))
(t
(loop
:with inherit = nil
(cond
((equal "" s) ; empty element: inherit
(when inherit
- (error "only one inherited configuration allowed: ~S" string))
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
(setf inherit t)
(push ':inherit-configuration directives))
((ends-with s "//")
(defun* register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
- (funcall collect directory)
- (collect-sub*directories-with-asd
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
directory :exclude exclude :collect collect)))
(defparameter *default-source-registries*
system-source-registry-directory
default-source-registry))
-(defparameter *source-registry-file* #p"source-registry.conf")
-(defparameter *source-registry-directory* #p"source-registry.conf.d/")
+(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
+(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
(defun* wrapping-source-registry ()
`(:source-registry
- #+sbcl (:tree ,(getenv "SBCL_HOME"))
+ #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
:inherit-configuration
#+cmu (:tree #p"modules:")))
(defun* default-source-registry ()
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(:source-registry
#+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
- (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
+ (:directory ,(default-directory))
,@(let*
- #+(or unix cygwin)
+ #+asdf-unix
((datahome
(or (getenv "XDG_DATA_HOME")
(try (user-homedir) ".local/share/")))
(datadirs
(or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
(dirs (cons datahome (split-string datadirs :separator ":"))))
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
+ #+asdf-windows
((datahome (getenv "APPDATA"))
(datadir
#+lispworks (sys:get-folder-path :local-appdata)
#-lispworks (try (getenv "ALLUSERSPROFILE")
"Application Data"))
(dirs (list datahome datadir)))
- #-(or unix win32 windows mswindows mingw32 cygwin)
+ #-(or asdf-unix asdf-windows)
((dirs ()))
(loop :for dir :in dirs
:collect `(:directory ,(try dir "common-lisp/systems/"))
(defmethod process-source-registry ((pathname pathname) &key inherit register)
(cond
((directory-pathname-p pathname)
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register))
- ((probe-file pathname)
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register))
+ (let ((*here-directory* (truenamize pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
+ ((probe-file* pathname)
+ (let ((*here-directory* (pathname-directory-pathname pathname)))
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register)))
(t
(inherit-source-registry inherit :register register))))
(defmethod process-source-registry ((string string) &key inherit register)
(defun* flatten-source-registry (&optional parameter)
(remove-duplicates
(while-collecting (collect)
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register (lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude)))))
- :test 'equal :from-end t))
+ (let ((*default-pathname-defaults* (default-directory)))
+ (inherit-source-registry
+ `(wrapping-source-registry
+ ,parameter
+ ,@*default-source-registries*)
+ :register #'(lambda (directory &key recurse exclude)
+ (collect (list directory :recurse recurse :exclude exclude)))))
+ :test 'equal :from-end t)))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
-(defun* compute-source-registry (&optional parameter)
- (while-collecting (collect)
- (dolist (entry (flatten-source-registry parameter))
- (destructuring-bind (directory &key recurse exclude) entry
+(defun* compute-source-registry (&optional parameter (registry *source-registry*))
+ (dolist (entry (flatten-source-registry parameter))
+ (destructuring-bind (directory &key recurse exclude) entry
+ (let* ((h (make-hash-table :test 'equal)))
(register-asd-directory
- directory
- :recurse recurse :exclude exclude :collect #'collect)))))
+ directory :recurse recurse :exclude exclude :collect
+ #'(lambda (asd)
+ (let ((name (pathname-name asd)))
+ (cond
+ ((gethash name registry) ; already shadowed by something else
+ nil)
+ ((gethash name h) ; conflict at current level
+ (when *asdf-verbose*
+ (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
+ found several entries for ~A - picking ~S over ~S~:>")
+ directory recurse name (gethash name h) asd)))
+ (t
+ (setf (gethash name registry) asd)
+ (setf (gethash name h) asd))))))
+ h)))
+ (values))
-(defun* initialize-source-registry (&optional parameter)
- (setf (source-registry) (compute-source-registry parameter)))
+(defvar *source-registry-parameter* nil)
+
+(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
+ (setf *source-registry-parameter* parameter)
+ (setf *source-registry* (make-hash-table :test 'equal))
+ (compute-source-registry parameter))
;; Checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; you may override the configuration explicitly by calling
;; initialize-source-registry directly with your parameter.
(defun* ensure-source-registry (&optional parameter)
- (if (source-registry-initialized-p)
- (source-registry)
- (initialize-source-registry parameter)))
+ (unless (source-registry-initialized-p)
+ (initialize-source-registry parameter))
+ (values))
(defun* sysdef-source-registry-search (system)
(ensure-source-registry)
- (loop :with name = (coerce-name system)
- :for defaults :in (source-registry)
- :for file = (probe-asd name defaults)
- :when file :return file))
+ (values (gethash (coerce-name system) *source-registry*)))
(defun* clear-configuration ()
(clear-source-registry)
(clear-output-translations))
+
+;;; ECL support for COMPILE-OP / LOAD-OP
+;;;
+;;; In ECL, these operations produce both FASL files and the
+;;; object files that they are built from. Having both of them allows
+;;; us to later on reuse the object files for bundles, libraries,
+;;; standalone executables, etc.
+;;;
+;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
+;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
+;;;
+#+ecl
+(progn
+ (setf *compile-op-compile-file-function*
+ (lambda (input-file &rest keys &key output-file &allow-other-keys)
+ (declare (ignore output-file))
+ (multiple-value-bind (object-file flags1 flags2)
+ (apply 'compile-file* input-file :system-p t keys)
+ (values (and object-file
+ (c::build-fasl (compile-file-pathname object-file :type :fasl)
+ :lisp-files (list object-file))
+ object-file)
+ flags1
+ flags2))))
+
+ (defmethod output-files ((operation compile-op) (c cl-source-file))
+ (declare (ignorable operation))
+ (let ((p (lispize-pathname (component-pathname c))))
+ (list (compile-file-pathname p :type :object)
+ (compile-file-pathname p :type :fasl))))
+
+ (defmethod perform ((o load-op) (c cl-source-file))
+ (map () #'load
+ (loop :for i :in (input-files o c)
+ :unless (string= (pathname-type i) "fas")
+ :collect (compile-file-pathname (lispize-pathname i))))))
+
;;;; -----------------------------------------------------------------
-;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
+;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
;;;;
+(defvar *require-asdf-operator* 'load-op)
+
(defun* module-provide-asdf (name)
(handler-bind
((style-warning #'muffle-warning)
(missing-component (constantly nil))
- (error (lambda (e)
- (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
- name e))))
- (let* ((*verbose-out* (make-broadcast-stream))
- (system (find-system (string-downcase name) nil)))
+ (error #'(lambda (e)
+ (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
+ name e))))
+ (let ((*verbose-out* (make-broadcast-stream))
+ (system (find-system (string-downcase name) nil)))
(when system
- (load-system system)
+ (operate *require-asdf-operator* system :verbose nil)
t))))
#+(or abcl clisp clozure cmu ecl sbcl)
-(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
+(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
(when x
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;;
-;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
-(eval-when (:compile-toplevel :load-toplevel :execute)
- #+ecl ;; Support upgrade from before ECL went to 1.369
- (when (fboundp 'compile-op-system-p)
- (defmethod compile-op-system-p ((op compile-op))
- (getf :system-p (compile-op-flags op)))
- (defmethod initialize-instance :after ((op compile-op)
- &rest initargs
- &key system-p &allow-other-keys)
- (declare (ignorable initargs))
- (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
+
+;;; If a previous version of ASDF failed to read some configuration, try again.
+(when *ignored-configuration-form*
+ (clear-configuration)
+ (setf *ignored-configuration-form* nil))
;;;; -----------------------------------------------------------------
;;;; Done!
You can find the latest version of this manual at
@url{http://common-lisp.net/project/asdf/asdf.html}.
-ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
+ASDF Copyright @copyright{} 2001-2011 Daniel Barlow and contributors.
-This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
+This manual Copyright @copyright{} 2001-2011 Daniel Barlow and contributors.
-This manual revised @copyright{} 2009-2010 Robert P. Goldman and Francois-Rene Rideau.
+This manual revised @copyright{} 2009-2011 Robert P. Goldman and Francois-Rene Rideau.
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
@emph{Nota Bene}:
We have released ASDF 2.000 on May 31st 2010.
-It hopefully will have been it included
-in all CL maintained implementations shortly afterwards.
+Subsequent releases of ASDF 2 have since then been included
+in all actively maintained CL implementations that bundle ASDF,
+and made to work with all actively used CL implementations and a few more.
@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
+Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 on the fly.
+For this reason, we have stopped supporting ASDF 1;
+if you are using ASDF 1 and are experiencing any kind of issues or limitations,
+we recommend you upgrade to ASDF 2
+--- and we explain how to do it. @xref{Loading ASDF}.
@node Loading ASDF, Configuring ASDF, Introduction, Top
(require :asdf)
@end lisp
-Consult your Lisp implementation's documentation for details.
+As of the writing of this manual,
+the following implementations provide ASDF 2 this way:
+abcl allegro ccl clisp cmucl ecl sbcl xcl.
+The following implementations don't provide it yet but might in a future release:
+lispworks scl.
+The following implementations are obsolete and most probably will never bundle it:
+cormancl gcl genera mcl.
+
+If the implementation you are using doesn't provide ASDF 2,
+see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
+If that implementation is still actively maintained,
+you may also send a bug report to your Lisp vendor and complain
+about their failing to provide ASDF.
-Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation,
-and you can load it that way.
-If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
-if you are using the latest version of your Lisp vendor's software,
-you may also send a bug report to your Lisp vendor and complain about
-their failing to provide ASDF.
@section Checking whether ASDF is loaded
then you're using an old version of ASDF (from before 1.635).
If it returns @code{NIL} then ASDF is not installed.
-If you are running a version older than 2.008,
-we recommend that you load a newer ASDF using the method below.
+If you are experiencing problems with ASDF,
+please try upgrading to the latest released version,
+using the method below,
+before you contact us and raise an issue.
@section Upgrading ASDF
for multiple mutually incompatible implementations.
At worst, you may have to have multiple copies of the new ASDF,
e.g. one per implementation installation, to avoid clashes.
+Note that to our knowledge all implementations that provide ASDF
+provide ASDF 2 in their latest release, so
+you may want to upgrade your implementation rather than go through that hoop.
Finally, note that there are some limitations to upgrading ASDF:
@itemize
@item
-Any ASDF extension is invalidated, and will need to be reloaded.
+Any ASDF extension becomes invalid, and will need to be reloaded.
+This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc.
+Starting with ASDF 2.014.8, ASDF will actually invalidate
+all previously loaded systems when it is loaded on top of
+a different ASDF version.
@item
-It is safer if you upgrade ASDF and its extensions as a special step
+Until all implementations provide ASDF 2.015 or later,
+it is safer if you upgrade ASDF and its extensions as a special step
at the very beginning of whatever script you are running,
before you start using ASDF to load anything else.
+@item
+Until all implementations provide ASDF 2.015 or later,
+it is unsafe to upgrade ASDF as part of loading a system
+that depends on a more recent version of ASDF,
+since the new one might shadow the old one while the old one is running,
+and the running old one will be confused
+when extensions are loaded into the new one.
+In the meantime, we recommend that your systems should @emph{not} specify
+@code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "2.010"))},
+but instead that they check that a recent enough ASDF is installed,
+with such code as:
+@example
+(unless (or #+asdf2 (asdf:version-satisfies
+ (asdf:asdf-version) *required-asdf-version*))
+ (error "FOO requires ASDF ~A or later." *required-asdf-version*))
+@end example
@end itemize
(defsystem "hello-lisp"
:description "hello-lisp: a sample Lisp system."
- :version "0.2"
+ :version "0.2.1"
:author "Joe User <joe@@example.com>"
:licence "Public Domain"
:components ((:file "packages")
This is a good thing because the user can move the system sources
without having to edit the system definition.
+@c FIXME: Should have cross-reference to "Version specifiers" in the
+@c defsystem grammar, but the cross-referencing is so broken by
+@c insufficient node breakdown that I have not put one in.
+@item
+Make sure you know how the @code{:version} numbers will be parsed! They
+are parsed as period-separated lists of integers. I.e., in the example,
+@code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}.
+In particular, version @code{0.2.1} is interpreted the same as
+@code{0.0002.1} and is strictly version-less-than version @code{0.20.1},
+even though the two are the same when interpreted as decimal fractions.
+@cindex version specifiers
+@cindex :version
+
@end itemize
@node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem
@lisp
(defsystem "foo"
- :version "1.0"
+ :version "1.0.0"
:components ((:module "mod"
:components ((:file "bar")
(:file"baz")
@end example
-
@subsection Component names
Component names (@code{simple-component-name})
on the other hand, you can circumvent the file type that would otherwise
be forced upon you if you were specifying a string.
+@subsection Version specifiers
+@cindex version specifiers
+@cindex :version
+
+Version specifiers are parsed as period-separated lists of integers. I.e., in the example,
+@code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}.
+In particular, version @code{0.2.1} is interpreted the same as
+@code{0.0002.1} and is strictly version-less-than version @code{0.20.1},
+even though the two are the same when interpreted as decimal fractions.
+
+System definers are encouraged to use version identifiers of the form
+@var{x}.@var{y}.@var{z} for major version, minor version (compatible
+API) and patch level.
+
+@xref{Common attributes of components}.
+
@subsection Warning about logical pathnames
@cindex logical pathnames
To find and update systems, @code{find-system} funcalls each element
in the @code{*system-definition-search-functions*} list,
-expecting a pathname to be returned.
-The resulting pathname is loaded if either of the following conditions is true:
+expecting a pathname to be returned, or a system object,
+from which a pathname may be extracted, and that will be registered.
+The resulting pathname (if any) is loaded
+if one of the following conditions is true:
@itemize
@item
there is no system of that name in memory
@item
+the pathname is different from that which was previously loaded
+@item
the file's @code{last-modified} time exceeds the @code{last-modified} time
of the system in memory
@end itemize
@xref{The defsystem grammar,,Pathname specifiers}.
@subsubsection Version identifier
+@findex version-satisfies
+@cindex :version
-This optional attribute is used by the @code{test-system-version} operation.
-@xref{Predefined operations of ASDF}.
-For the default method of @code{test-system-version},
+This optional attribute is used by the generic function
+@code{version-satisfies}, which tests to see if @code{:version}
+dependencies are satisfied.
the version should be a string of integers separated by dots,
for example @samp{1.0.11}.
+For more information on the semantics of version specifiers, see @ref{The defsystem grammar}.
+
+@c This optional attribute is intended to be used by the @code{test-system-version} operation.
+@c @xref{Predefined operations of ASDF}.
+@c @emph{Nota Bene}:
+@c This operation, planned for ASDF 1,
+@c is still not implemented yet as of ASDF 2.
+@c Don't hold your breath.
-@emph{Nota Bene}:
-This operation, planned for ASDF 1,
-is still not implement yet as of ASDF 2.
-Don't hold your breath.
@subsubsection Required features
I'm sure they'd welcome your fixes.
@c Doesn't CLISP now support LIST method combination?
+See the discussion of the semantics of @code{:version} in the defsystem
+grammar.
+
+@c FIXME: Should have cross-reference to "Version specifiers" in the
+@c defsystem grammar, but the cross-referencing is so broken by
+@c insufficient node breakdown that I have not put one in.
+
+
@subsubsection pathname
This attribute is optional and if absent (which is the usual case),
())
@end lisp
-A hypothetical function @code{system-dependent-dirname}
+Function @code{asdf:implementation-type} (exported since 2.014.14)
gives us the name of the subdirectory.
All that's left is to define how to calculate the pathname
of an @code{unportable-cl-source-file}.
@lisp
(defmethod component-pathname ((component unportable-cl-source-file))
- (let ((pathname (call-next-method))
- (name (string-downcase (system-dependent-dirname))))
- (merge-pathnames*
- (make-pathname :directory (list :relative name))
- pathname)))
+ (merge-pathnames*
+ (coerce-pathname (format nil "~(~A~)/" (asdf:implementation-type)))
+ (call-next-method)))
@end lisp
The new component type is used in a @code{defsystem} form in this way:
@section Configuration DSL
-Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
+Here is the grammar of the s-expression (SEXP) DSL for source-registry
+configuration:
+
+@c FIXME: This is too wide for happy compilation into pdf.
@example
;; A configuration is a single SEXP starting with keyword :source-registry
:inherit-configuration | ; splices inherited configuration (often specified last)
:ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+ ;; forward compatibility directive (since ASDF 2.011.4), useful when
+ ;; you want to use new configuration features but have to bootstrap a
+ ;; the newer required ASDF from an older release that doesn't sport said features:
+ :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
+
;; add a single directory to be scanned (no recursion)
(:directory DIRECTORY-PATHNAME-DESIGNATOR) |
PATHNAME | ;; pathname (better be an absolute path, or bust)
:HOME | ;; designates the user-homedir-pathname ~/
:USER-CACHE | ;; designates the default location for the user cache
- :SYSTEM-CACHE ;; designates the default location for the system cache
+ :SYSTEM-CACHE | ;; designates the default location for the system cache
+ :HERE ;; designates the location of the configuration file
+ ;; (or *default-pathname-defaults*, if invoked interactively)
RELATIVE-COMPONENT-DESIGNATOR :=
STRING | ;; namestring (directory assumed where applicable)
PATHNAME | ;; pathname
- :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
+ :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
:IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
:UID | ;; current UID -- not available on Windows
:USER ;; current USER name -- NOT IMPLEMENTED(!)
@section Configuration Directories
-Configuration directories consist in files each contains
+Configuration directories consist in files each containing
a list of directives without any enclosing @code{(:source-registry ...)} form.
The files will be sorted by namestring as if by @code{string<} and
the lists of directives of these files with be concatenated in order.
(:tree "/home/fare/cl/")
@end example
+@subsection The :here directive
+
+The @code{:here} directive is an absolute pathname designator that
+refers to the directory containing the configuration file currently
+being processed.
+
+The @code{:here} directive is intended to simplify the delivery of
+complex CL systems, and for easy configuration of projects shared through
+revision control systems, in accordance with our design principle that
+each participant should be able to provide all and only the information
+available to him or her.
+
+Consider a person X who has set up the source code repository for a
+complex project with a master directory @file{dir/}. Ordinarily, one
+might simply have the user add a directive that would look something
+like this:
+@example
+ (:tree "path/to/dir")
+@end example
+But what if X knows that there are very large subtrees
+under dir that are filled with, e.g., Java source code, image files for
+icons, etc.? All of the asdf system definitions are contained in the
+subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and
+these are the only directories that should be searched.
+
+In this case, X can put into @file{dir/} a file @file{asdf.conf} that
+contains the following:
+@example
+(:source-registry
+ (:tree (:here "src/lisp/"))
+ (:tree (:here "extlib/lisp"))
+ (:directory (:here "outlier/")))
+@end example
+
+Then when someone else (call her Y) checks out a copy of this
+repository, she need only add
+@example
+(:include "/path/to/my/checkout/directory/asdf.conf")
+@end example
+to one of her previously-existing asdf source location configuration
+files, or invoke @code{initialize-source-registry} with a configuration
+form containing that s-expression. ASDF will find the .conf file that X
+has provided, and then set up source locations within the working
+directory according to X's (relative) instructions.
@section Shell-friendly syntax for configuration
@section Backward Compatibility
+@cindex ASDF-BINARY-LOCATIONS compatibility
-@c FIXME -- I think we should provide an easy way
-@c to get behavior equivalent to A-B-L and
-@c I will propose a technique for doing this.
We purposefully do NOT provide backward compatibility with earlier versions of
@code{ASDF-Binary-Locations} (8 Sept 2009),
Nevertheless, if you are a fan of @code{ASDF-Binary-Locations},
we provide a limited emulation mode:
-@defun asdf:enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
+@defun enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
This function will initialize the new @code{asdf-output-translations} facility in a way
that emulates the behavior of the old @code{ASDF-Binary-Locations} facility.
Where you would previously set global variables
:inherit-configuration | ; splices inherited configuration (often specified last)
:ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+ ;; forward compatibility directive (since ASDF 2.011.4), useful when
+ ;; you want to use new configuration features but have to bootstrap a
+ ;; the newer required ASDF from an older release that doesn't sport said features:
+ :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
+
;; include a configuration file or directory
(:include PATHNAME-DESIGNATOR) |
- ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
+ ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ or something.
:enable-user-cache |
;; Disable global cache. Map / to /
:disable-cache |
RELATIVE-COMPONENT-DESIGNATOR :=
STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
- PATHNAME | ;; pathname unless last component, directory is assumed.
- :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
+ PATHNAME | ;; pathname; unless last component, directory is assumed.
+ :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
:IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
+ :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
+ :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
+ :*.*.* | ;; any file (since ASDF 2.011.4)
:UID | ;; current UID -- not available on Windows
:USER ;; current USER name -- NOT IMPLEMENTED(!)
before it is translated.
When the second designator is @code{t}, the mapping is the identity.
-When the second designator starts with @code{root},
+When the second designator starts with @code{:root},
the mapping preserves the host and device of the original pathname.
+Notably, this allows you to map files
+to a subdirectory of the whichever directory the file is in.
+Though the syntax is not quite as easy to use as we'd like,
+you can have an (source destination) mapping entry such as follows
+in your configuration file,
+or you may use @code{enable-asdf-binary-locations-compatibility}
+with @code{:centralize-lisp-binaries nil}
+which will do the same thing internally for you:
+@verbatim
+ #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors)))
+ (wild-file (make-pathname :name :wild :version :wild :type :wild)))
+ `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root
+ (:root ,wild-subdir :implementation ,wild-file)))
+@end verbatim
+Starting with ASDF 2.011.4, you can use the simpler:
+ @code{`(:root (:root :**/ :implementation :*.*.*))}
+
+
@code{:include} statements cause the search to recurse with the path specifications
from the file specified.
@c @itemize
@c @item
-@c SBCL, version 1.0 on Mac OS X for intel: @code{sbcl-1.0-darwin-x86}
+@c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86}
@c @item
@c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86}
ASDF includes several additional features that are generally
useful for system definition and development. These include:
+@defun coerce-pathname name @&key type defaults
+
+This function (available starting with ASDF 2.012.11)
+takes an argument, and portably interprets it as a pathname.
+If the argument @var{name} is a pathname or @code{nil}, it is passed through;
+if it's a symbol, it's interpreted as a string by downcasing it;
+if it's a string, it is first separated using @code{/} into substrings;
+the leading substrings denote subdirectories of a relative pathname.
+If @var{type} is @code{:directory} or the string ends with @code{/},
+the last substring is also a subdirectory;
+if @var{type} is a string, it is used as the type of the pathname, and
+the last substring is the name component of the pathname;
+if @var{type} is @code{nil}, the last substring specifies both name and type components
+of the pathname, with the last @code{.} separating them, or only the name component
+if there's no last @code{.} or if there is only one dot and it's the first character.
+The host, device and version components come from @var{defaults}, which defaults to
+@var{*default-pathname-defaults*}; but that shouldn't matter if you use @code{merge-pathnames*}.
+
+@end defun
+
+@defun merge-pathnames* @&key specified defaults
+
+This function is a replacement for @code{merge-pathnames} that uses the host and device
+from the @var{defaults} rather than the @var{specified} pathname when the latter
+is a relative pathname. This allows ASDF and its users to create and use relative pathnames
+without having to know beforehand what are the host and device
+of the absolute pathnames they are relative to.
+
+@end defun
+
@defun system-relative-pathname system name @&key type
It's often handy to locate a file relative to some system.
The @code{system-relative-pathname} function meets this need.
-It takes two arguments: the name of a system and a relative pathname.
-It returns a pathname built from the location of the system's source file
-and the relative pathname. For example
+
+It takes two mandatory arguments @var{system} and @var{name}
+and a keyword argument @var{type}:
+@var{system} is name of a system, whereas @var{name} and optionally @var{type}
+specify a relative pathname, interpreted like a component pathname specifier
+by @code{coerce-pathname}. @xref{The defsystem grammar,,Pathname specifiers}.
+
+It returns a pathname built from the location of the system's
+source directory and the relative pathname. For example:
@lisp
-> (asdf:system-relative-pathname 'cl-ppcre #p"regex.data")
+> (asdf:system-relative-pathname 'cl-ppcre "regex.data")
#P"/repository/other/cl-ppcre/regex.data"
@end lisp
-Instead of a pathname, you can provide a symbol or a string,
-and optionally a keyword argument @code{type}.
-The arguments will then be interpreted in the same way
-as pathname specifiers for components.
-@xref{The defsystem grammar,,Pathname specifiers}.
@end defun
@defun system-source-directory system-designator
@chapter Getting the latest version
Decide which version you want.
-HEAD is the newest version and usually OK, whereas
-RELEASE is for cautious people
-(e.g. who already have systems using ASDF that they don't want broken),
-a slightly older version about which none of the HEAD users have complained.
-There is also a STABLE version, which is earlier than release.
+The @code{master} branch is where development happens;
+its @code{HEAD} is usually OK, including the latest fixes and portability tweaks,
+but an occasional regression may happen despite our (limited) test suite.
+
+The @code{release} branch is what cautious people should be using;
+it has usually been tested more, and releases are cut at a point
+where there isn't any known unresolved issue.
You may get the ASDF source repository using git:
@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
ASDF 2 implements its own portable syntax for strings as pathname specifiers.
Naming files within a system definition becomes easy and portable again.
@xref{Miscellaneous additional functionality,asdf:system-relative-pathname},
-@code{asdf-utilities:merge-pathnames*},
-@code{asdf::merge-component-name-type}.
+@code{merge-pathnames*},
+@code{coerce-pathname}.
On the other hand, there are places where systems used to accept namestrings
where you must now use an explicit pathname object:
The new ASDF output translations are incompatible with ASDF-Binary-Locations.
They replace A-B-L, and there is compatibility mode to emulate
your previous A-B-L configuration.
-See @code{asdf:enable-asdf-binary-locations-compatibility} in
+See @code{enable-asdf-binary-locations-compatibility} in
@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
But thou shall not load ABL on top of ASDF 2.
@code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
(declare (ignorable component system)) "cl")}.
Now, the pathname for a component is eagerly computed when defining the system,
-and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))}
-and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem},
+and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))}
+and use @code{:default-component-class cl-source-file.lis} as argument to @code{defsystem},
as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
@findex source-file-type
Starting with current candidate releases of ASDF 2,
it should always be a good time to upgrade to a recent ASDF.
You may consult with the maintainer for which specific version they recommend,
-but the latest RELEASE should be correct.
+but the latest @code{release} should be correct.
We trust you to thoroughly test it with your implementation before you release it.
If there are any issues with the current release,
it's a bug that you should report upstream and that we will fix ASAP.
@subsection How do I create a system definition where all the source files have a .cl extension?
-First, create a new @code{cl-source-file} subclass that provides an
-initform for the @code{type} slot:
+Starting with ASDF 2.014.14, you may just pass
+the builtin class @code{cl-source-file.cl} as
+the @code{:default-component-class} argument to @code{defsystem}:
@lisp
-(defclass my-cl-source-file (cl-source-file)
- ((type :initform "cl")))
+(defsystem my-cl-system
+ :default-component-class cl-source-file.cl
+ ...)
@end lisp
-To support both ASDF 1 and ASDF 2,
-you may omit the above @code{type} slot definition and instead define:
+Another builtin class @code{cl-source-file.lsp} is offered
+for files ending in @file{.lsp}.
+
+If you want to use a different extension
+for which ASDF doesn't provide builtin support,
+or want to support versions of ASDF
+earlier than 2.014.14 (but later than 2.000),
+you can define a class as follows:
@lisp
-(defmethod source-file-type ((f my-cl-source-file) (m module))
- (declare (ignorable f m))
- "cl")
+;; Prologue: make sure we're using a sane package.
+(defpackage :my-asdf-extension
+ (:use :asdf :common-lisp)
+ (:export #:cl-source-file.lis))
+(in-package :my-asdf-extension)
+
+(defclass cl-source-file.lis (cl-source-file)
+ ((type :initform "lis")))
@end lisp
-Then make your system use this subclass in preference to the standard
-one:
+Then you can use it as follows:
+@lisp
+(defsystem my-cl-system
+ :default-component-class my-asdf-extension:cl-source-file.lis
+ ...)
+@end lisp
+
+Of course, if you're in the same package, e.g. in the same file,
+you won't need to use the package qualifier before @code{cl-source-file.lis}.
+Actually, if all you're doing is defining this class
+and using it in the same file without other fancy definitions,
+you might skip package complications:
@lisp
+(in-package :asdf)
+(defclass cl-source-file.lis (cl-source-file)
+ ((type :initform "lis")))
(defsystem my-cl-system
- :default-component-class my-cl-source-file
- ....
-)
+ :default-component-class cl-source-file.lis
+ ...)
@end lisp
-We assume that these definitions are loaded into a package that uses
-@code{ASDF}.
+It is possible to achieve the same effect
+in a way that supports both ASDF 1 and ASDF 2,
+but really, friends don't let friends use ASDF 1.
+Please upgrade to ASDF 2.
+In short, though: do same as above, but
+@emph{before} you use the class in a @code{defsystem},
+you also define the following method:
+@lisp
+(defmethod source-file-type ((f cl-source-file.lis) (m module))
+ (declare (ignorable f m))
+ "lis")
+@end lisp
@node TODO list, Inspiration, FAQ, Top
projects / sbcl.git / commitdiff