-;;; -*- 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.017: 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 port 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)
+ #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
+ (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
+ (and (= system::*gcl-major-version* 2)
+ (< system::*gcl-minor-version* 7)))
+ (pushnew :gcl-pre2.7 *features*))
+ #+(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 ;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134
- (existing-asdf (fboundp 'find-system))
+ (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
+ (defun find-symbol* (s p)
+ (find-symbol (string s) p))
+ ;; Strip out formatting that is not supported on Genera.
+ ;; Has to be inside the eval-when to make Lispworks happy (!)
+ (defmacro compatfmt (format)
+ #-(or gcl genera) format
+ #+(or gcl genera)
+ (loop :for (unsupported . replacement) :in
+ `(("~3i~_" . "")
+ #+genera
+ ,@(("~@<" . "")
+ ("; ~@;" . "; ")
+ ("~@:>" . "")
+ ("~:>" . ""))) :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.017")
+ (existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
- (when existing-asdf
+ (when (and existing-asdf *asdf-verbose*)
(format *trace-output*
- "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
+ (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-symbol* 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))))
p)
(t
(make-package name :nicknames nicknames :use use))))))
- (find-sym (symbol package)
- (find-symbol (string symbol) package))
(intern* (symbol package)
(intern (string symbol) package))
(remove-symbol (symbol package)
- (let ((sym (find-sym symbol package)))
+ (let ((sym (find-symbol* symbol package)))
(when sym
- (unexport sym package)
+ #-cormanlisp (unexport sym package)
(unintern sym package)
sym)))
(ensure-unintern (package symbols)
:for removed = (remove-symbol sym package)
:when removed :do
(loop :for p :in packages :do
- (when (eq removed (find-sym sym p))
+ (when (eq removed (find-symbol* sym p))
(unintern removed p)))))
(ensure-shadow (package symbols)
(shadow symbols package))
(ensure-use (package use)
(dolist (used (reverse use))
(do-external-symbols (sym used)
- (unless (eq sym (find-sym sym package))
+ (unless (eq sym (find-symbol* sym package))
(remove-symbol sym package)))
(use-package used package)))
(ensure-fmakunbound (package symbols)
(loop :for name :in symbols
- :for sym = (find-sym name package)
+ :for sym = (find-symbol* name package)
:when sym :do (fmakunbound sym)))
(ensure-export (package export)
(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)))
(loop :for user :in (package-used-by-list package)
:for shadowing = (package-shadowing-symbols user) :do
(loop :for new :in newly-exported-symbols
- :for old = (find-sym new user)
+ :for old = (find-symbol* new user)
:when (and old (not (member old shadowing)))
:do (unintern old user)))
(loop :for x :in newly-exported-symbols :do
(export (intern* x package)))))
- (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
+ (ensure-package (name &key nicknames use unintern fmakunbound
+ shadow export redefined-functions)
(let* ((p (ensure-exists name nicknames use)))
(ensure-unintern p unintern)
(ensure-shadow p shadow)
(ensure-export p export)
- (ensure-fmakunbound p fmakunbound)
+ (ensure-fmakunbound p (append fmakunbound redefined-functions))
p)))
(macrolet
((pkgdcl (name &key nicknames use export
`(ensure-package
',name :nicknames ',nicknames :use ',use :export ',export
:shadow ',shadow
- :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
- :fmakunbound ',(append fmakunbound))))
- (unlink-package :asdf-utilities)
+ :unintern ',unintern
+ :redefined-functions ',redefined-functions
+ :fmakunbound ',fmakunbound)))
(pkgdcl
:asdf
+ :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
:use (:common-lisp)
:redefined-functions
(#: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 #:with-system-definitions
+ #: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
;; #:ends-with
#:ensure-directory-pathname
#:getenv
- ;; #:get-uid
;; #:length=n-p
+ ;; #:find-symbol*
#:merge-pathnames*
+ #:coerce-pathname
#:pathname-directory-pathname
#:read-file-forms
;; #:remove-keys
#:split-string
#:component-name-to-pathname-components
#:split-name-type
+ #: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*)
-
(defvar *resolve-symlinks* t
"Determine whether or not ASDF resolves symlinks when defining systems.
(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)
+ #-(or cormanlisp gcl-pre2.7)
+ (ftype (function (t t) t) (setf module-components-by-name)))
+
+;;;; -------------------------------------------------------------------------
+;;;; Compatibility various implementations
+#+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))))
+
+#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
+ (read-from-string
+ "(eval-when (:compile-toplevel :load-toplevel :execute)
+ (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
+ (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
+ ;; Note: ASDF may expect user-homedir-pathname to provide
+ ;; the pathname of the current user's home directory, whereas
+ ;; MCL by default provides the directory from which MCL was started.
+ ;; See http://code.google.com/p/mcl/wiki/Portability
+ (defun current-user-homedir-pathname ()
+ (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
+ (defun probe-posix (posix-namestring)
+ \"If a file exists for the posix namestring, return the pathname\"
+ (ccl::with-cstrs ((cpath posix-namestring))
+ (ccl::rlet ((is-dir :boolean)
+ (fsref :fsref))
+ (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
+ (ccl::%path-from-fsref fsref is-dir))))))"))
+
+;;;; -------------------------------------------------------------------------
+;;;; 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
+ #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
+ #-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.
+ "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
+if the SPECIFIED pathname does not have an absolute directory,
+then the HOST and DEVICE both come from the DEFAULTS, whereas
+if the SPECIFIED pathname does have an absolute directory,
+then the HOST and DEVICE both come from the SPECIFIED.
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))
- #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
+ (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))))
(unspecific-handler (p)
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
- (#-gcl ecase #+gcl case (first directory)
- ((nil)
- (values (pathname-host defaults)
- (pathname-device defaults)
- (pathname-directory defaults)
- (unspecific-handler defaults)))
+ (ecase (first directory)
((: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)
- (unspecific-handler defaults)))
- #+gcl
- (t
- (assert (stringp (first directory)))
- (values (pathname-host defaults)
- (pathname-device defaults)
- (append (pathname-directory defaults) 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 "")
(values filename unspecific)
(values name type)))))
-(defun* component-name-to-pathname-components (s &optional force-directory)
+(defun* component-name-to-pathname-components (s &key force-directory force-relative)
"Splits the path string S, returning three values:
A flag that is either :absolute or :relative, indicating
how the rest of the values are to be interpreted.
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
pathnames."
(check-type s string)
+ (when (find #\: 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 components) "")
(if (equal (first-char s) #\/)
- (values :absolute (cdr components))
+ (progn
+ (when force-relative
+ (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
:append (list k v)))
(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?
Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
- (flet ((check-one (x)
- (member x '(nil :unspecific "") :test 'equal)))
- (and (check-one (pathname-name pathname))
- (check-one (pathname-type pathname))
- t)))
+ (when pathname
+ (let ((pathname (pathname pathname)))
+ (flet ((check-one (x)
+ (member x '(nil :unspecific "") :test 'equal)))
+ (and (not (wild-pathname-p pathname))
+ (check-one (pathname-name pathname))
+ (check-one (pathname-type pathname))
+ t)))))
(defun* ensure-directory-pathname (pathspec)
"Converts the non-wild pathname designator PATHSPEC to directory form."
((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 pathnames."))
+ (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))
-(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)
- #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
- :for f = (ignore-errors (read-from-string s))
- :when f :return (funcall f))
- #+(or cmu scl) (unix:unix-getuid)
- #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
- '(ffi:c-inline () () :int "getuid()" :one-liner t)
- '(ext::getuid))
- #+sbcl (sb-unix:unix-getuid)
- #-(or allegro clisp cmu ecl sbcl scl)
- (let ((uid-string
- (with-output-to-string (*verbose-out*)
- (run-shell-command "id -ur"))))
- (with-input-from-string (stream uid-string)
- (read-line stream)
- (handler-case (parse-integer (read-line stream))
- (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, *some*
+ ;; scheme-specific parts: port username password, not others:
+ . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
(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) `(,it p))
- '(ignore-errors (truename p)))))))
-
-(defun* truenamize (p)
+ (null nil)
+ (string (probe-file* (parse-namestring p)))
+ (pathname (unless (wild-pathname-p p)
+ #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
+ '(probe-file p)
+ #+clisp (aif (find-symbol* '#:probe-pathname :ext)
+ `(ignore-errors (,it p)))
+ '(ignore-errors (truename p)))))))
+
+(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
"Resolve as much of a pathname as possible"
(block nil
- (when (typep p 'logical-pathname) (return p))
- (let* ((p (merge-pathnames* p))
- (directory (pathname-directory p)))
+ (when (typep pathname '(or null logical-pathname)) (return pathname))
+ (let ((p (merge-pathnames* pathname defaults)))
(when (typep p 'logical-pathname) (return p))
(let ((found (probe-file* p)))
(when found (return found)))
- #-(or sbcl cmu) (when (stringp directory) (return p))
- (when (not (eq :absolute (car directory))) (return p))
+ (unless (absolute-pathname-p p)
+ (let ((true-defaults (ignore-errors (truename defaults))))
+ (when true-defaults
+ (setf p (merge-pathnames pathname true-defaults)))))
+ (unless (absolute-pathname-p p) (return p))
(let ((sofar (probe-file* (pathname-root p))))
(unless sofar (return p))
(flet ((solution (directories)
:type (pathname-type p)
:version (pathname-version p))
sofar)))
- (loop :for component :in (cdr directory)
+ (loop :with directory = (normalize-pathname-directory-component
+ (pathname-directory p))
+ :for component :in (cdr directory)
:for rest :on (cdr directory)
:for more = (probe-file*
(merge-pathnames*
(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 (or #-(or abcl xcl) *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 t)
+ (component-name-to-pathname-components root-string :force-directory t)
(declare (ignore relative filename))
(let ((new-base
(make-pathname :defaults root
: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 (#-gcl :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")
+ ;; We might want to constrain version with
+ ;; :type (and string (satisfies parse-version))
+ ;; but we cannot until we fix all systems that don't use it correctly!
(version :accessor component-version :initarg :version)
+ (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
+ ;; alists of operations to dependencies (other actions) in each component.
+ ;; There are two kinds of dependencies, each stored in its own slot:
+ ;; in-order-to and do-first dependencies. These two kinds are related to
+ ;; the fact that some actions modify the filesystem,
+ ;; whereas other actions modify the current image, and
+ ;; this implies a difference in how to interpret timestamps.
+ ;; in-order-to dependencies will trigger re-performing the action
+ ;; when the timestamp of some dependency
+ ;; makes the timestamp of current action out-of-date;
+ ;; do-first dependencies do not trigger such re-performing.
+ ;; Therefore, a FASL must be recompiled if it is obsoleted
+ ;; by any of its FASL dependencies (in-order-to); but
+ ;; 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)
- ;; 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
- (load-dependencies :accessor component-load-dependencies :initform nil)
- ;; XXX crap name, but it's an official API name!
(do-first :initform nil :initarg :do-first
:accessor component-do-first)
;; methods defined using the "inline" style inside a defsystem form:
(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)
(slot-value component 'absolute-pathname)
(let ((pathname
(merge-pathnames*
- (component-relative-pathname component)
- (pathname-directory-pathname (component-parent-pathname 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
:accessor system-license :initarg :license)
(source-file :reader system-source-file :initarg :source-file
- :writer %set-system-source-file)))
+ :writer %set-system-source-file)
+ (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
;;;; -------------------------------------------------------------------------
;;;; version-satisfies
(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* 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.345.67\")."
+ *asdf-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))
+ (cons 'find-system-if-being-defined *system-definition-search-functions*))))
(defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems.
(defun* probe-asd (name defaults)
(block nil
(when (directory-pathname-p defaults)
- (let ((file
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name name
- :type "asd")))
- (when (probe-file file)
+ (let ((file (make-pathname
+ :defaults defaults :name name
+ :version :newest :case :local :type "asd")))
+ (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))
+(defvar *systems-being-defined* nil
+ "A hash-table of systems currently being defined keyed by name, or NIL")
+
+(defun* find-system-if-being-defined (name)
+ (when *systems-being-defined*
+ (gethash (coerce-name name) *systems-being-defined*)))
+
+(defun* call-with-system-definitions (thunk)
+ (if *systems-being-defined*
+ (funcall thunk)
+ (let ((*systems-being-defined* (make-hash-table :test 'equal)))
+ (funcall thunk))))
+
+(defmacro with-system-definitions (() &body body)
+ `(call-with-system-definitions #'(lambda () ,@body)))
+
+(defun* load-sysdef (name pathname)
+ ;; Tries to load system definition with canonical NAME from PATHNAME.
+ (with-system-definitions ()
+ (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)))
+ (with-system-definitions ()
+ (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 on-disk
- (setf (car in-memory) (safe-file-write-date on-disk)))
+ (when pathname
+ (setf (car in-memory) (safe-file-write-date pathname)))
(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)))
-
-(defun* find-system-fallback (requested fallback &optional source-file)
+(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
- (make-instance
- 'system :name fallback
- :source-file source-file))))
- (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"))
+ ;; 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 (eq type :directory))
+ (component-name-to-pathname-components name :force-directory (eq type :directory)
+ :force-relative t)
(multiple-value-bind (name type)
(cond
((or (eq type :directory) (null filename))
(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
+ (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))))))))
(do-traverse op dep-c collect)))
(defun* do-one-dep (operation c collect required-op required-c required-v)
- ;; this function is a thin, error-handling wrapper around
- ;; %do-one-dep. Returns a partial plan per that function.
+ ;; this function is a thin, error-handling wrapper around %do-one-dep.
+ ;; Collects a partial plan per that function.
(loop
(restart-case
(return (%do-one-dep operation c collect
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)
- #|
- (print (list :c1 c (typep c 'missing-dependency)))
- (when (typep c 'missing-dependency)
- (print (list :c2 (missing-requires c) required-c
- (equalp (missing-requires c)
- required-c))))
- |#
(or (null c)
(and (typep c 'missing-dependency)
(equalp (missing-requires 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)
+(defun* output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(let ((files (output-files operation component)))
(assert (length=n-p files 1))
(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 &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
- (compile-op-flags operation))
- (when warnings-p
- (case (operation-on-warnings operation)
- (:warn (warn
- "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
- operation c))
- (:error (error 'compile-warned :component c :operation operation))
- (:ignore nil)))
+ (apply *compile-op-compile-file-function* source-file
+ :output-file output-file (compile-op-flags operation))
+ (unless output
+ (error 'compile-error :component c :operation operation))
(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)))
- (unless output
- (error 'compile-error :component c :operation operation)))))
+ (when warnings-p
+ (case (operation-on-warnings operation)
+ (:warn (warn
+ (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
+ operation c))
+ (:error (error 'compile-warned :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
(declare (ignorable operation c))
nil)
-;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
+;;; 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 (funcall (find-symbol* 'find-system :asdf) :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
- :original-initargs args
- args))
- (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
- (system (if (typep system 'component) system (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))))))
- (values op steps))))
+ (with-system-definitions ()
+ (let* ((op (apply 'make-instance operation-class
+ :original-initargs args
+ args))
+ (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
+ (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)))
+ (when (and (not (equal '("asdf") (component-find-path system)))
+ (find '("asdf") (mapcar 'cdr steps)
+ :test 'equal :key 'component-find-path)
+ (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)
- (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
- defsystem-depends-on &allow-other-keys)
- options
- (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
- `(progn
- ;; system must be registered before we parse the body, otherwise
- ;; 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))
- (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))))
- (%set-system-source-file (load-pathname)
- (cdr (system-registered-p ',name))))
- (parse-component-form
- nil (list*
- :module (coerce-name ',name)
- :pathname
- ,(determine-system-pathname pathname pathname-arg-p)
- ',component-options))))))
-
(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)
+ (or (and parent (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))
components pathname default-component-class
perform explain output-files operation-done-p
weakly-depends-on
- depends-on serial in-order-to
+ depends-on serial in-order-to do-first
+ (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
in-order-to
`((compile-op (compile-op ,@depends-on))
(load-op (load-op ,@depends-on)))))
- (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
+ (setf (component-do-first ret)
+ (union-of-dependencies
+ do-first
+ `((compile-op (load-op ,@depends-on)))))
(%refresh-component-inline-methods ret rest)
ret)))
+(defun* do-defsystem (name &rest options
+ &key (pathname nil pathname-arg-p) (class 'system)
+ defsystem-depends-on &allow-other-keys)
+ ;; The system must be registered before we parse the body,
+ ;; otherwise we recur when trying to find an existing system
+ ;; of the same name to reuse options (e.g. pathname) from.
+ ;; To avoid infinite recursion in cases where you defsystem a system
+ ;; that is registered to a different location to find-system,
+ ;; we also need to remember it in a special variable *systems-being-defined*.
+ (with-system-definitions ()
+ (let* ((name (coerce-name name))
+ (registered (system-registered-p name))
+ (system (cdr (or registered
+ (register-system (make-instance 'system :name name)))))
+ (component-options (remove-keys '(:class) options)))
+ (%set-system-source-file (load-pathname) system)
+ (setf (gethash name *systems-being-defined*) system)
+ (when registered
+ (setf (car registered) (get-universal-time)))
+ (map () 'load-system defsystem-depends-on)
+ ;; We change-class (when necessary) AFTER we load the defsystem-dep's
+ ;; since the class might not be defined as part of those.
+ (let ((class (class-for-type nil class)))
+ (unless (eq (type-of system) class)
+ (change-class system class)))
+ (parse-component-form
+ nil (list*
+ :module name
+ :pathname (determine-system-pathname pathname pathname-arg-p)
+ component-options)))))
+
+(defmacro defsystem (name &body options)
+ `(apply 'do-defsystem ',name ',options))
+
;;;; ---------------------------------------------------------------------------
;;;; run-shell-command
;;;;
"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
:input nil :output *verbose-out*
:wait t)))
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
(si:system command)
:prefix ""
:output-stream *verbose-out*)
+ #+mcl
+ (ccl::with-cstrs ((%command command)) (_system %command))
+
#+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*
#+win32 '(:search t) #-win32 nil))
- #+(or cmu scl)
- (ext:process-exit-code
- (ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output *verbose-out*))
+ #+xcl
+ (ext:run-shell-command command)
- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
+ #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl 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))
"Return a pathname object corresponding to the
directory in which the system specification (.asd file) is
located."
- (make-pathname :name nil
- :type nil
- :defaults (system-source-file system-designator)))
+ (pathname-directory-pathname (system-source-file system-designator)))
(defun* relativize-directory (directory)
(cond
(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)))
;;; implementation-identifier
;;;
;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, hacked since.
-
-(defparameter *implementation-features*
- '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
- :corman :cormanlisp :armedbear :gcl :ecl :scl))
-
-(defparameter *os-features*
- '((:windows :mswindows :win32 :mingw32)
- (:solaris :sunos)
- :linux ;; for GCL at least, must appear before :bsd.
- :macosx :darwin :apple
- :freebsd :netbsd :openbsd :bsd
- :unix))
-
-(defparameter *architecture-features*
- '((:x86-64 :amd64 :x86_64 :x8664-target)
- (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
- :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
- :java-1.4 :java-1.5 :java-1.6 :java-1.7))
-
-
-(defun* lisp-version-string ()
+;;; Initially stolen from SLIME's SWANK, rewritten since.
+;;; The (car '(...)) idiom avoids unreachable code warnings.
+
+(defparameter *implementation-type*
+ (car '(#+abcl :abcl #+allegro :acl
+ #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
+ #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
+ #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
+
+(defparameter *operating-system*
+ (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
+ #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
+ #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
+ #+(or solaris sunos) :solaris
+ #+(or freebsd netbsd openbsd bsd) :bsd
+ #+unix :unix
+ #+genera :genera)))
+
+(defparameter *architecture*
+ (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
+ #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
+ #+hppa64 :hppa64 #+hppa :hppa
+ #+(or ppc64 ppc64-target) :ppc64
+ #+(or ppc32 ppc32-target ppc powerpc) :ppc32
+ #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
+ #+(or arm arm-target) :arm
+ #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
+ #+mipsel :mispel #+mipseb :mipseb #+mips :mips
+ #+alpha :alpha #+imach :imach)))
+
+(defparameter *lisp-version-string*
(let ((s (lisp-implementation-version)))
- (declare (ignorable s))
- #+allegro (format nil
- "~A~A~A~A"
- excl::*common-lisp-version-number*
- ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
- (if (eq excl:*current-case-mode*
- :case-sensitive-lower) "M" "A")
- ;; Note if not using International ACL
- ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
- (excl:ics-target-case
- (:-ics "8")
- (:+ics ""))
- (if (member :64bit *features*) "-64bit" ""))
- #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
- #+clisp (subseq s 0 (position #\space s))
- #+clozure (format nil "~d.~d-fasl~d"
- 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)))
- #+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))
-
-(defun* first-feature (features)
- (labels
- ((fp (thing)
- (etypecase thing
- (symbol
- (let ((feature (find thing *features*)))
- (when feature (return-from fp feature))))
- ;; allows features to be lists of which the first
- ;; member is the "main name", the rest being aliases
- (cons
- (dolist (subf thing)
- (when (find subf *features*) (return-from fp (first thing))))))
- nil))
- (loop :for f :in features
- :when (fp f) :return :it)))
+ (or
+ #+allegro
+ (format nil "~A~A~@[~A~]"
+ excl::*common-lisp-version-number*
+ ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
+ (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
+ ;; Note if not using International ACL
+ ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+ (excl:ics-target-case (:-ics "8")))
+ #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+ #+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)
+ #+ecl (format nil "~A~@[-~A~]" s
+ (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+ (subseq vcs-id 0 (min (length vcs-id) 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))
+ #+mcl (subseq s 8) ; strip the leading "Version "
+ s)))
(defun* implementation-type ()
- (first-feature *implementation-features*))
+ *implementation-type*)
(defun* implementation-identifier ()
- (labels
- ((maybe-warn (value fstring &rest args)
- (cond (value)
- (t (apply #'warn fstring args)
- "unknown"))))
- (let ((lisp (maybe-warn (implementation-type)
- "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*))
- (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)))))
-
+ (substitute-if
+ #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
+ (format nil "~(~a~@{~@[-~a~]~}~)"
+ (or *implementation-type* (lisp-implementation-type))
+ (or *lisp-version-string* (lisp-implementation-version))
+ (or *operating-system* (software-type))
+ (or *architecture* (machine-type)))))
;;; ---------------------------------------------------------------------------
;;; 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
+ #+mcl (current-user-homedir-pathname)
+ #-mcl (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 ()
- (remove-if
- #'null
- (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
- `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
- ,@(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))
- ,@`(#+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/"))
- ,(try (user-homedir) ".config/common-lisp/")))))
+ (let ((dirs
+ (flet ((try (x sub) (try-directory-subpath x sub)))
+ `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
+ ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
+ :for dir :in (split-string dirs :separator ":")
+ :collect (try dir "common-lisp/"))
+ #+asdf-windows
+ ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
+ (getenv "LOCALAPPDATA"))
+ "common-lisp/config/")
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+ ,(try (or #+lispworks (sys:get-folder-path :appdata)
+ (getenv "APPDATA"))
+ "common-lisp/config/"))
+ ,(try (user-homedir) ".config/common-lisp/")))))
+ (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
(defun* system-configuration-directories ()
(remove-if
#'null
- (append
- #+(and (or win32 windows mswindows mingw32) (not cygwin))
- (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/"))))
- (list #p"/etc/common-lisp/"))))
+ `(#+asdf-windows
+ ,(flet ((try (x sub) (try-directory-subpath x sub)))
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+ (try (or #+lispworks (sys:get-folder-path :common-appdata)
+ (getenv "ALLUSERSAPPDATA")
+ (try (getenv "ALLUSERSPROFILE") "Application Data/"))
+ "common-lisp/config/"))
+ #+asdf-unix #p"/etc/common-lisp/")))
+
(defun* in-first-directory (dirs x)
(loop :for dir :in dirs
:thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
(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))
- (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+ #+asdf-windows
+ (try (or #+lispworks (sys:get-folder-path :local-appdata)
+ (getenv "LOCALAPPDATA")
+ #+lispworks (sys:get-folder-path :appdata)
+ (getenv "APPDATA"))
+ "common-lisp" "cache" :implementation)
'(:home ".cache" "common-lisp" :implementation))))
-(defvar *system-cache*
- ;; No good default, plus there's a security problem
- ;; with other users messing with such directories.
- *user-cache*)
(defun* output-translations ()
(car *output-translations*))
(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 ()
(setf *output-translations* '())
(values))
-(defparameter *wild-asd*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type "asd" :version :newest))
-
(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
(values (or null pathname) &optional))
resolve-location))
-(defun* resolve-relative-location-component (super x &key directory wilden)
- (let* ((r (etypecase x
- (pathname x)
- (string x)
- (cons
- (return-from resolve-relative-location-component
- (if (null (cdr x))
+(defun* resolve-relative-location-component (x &key directory wilden)
+ (let ((r (etypecase x
+ (pathname x)
+ (string (coerce-pathname x :type (when directory :directory)))
+ (cons
+ (if (null (cdr x))
+ (resolve-relative-location-component
+ (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-relative-location-component
+ (car x) :directory t :wilden nil)))
+ (merge-pathnames*
(resolve-relative-location-component
- super (car x) :directory directory :wilden wilden)
- (let* ((car (resolve-relative-location-component
- super (car x) :directory t :wilden nil))
- (cdr (resolve-relative-location-component
- (merge-pathnames* car super) (cdr x)
- :directory directory :wilden wilden)))
- (merge-pathnames* cdr car)))))
- ((eql :default-directory)
- (relativize-pathname-directory (default-directory)))
- ((eql :implementation) (implementation-identifier))
- ((eql :implementation-type) (string-downcase (implementation-type)))
- #-(and (or win32 windows mswindows mingw32) (not cygwin))
- ((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))
- (merge-pathnames* s super)))
+ (cdr x) :directory directory :wilden wilden)
+ car))))
+ ((eql :default-directory)
+ (relativize-pathname-directory (default-directory)))
+ ((eql :*/) *wild-directory*)
+ ((eql :**/) *wild-inferiors*)
+ ((eql :*.*.*) *wild-file*)
+ ((eql :implementation)
+ (coerce-pathname (implementation-identifier) :type :directory))
+ ((eql :implementation-type)
+ (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
+ (when (absolute-pathname-p r)
+ (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
+ (if (or (pathnamep x) (not wilden)) r (wilden r))))
+
+(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
(pathname x)
- (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
+ (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
+ #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+ (if directory (ensure-directory-pathname p) p)))
(cons
(return-from resolve-absolute-location-component
(if (null (cdr x))
(resolve-absolute-location-component
(car x) :directory directory :wilden wilden)
- (let* ((car (resolve-absolute-location-component
- (car x) :directory t :wilden nil))
- (cdr (resolve-relative-location-component
- car (cdr x) :directory directory :wilden wilden)))
- (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
+ (merge-pathnames*
+ (resolve-relative-location-component
+ (cdr x) :directory directory :wilden wilden)
+ (resolve-absolute-location-component
+ (car x) :directory t :wilden nil)))))
((eql :root)
;; special magic! we encode such paths as relative pathnames,
;; but it means "relative to the root of the source pathname's host and device".
(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 :system-cache)
+ (error "Using the :system-cache is deprecated. ~%~
+Please remove it from your ASDF configuration"))
((eql :default-directory) (default-directory))))
(s (if (and wilden (not (pathnamep x)))
(wilden r)
r)))
(unless (absolute-pathname-p s)
- (error "Not an absolute pathname ~S" s))
+ (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
s))
(defun* resolve-location (x &key directory wilden)
:for (component . morep) :on (cdr x)
:for dir = (and (or morep directory) t)
:for wild = (and wilden (not morep))
- :do (setf path (resolve-relative-location-component
- path component :directory dir :wilden wild))
+ :do (setf path (merge-pathnames*
+ (resolve-relative-location-component
+ component :directory dir :wilden wild)
+ path))
: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 ())))
- #+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
+ #+sbcl ,(let ((h (getenv "SBCL_HOME")))
+ (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
+ ;; The below two are not needed: no precompiled ASDF system there
+ ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+ ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
;; All-import, here is where we want user stuff to be:
:inherit-configuration
;; These are for convenience, and can be overridden by the user:
#+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; If we want to enable the user cache by default, here would be the place:
+ ;; 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)))
((eq dst t)
(funcall collect (list trusrc t)))
(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)))
+ (let* ((trudst (if dst
+ (resolve-location dst :directory t :wilden t)
+ trusrc))
+ (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)
t))
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
- (or output-file
+ (if (absolute-pathname-p output-file)
+ ;; what cfp should be doing, w/ mp* instead of mp
+ (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
+ (defaults (make-pathname
+ :type type :defaults (merge-pathnames* input-file))))
+ (merge-pathnames* output-file defaults))
(apply-output-translations
- (apply 'compile-file-pathname
- (truenamize (lispize-pathname input-file))
- keys))))
+ (apply 'compile-file-pathname input-file keys))))
(defun* tmpize-pathname (x)
(make-pathname
: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 &allow-other-keys)
- (let* ((output-file (apply 'compile-file-pathname* input-file keys))
+(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
+ (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
(tmp-file (tmpize-pathname output-file))
(status :error))
(multiple-value-bind (output-truename warnings-p failure-p)
;;;; -----------------------------------------------------------------
;;;; 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)
(include-per-user-information nil)
(map-all-source-files (or #+(or ecl clisp) t nil))
(source-to-target-mappings nil))
- (when (and (null map-all-source-files) #-(or ecl clisp) nil)
+ #+(or ecl clisp)
+ (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 :type fasl-type :defaults *wild-file*)))
(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))
:do (write-char (code-char code) out))))
(defun* read-little-endian (s &optional (bytes 4))
- (loop
- :for i :from 0 :below bytes
+ (loop :for i :from 0 :below bytes
:sum (ash (read-byte s) (* 8 i))))
(defun* parse-file-location-info (s)
;; Using ack 1.2 exclusions
(defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+ '(".bzr" ".cdv"
+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"
- "debian")) ;; debian often build stuff under the debian directory... BAD.
+ "debian")) ;; debian often builds stuff under the debian directory... BAD.
(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))
+
+(defun* filter-logical-directory-results (directory entries merger)
+ (if (typep directory 'logical-pathname)
+ ;; Try hard to not resolve logical-pathname into physical pathnames;
+ ;; otherwise logical-pathname users/lovers will be disappointed.
+ ;; If directory* could use some implementation-dependent magic,
+ ;; we will have logical pathnames already; otherwise,
+ ;; we only keep pathnames for which specifying the name and
+ ;; translating the LPN commute.
+ (loop :for f :in entries
+ :for p = (or (and (typep f 'logical-pathname) f)
+ (let* ((u (ignore-errors (funcall merger f))))
+ (and u (equal (ignore-errors (truename u)) f) u)))
+ :when p :collect p)
+ entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+ (when (wild-pathname-p directory)
+ (error "Invalid wild in ~S" directory))
+ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S" pattern))
+ (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
+ (filter-logical-directory-results
+ directory entries
+ #'(lambda (f)
+ (make-pathname :defaults directory :version (pathname-version f)
+ :name (pathname-name f) :type (pathname-type f))))))
+
+(defun* directory-asd-files (directory)
+ (directory-files directory *wild-asd*))
+
+(defun* subdirectories (directory)
+ (let* ((directory (ensure-directory-pathname directory))
+ #-(or abcl cormanlisp genera xcl)
+ (wild (merge-pathnames*
+ #-(or abcl allegro cmu lispworks scl xcl)
+ *wild-directory*
+ #+(or abcl allegro cmu lispworks scl xcl) "*.*"
+ directory))
+ (dirs
+ #-(or abcl cormanlisp genera xcl)
+ (ignore-errors
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+(or abcl xcl) (system:list-directory directory)
+ #+cormanlisp (cl::directory-subdirs directory)
+ #+genera (fs:directory-list 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)))
+ (filter-logical-directory-results
+ directory dirs
+ (let ((prefix (normalize-pathname-directory-component
+ (pathname-directory directory))))
+ #'(lambda (d)
+ (let ((dir (normalize-pathname-directory-component
+ (pathname-directory d))))
+ (and (consp dir) (consp (cdr dir))
+ (make-pathname
+ :defaults directory :name nil :type nil :version nil
+ :directory (append prefix (last dir))))))))))
+
+(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))
+ (dolist (subdir (subdirectories directory))
+ (when (funcall recursep subdir)
+ (collect-sub*directories subdir collectp recursep collector))))
+
+(defun* collect-sub*directories-asd-files
+ (directory &key
+ (exclude *default-source-registry-exclusions*)
+ collect)
+ (collect-sub*directories
+ directory
+ (constantly t)
+ #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+ #'(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
:with end = (length string)
:for pos = (position *inter-directory-separator* string :start start) :do
(let ((s (subseq string start (or pos end))))
- (cond
- ((equal "" s) ; empty element: inherit
- (when inherit
- (error "only one inherited configuration allowed: ~S" string))
- (setf inherit t)
- (push ':inherit-configuration directives))
- ((ends-with s "//")
- (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
- (t
- (push `(:directory ,s) directives)))
+ (flet ((check (dir)
+ (unless (absolute-pathname-p dir)
+ (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+ dir))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
+ (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+ (t
+ (push `(:directory ,(check s)) directives))))
(cond
(pos
(setf start (1+ pos)))
(defun* register-asd-directory (directory &key recurse exclude collect)
(if (not recurse)
- (funcall collect directory)
- (let* ((files
- (handler-case
- (directory (merge-pathnames* *wild-asd* directory)
- #+sbcl #+sbcl :resolve-symlinks nil
- #+clisp #+clisp :circle t)
- (error (c)
- (warn "Error while scanning system definitions under directory ~S:~%~A"
- directory c)
- nil)))
- (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
- :test #'equal :from-end t)))
- (loop
- :for dir :in dirs
- :unless (loop :for x :in exclude
- :thereis (find x (pathname-directory dir) :test #'equal))
- :do (funcall collect dir)))))
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect)))
(defparameter *default-source-registries*
'(environment-source-registry
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)))
+ (flet ((try (x sub) (try-directory-subpath x sub)))
`(:source-registry
- #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
- (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
- ,@(let*
- #+(or unix cygwin)
- ((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))
- ((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)
- ((dirs ()))
- (loop :for dir :in dirs
- :collect `(:directory ,(try dir "common-lisp/systems/"))
- :collect `(:tree ,(try dir "common-lisp/source/"))))
+ #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
+ (:directory ,(default-directory))
+ ,@(loop :for dir :in
+ `(#+asdf-unix
+ ,@`(,(or (getenv "XDG_DATA_HOME")
+ (try (user-homedir) ".local/share/"))
+ ,@(split-string (or (getenv "XDG_DATA_DIRS")
+ "/usr/local/share:/usr/share")
+ :separator ":"))
+ #+asdf-windows
+ ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
+ (getenv "LOCALAPPDATA"))
+ ,(or #+lispworks (sys:get-folder-path :appdata)
+ (getenv "APPDATA"))
+ ,(or #+lispworks (sys:get-folder-path :common-appdata)
+ (getenv "ALLUSERSAPPDATA")
+ (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
+ :collect `(:directory ,(try dir "common-lisp/systems/"))
+ :collect `(:tree ,(try dir "common-lisp/source/")))
:inherit-configuration)))
(defun* user-source-registry ()
(in-user-configuration-directory *source-registry-file*))
(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))) ; table to detect duplicates
(register-asd-directory
- directory
- :recurse recurse :exclude exclude :collect #'collect)))))
+ directory :recurse recurse :exclude exclude :collect
+ #'(lambda (asd)
+ (let* ((name (pathname-name asd))
+ (name (if (typep asd 'logical-pathname)
+ ;; logical pathnames are upper-case,
+ ;; at least in the CLHS and on SBCL,
+ ;; yet (coerce-name :foo) is lower-case.
+ ;; won't work well with (load-system "Foo")
+ ;; instead of (load-system 'foo)
+ (string-downcase name)
+ name)))
+ (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!
projects / sbcl.git / blobdiff