-;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.33.10: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
+;;; This is ASDF 3.1.2: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
-;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2014 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
#+cmu
(eval-when (:load-toplevel :compile-toplevel :execute)
- (declaim (optimize (speed 1) (safety 3) (debug 3)))
(setf ext:*gc-verbose* nil))
-#+(or abcl clisp clozure cmu ecl xcl)
+;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X
+#+abcl
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (unless (and (member :darwin *features*)
+ (second (third (sys::arglist 'directory))))
+ (push :abcl-bundle-op-supported *features*)))
+
+;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations.
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*)
(let* ((existing-version
(existing-major-minor (subseq existing-version 0 second-dot))
(existing-version-number (and existing-version (read-from-string existing-major-minor)))
(away (format nil "~A-~A" :asdf existing-version)))
- (when (and existing-version (< existing-version-number
- (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)))
+ (when (and existing-version
+ (< existing-version-number
+ #+(or allegro clisp lispworks sbcl) 2.0
+ #-(or allegro clisp lispworks sbcl) 2.27))
(rename-package :asdf away)
(when *load-verbose*
(format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
-
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
;;
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; This package definition MUST NOT change unless its name too changes;
;; if/when it changes, don't forget to add new functions missing from below.
- ;; Until then, asdf/package is frozen to forever
+ ;; Until then, uiop/package is frozen to forever
;; import and export the same exact symbols as for ASDF 2.27.
;; Any other symbol must be import-from'ed and re-export'ed in a different package.
(:use :common-lisp)
(home-package-p existing to-package) (symbol-package-name existing)))
(t
(ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
+
(defun recycle-symbol (name recycle exported)
+ ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
+ ;; packages, and a hash-table of names (strings) of symbols scheduled to be
+ ;; EXPORTED from the package being defined. It returns two values, the
+ ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
+ ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
+ ;; re-homing of the symbol, etc.
(check-type name string)
(check-type recycle list)
(check-type exported hash-table)
(unintern existing))
(when intern
(intern* name package))))))))
- (declaim (ftype function ensure-exported))
+ (declaim (ftype (function (t t t &optional t) t) ensure-exported))
(defun ensure-exported-to-user (name symbol to-package &optional recycle)
(check-type name string)
(check-type symbol symbol)
import-from export intern
recycle mix reexport
unintern)
- #+(or gcl2.6 genera) (declare (ignore documentation))
+ #+genera (declare (ignore documentation))
(let* ((package-name (string name))
(nicknames (mapcar #'string nicknames))
(names (cons package-name nicknames))
;; string to list home package and use package:
(inherited (make-hash-table :test 'equal)))
(when-package-fishiness (record-fishy package-name))
- #-(or gcl2.6 genera)
+ #-genera
(when documentation (setf (documentation package t) documentation))
(loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (note-package-fishiness :over-use name (package-names p))
:with documentation = nil
:for (kw . args) :in clauses
:when (eq kw :nicknames) :append args :into nicknames :else
- :when (eq kw :documentation)
- :do (cond
- (documentation (error "define-package: can't define documentation twice"))
- ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
- (t (setf documentation (car args)))) :else
+ :when (eq kw :documentation)
+ :do (cond
+ (documentation (error "define-package: can't define documentation twice"))
+ ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
+ (t (setf documentation (car args)))) :else
:when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
- :when (eq kw :shadow) :append args :into shadow :else
- :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
- :when (eq kw :import-from) :collect args :into import-from :else
- :when (eq kw :export) :append args :into export :else
- :when (eq kw :intern) :append args :into intern :else
- :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
- :when (eq kw :mix) :append args :into mix :else
- :when (eq kw :reexport) :append args :into reexport :else
- :when (eq kw :unintern) :append args :into unintern :else
- :do (error "unrecognized define-package keyword ~S" kw)
+ :when (eq kw :shadow) :append args :into shadow :else
+ :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
+ :when (eq kw :import-from) :collect args :into import-from :else
+ :when (eq kw :export) :append args :into export :else
+ :when (eq kw :intern) :append args :into intern :else
+ :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
+ :when (eq kw :mix) :append args :into mix :else
+ :when (eq kw :reexport) :append args :into reexport :else
+ :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
+ :and :do (setf use-p t) :else
+ :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
+ :and :do (setf use-p t) :else
+ :when (eq kw :unintern) :append args :into unintern :else
+ :do (error "unrecognized define-package keyword ~S" kw)
:finally (return `(,package
:nicknames ,nicknames :documentation ,documentation
:use ,(if use-p use '(:common-lisp))
:mix ,mix :reexport ,reexport :unintern ,unintern)))))
(defmacro define-package (package &rest clauses)
+ "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
+\(KEYWORD . ARGS\).
+DEFINE-PACKAGE supports the following keywords:
+USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
+RECYCLE -- Recycle the package's exported symbols from the specified packages,
+in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
+either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
+one of the :RECYCLE packages, the first such symbol is re-homed to the package
+being defined.
+For the sake of idempotence, it is important that the package being defined
+should appear in first position if it already exists, and even if it doesn't,
+ahead of any package that is not going to be deleted afterwards and never
+created again. In short, except for special cases, always make it the first
+package on the list if the list is not empty.
+MIX -- Takes a list of package designators. MIX behaves like
+\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
+resolve conflicts in favor of the first found symbol. It may still yield
+an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
+REEXPORT -- Takes a list of package designators. For each package, p, in the list,
+export symbols with the same name as those exported from p. Note that in the case
+of shadowing, etc. the symbols with the same name may not be the same symbols.
+UNINTERN -- Remove symbols here from PACKAGE."
(let ((ensure-form
`(apply 'ensure-package ',(parse-define-package-form package clauses))))
`(progn
- #+clisp
- (eval-when (:compile-toplevel :load-toplevel :execute)
- ,ensure-form)
- #+(or clisp ecl gcl) (defpackage ,package (:use))
+ #+(or ecl gcl mkcl) (defpackage ,package (:use))
(eval-when (:compile-toplevel :load-toplevel :execute)
,ensure-form))))
#+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
- :test 'equalp :key 'car))
- #+gcl
- ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
- ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
- (cond
- ((or (< system::*gcl-major-version* 2)
- (and (= system::*gcl-major-version* 2)
- (< system::*gcl-minor-version* 6)))
- (error "GCL 2.6 or later required to use ASDF"))
- ((and (= system::*gcl-major-version* 2)
- (= system::*gcl-minor-version* 6))
- (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
- (pushnew :gcl2.6 *features*))
- (t
- (pushnew :gcl2.7 *features*))))
+ :test 'equalp :key 'car)))
;; Compatibility with whoever calls asdf/package
(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package))
(:export
#:logical-pathname #:translate-logical-pathname
#:make-broadcast-stream #:file-namestring)
- #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
- #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
#+genera (:shadowing-import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist)
#+mcl (:shadow #:user-homedir-pathname))
;;;; Early meta-level tweaks
-#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
- clozure lispworks (and sbcl sb-unicode) scl)
+#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl)
(eval-when (:load-toplevel :compile-toplevel :execute)
- (pushnew :asdf-unicode *features*))
+ ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
+ ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
+ (when (and #+allegro (member :ics *features*)
+ #+(or clisp cmu ecl mkcl) (member :unicode *features*)
+ #+sbcl (member :sb-unicode *features*))
+ (pushnew :asdf-unicode *features*)))
#+allegro
(eval-when (:load-toplevel :compile-toplevel :execute)
(setf excl:*warn-on-nested-reader-conditionals* nil))
(setf *print-readably* nil))
+#+clozure (in-package :ccl)
+#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (unless (fboundp 'external-process-wait)
+ (in-development-mode
+ (defun external-process-wait (proc)
+ (when (and (external-process-pid proc) (eq (external-process-%status proc) :running))
+ (with-interrupts-enabled
+ (wait-on-semaphore (external-process-completed proc))))
+ (values (external-process-%exit-code proc)
+ (external-process-%status proc))))))
+#+clozure (in-package :uiop/common-lisp)
+
+
#+cormanlisp
(eval-when (:load-toplevel :compile-toplevel :execute)
(deftype logical-pathname () nil)
(defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
(unless (use-ecl-byte-compiler-p) (require :cmp)))
-#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
+#+gcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :ansi-cl *features*)
(error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
(setf compiler::*compiler-default-type* (pathname "")
- compiler::*lsp-ext* ""))
-
-#+gcl2.6
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (shadow 'type-of :uiop/common-lisp)
- (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
-
-#+gcl2.6
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export 'type-of :uiop/common-lisp)
- (export 'system:*load-pathname* :uiop/common-lisp))
-
-#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (defvar *gcl2.6* t)
- (deftype logical-pathname () nil)
- (defun type-of (x) (class-name (class-of x)))
- (defun wild-pathname-p (path) (declare (ignore path)) nil)
- (defun translate-logical-pathname (x) x)
- (defvar *compile-file-pathname* nil)
- (defun pathname-match-p (in-pathname wild-pathname)
- (declare (ignore in-wildname wild-wildname)) nil)
- (defun translate-pathname (source from-wildname to-wildname &key)
- (declare (ignore from-wildname to-wildname)) source)
- (defun %print-unreadable-object (object stream type identity thunk)
- (format stream "#<~@[~S ~]" (when type (type-of object)))
- (funcall thunk)
- (format stream "~@[ ~X~]>" (when identity (system:address object))))
- (defmacro with-standard-io-syntax (&body body)
- `(progn ,@body))
- (defmacro with-compilation-unit (options &body body)
- (declare (ignore options)) `(progn ,@body))
- (defmacro print-unreadable-object ((object stream &key type identity) &body body)
- `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
- (defun ensure-directories-exist (path)
- (lisp:system (format nil "mkdir -p ~S"
- (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
+ compiler::*lsp-ext* "")
+ #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
+ (cond
+ #+gcl
+ ((or (< system::*gcl-major-version* 2)
+ (and (= system::*gcl-major-version* 2)
+ (< system::*gcl-minor-version* 7)))
+ '(error "GCL 2.7 or later required to use ASDF")))))
+ (eval code)
+ code))
#+genera
(eval-when (:load-toplevel :compile-toplevel :execute)
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun frob-substrings (string substrings &optional frob)
- (declare (optimize (speed 0) (safety 3) (debug 3)))
+ "for each substring in SUBSTRINGS, find occurrences of it within STRING
+that don't use parts of matched occurrences of previous strings, and
+FROB them, that is to say, remove them if FROB is NIL,
+replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
+call FROB with the match and a function that emits a string in the output.
+Return a string made of the parts not omitted or emitted by FROB."
+ (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
(let ((length (length string)) (stream nil))
(labels ((emit-string (x &optional (start 0) (end (length x)))
(when (< start end)
(defmacro compatfmt (format)
#+(or gcl genera)
- (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
+ (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format))
-
-
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities for ASDF
(:nicknames :asdf/utility)
(:recycle :uiop/utility :asdf/utility :asdf)
(:use :uiop/common-lisp :uiop/package)
- ;; import and reexport a few things defined in :asdf/common-lisp
+ ;; import and reexport a few things defined in :uiop/common-lisp
(:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
(:export
;; magic helper to define debugging functions:
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
- #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
- #:if-let ;; basic flow control
+ #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
+ #:undefine-function #:undefine-functions #:defun* #:defgeneric*
+ #:nest #:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
#:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
#:+non-base-chars-exist-p+ ;; characters
+ #:+max-character-type-index+ #:character-type-index #:+character-types+
#:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
- #:first-char #:last-char #:split-string
+ #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
- #:find-class* ;; CLOS
+ #:coerce-class ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
#:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
- #:list-to-hash-set ;; hash-table
+ #:list-to-hash-set #:ensure-gethash ;; hash-table
#:ensure-function #:access-at #:access-at-count ;; functions
#:call-function #:call-functions #:register-hook-function
#:match-condition-p #:match-any-condition-p ;; conditions
(defun undefine-function (function-spec)
(cond
((symbolp function-spec)
+ ;; undefining the previous function is the portable way
+ ;; of overriding any incompatible previous gf,
+ ;; but CLISP needs extra help with getting rid of previous methods.
#+clisp
(let ((f (and (fboundp function-spec) (fdefinition function-spec))))
(when (typep f 'clos:standard-generic-function)
(fmakunbound function-spec))
((and (consp function-spec) (eq (car function-spec) 'setf)
(consp (cdr function-spec)) (null (cddr function-spec)))
- #-gcl2.6 (fmakunbound function-spec))
+ (fmakunbound function-spec))
(t (error "bad function spec ~S" function-spec))))
(defun undefine-functions (function-spec-list)
(map () 'undefine-function function-spec-list))
name)
(declare (ignorable supersede))
`(progn
- ;; undefining the previous function is the portable way
- ;; of overriding any incompatible previous gf, except on CLISP.
;; We usually try to do it only for the functions that need it,
- ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
- ;; (which causes issues in clisp)
- ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
+ ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
+ ,@(when (or supersede #+ecl t)
`((undefine-function ',name)))
- #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
`((declaim (notinline ,name))))
(,',def ,name ,formals ,@rest))))))
(defdef defgeneric* defgeneric)
(defdef defun* defun))
(defmacro with-upgradability ((&optional) &body body)
+ "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
+to also declare the functions NOTINLINE and to accept a wrapping the function name
+specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
+is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
+to supersede any previous definition."
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(loop :for form :in body :collect
(if (consp form)
(destructuring-bind (car . cdr) form
(case car
((defun) `(defun* ,@cdr))
- ((defgeneric)
- (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
- `(defgeneric* ,@cdr)))
+ ((defgeneric) `(defgeneric* ,@cdr))
(otherwise form)))
form)))))
(if file (load file)
(error "Failed to locate debug utility file: ~S" utility-file)))))))
-
;;; Flow control
(with-upgradability ()
+ (defmacro nest (&rest things)
+ "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer
+ (reduce #'(lambda (outer inner) `(,@outer ,inner))
+ things :from-end t))
+
(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
;; bindings can be (var form) or ((var1 form1) ...)
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
;;; Characters
-(with-upgradability ()
+(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
(defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
+ #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
+(with-upgradability ()
+ (defparameter +character-types+ ;; assuming a simple hierarchy
+ #(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character))
+ (defparameter +max-character-type-index+ (1- (length +character-types+))))
+
+(with-upgradability ()
+ (defun character-type-index (x)
+ (declare (ignorable x))
+ #.(case +max-character-type-index+
+ (0 0)
+ (1 '(etypecase x
+ (character (if (typep x 'base-char) 0 1))
+ (symbol (if (subtypep x 'base-char) 0 1))))
+ (otherwise
+ '(or (position-if (etypecase x
+ (character #'(lambda (type) (typep x type)))
+ (symbol #'(lambda (type) (subtypep x type))))
+ +character-types+)
+ (error "Not a character or character type: ~S" x))))))
+
;;; Strings
(with-upgradability ()
(defun base-string-p (string)
+ "Does the STRING only contain BASE-CHARs?"
(declare (ignorable string))
(and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
(defun strings-common-element-type (strings)
+ "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
(declare (ignorable strings))
- #-non-base-chars-exist-p 'character
- #+non-base-chars-exist-p
- (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
- 'base-char 'character))
+ #.(if +non-base-chars-exist-p+
+ `(aref +character-types+
+ (loop :with index = 0 :for s :in strings :do
+ (cond
+ ((= index ,+max-character-type-index+) (return index))
+ ((emptyp s)) ;; NIL or empty string
+ ((characterp s) (setf index (max index (character-type-index s))))
+ ((stringp s) (unless (>= index (character-type-index (array-element-type s)))
+ (setf index (reduce 'max s :key #'character-type-index
+ :initial-value index))))
+ (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))
+ :finally (return index)))
+ ''character))
(defun reduce/strcat (strings &key key start end)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
NIL is interpreted as an empty string. A character is interpreted as a string of length one."
(when (or start end) (setf strings (subseq strings start end)))
(when key (setf strings (mapcar key strings)))
- (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
+ (loop :with output = (make-string (loop :for s :in strings
+ :sum (if (characterp s) 1 (length s)))
:element-type (strings-common-element-type strings))
:with pos = 0
:for input :in strings
:finally (return output)))
(defun strcat (&rest strings)
+ "Concatenate strings.
+NIL is interpreted as an empty string, a character as a string of length one."
(reduce/strcat strings))
(defun first-char (s)
+ "Return the first character of a non-empty string S, or NIL"
(and (stringp s) (plusp (length s)) (char s 0)))
(defun last-char (s)
+ "Return the last character of a non-empty string S, or NIL"
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
(defun split-string (string &key max (separator '(#\Space #\Tab)))
\"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
(block ()
(let ((list nil) (words 0) (end (length string)))
+ (when (zerop end) (return nil))
(flet ((separatorp (char) (find char separator))
(done () (return (cons (subseq string 0 end) list))))
(loop
(and (string-prefix-p prefix string)
(string-suffix-p string suffix))))
-
-;;; CLOS
-(with-upgradability ()
- (defun find-class* (x &optional (errorp t) environment)
- (etypecase x
- ((or standard-class built-in-class) x)
- #+gcl2.6 (keyword nil)
- (symbol (find-class x errorp environment)))))
+ (defvar +cr+ (coerce #(#\Return) 'string))
+ (defvar +lf+ (coerce #(#\Linefeed) 'string))
+ (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))
+
+ (defun stripln (x)
+ "Strip a string X from any ending CR, LF or CRLF.
+Return two values, the stripped string and the ending that was stripped,
+or the original value and NIL if no stripping took place.
+Since our STRCAT accepts NIL as empty string designator,
+the two results passed to STRCAT always reconstitute the original string"
+ (check-type x string)
+ (block nil
+ (flet ((c (end) (when (string-suffix-p x end)
+ (return (values (subseq x 0 (- (length x) (length end))) end)))))
+ (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
-;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
+;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
(deftype stamp () '(or real boolean)))
(with-upgradability ()
(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
-;;; Hash-tables
-(with-upgradability ()
- (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
- (dolist (x list h) (setf (gethash x h) t))))
-
-
;;; Function designators
(with-upgradability ()
(defun ensure-function (fun &key (package :cl))
i.e. for a boolean keyword character number or pathname.
Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
If FUN is a CONS, return the function that applies its CAR
-to the appended list of the rest of its CDR and the arguments.
+to the appended list of the rest of its CDR and the arguments,
+unless the CAR is LAMBDA, in which case the expression is evaluated.
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
(etypecase fun
(function fun)
((or boolean keyword character number pathname) (constantly fun))
- ((or function symbol) fun)
- (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
+ (hash-table (lambda (x) (gethash x fun)))
+ (symbol (fdefinition fun))
+ (cons (if (eq 'lambda (car fun))
+ (eval fun)
+ #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
(string (eval `(function ,(with-standard-io-syntax
(let ((*package* (find-package package)))
(read-from-string fun))))))))
(defun access-at-count (at)
"From an AT specification, extract a COUNT of maximum number
- of sub-objects to read as per ACCESS-AT"
+of sub-objects to read as per ACCESS-AT"
(cond
((integerp at)
(1+ at))
(1+ (first at)))))
(defun call-function (function-spec &rest arguments)
+ "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
+with the given ARGUMENTS"
(apply (ensure-function function-spec) arguments))
(defun call-functions (function-specs)
+ "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
(map () 'call-function function-specs))
(defun register-hook-function (variable hook &optional call-now-p)
- (pushnew hook (symbol-value variable))
+ "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
+When CALL-NOW-P is true, also call the function immediately."
+ (pushnew hook (symbol-value variable) :test 'equal)
(when call-now-p (call-function hook))))
+;;; CLOS
+(with-upgradability ()
+ (defun coerce-class (class &key (package :cl) (super t) (error 'error))
+ "Coerce CLASS to a class that is subclass of SUPER if specified,
+or invoke ERROR handler as per CALL-FUNCTION.
+
+A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
+-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
+A string is read as a symbol while in PACKAGE, the symbol designates a class.
+
+A class object designates itself.
+NIL designates itself (no class).
+A symbol otherwise designates a class by name."
+ (let* ((normalized
+ (typecase class
+ (keyword (or (find-symbol* class package nil)
+ (find-symbol* class *package* nil)))
+ (string (symbol-call :uiop :safe-read-from-string class :package package))
+ (t class)))
+ (found
+ (etypecase normalized
+ ((or standard-class built-in-class) normalized)
+ ((or null keyword) nil)
+ (symbol (find-class normalized nil nil)))))
+ (or (and found
+ (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
+ found)
+ (call-function error "Can't coerce ~S to a ~@[class~;subclass of ~:*~S]" class super)))))
+
+
+;;; Hash-tables
+(with-upgradability ()
+ (defun ensure-gethash (key table default)
+ "Lookup the TABLE for a KEY as by GETHASH, but if not present,
+call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
+set the corresponding entry to the result in the table.
+Return two values: the entry after its optional computation, and whether it was found"
+ (multiple-value-bind (value foundp) (gethash key table)
+ (values
+ (if foundp
+ value
+ (setf (gethash key table) (call-function default)))
+ foundp)))
+
+ (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
+ "Convert a LIST into hash-table that has the same elements when viewed as a set,
+up to the given equality TEST"
+ (dolist (x list h) (setf (gethash x h) t))))
+
+
;;; Version handling
(with-upgradability ()
(defun unparse-version (version-list)
#+clisp 'system::$format-control
#+clozure 'ccl::format-control
#+(or cmu scl) 'conditions::format-control
- #+ecl 'si::format-control
+ #+(or ecl mkcl) 'si::format-control
#+(or gcl lispworks) 'conditions::format-string
#+sbcl 'sb-kernel:format-control
- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
+ #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil
"Name of the slot for FORMAT-CONTROL in simple-condition")
(defun match-condition-p (x condition)
(loop :for x :in conditions :thereis (match-condition-p x condition)))
(defun call-with-muffled-conditions (thunk conditions)
+ "calls the THUNK in a context where the CONDITIONS are muffled"
(handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
(muffle-warning c)))))
(funcall thunk)))
(defmacro with-muffled-conditions ((conditions) &body body)
+ "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
`(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
-
;;;; ---------------------------------------------------------------------------
;;;; Access to the Operating System
(:recycle :uiop/os :asdf/os :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility)
(:export
- #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
+ #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
#:getenv #:getenvp ;; environment variables
#:implementation-identifier ;; implementation identifier
#:implementation-type #:*implementation-type*
;;; Features
(with-upgradability ()
(defun featurep (x &optional (*features* *features*))
+ "Checks whether a feature expression X is true with respect to the *FEATURES* set,
+as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
+we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
+your reader will not have magically used the KEYWORD package, so you need specify
+keywords explicitly."
(cond
((atom x) (and (member x *features*) t))
((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
(t (error "Malformed feature specification ~S" x))))
(defun os-unix-p ()
+ "Is the underlying operating system some Unix variant?"
(or #+abcl (featurep :unix)
#+(and (not abcl) (or unix cygwin darwin)) t))
+ (defun os-macosx-p ()
+ "Is the underlying operating system MacOS X?"
+ ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
+ ;; in fact the former implies the latter.
+ (or
+ #+allegro (featurep :macosx)
+ #+clisp (featurep :macos)
+ (featurep :darwin)))
+
(defun os-windows-p ()
+ "Is the underlying operating system Microsoft Windows?"
(or #+abcl (featurep :windows)
- #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
+ #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t))
(defun os-genera-p ()
+ "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
(or #+genera t))
+ (defun os-oldmac-p ()
+ "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
+ (or #+mcl t))
+
(defun detect-os ()
- (flet ((yes (yes) (pushnew yes *features*))
- (no (no) (setf *features* (remove no *features*))))
- (cond
- ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
- ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
- ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
- (t (error "Congratulations for trying XCVB on an operating system~%~
-that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
+ "Detects the current operating system. Only needs be run at compile-time,
+except on ABCL where it might change between FASL compilation and runtime."
+ (loop* :with o
+ :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
+ (:os-windows . os-windows-p)
+ (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
+ :when (and (or (not o) (eq feature :os-macosx)) (funcall detect))
+ :do (setf o feature) (pushnew feature *features*)
+ :else :do (setf *features* (remove feature *features*))
+ :finally
+ (return (or o (error "Congratulations for trying ASDF on an operating system~%~
+that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
(detect-os))
(with-upgradability ()
(defun getenv (x)
+ "Query the environment, as in C getenv.
+Beware: may return empty string if a variable is present but empty;
+use getenvp to return NIL in such a case."
(declare (ignorable x))
#+(or abcl clisp ecl xcl) (ext:getenv x)
#+allegro (sys:getenv x)
(with-upgradability ()
(defun first-feature (feature-sets)
+ "A helper for various feature detection functions"
(dolist (x feature-sets)
(multiple-value-bind (short long feature-expr)
(if (consp x)
(return (values short long))))))
(defun implementation-type ()
+ "The type of Lisp implementation used, as a short UIOP-standardized keyword"
(first-feature
'(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
(:cmu :cmucl :cmu) :ecl :gcl
(:lwpe :lispworks-personal-edition) (:lw :lispworks)
:mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
- (defvar *implementation-type* (implementation-type))
+ (defvar *implementation-type* (implementation-type)
+ "The type of Lisp implementation used, as a short UIOP-standardized keyword")
(defun operating-system ()
+ "The operating system of the current host"
(first-feature
'(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
(:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
:genera)))
(defun architecture ()
+ "The CPU architecture of the current host"
(first-feature
'((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
(:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
(error "Can't determine fasl version.")))
(defun lisp-version-string ()
+ "return a string that identifies the current Lisp implementation version"
(let ((s (lisp-implementation-version)))
(car ; as opposed to OR, this idiom prevents some unreachable code warning
(list
s))))
(defun implementation-identifier ()
+ "Return a string that identifies the ABI of the current implementation,
+suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
(substitute-if
#\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
(format nil "~(~a~@{~@[-~a~]~}~)"
(with-upgradability ()
(defun hostname ()
+ "return the hostname of the current host"
;; Note: untested on RMCL
#+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
#+cormanlisp "localhost" ;; is there a better way? Does it matter?
#+cmu
(defun parse-unix-namestring* (unix-namestring)
+ "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
(multiple-value-bind (host device directory name type version)
(lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
(make-pathname :host (or host lisp::*unix-host*) :device device
(defun getcwd ()
"Get the current working directory as per POSIX getcwd(3), as a pathname object"
- (or #+abcl (parse-namestring
- (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
+ (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring
+ (java:jstatic "getProperty" "java.lang.System" "user.dir")
+ :ensure-directory t))
#+allegro (excl::current-directory)
#+clisp (ext:default-directory)
#+clozure (ccl:current-directory)
(strcat (nth-value 1 (unix:unix-current-directory)) "/"))
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd)
- #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
- (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
+ #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
#+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
#+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
#+genera (setf *default-pathname-defaults* x)
#+lispworks (hcl:change-directory x)
#+mkcl (mk-ext:chdir x)
- #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
+ #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
(error "chdir not supported on your implementation")))))
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
-#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
+#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
(with-upgradability ()
(defparameter *link-initial-dword* 76)
(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
(defun read-null-terminated-string (s)
+ "Read a null-terminated string from an octet stream S"
+ ;; note: doesn't play well with UNICODE
(with-output-to-string (out)
(loop :for code = (read-byte s)
:until (zerop code)
:do (write-char (code-char code) out))))
(defun read-little-endian (s &optional (bytes 4))
+ "Read a number in little-endian format from an byte (octet) stream S,
+the number having BYTES octets (defaulting to 4)."
(loop :for i :from 0 :below bytes
:sum (ash (read-byte s) (* 8 i))))
(defun parse-file-location-info (s)
+ "helper to parse-windows-shortcut"
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
(read-null-terminated-string s))))))
(defun parse-windows-shortcut (pathname)
+ "From a .lnk windows shortcut, extract the pathname linked to"
+ ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
(when (and (= (read-little-endian s) *link-initial-dword*)
#:merge-pathnames*
#:nil-pathname #:*nil-pathname* #:with-pathname-defaults
;; Predicates
- #:pathname-equal #:logical-pathname-p #:physical-pathname-p
+ #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname
#:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
;; Directories
#:pathname-directory-pathname #:pathname-parent-directory-pathname
#:subpathname #:subpathname*
#:ensure-absolute-pathname
#:pathname-root #:pathname-host-pathname
- #:subpathp
+ #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname
;; Checking constraints
#:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
;; Wildcard pathnames
(with-upgradability ()
(defun normalize-pathname-directory-component (directory)
- "Given a pathname directory component, return an equivalent form that is a list"
- #+gcl2.6 (setf directory (substitute :back :parent directory))
+ "Convert the DIRECTORY component from a format usable by the underlying
+implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
+that is a list and not a string."
(cond
#-(or cmu sbcl scl) ;; these implementations already normalize directory components.
((stringp directory) `(:absolute ,directory))
- #+gcl2.6
- ((and (consp directory) (eq :root (first directory)))
- `(:absolute ,@(rest directory)))
((or (null directory)
(and (consp directory) (member (first directory) '(:absolute :relative))))
directory)
- #+gcl2.6
+ #+gcl
((consp directory)
- `(:relative ,@directory))
+ (cons :relative directory))
(t
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
(defun denormalize-pathname-directory-component (directory-component)
- #-gcl2.6 directory-component
- #+gcl2.6
- (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
- directory-component)))
- (cond
- ((and (consp d) (eq :relative (first d))) (rest d))
- ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
- (t d))))
+ "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
+by the underlying implementation's MAKE-PATHNAME and other primitives"
+ directory-component)
(defun merge-pathname-directory-components (specified defaults)
- ;; Helper for merge-pathnames* that handles directory components.
+ "Helper for MERGE-PATHNAMES* that handles directory components"
(let ((directory (normalize-pathname-directory-component specified)))
(ecase (first directory)
((nil) defaults)
;; See CLHS make-pathname and 19.2.2.2.3.
;; This will be :unspecific if supported, or NIL if not.
(defparameter *unspecific-pathname-type*
- #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
- #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
+ #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific
+ #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil
+ "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
- (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
+ (defun make-pathname* (&rest keys &key (directory nil)
host (device () #+allegro devicep) name type version defaults
#+scl &allow-other-keys)
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
tries hard to make a pathname that will actually behave as documented,
despite the peculiarities of each implementation"
+ ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
(declare (ignorable host device directory name type version defaults))
(apply 'make-pathname
(append
#+allegro (when (and devicep (null device)) `(:device :unspecific))
- #+gcl2.6
- (when directoryp
- `(:directory ,(denormalize-pathname-directory-component directory)))
keys)))
(defun make-pathname-component-logical (x)
if the SPECIFIED pathname does not have an absolute directory,
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
-then the HOST and DEVICE both come from the SPECIFIED.
+then the HOST and DEVICE both come from the SPECIFIED pathname.
This is what users want on a modern Unix or Windows operating system,
-unlike the MERGE-PATHNAME behavior.
+unlike the MERGE-PATHNAMES behavior.
Also, if either argument is NIL, then the other argument is returned unmodified;
-this is unlike MERGE-PATHNAME which always merges with a pathname,
+this is unlike MERGE-PATHNAMES which always merges with a pathname,
by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
(when (null specified) (return-from merge-pathnames* defaults))
(when (null defaults) (return-from merge-pathnames* specified))
:type (funcall unspecific-handler type)
:version (funcall unspecific-handler version))))))
+ (defun logical-pathname-p (x)
+ "is X a logical-pathname?"
+ (typep x 'logical-pathname))
+
+ (defun physical-pathname-p (x)
+ "is X a pathname that is not a logical-pathname?"
+ (and (pathnamep x) (not (logical-pathname-p x))))
+
+ (defun physicalize-pathname (x)
+ "if X is a logical pathname, use translate-logical-pathname on it."
+ ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP
+ (let ((p (when x (pathname x))))
+ (if (logical-pathname-p p) (translate-logical-pathname p) p)))
+
(defun nil-pathname (&optional (defaults *default-pathname-defaults*))
"A pathname that is as neutral as possible for use as defaults
- when merging, making or parsing pathnames"
+when merging, making or parsing pathnames"
;; 19.2.2.2.1 says a NIL host can mean a default host;
;; see also "valid physical pathname host" in the CLHS glossary, that suggests
;; strings and lists of strings or :unspecific
;; But CMUCL decides to die on NIL.
- #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
- :host (or #+cmu lisp::*unix-host*)
+ ;; MCL has issues with make-pathname, nil and defaulting
+ (declare (ignorable defaults))
+ #.`(make-pathname* :directory nil :name nil :type nil :version nil
+ :device (or #+(and mkcl unix) :unspecific)
+ :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost")
#+scl ,@'(:scheme nil :scheme-specific-part nil
:username nil :password nil :parameters nil :query nil :fragment nil)
;; the default shouldn't matter, but we really want something physical
- :defaults defaults))
+ #-mcl ,@'(:defaults defaults)))
- (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
+ (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname)))
+ "A pathname that is as neutral as possible for use as defaults
+when merging, making or parsing pathnames")
(defmacro with-pathname-defaults ((&optional defaults) &body body)
+ "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible
+when merging, making or parsing pathnames"
`(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
;;; Some pathname predicates
(with-upgradability ()
(defun pathname-equal (p1 p2)
+ "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?"
(when (stringp p1) (setf p1 (pathname p1)))
(when (stringp p2) (setf p2 (pathname p2)))
(flet ((normalize-component (x)
(or (and (null p1) (null p2))
(and (pathnamep p1) (pathnamep p2)
(and (=? pathname-host)
- (=? pathname-device)
+ #-(and mkcl unix) (=? pathname-device)
(=? normalize-pathname-directory-component pathname-directory)
(=? pathname-name)
(=? pathname-type)
- (=? pathname-version)))))))
-
- (defun logical-pathname-p (x)
- (typep x 'logical-pathname))
-
- (defun physical-pathname-p (x)
- (and (pathnamep x) (not (logical-pathname-p x))))
+ #-mkcl (=? pathname-version)))))))
(defun absolute-pathname-p (pathspec)
"If PATHSPEC is a pathname or namestring object that parses as a pathname
Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
(when pathname
+ ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
+ ;; because it rejects apparently legal pathnames as
+ ;; ill-formed. [2014/02/10:rpg]
(let ((pathname (pathname pathname)))
(flet ((check-one (x)
- (member x '(nil :unspecific "") :test 'equal)))
+ (member x '(nil :unspecific) :test 'equal)))
(and (not (wild-pathname-p pathname))
(check-one (pathname-name pathname))
(check-one (pathname-type pathname))
1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
the string is made the last directory component, and NAME and TYPE are NIL.
if the string is empty, it's the empty pathname with all slots NIL.
-2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
+2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
are separated by SPLIT-NAME-TYPE.
3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
which must be one of :BACK or :UP and defaults to :BACK.
HOST, DEVICE and VERSION components are taken from DEFAULTS,
-which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
+which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL.
No host or device can be specified in the string itself,
which makes it unsuitable for absolute pathnames outside Unix.
(make-pathname*
:directory (unless file-only (cons relative path))
:name name :type type
- :defaults (or defaults *nil-pathname*))
+ :defaults (or #-mcl defaults *nil-pathname*))
(remove-plist-keys '(:type :dot-dot :defaults) keys))))))
(defun unix-namestring (pathname)
((or null string) pathname)
(pathname
(with-output-to-string (s)
- (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
+ (flet ((err () #+lispworks (describe pathname) (error "Not a valid unix-namestring ~S" pathname)))
(let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
(name (pathname-name pathname))
+ (name (and (not (eq name :unspecific)) name))
(type (pathname-type pathname))
(type (and (not (eq type :unspecific)) type)))
(cond
- ((eq dir ()))
+ ((member dir '(nil :unspecific)))
((eq dir '(:relative)) (princ "./" s))
((consp dir)
(destructuring-bind (relabs &rest dirs) dir
(t (err)))
(cond
(name
- (or (and (stringp name) (or (null type) (stringp type))) (err))
+ (unless (and (stringp name) (or (null type) (stringp type))) (err))
(format s "~A~@[.~A~]" name type))
(t
(or (null type) (err)))))))))))
(subpathname (ensure-directory-pathname pathname) subpath :type type)))
(defun pathname-root (pathname)
+ "return the root directory for the host and device of given PATHNAME"
(make-pathname* :directory '(:absolute)
:name nil :type nil :version nil
:defaults pathname ;; host device, and on scl, *some*
. #.(or #+scl '(:parameters nil :query nil :fragment nil))))
(defun pathname-host-pathname (pathname)
+ "return a pathname with the same host as given PATHNAME, and all other fields NIL"
(make-pathname* :directory nil
:name nil :type nil :version nil :device 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 subpathp (maybe-subpath base-pathname)
- (and (pathnamep maybe-subpath) (pathnamep base-pathname)
- (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
- (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
- (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
- (with-pathname-defaults ()
- (let ((enough (enough-namestring maybe-subpath base-pathname)))
- (and (relative-pathname-p enough) (pathname enough))))))
-
(defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
+ "Given a pathname designator PATH, return an absolute pathname as specified by PATH
+considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
+with a format control-string and other arguments as arguments"
(cond
((absolute-pathname-p path))
((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
path default-pathname))))
(t (call-function on-error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
- path defaults)))))
+ path defaults))))
+
+ (defun subpathp (maybe-subpath base-pathname)
+ "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
+when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
+ (and (pathnamep maybe-subpath) (pathnamep base-pathname)
+ (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
+ (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
+ (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
+ (with-pathname-defaults ()
+ (let ((enough (enough-namestring maybe-subpath base-pathname)))
+ (and (relative-pathname-p enough) (pathname enough))))))
+
+ (defun enough-pathname (maybe-subpath base-pathname)
+ "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
+when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
+ (let ((sub (when maybe-subpath (pathname maybe-subpath)))
+ (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
+ (or (and base (subpathp sub base)) sub)))
+
+ (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
+ "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
+or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
+given DEFAULTS-PATHNAME as a base pathname."
+ (let ((enough (enough-pathname maybe-subpath defaults-pathname))
+ (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*)))
+ (funcall thunk enough)))
+
+ (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var)
+ (defaults *default-pathname-defaults*))
+ &body body)
+ "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
+ `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))))
;;; Wildcard pathnames
(with-upgradability ()
- (defparameter *wild* (or #+cormanlisp "*" :wild))
- (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
- (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
+ (defparameter *wild* (or #+cormanlisp "*" :wild)
+ "Wild component for use with MAKE-PATHNAME")
+ (defparameter *wild-directory-component* (or :wild)
+ "Wild directory component for use with MAKE-PATHNAME")
+ (defparameter *wild-inferiors-component* (or :wild-inferiors)
+ "Wild-inferiors directory component for use with MAKE-PATHNAME")
(defparameter *wild-file*
(make-pathname :directory nil :name *wild* :type *wild*
- :version (or #-(or allegro abcl xcl) *wild*)))
+ :version (or #-(or allegro abcl xcl) *wild*))
+ "A pathname object with wildcards for matching any file in a given directory")
(defparameter *wild-directory*
(make-pathname* :directory `(:relative ,*wild-directory-component*)
- :name nil :type nil :version nil))
+ :name nil :type nil :version nil)
+ "A pathname object with wildcards for matching any subdirectory")
(defparameter *wild-inferiors*
(make-pathname* :directory `(:relative ,*wild-inferiors-component*)
- :name nil :type nil :version nil))
+ :name nil :type nil :version nil)
+ "A pathname object with wildcards for matching any recursive subdirectory")
(defparameter *wild-path*
- (merge-pathnames* *wild-file* *wild-inferiors*))
+ (merge-pathnames* *wild-file* *wild-inferiors*)
+ "A pathname object with wildcards for matching any file in any recursive subdirectory")
(defun wilden (path)
+ "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory"
(merge-pathnames* *wild-path* path)))
;;; Translate a pathname
(with-upgradability ()
(defun relativize-directory-component (directory-component)
+ "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component"
(let ((directory (normalize-pathname-directory-component directory-component)))
(cond
((stringp directory)
directory))))
(defun relativize-pathname-directory (pathspec)
+ "Given a PATHNAME, return a relative pathname with otherwise the same components"
(let ((p (pathname pathspec)))
(make-pathname*
:directory (relativize-directory-component (pathname-directory p))
:defaults p)))
(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+ "Given a PATHNAME, return the character used to delimit directory names on this host and device."
(let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
(last-char (namestring foo))))
#-scl
(defun directorize-pathname-host-device (pathname)
+ "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
+added to its DIRECTORY component. This is useful for output translations."
#+(or unix abcl)
(when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
(return-from directorize-pathname-host-device pathname))
pathname)))
(defun* (translate-pathname*) (path absolute-source destination &optional root source)
+ "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
+PATH is the pathname to be translated.
+ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
+DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE,
+or a relative pathname, to be merged with ROOT and used as destination for translate-pathname
+or an absolute pathname, to be used as destination for translate-pathname.
+In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE."
(declare (ignore source))
(cond
((functionp destination)
;;; Probing the filesystem
(with-upgradability ()
(defun truename* (p)
+ "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
;; avoids both logical-pathname merging and physical resolution issues
(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
(defun safe-file-write-date (pathname)
+ "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
;; If FILE-WRITE-DATE returns NIL, it's possible that
;; the user or some other agent has deleted an input file.
;; Also, generated files will not exist at the time planning is done
;; as if the file were very old.
;; (or should we treat the case in a different, special way?)
(and pathname
- (handler-case (file-write-date (translate-logical-pathname pathname))
+ (handler-case (file-write-date (physicalize-pathname pathname))
(file-error () nil))))
(defun probe-file* (p &key truename)
(or
#+allegro
(probe-file p :follow-symlinks truename)
- #-(or allegro clisp gcl2.6)
+ #+gcl
(if truename
- (probe-file p)
- (ignore-errors
- (let ((pp (translate-logical-pathname p)))
- (and
- #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
- #+(and lispworks unix) (system:get-file-stat pp)
- #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
- #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
- p))))
- #+(or clisp gcl2.6)
+ (truename* p)
+ (let ((kind (car (si::stat p))))
+ (when (eq kind :link)
+ (setf kind (ignore-errors (car (si::stat (truename* p))))))
+ (ecase kind
+ ((nil) nil)
+ ((:file :link)
+ (cond
+ ((file-pathname-p p) p)
+ ((directory-pathname-p p)
+ (subpathname p (car (last (pathname-directory p)))))))
+ (:directory (ensure-directory-pathname p)))))
+ #+clisp
#.(flet ((probe (probe)
`(let ((foundtrue ,probe))
(cond
(truename foundtrue)
(foundtrue p)))))
- #+gcl2.6
- (probe '(or (probe-file p)
- (and (directory-pathname-p p)
- (ignore-errors
- (ensure-directory-pathname
- (truename* (subpathname
- (ensure-directory-pathname p) ".")))))))
- #+clisp
- (let* ((fs (find-symbol* '#:file-stat :posix nil))
+ (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
(pp (find-symbol* '#:probe-pathname :ext nil))
(resolve (if pp
`(ignore-errors (,pp p))
`(if truename
,resolve
(and (ignore-errors (,fs p)) p))
- (probe resolve)))))
+ (probe resolve))))
+ #-(or allegro clisp gcl)
+ (if truename
+ (probe-file p)
+ (ignore-errors
+ (let ((pp (physicalize-pathname p)))
+ (and
+ #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
+ #+(and lispworks unix) (system:get-file-stat pp)
+ #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
+ #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
+ p)))))
(file-error () nil)))))))
(defun directory-exists-p (x)
+ "Is X the name of a directory that exists on the filesystem?"
+ #+allegro
+ (excl:probe-directory x)
+ #+clisp
+ (handler-case (ext:probe-directory x)
+ (sys::simple-file-error ()
+ nil))
+ #-(or allegro clisp)
(let ((p (probe-file* x :truename t)))
(and (directory-pathname-p p) p)))
(defun file-exists-p (x)
+ "Is X the name of a file that exists on the filesystem?"
(let ((p (probe-file* x :truename t)))
(and (file-pathname-p p) p)))
(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
+ "Return a list of the entries in a directory by calling DIRECTORY.
+Try to override the defaults to not resolving symlinks, if implementation allows."
(apply 'directory pathname-spec
(append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
#+(or clozure digitool) '(:follow-links nil)
#+clisp '(:circle t :if-does-not-exist :ignore)
#+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+lispworks '(:link-transparency nil)
#+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
'(:resolve-symlinks nil))))))
(defun filter-logical-directory-results (directory entries merger)
- (if (logical-pathname-p directory)
- ;; 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 (logical-pathname-p f) f)
- (let* ((u (ignore-errors (funcall merger f))))
- ;; The first u avoids a cumbersome (truename u) error.
- ;; At this point f should already be a truename,
- ;; but isn't quite in CLISP, for it doesn't have :version :newest
- (and u (equal (truename* u) (truename* f)) u)))
- :when p :collect p)
- entries))
+ "Given ENTRIES in a DIRECTORY, remove if the directory is logical
+the entries which are physical yet when transformed by MERGER have a different TRUENAME.
+This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
+ (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
+ (if (logical-pathname-p directory)
+ ;; 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 (logical-pathname-p f) f)
+ (let* ((u (ignore-errors (call-function merger f))))
+ ;; The first u avoids a cumbersome (truename u) error.
+ ;; At this point f should already be a truename,
+ ;; but isn't quite in CLISP, for it doesn't have :version :newest
+ (and u (equal (truename* u) (truename* f)) u)))
+ :when p :collect p)
+ entries)
+ :test 'pathname-equal))
+
(defun directory-files (directory &optional (pattern *wild-file*))
+ "Return a list of the files in a directory according to the PATTERN.
+Subdirectories should NOT be returned.
+ PATTERN defaults to a pattern carefully chosen based on the implementation;
+override the default at your own risk.
+ DIRECTORY-FILES tries NOT to resolve symlinks if the implementation
+permits this."
(let ((dir (pathname directory)))
(when (logical-pathname-p dir)
;; Because of the filtering we do below,
(setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let* ((pat (merge-pathnames* pattern dir))
(entries (append (ignore-errors (directory* pat))
- #+clisp
+ #+(or clisp gcl)
(when (equal :wild (pathname-type pattern))
(ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
- (filter-logical-directory-results
- directory entries
- #'(lambda (f)
- (make-pathname :defaults dir
- :name (make-pathname-component-logical (pathname-name f))
- :type (make-pathname-component-logical (pathname-type f))
- :version (make-pathname-component-logical (pathname-version f))))))))
+ (remove-if 'directory-pathname-p
+ (filter-logical-directory-results
+ directory entries
+ #'(lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical (pathname-name f))
+ :type (make-pathname-component-logical (pathname-type f))
+ :version (make-pathname-component-logical (pathname-version f)))))))))
(defun subdirectories (directory)
+ "Given a DIRECTORY pathname designator, return a list of the subdirectories under it."
(let* ((directory (ensure-directory-pathname directory))
#-(or abcl cormanlisp genera xcl)
(wild (merge-pathnames*
:directory (append prefix (make-pathname-component-logical (last dir)))))))))))
(defun collect-sub*directories (directory collectp recursep collector)
+ "Given a DIRECTORY, call-function the COLLECTOR function designator
+on the directory if COLLECTP returns true when CALL-FUNCTION'ed with the directory,
+and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them."
(when (call-function collectp directory)
(call-function collector directory))
(dolist (subdir (subdirectories directory))
(down-components ()))
(assert (eq :absolute (first directory)))
(loop :while up-components :do
- (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
- :name nil :type nil :version nil :defaults p)))
- (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
- :defaults p)
- (ensure-directory-pathname parent)))
- (push (pop up-components) down-components))
- :finally (return p))))))
+ (if-let (parent
+ (ignore-errors
+ (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
+ :name nil :type nil :version nil :defaults p))))
+ (if-let (simplified
+ (ignore-errors
+ (merge-pathnames*
+ (make-pathname* :directory `(:relative ,@down-components)
+ :defaults p)
+ (ensure-directory-pathname parent))))
+ (return simplified)))
+ (push (pop up-components) down-components)
+ :finally (return p))))))
(defun resolve-symlinks (path)
+ "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
#-allegro (truenamize path)
#+allegro
(if (physical-pathname-p path)
Defaults to T.")
(defun resolve-symlinks* (path)
+ "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
(if *resolve-symlinks*
(and path (resolve-symlinks path))
path)))
(defun ensure-pathname
(pathname &key
on-error
- defaults type dot-dot
+ defaults type dot-dot namestring
want-pathname
want-logical want-physical ensure-physical
want-relative want-absolute ensure-absolute ensure-subpath
If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
-If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
-reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
-then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
-and the all the checks and transformations are run.
+If the argument is a STRING, it is first converted to a pathname via
+PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
+depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
+or else by using CALL-FUNCTION on the NAMESTRING argument;
+if :UNIX is specified (or NIL, the default, which specifies the same thing),
+then PARSE-UNIX-NAMESTRING it is called with the keywords
+DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
+the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
+
+The pathname passed or resulting from parsing the string
+is then subjected to all the checks and transformations below are run.
Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
The boolean T is an alias for ERROR.
(etypecase p
((or null pathname))
(string
- (setf p (parse-unix-namestring
- p :defaults defaults :type type :dot-dot dot-dot
- :ensure-directory ensure-directory :want-relative want-relative))))
- (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
- (unless (pathnamep p) (return nil))
+ (setf p (case namestring
+ ((:unix nil)
+ (parse-unix-namestring
+ p :defaults defaults :type type :dot-dot dot-dot
+ :ensure-directory ensure-directory :want-relative want-relative))
+ ((:native)
+ (parse-native-namestring p))
+ ((:lisp)
+ (parse-namestring p))
+ (t
+ (call-function namestring p))))))
+ (etypecase p
+ (pathname)
+ (null
+ (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
+ (return nil)))
(check want-logical (logical-pathname-p p) "Expected a logical pathname")
(check want-physical (physical-pathname-p p) "Expected a physical pathname")
- (transform ensure-physical () (translate-logical-pathname p))
+ (transform ensure-physical () (physicalize-pathname p))
(check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
(check want-relative (relative-pathname-p p) "Expected a relative pathname")
(check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
;;; Pathname defaults
(with-upgradability ()
(defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
+ "Find the actual DEFAULTS to use for pathnames, including
+resolving them with respect to GETCWD if the DEFAULTS were relative"
(or (absolute-pathname-p defaults)
(merge-pathnames* defaults (getcwd))))
(defun call-with-current-directory (dir thunk)
+ "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
+Note that this operation is usually NOT thread-safe."
(if dir
(let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
- (*default-pathname-defaults* dir)
- (cwd (getcwd)))
+ (cwd (getcwd))
+ (*default-pathname-defaults* dir))
(chdir dir)
(unwind-protect
(funcall thunk)
;;; Environment pathnames
(with-upgradability ()
(defun inter-directory-separator ()
+ "What character does the current OS conventionally uses to separate directories?"
(if (os-unix-p) #\: #\;))
(defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
+ "Given a string of pathnames specified in native OS syntax, separate them in a list,
+check constraints and normalize each one as per ENSURE-PATHNAME."
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:collect (apply 'parse-native-namestring namestring constraints)))
(defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
+ "Extract a pathname from a user-configured environment variable, as per native OS,
+check constraints and normalize as per ENSURE-PATHNAME."
;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
(apply 'parse-native-namestring (getenvp x)
:ensure-directory (or ensure-directory want-directory)
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
constraints))
(defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
+ "Extract a list of pathname from a user-configured environment variable, as per native OS,
+check constraints and normalize each one as per ENSURE-PATHNAME."
(apply 'split-native-pathnames-string (getenvp x)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
constraints))
(defun getenv-absolute-directory (x)
+ "Extract an absolute directory pathname from a user-configured environment variable,
+as per native OS"
(getenv-pathname x :want-absolute t :ensure-directory t))
(defun getenv-absolute-directories (x)
+ "Extract a list of absolute directories from a user-configured environment variable,
+as per native OS"
(getenv-pathnames x :want-absolute t :ensure-directory t))
(defun lisp-implementation-directory (&key truename)
+ "Where are the system files of the current installation of the CL implementation?"
(declare (ignorable truename))
#+(or clozure ecl gcl mkcl sbcl)
(let ((dir
dir)))
(defun lisp-implementation-pathname-p (pathname)
+ "Is the PATHNAME under the current installation of the CL implementation?"
;; Other builtin systems are those under the implementation directory
(and (when pathname
(if-let (impdir (lisp-implementation-directory))
;;; Simple filesystem operations
(with-upgradability ()
(defun ensure-all-directories-exist (pathnames)
+ "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
(dolist (pathname pathnames)
(when pathname
- (ensure-directories-exist (translate-logical-pathname pathname)))))
+ (ensure-directories-exist (physicalize-pathname pathname)))))
(defun rename-file-overwriting-target (source target)
- #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
- (posix:copy-file source target :method :rename)
+ "Rename a file, overwriting any previous file with the TARGET name,
+in an atomic way if the implementation allows."
+ #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
+ (progn (funcall 'require "syscalls")
+ (symbol-call :posix :copy-file source target :method :rename))
#-clisp
(rename-file source target
- #+clozure :if-exists #+clozure :rename-and-delete))
+ #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t))
(defun delete-file-if-exists (x)
+ "Delete a file X if it already exists"
(when x (handler-case (delete-file x) (file-error () nil))))
(defun delete-empty-directory (directory-pathname)
#+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
`(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
`(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
- #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
- (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
+ #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
+ #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl)
+ (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera
(defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
"Delete a directory including all its recursive contents, aka rm -rf.
(:recycle :uiop/stream :asdf/stream :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
(:export
- #:*default-stream-element-type* #:*stderr* #:setup-stderr
+ #:*default-stream-element-type*
+ #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*
#:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
#:with-output #:output-string #:with-input
#:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
+ #:null-device-pathname #:call-with-null-input #:with-null-input
+ #:call-with-null-output #:with-null-output
#:finish-outputs #:format! #:safe-format!
#:copy-stream-to-stream #:concatenate-files #:copy-file
#:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
#:slurp-stream-forms #:slurp-stream-form
- #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
+ #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
+ #:read-file-forms #:read-file-form #:safe-read-file-form
#:eval-input #:eval-thunk #:standard-eval-thunk
+ #:println #:writeln
;; Temporary files
#:*temporary-directory* #:temporary-directory #:default-temporary-directory
#:setup-temporary-directory
(in-package :uiop/stream)
(with-upgradability ()
- (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
+ (defvar *default-stream-element-type*
+ (or #+(or abcl cmu cormanlisp scl xcl) 'character
+ #+lispworks 'lw:simple-char
+ :default)
"default element-type for open (depends on the current CL implementation)")
+ (defvar *stdin* *standard-input*
+ "the original standard input stream at startup")
+
+ (defun setup-stdin ()
+ (setf *stdin*
+ #.(or #+clozure 'ccl::*stdin*
+ #+(or cmu scl) 'system:*stdin*
+ #+ecl 'ext::+process-standard-input+
+ #+sbcl 'sb-sys:*stdin*
+ '*standard-input*)))
+
+ (defvar *stdout* *standard-output*
+ "the original standard output stream at startup")
+
+ (defun setup-stdout ()
+ (setf *stdout*
+ #.(or #+clozure 'ccl::*stdout*
+ #+(or cmu scl) 'system:*stdout*
+ #+ecl 'ext::+process-standard-output+
+ #+sbcl 'sb-sys:*stdout*
+ '*standard-output*)))
+
(defvar *stderr* *error-output*
"the original error output stream at startup")
(defun setup-stderr ()
(setf *stderr*
- #+allegro excl::*stderr*
- #+clozure ccl::*stderr*
- #-(or allegro clozure) *error-output*))
- (setup-stderr))
+ #.(or #+allegro 'excl::*stderr*
+ #+clozure 'ccl::*stderr*
+ #+(or cmu scl) 'system:*stderr*
+ #+ecl 'ext::+process-error-output+
+ #+sbcl 'sb-sys:*stderr*
+ '*error-output*)))
+
+ ;; Run them now. In image.lisp, we'll register them to be run at image restart.
+ (setup-stdin) (setup-stdout) (setup-stderr))
;;; Encodings (mostly hooks only; full support requires asdf-encodings)
and falling back to utf-8 or latin1 if nothing is specified.")
(defparameter *utf-8-external-format*
- #+(and asdf-unicode (not clisp)) :utf-8
- #+(and asdf-unicode clisp) charset:utf-8
- #-asdf-unicode :default
+ (if (featurep :asdf-unicode)
+ (or #+clisp charset:utf-8 :utf-8)
+ :default)
"Default :external-format argument to pass to CL:OPEN and also
CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
On modern implementations, this will decode UTF-8 code points as CL characters.
hopefully, if done consistently, that won't affect program behavior too much.")
(defun always-default-encoding (pathname)
+ "Trivial function to use as *encoding-detection-hook*,
+always 'detects' the *default-encoding*"
(declare (ignore pathname))
*default-encoding*)
"Hook for an extension to define a function to automatically detect a file's encoding")
(defun detect-encoding (pathname)
+ "Detects the encoding of a specified file, going through user-configurable hooks"
(if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
(funcall *encoding-detection-hook* pathname)
*default-encoding*))
(defun default-encoding-external-format (encoding)
+ "Default, ignorant, function to transform a character ENCODING as a
+portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
+Load system ASDF-ENCODINGS to hook in a better one."
(case encoding
(:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
(:utf-8 *utf-8-external-format*)
(defvar *encoding-external-format-hook*
#'default-encoding-external-format
- "Hook for an extension to define a mapping between non-default encodings
-and implementation-defined external-format's")
+ "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
+from non-default encodings to and implementation-defined external-format's")
(defun encoding-external-format (encoding)
- (funcall *encoding-external-format-hook* encoding)))
+ "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
+going through all the proper hooks."
+ (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
;;; Safe syntax
(with-upgradability ()
- (defvar *standard-readtable* (copy-readtable nil))
+ (defvar *standard-readtable* (with-standard-io-syntax *readtable*)
+ "The standard readtable, implementing the syntax specified by the CLHS.
+It must never be modified, though only good implementations will even enforce that.")
(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
"Establish safe CL reader options around the evaluation of BODY"
(funcall thunk))))
(defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
+ "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
(with-safe-io-syntax (:package package)
(read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
-
-;;; Output to a stream or string, FORMAT-style
+;;; Output helpers
(with-upgradability ()
- (defun call-with-output (output function)
+ (defun call-with-output-file (pathname thunk
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :error)
+ (if-does-not-exist :create))
+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
+Other keys are accepted but discarded."
+ (with-open-file (s pathname :direction :output
+ :element-type element-type
+ :external-format external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (funcall thunk s)))
+
+ (defmacro with-output-file ((var pathname &rest keys
+ &key element-type external-format if-exists if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-exists if-does-not-exist))
+ `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))
+
+ (defun call-with-output (output function &key keys)
"Calls FUNCTION with an actual stream argument,
behaving like FORMAT with respect to how stream designators are interpreted:
-If OUTPUT is a stream, use it as the stream.
+If OUTPUT is a STREAM, use it as the stream.
If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
-If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
+If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream.
+If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE
+-- this latter as an extension since ASDF 3.1.
Otherwise, signal an error."
(etypecase output
(null
(funcall function output))
(string
(assert (fill-pointer output))
- (with-output-to-string (stream output) (funcall function stream)))))
+ (with-output-to-string (stream output) (funcall function stream)))
+ (pathname
+ (apply 'call-with-output-file output function keys))))
(defmacro with-output ((output-var &optional (value output-var)) &body body)
"Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
;;; Input helpers
(with-upgradability ()
- (defun call-with-input (input function)
- "Calls FUNCTION with an actual stream argument, interpreting
-stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
-If INPUT is a STREAM, use it as the stream.
-If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
-If INPUT is T, use *TERMINAL-IO* as the stream.
-As an extension, if INPUT is a string, use it as a string-input-stream.
-Otherwise, signal an error."
- (etypecase input
- (null (funcall function *standard-input*))
- ((eql t) (funcall function *terminal-io*))
- (stream (funcall function input))
- (string (with-input-from-string (stream input) (funcall function stream)))))
-
- (defmacro with-input ((input-var &optional (value input-var)) &body body)
- "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
-as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
- `(call-with-input ,value #'(lambda (,input-var) ,@body)))
-
(defun call-with-input-file (pathname thunk
&key
(element-type *default-stream-element-type*)
(if-does-not-exist :error))
"Open FILE for input with given recognizes options, call THUNK with the resulting stream.
Other keys are accepted but discarded."
- #+gcl2.6 (declare (ignore external-format))
(with-open-file (s pathname :direction :input
:element-type element-type
- #-gcl2.6 :external-format #-gcl2.6 external-format
+ :external-format external-format
:if-does-not-exist if-does-not-exist)
(funcall thunk s)))
(declare (ignore element-type external-format if-does-not-exist))
`(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
- (defun call-with-output-file (pathname thunk
- &key
- (element-type *default-stream-element-type*)
- (external-format *utf-8-external-format*)
- (if-exists :error)
- (if-does-not-exist :create))
- "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
-Other keys are accepted but discarded."
- #+gcl2.6 (declare (ignore external-format))
- (with-open-file (s pathname :direction :output
- :element-type element-type
- #-gcl2.6 :external-format #-gcl2.6 external-format
- :if-exists if-exists
- :if-does-not-exist if-does-not-exist)
- (funcall thunk s)))
+ (defun call-with-input (input function &key keys)
+ "Calls FUNCTION with an actual stream argument, interpreting
+stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
+and PATHNAME to FILE-STREAM.
+If INPUT is a STREAM, use it as the stream.
+If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
+If INPUT is T, use *TERMINAL-IO* as the stream.
+If INPUT is a STRING, use it as a string-input-stream.
+If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
+-- the latter is an extension since ASDF 3.1.
+Otherwise, signal an error."
+ (etypecase input
+ (null (funcall function *standard-input*))
+ ((eql t) (funcall function *terminal-io*))
+ (stream (funcall function input))
+ (string (with-input-from-string (stream input) (funcall function stream)))
+ (pathname (apply 'call-with-input-file input function keys))))
- (defmacro with-output-file ((var pathname &rest keys
- &key element-type external-format if-exists if-does-not-exist)
+ (defmacro with-input ((input-var &optional (value input-var)) &body body)
+ "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
+as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
+ `(call-with-input ,value #'(lambda (,input-var) ,@body))))
+
+
+;;; Null device
+(with-upgradability ()
+ (defun null-device-pathname ()
+ "Pathname to a bit bucket device that discards any information written to it
+and always returns EOF when read from"
+ (cond
+ ((os-unix-p) #p"/dev/null")
+ ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
+ (t (error "No /dev/null on your OS"))))
+ (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist)
+ "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
+ (declare (ignore element-type external-format if-does-not-exist))
+ (apply 'call-with-input-file (null-device-pathname) fun keys))
+ (defmacro with-null-input ((var &rest keys
+ &key element-type external-format if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-does-not-exist))
+ "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
+Pass keyword arguments to OPEN."
+ `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
+ (defun call-with-null-output (fun
+ &key (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :overwrite)
+ (if-does-not-exist :error))
+ "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
+ (call-with-output-file
+ (null-device-pathname) fun
+ :element-type element-type :external-format external-format
+ :if-exists if-exists :if-does-not-exist if-does-not-exist))
+ (defmacro with-null-output ((var &rest keys
+ &key element-type external-format if-does-not-exist if-exists)
&body body)
+ "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
+Pass keyword arguments to OPEN."
(declare (ignore element-type external-format if-exists if-does-not-exist))
- `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
+ `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
;;; Ensure output buffers are flushed
(with-upgradability ()
Useful for portably flushing I/O before user input or program exit."
;; CCL notably buffers its stream output by default.
(dolist (s (append streams
- (list *stderr* *error-output* *standard-output* *trace-output*
- *debug-io* *terminal-io* *debug-io* *query-io*)))
+ (list *stdout* *stderr* *error-output* *standard-output* *trace-output*
+ *debug-io* *terminal-io* *query-io*)))
(ignore-errors (finish-output s)))
(values))
"Just like format, but call finish-outputs before and after the output."
(finish-outputs stream)
(apply 'format stream format args)
- (finish-output stream))
+ (finish-outputs stream))
(defun safe-format! (stream format &rest args)
+ "Variant of FORMAT that is safe against both
+dangerous syntax configuration and errors while printing."
(with-safe-io-syntax ()
(ignore-errors (apply 'format! stream format args))
(finish-outputs stream)))) ; just in case format failed
(when (< end buffer-size) (return))))))
(defun concatenate-files (inputs output)
+ "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
(with-open-file (o output :element-type '(unsigned-byte 8)
:direction :output :if-exists :rename-and-delete)
(dolist (input inputs)
(copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
(defun copy-file (input output)
+ "Copy contents of the INPUT file to the OUTPUT file"
;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
(concatenate-files (list input) output))
- (defun slurp-stream-string (input &key (element-type 'character))
+ (defun slurp-stream-string (input &key (element-type 'character) stripped)
"Read the contents of the INPUT stream as a string"
- (with-open-stream (input input)
- (with-output-to-string (output)
- (copy-stream-to-stream input output :element-type element-type))))
+ (let ((string
+ (with-open-stream (input input)
+ (with-output-to-string (output)
+ (copy-stream-to-stream input output :element-type element-type)))))
+ (if stripped (stripln string) string)))
(defun slurp-stream-lines (input &key count)
"Read the contents of the INPUT stream as a list of lines, return those lines.
+Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
+from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
+
Read no more than COUNT lines."
(check-type count (or null integer))
(with-open-stream (input input)
(loop :for n :from 0
:for l = (and (or (not count) (< n count))
(read-line input nil nil))
- :while l :collect l)))
+ ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
+ :while l :collect (stripln l))))
(defun slurp-stream-line (input &key (at 0))
"Read the contents of the INPUT stream as a list of lines,
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(apply 'call-with-input-file file 'slurp-stream-lines keys))
+ (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys)
+ "Open input FILE with option KEYS (except AT),
+and read its contents as per SLURP-STREAM-LINE with given AT specifier.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+ (apply 'call-with-input-file file
+ #'(lambda (input) (slurp-stream-line input :at at))
+ (remove-plist-key :at keys)))
+
(defun read-file-forms (file &rest keys &key count &allow-other-keys)
"Open input FILE with option KEYS (except COUNT),
and read its contents as per SLURP-STREAM-FORMS with given COUNT.
#'(lambda (input) (slurp-stream-form input :at at))
(remove-plist-key :at keys)))
+ (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys)
+ "Reads the specified line from the top of a file using a safe standardized syntax.
+Extracts the line using READ-FILE-LINE,
+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
+ (with-safe-io-syntax (:package package)
+ (apply 'read-file-line pathname (remove-plist-key :package keys))))
+
(defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
"Reads the specified form from the top of a file using a safe standardized syntax.
Extracts the form using READ-FILE-FORM,
(let ((*read-eval* t))
(eval-thunk thunk))))))
+(with-upgradability ()
+ (defun println (x &optional (stream *standard-output*))
+ "Variant of PRINC that also calls TERPRI afterwards"
+ (princ x stream) (terpri stream) (finish-output stream) (values))
+
+ (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
+ "Variant of WRITE that also calls TERPRI afterwards"
+ (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
+
;;; Using temporary files
(with-upgradability ()
(defun default-temporary-directory ()
+ "Return a default directory to use for temporary files"
(or
(when (os-unix-p)
(or (getenv-pathname "TMPDIR" :ensure-directory t)
(getenv-pathname "TEMP" :ensure-directory t))
(subpathname (user-homedir-pathname) "tmp/")))
- (defvar *temporary-directory* nil)
+ (defvar *temporary-directory* nil "User-configurable location for temporary files")
(defun temporary-directory ()
+ "Return a directory to use for temporary files"
(or *temporary-directory* (default-temporary-directory)))
(defun setup-temporary-directory ()
+ "Configure a default temporary directory to use."
(setf *temporary-directory* (default-temporary-directory))
- ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
- #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
+ #+gcl (setf system::*tmp-dir* *temporary-directory*))
(defun call-with-temporary-file
(thunk &key
- prefix keep (direction :io)
+ (want-stream-p t) (want-pathname-p t) (direction :io) keep after
+ directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
(element-type *default-stream-element-type*)
- (external-format :default))
- #+gcl2.6 (declare (ignorable external-format))
+ (external-format *utf-8-external-format*))
+ "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
+
+The temporary file's pathname will be based on concatenating
+PREFIX (defaults to \"uiop\"), a random alphanumeric string,
+and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
+and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
+within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
+
+The file will be open with specified DIRECTION (defaults to :IO),
+ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
+EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
+If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
+with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
+and stream with be closed after the THUNK exits (either normally or abnormally).
+If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
+THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
+Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
+If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
+Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
+ #+xcl (declare (ignorable typep))
(check-type direction (member :output :io))
+ (assert (or want-stream-p want-pathname-p))
(loop
- :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
- :for counter :from (random (ash 1 32))
- :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
+ :with prefix = (native-namestring
+ (ensure-absolute-pathname
+ (or prefix "tmp")
+ (or (ensure-pathname directory :namestring :native :ensure-directory t)
+ #'temporary-directory)))
+ :with results = ()
+ :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
+ :for pathname = (parse-native-namestring
+ (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type))
+ :for okp = nil :do
;; TODO: on Unix, do something about umask
;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
- ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
- (with-open-file (stream pathname
- :direction direction
- :element-type element-type
- #-gcl2.6 :external-format #-gcl2.6 external-format
- :if-exists nil :if-does-not-exist :create)
- (when stream
- (return
- (if keep
- (funcall thunk stream pathname)
- (unwind-protect
- (funcall thunk stream pathname)
- (ignore-errors (delete-file pathname)))))))))
+ ;; TODO: on Unix, use CFFI and mkstemp --
+ ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
+ ;; Can we at least design some hook?
+ (unwind-protect
+ (progn
+ (with-open-file (stream pathname
+ :direction direction
+ :element-type element-type
+ :external-format external-format
+ :if-exists nil :if-does-not-exist :create)
+ (when stream
+ (setf okp pathname)
+ (when want-stream-p
+ (setf results
+ (multiple-value-list
+ (if want-pathname-p
+ (funcall thunk stream pathname)
+ (funcall thunk stream)))))))
+ (when okp
+ (unless want-stream-p
+ (setf results (multiple-value-list (call-function thunk pathname))))
+ (when after
+ (setf results (multiple-value-list (call-function after pathname))))
+ (return (apply 'values results))))
+ (when (and okp (not (call-function keep)))
+ (ignore-errors (delete-file-if-exists okp))))))
(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
(pathname (gensym "PATHNAME") pathnamep)
- prefix keep direction element-type external-format)
+ directory prefix suffix type
+ keep direction element-type external-format)
&body body)
"Evaluate BODY where the symbols specified by keyword arguments
-STREAM and PATHNAME are bound corresponding to a newly created temporary file
-ready for I/O. Unless KEEP is specified, delete the file afterwards."
+STREAM and PATHNAME (if respectively specified) are bound corresponding
+to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
+At least one of STREAM or PATHNAME must be specified.
+If the STREAM is not specified, it will be closed before the BODY is evaluated.
+If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
+separates forms run before and after the stream is closed.
+The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
+Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
(check-type stream symbol)
(check-type pathname symbol)
- `(flet ((think (,stream ,pathname)
- ,@(unless pathnamep `((declare (ignore ,pathname))))
- ,@(unless streamp `((when ,stream (close ,stream))))
- ,@body))
- #-gcl (declare (dynamic-extent #'think))
- (call-with-temporary-file
- #'think
- ,@(when direction `(:direction ,direction))
- ,@(when prefix `(:prefix ,prefix))
- ,@(when keep `(:keep ,keep))
- ,@(when element-type `(:element-type ,element-type))
- ,@(when external-format `(:external-format external-format)))))
+ (assert (or streamp pathnamep))
+ (let* ((afterp (position :close-stream body))
+ (before (if afterp (subseq body 0 afterp) body))
+ (after (when afterp (subseq body (1+ afterp))))
+ (beforef (gensym "BEFORE"))
+ (afterf (gensym "AFTER")))
+ `(flet (,@(when before
+ `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before)))
+ ,@(when after
+ (assert pathnamep)
+ `((,afterf (,pathname) ,@after))))
+ #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
+ (call-with-temporary-file
+ ,(when before `#',beforef)
+ :want-stream-p ,streamp
+ :want-pathname-p ,pathnamep
+ ,@(when direction `(:direction ,direction))
+ ,@(when directory `(:directory ,directory))
+ ,@(when prefix `(:prefix ,prefix))
+ ,@(when suffix `(:suffix ,suffix))
+ ,@(when type `(:type ,type))
+ ,@(when keep `(:keep ,keep))
+ ,@(when after `(:after #',afterf))
+ ,@(when element-type `(:element-type ,element-type))
+ ,@(when external-format `(:external-format ,external-format))))))
+
+ (defun get-temporary-file (&key directory prefix suffix type)
+ (with-temporary-file (:pathname pn :keep t
+ :directory directory :prefix prefix :suffix suffix :type type)
+ pn))
;; Temporary pathnames in simple cases where no contention is assumed
- (defun add-pathname-suffix (pathname suffix)
- (make-pathname :name (strcat (pathname-name pathname) suffix)
- :defaults pathname))
+ (defun add-pathname-suffix (pathname suffix &rest keys)
+ "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
+Further KEYS can be passed to MAKE-PATHNAME."
+ (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
+ :defaults pathname keys))
(defun tmpize-pathname (x)
- (add-pathname-suffix x "-ASDF-TMP"))
+ "Return a new pathname modified from X by adding a trivial deterministic suffix"
+ (add-pathname-suffix x "-TMP"))
(defun call-with-staging-pathname (pathname fun)
- "Calls fun with a staging pathname, and atomically
-renames the staging pathname to the pathname in the end.
-Note: this protects only against failure of the program,
-not against concurrent attempts.
-For the latter case, we ought pick random suffix and atomically open it."
+ "Calls FUN with a staging pathname, and atomically
+renames the staging pathname to the PATHNAME in the end.
+NB: this protects only against failure of the program, not against concurrent attempts.
+For the latter case, we ought pick a random suffix and atomically open it."
(let* ((pathname (pathname pathname))
(staging (tmpize-pathname pathname)))
(unwind-protect
(delete-file-if-exists staging))))
(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
+ "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
;;;; -------------------------------------------------------------------------
(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
(:export
#:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
- #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
+ #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
#:*lisp-interaction*
#:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
#:call-with-fatal-condition-handler #:with-fatal-condition-handler
#+cormanlisp (win32:exitprocess code)
#+(or cmu scl) (unix:unix-exit code)
#+ecl (si:quit code)
- #+gcl (lisp:quit code)
+ #+gcl (system:quit code)
#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
- #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
+ #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code)
#+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
(quit (find-symbol* :quit :sb-ext nil)))
"Die in error with some error message"
(with-safe-io-syntax ()
(ignore-errors
- (fresh-line *stderr*)
- (apply #'format *stderr* format arguments)
- (format! *stderr* "~&")))
+ (format! *stderr* "~&~?~&" format arguments)))
(quit code))
- (defun raw-print-backtrace (&key (stream *debug-io*) count)
+ (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
"Print a backtrace, directly accessing the implementation"
- (declare (ignorable stream count))
+ (declare (ignorable stream count condition))
#+abcl
- (let ((*debug-io* stream)) (top-level::backtrace-command count))
+ (loop :for i :from 0
+ :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
+ (safe-format! stream "~&~D: ~A~%" i frame))
#+allegro
(let ((*terminal-io* stream)
(*standard-output* stream)
(tpl:*zoom-print-length* *print-length*))
(tpl:do-command "zoom"
:from-read-eval-print-loop nil
- :count t
+ :count (or count t)
:all t))
#+clisp
(system::print-backtrace :out stream :limit count)
#+(or clozure mcl)
(let ((*debug-io* stream))
- (ccl:print-call-history :count count :start-frame-number 1)
+ #+clozure (ccl:print-call-history :count count :start-frame-number 1)
+ #+mcl (ccl:print-call-history :detailed-p nil)
(finish-output stream))
#+(or cmu scl)
(let ((debug:*debug-print-level* *print-level*)
(debug:*debug-print-length* *print-length*))
- (debug:backtrace most-positive-fixnum stream))
- #+ecl
- (si::tpl-backtrace)
+ (debug:backtrace (or count most-positive-fixnum) stream))
+ #+(or ecl mkcl)
+ (let* ((top (si:ihs-top))
+ (repeats (if count (min top count) top))
+ (backtrace (loop :for ihs :from 0 :below top
+ :collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)))))
+ (loop :for i :from 0 :below repeats
+ :for frame :in (nreverse backtrace) :do
+ (safe-format! stream "~&~D: ~S~%" i frame)))
+ #+gcl
+ (let ((*debug-io* stream))
+ (ignore-errors
+ (with-safe-io-syntax ()
+ (if condition
+ (conditions::condition-backtrace condition)
+ (system::simple-backtrace)))))
#+lispworks
(let ((dbg::*debugger-stack*
(dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
#+sbcl
(sb-debug:backtrace
#.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
- stream))
-
- (defun print-backtrace (&rest keys &key stream count)
- (declare (ignore stream count))
+ stream)
+ #+xcl
+ (loop :for i :from 0 :below (or count most-positive-fixnum)
+ :for frame :in (extensions:backtrace-as-list) :do
+ (safe-format! stream "~&~D: ~S~%" i frame)))
+
+ (defun print-backtrace (&rest keys &key stream count condition)
+ "Print a backtrace"
+ (declare (ignore stream count condition))
(with-safe-io-syntax (:package :cl)
(let ((*print-readably* nil)
(*print-circle* t)
(ignore-errors (apply 'raw-print-backtrace keys)))))
(defun print-condition-backtrace (condition &key (stream *stderr*) count)
+ "Print a condition after a backtrace triggered by that condition"
;; We print the condition *after* the backtrace,
;; for the sake of who sees the backtrace at a terminal.
;; It is up to the caller to print the condition *before*, with some context.
- (print-backtrace :stream stream :count count)
+ (print-backtrace :stream stream :count count :condition condition)
(when condition
(safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
condition)))
(defun fatal-condition-p (condition)
+ "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
(match-any-condition-p condition *fatal-conditions*))
(defun handle-fatal-condition (condition)
- "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
+ "Handle a fatal CONDITION:
+depending on whether *LISP-INTERACTION* is set, enter debugger or die"
(cond
(*lisp-interaction*
(invoke-debugger condition))
(die 99 "~A" condition))))
(defun call-with-fatal-condition-handler (thunk)
+ "Call THUNK in a context where fatal conditions are appropriately handled"
(handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
(funcall thunk)))
(defmacro with-fatal-condition-handler ((&optional) &body body)
+ "Execute BODY in a context where fatal conditions are appropriately handled"
`(call-with-fatal-condition-handler #'(lambda () ,@body)))
(defun shell-boolean-exit (x)
;;; Using image hooks
(with-upgradability ()
(defun register-image-restore-hook (hook &optional (call-now-p t))
+ "Regiter a hook function to be run when restoring a dumped image"
(register-hook-function '*image-restore-hook* hook call-now-p))
(defun register-image-dump-hook (hook &optional (call-now-p nil))
+ "Register a the hook function to be run before to dump an image"
(register-hook-function '*image-dump-hook* hook call-now-p))
(defun call-image-restore-hook ()
+ "Call the hook functions registered to be run when restoring a dumped image"
(call-functions (reverse *image-restore-hook*)))
(defun call-image-dump-hook ()
+ "Call the hook functions registered to be run before to dump an image"
(call-functions *image-dump-hook*)))
#+(or cmu scl) extensions:*command-line-strings*
#+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
#+gcl si:*command-args*
- #+genera nil
+ #+(or genera mcl) nil
#+lispworks sys:*line-arguments-list*
+ #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
#+sbcl sb-ext:*posix-argv*
#+xcl system:*argv*
- #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "raw-command-line-arguments not implemented yet"))
(defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
"Extract user arguments from command-line invocation of current process.
Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image."
- #+abcl arguments
- #-abcl
- (let* (#-(or sbcl allegro)
- (arguments
- (if (eq *image-dumped-p* :executable)
- arguments
- (member "--" arguments :test 'string-equal))))
+ (block nil
+ #+abcl (return arguments)
+ ;; SBCL and Allegro already separate user arguments from implementation arguments.
+ #-(or sbcl allegro)
+ (unless (eq *image-dumped-p* :executable)
+ ;; LispWorks command-line processing isn't transparent to the user
+ ;; unless you create a standalone executable; in that case,
+ ;; we rely on cl-launch or some other script to set the arguments for us.
+ #+lispworks (return *command-line-arguments*)
+ ;; On other implementations, on non-standalone executables,
+ ;; we trust cl-launch or whichever script starts the program
+ ;; to use -- as a delimiter between implementation arguments and user arguments.
+ #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
(rest arguments)))
+ (defun argv0 ()
+ "On supported implementations (most that matter), or when invoked by a proper wrapper script,
+return a string that for the name with which the program was invoked, i.e. argv[0] in C.
+Otherwise, return NIL."
+ (cond
+ ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
+ ;; NB: not currently available on ABCL, Corman, Genera, MCL
+ (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
+ (first (raw-command-line-arguments))
+ #+ecl (si:argv 0) #+mkcl (mkcl:argv 0)))
+ (t ;; argv[0] is the name of the interpreter.
+ ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
+ (getenvp "__CL_ARGV0"))))
+
(defun setup-command-line-arguments ()
(setf *command-line-arguments* (command-line-arguments)))
(defun restore-image (&key
- ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
- ((:restore-hook *image-restore-hook*) *image-restore-hook*)
- ((:prelude *image-prelude*) *image-prelude*)
- ((:entry-point *image-entry-point*) *image-entry-point*)
+ (lisp-interaction *lisp-interaction*)
+ (restore-hook *image-restore-hook*)
+ (prelude *image-prelude*)
+ (entry-point *image-entry-point*)
(if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
+ "From a freshly restarted Lisp image, restore the saved Lisp environment
+by setting appropriate variables, running various hooks, and calling any specified entry point.
+
+If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
+call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
+immediately to the surrounding restore process if allowed to continue.
+
+Then, comes the restore process itself:
+First, call each function in the RESTORE-HOOK,
+in the order they were registered with REGISTER-RESTORE-HOOK.
+Second, evaluate the prelude, which is often Lisp text that is read,
+as per EVAL-INPUT.
+Third, call the ENTRY-POINT function, if any is specified, with no argument.
+
+The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
+any unhandled error leads to a backtrace and an exit with an error status.
+If LISP-INTERACTION is NIL, the process also exits when no error occurs:
+if neither restart nor entry function is provided, the program will exit with status 0 (success);
+if a function was provided, the program will exit after the function returns (if it returns),
+with status 0 if and only if the primary return value of result is generalized boolean true,
+and with status 1 if this value is NIL.
+
+If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
+of the function will be returned rather than interpreted as a boolean designating an exit code."
(when *image-restored-p*
(if if-already-restored
- (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
+ (call-function if-already-restored "Image already ~:[being ~;~]restored"
+ (eq *image-restored-p* t))
(return-from restore-image)))
(with-fatal-condition-handler ()
+ (setf *lisp-interaction* lisp-interaction)
+ (setf *image-restore-hook* restore-hook)
+ (setf *image-prelude* prelude)
(setf *image-restored-p* :in-progress)
(call-image-restore-hook)
- (standard-eval-thunk *image-prelude*)
+ (standard-eval-thunk prelude)
(setf *image-restored-p* t)
(let ((results (multiple-value-list
- (if *image-entry-point*
- (call-function *image-entry-point*)
+ (if entry-point
+ (call-function entry-point)
t))))
- (if *lisp-interaction*
+ (if lisp-interaction
(apply 'values results)
(shell-boolean-exit (first results)))))))
(with-upgradability ()
(defun dump-image (filename &key output-name executable
- ((:postlude *image-postlude*) *image-postlude*)
- ((:dump-hook *image-dump-hook*) *image-dump-hook*)
- #+clozure prepend-symbols #+clozure (purify t))
+ (postlude *image-postlude*)
+ (dump-hook *image-dump-hook*)
+ #+clozure prepend-symbols #+clozure (purify t)
+ #+sbcl compression
+ #+(and sbcl windows) application-type)
+ "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
+
+First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
+ the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK.
+
+If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
+
+Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
+or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
+ ;; Note: at least SBCL saves only global values of variables in the heap image,
+ ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
(declare (ignorable filename output-name executable))
(setf *image-dumped-p* (if executable :executable t))
(setf *image-restored-p* :in-regress)
+ (setf *image-postlude* postlude)
(standard-eval-thunk *image-postlude*)
+ (setf *image-dump-hook* dump-hook)
(call-image-dump-hook)
(setf *image-restored-p* nil)
#-(or clisp clozure cmu lispworks sbcl scl)
(ext:gc :full t)
(setf ext:*batch-mode* nil)
(setf ext::*gc-run-time* 0)
- (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
- (when executable '(:init-function restore-image :process-command-line nil))))
+ (apply 'ext:save-lisp filename
+ #+cmu :executable #+cmu t
+ (when executable '(:init-function restore-image :process-command-line nil))))
#+gcl
(progn
(si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
(setf sb-ext::*gc-run-time* 0)
(apply 'sb-ext:save-lisp-and-die filename
:executable t ;--- always include the runtime that goes with the core
- (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
+ (append
+ (when compression (list :compression compression))
+ ;;--- only save runtime-options for standalone executables
+ (when executable (list :toplevel #'restore-image :save-runtime-options t))
+ #+(and sbcl windows) ;; passing :application-type :gui will disable the console window.
+ ;; the default is :console - only works with SBCL 1.1.15 or later.
+ (when application-type (list :application-type application-type)))))
#-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
(error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
'dump-image filename (nth-value 1 (implementation-type))))
- (defun create-image (destination object-files
- &key kind output-name prologue-code epilogue-code
+ (defun create-image (destination lisp-object-files
+ &key kind output-name prologue-code epilogue-code extra-object-files
(prelude () preludep) (postlude () postludep)
- (entry-point () entry-point-p) build-args)
- (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
- prelude preludep postlude postludep entry-point entry-point-p build-args))
+ (entry-point () entry-point-p) build-args no-uiop)
+ (declare (ignorable destination lisp-object-files extra-object-files kind output-name
+ prologue-code epilogue-code prelude preludep postlude postludep
+ entry-point entry-point-p build-args no-uiop))
+ "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
;; Is it meaningful to run these in the current environment?
;; only if we also track the object files that constitute the "current" image,
;; and otherwise simulate dump-image, including quitting at the end.
- #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
- #+ecl
- (progn
- (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
- (apply 'c::builder
- kind (pathname destination)
- :lisp-files object-files
- :init-name (c::compute-init-name (or output-name destination) :kind kind)
- :prologue-code prologue-code
- :epilogue-code
- `(progn
- ,epilogue-code
- ,@(when (eq kind :program)
- `((setf *image-dumped-p* :executable)
- (restore-image ;; default behavior would be (si::top-level)
- ,@(when preludep `(:prelude ',prelude))
- ,@(when entry-point-p `(:entry-point ',entry-point))))))
- build-args))))
+ #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
+ #+(or ecl mkcl)
+ (let ((epilogue-code
+ (if no-uiop
+ epilogue-code
+ (let ((forms
+ (append
+ (when epilogue-code `(,epilogue-code))
+ (when postludep `((setf *image-postlude* ',postlude)))
+ (when preludep `((setf *image-prelude* ',prelude)))
+ (when entry-point-p `((setf *image-entry-point* ',entry-point)))
+ (case kind
+ ((:image)
+ (setf kind :program) ;; to ECL, it's just another program.
+ `((setf *image-dumped-p* t)
+ (si::top-level #+ecl t) (quit)))
+ ((:program)
+ `((setf *image-dumped-p* :executable)
+ (shell-boolean-exit
+ (restore-image))))))))
+ (when forms `(progn ,@forms))))))
+ #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
+ (apply #+ecl 'c::builder #+ecl kind
+ #+mkcl (ecase kind
+ ((:dll) 'compiler::build-shared-library)
+ ((:lib :static-library) 'compiler::build-static-library)
+ ((:fasl) 'compiler::build-bundle)
+ ((:program) 'compiler::build-program))
+ (pathname destination)
+ #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
+ #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
+ (append
+ (when prologue-code `(:prologue-code ,prologue-code))
+ (when epilogue-code `(:epilogue-code ,epilogue-code))
+ #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
+ build-args)))))
;;; Some universal image restore hooks
(with-upgradability ()
(map () 'register-image-restore-hook
- '(setup-temporary-directory setup-stderr setup-command-line-arguments
+ '(setup-stdin setup-stdout setup-stderr
+ setup-command-line-arguments setup-temporary-directory
#+abcl detect-os)))
;;;; -------------------------------------------------------------------------
;;;; run-program initially from xcvb-driver.
(uiop/package:define-package :uiop/run-program
(:nicknames :asdf/run-program)
(:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
- (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility
+ :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
(:export
;;; Escaping the command invocation madness
#:easy-sh-character-p #:escape-sh-token #:escape-sh-command
#:escape-token #:escape-command
;;; run-program
- #:slurp-input-stream
+ #:slurp-input-stream #:vomit-output-stream
#:run-program
#:subprocess-error
#:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
(when quote (princ #\" s)))
(defun easy-sh-character-p (x)
+ "Is X an \"easy\" character that does not require quoting by the shell?"
(or (alphanumericp x) (find x "+-_.,%@:/")))
(defun escape-sh-token (token &optional s)
"Escape a string TOKEN within double-quotes if needed
for use within a POSIX Bourne shell, outputing to S."
- (escape-token token :stream s :quote #\" :good-chars
- #'easy-sh-character-p
+ (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
:escaper 'escape-sh-token-within-double-quotes))
(defun escape-shell-token (token &optional s)
+ "Escape a token for the current operating system shell"
(cond
((os-unix-p) (escape-sh-token token s))
((os-windows-p) (escape-windows-token token s))))
;;;; Slurping a stream, typically the output of another program
(with-upgradability ()
- (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
-
- #-(or gcl2.6 genera)
- (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
+ (defun call-stream-processor (fun processor stream)
+ "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
+a PROCESSOR specification which is either an atom or a list specifying
+a processor an keyword arguments, call the specified processor with
+the given STREAM as input"
+ (if (consp processor)
+ (apply fun (first processor) stream (rest processor))
+ (funcall fun processor stream)))
+
+ (defgeneric slurp-input-stream (processor input-stream &key)
+ (:documentation
+ "SLURP-INPUT-STREAM is a generic function with two positional arguments
+PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
+the contents of the INPUT-STREAM and processes them according to a method
+specified by PROCESSOR.
+
+Built-in methods include the following:
+* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
+* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
+ INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
+ \(APPLY x <stream> y\)
+* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
+ per copy-stream-to-stream, with appropriate keyword arguments.
+* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
+ are returned as a string, as per SLURP-STREAM-STRING.
+* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
+* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
+* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
+* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
+* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
+
+Programmers are encouraged to define their own methods for this generic function."))
+
+ #-genera
+ (defmethod slurp-input-stream ((function function) input-stream &key)
(funcall function input-stream))
- (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
- (apply (first list) (cons input-stream (rest list))))
+ (defmethod slurp-input-stream ((list cons) input-stream &key)
+ (apply (first list) input-stream (rest list)))
- #-(or gcl2.6 genera)
+ #-genera
(defmethod slurp-input-stream ((output-stream stream) input-stream
- &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
+ &key linewise prefix (element-type 'character) buffer-size)
(copy-stream-to-stream
input-stream output-stream
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
- (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
- (declare (ignorable x))
- (slurp-stream-string stream))
+ (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
+ (slurp-stream-string stream :stripped stripped))
- (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
- (declare (ignorable x))
- (slurp-stream-string stream))
+ (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
+ (slurp-stream-string stream :stripped stripped))
- (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
- (declare (ignorable x))
+ (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
(slurp-stream-lines stream :count count))
- (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
- (declare (ignorable x))
+ (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
(slurp-stream-line stream :at at))
- (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
- (declare (ignorable x))
+ (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
(slurp-stream-forms stream :count count))
- (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
- (declare (ignorable x))
+ (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
(slurp-stream-form stream :at at))
(defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
- (declare (ignorable x))
(apply 'slurp-input-stream *standard-output* stream keys))
+ (defmethod slurp-input-stream ((x null) (stream t) &key)
+ nil)
+
(defmethod slurp-input-stream ((pathname pathname) input
&key
(element-type *default-stream-element-type*)
:element-type element-type :buffer-size buffer-size :linewise linewise)))
(defmethod slurp-input-stream (x stream
- &key linewise prefix (element-type 'character) buffer-size
- &allow-other-keys)
+ &key linewise prefix (element-type 'character) buffer-size)
(declare (ignorable stream linewise prefix element-type buffer-size))
(cond
- #+(or gcl2.6 genera)
+ #+genera
((functionp x) (funcall x stream))
- #+(or gcl2.6 genera)
+ #+genera
((output-stream-p x)
(copy-stream-to-stream
- input-stream output-stream
+ stream x
:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
(t
(error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
-;;;; ----- Running an external program -----
-;;; Simple variant of run-program with no input, and capturing output
-;;; On some implementations, may output to a temporary file...
(with-upgradability ()
- (define-condition subprocess-error (error)
- ((code :initform nil :initarg :code :reader subprocess-error-code)
- (command :initform nil :initarg :command :reader subprocess-error-command)
- (process :initform nil :initarg :process :reader subprocess-error-process))
- (:report (lambda (condition stream)
- (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
- (subprocess-error-process condition)
- (subprocess-error-command condition)
- (subprocess-error-code condition)))))
-
- (defun run-program (command
- &key output ignore-error-status force-shell
- (element-type *default-stream-element-type*)
- (external-format :default)
- &allow-other-keys)
- "Run program specified by COMMAND,
-either a list of strings specifying a program and list of arguments,
-or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
+ (defgeneric vomit-output-stream (processor output-stream &key)
+ (:documentation
+ "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
+PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
+some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
+
+Built-in methods include the following:
+* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
+* if PROCESSOR is a list, its first element should be a function.
+ It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
+ That is (x . y) will be treated as \(APPLY x <stream> y\)
+* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
+ per copy-stream-to-stream, with appropriate keyword arguments.
+* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
+* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
+
+Programmers are encouraged to define their own methods for this generic function."))
+
+ #-genera
+ (defmethod vomit-output-stream ((function function) output-stream &key)
+ (funcall function output-stream))
+
+ (defmethod vomit-output-stream ((list cons) output-stream &key)
+ (apply (first list) output-stream (rest list)))
+
+ #-genera
+ (defmethod vomit-output-stream ((input-stream stream) output-stream
+ &key linewise prefix (element-type 'character) buffer-size)
+ (copy-stream-to-stream
+ input-stream output-stream
+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
-Always call a shell (rather than directly execute the command)
-if FORCE-SHELL is specified.
+ (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
+ (princ x stream)
+ (when fresh-line (fresh-line stream))
+ (when terpri (terpri stream))
+ (values))
-Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
-unless IGNORE-ERROR-STATUS is specified.
+ (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
+ (apply 'vomit-output-stream *standard-input* stream keys))
-If OUTPUT is either NIL or :INTERACTIVE, then
-return the exit status code of the process that was called.
-if it was NIL, the output is discarded;
-if it was :INTERACTIVE, the output and the input are inherited from the current process.
-
-Otherwise, the output will be processed by SLURP-INPUT-STREAM,
-using OUTPUT as the first argument, and return whatever it returns,
-e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
-Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
- ;; TODO: specially recognize :output pathname ?
- (declare (ignorable ignore-error-status element-type external-format))
- #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
- (error "RUN-PROGRAM not implemented for this Lisp")
- (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
- (run-program (command &key pipe interactive)
- "runs the specified command (a list of program and arguments).
- If using a pipe, returns two values: process and stream
- If not using a pipe, returns one values: the process result;
- also, inherits the output stream."
- ;; NB: these implementations have unix vs windows set at compile-time.
- (assert (not (and pipe interactive)))
- (let* ((wait (not pipe))
- #-(and clisp os-windows)
- (command
- (etypecase command
- #+os-unix (string `("/bin/sh" "-c" ,command))
- #+os-unix (list command)
- #+os-windows
- (string
- ;; NB: We do NOT add cmd /c here. You might want to.
- #+allegro command
- ;; On ClozureCL for Windows, we assume you are using
- ;; r15398 or later in 1.9 or later,
- ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
- #+clozure (cons "cmd" (strcat "/c " command))
- ;; NB: On other Windows implementations, this is utterly bogus
- ;; except in the most trivial cases where no quoting is needed.
- ;; Use at your own risk.
- #-(or allegro clozure) (list "cmd" "/c" command))
- #+os-windows
- (list
- #+(or allegro clozure) (escape-windows-command command)
- #-(or allegro clozure) command)))
- #+(and clozure os-windows) (command (list command))
- (process*
- (multiple-value-list
- #+allegro
- (excl:run-shell-command
- #+os-unix (coerce (cons (first command) command) 'vector)
- #+os-windows command
- :input interactive :output (or (and pipe :stream) interactive) :wait wait
- #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
- #+clisp
- (flet ((run (f &rest args)
- (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
- ,(if pipe :stream :terminal)))))
- (etypecase command
- #+os-windows (run 'ext:run-shell-command command)
- (list (run 'ext:run-program (car command)
- :arguments (cdr command)))))
- #+lispworks
- (system:run-shell-command
- (cons "/usr/bin/env" command) ; lispworks wants a full path.
- :input interactive :output (or (and pipe :stream) interactive)
- :wait wait :save-exit-status (and pipe t))
- #+(or clozure cmu ecl sbcl scl)
- (#+(or cmu ecl scl) ext:run-program
- #+clozure ccl:run-program
- #+sbcl sb-ext:run-program
- (car command) (cdr command)
- :input interactive :wait wait
- :output (if pipe :stream t)
- . #.(append
- #+(or clozure cmu ecl sbcl scl) '(:error t)
- ;; note: :external-format requires a recent SBCL
- #+sbcl '(:search t :external-format external-format)))))
- (process
- #+allegro (if pipe (third process*) (first process*))
- #+ecl (third process*)
- #-(or allegro ecl) (first process*))
- (stream
- (when pipe
- #+(or allegro lispworks ecl) (first process*)
- #+clisp (first process*)
- #+clozure (ccl::external-process-output process)
- #+(or cmu scl) (ext:process-output process)
- #+sbcl (sb-ext:process-output process))))
- (values process stream)))
- #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
- (process-result (process pipe)
- (declare (ignorable pipe))
- ;; 1- wait
- #+(and clozure os-unix) (ccl::external-process-wait process)
- #+(or cmu scl) (ext:process-wait process)
- #+(and ecl os-unix) (ext:external-process-wait process)
- #+sbcl (sb-ext:process-wait process)
- ;; 2- extract result
- #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
- #+clisp process
- #+clozure (nth-value 1 (ccl:external-process-status process))
- #+(or cmu scl) (ext:process-exit-code process)
- #+ecl (nth-value 1 (ext:external-process-status process))
- #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
- #+sbcl (sb-ext:process-exit-code process))
- (check-result (exit-code process)
- #+clisp
- (setf exit-code
- (typecase exit-code (integer exit-code) (null 0) (t -1)))
- (unless (or ignore-error-status
- (equal exit-code 0))
- (error 'subprocess-error :command command :code exit-code :process process))
- exit-code)
- (use-run-program ()
- #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
- (let* ((interactive (eq output :interactive))
- (pipe (and output (not interactive))))
- (multiple-value-bind (process stream)
- (run-program command :pipe pipe :interactive interactive)
- (if (and output (not interactive))
- (unwind-protect
- (slurp-input-stream output stream)
- (when stream (close stream))
- (check-result (process-result process pipe) process))
- (unwind-protect
- (check-result
- #+(or allegro lispworks) ; when not capturing, returns the exit code!
- process
- #-(or allegro lispworks) (process-result process pipe)
- process))))))
- (system-command (command)
- (etypecase command
- (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
- (list (escape-shell-command
- (if (os-unix-p) (cons "exec" command) command)))))
- (redirected-system-command (command out)
- (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
- (system-command command) (native-namestring out)))
- (system (command &key interactive)
- (declare (ignorable interactive))
- #+(or abcl xcl) (ext:run-shell-command command)
- #+allegro
- (excl:run-shell-command
- command :input interactive :output interactive :wait t
- #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
- #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
- (process-result (run-program command :pipe nil :interactive interactive) nil)
- #+ecl (ext:system command)
- #+cormanlisp (win32:system command)
- #+gcl (lisp:system command)
- #+(and lispworks os-windows)
- (system:call-system-showing-output
- command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
- #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
- #+mkcl (nth-value 2
- (mkcl:run-program #+windows command #+windows ()
- #-windows "/bin/sh" (list "-c" command)
- :input nil :output nil)))
- (call-system (command-string &key interactive)
- (check-result (system command-string :interactive interactive) nil))
- (use-system ()
- (let ((interactive (eq output :interactive)))
- (if (and output (not interactive))
- (with-temporary-file (:pathname tmp :direction :output)
- (call-system (redirected-system-command command tmp))
- (with-open-file (stream tmp
- :direction :input
- :if-does-not-exist :error
- :element-type element-type
- #-gcl2.6 :external-format #-gcl2.6 external-format)
- (slurp-input-stream output stream)))
- (call-system (system-command command) :interactive interactive)))))
- (if (and (not force-shell)
- #+(or clisp ecl) ignore-error-status
- #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
- (use-run-program)
- (use-system)))))
+ (defmethod vomit-output-stream ((x null) (stream t) &key)
+ (values))
-;;;; -------------------------------------------------------------------------
-;;;; Support to build (compile and load) Lisp files
+ (defmethod vomit-output-stream ((pathname pathname) input
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :rename-and-delete)
+ (if-does-not-exist :create)
+ buffer-size
+ linewise)
+ (with-output-file (output pathname
+ :element-type element-type
+ :external-format external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (copy-stream-to-stream
+ input output
+ :element-type element-type :buffer-size buffer-size :linewise linewise)))
+
+ (defmethod vomit-output-stream (x stream
+ &key linewise prefix (element-type 'character) buffer-size)
+ (declare (ignorable stream linewise prefix element-type buffer-size))
+ (cond
+ #+genera
+ ((functionp x) (funcall x stream))
+ #+genera
+ ((input-stream-p x)
+ (copy-stream-to-stream
+ x stream
+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
+ (t
+ (error "Invalid ~S source ~S" 'vomit-output-stream x)))))
+
+
+;;;; ----- Running an external program -----
+;;; Simple variant of run-program with no input, and capturing output
+;;; On some implementations, may output to a temporary file...
+(with-upgradability ()
+ (define-condition subprocess-error (error)
+ ((code :initform nil :initarg :code :reader subprocess-error-code)
+ (command :initform nil :initarg :command :reader subprocess-error-command)
+ (process :initform nil :initarg :process :reader subprocess-error-process))
+ (:report (lambda (condition stream)
+ (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
+ (subprocess-error-process condition)
+ (subprocess-error-command condition)
+ (subprocess-error-code condition)))))
+
+ ;;; Internal helpers for run-program
+ (defun %normalize-command (command)
+ "Given a COMMAND as a list or string, transform it in a format suitable
+for the implementation's underlying run-program function"
+ (etypecase command
+ #+os-unix (string `("/bin/sh" "-c" ,command))
+ #+os-unix (list command)
+ #+os-windows
+ (string
+ #+mkcl (list "cmd" '#:/c command)
+ ;; NB: We do NOT add cmd /c here. You might want to.
+ #+(or allegro clisp) command
+ ;; On ClozureCL for Windows, we assume you are using
+ ;; r15398 or later in 1.9 or later,
+ ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
+ #+clozure (cons "cmd" (strcat "/c " command))
+ ;; NB: On other Windows implementations, this is utterly bogus
+ ;; except in the most trivial cases where no quoting is needed.
+ ;; Use at your own risk.
+ #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command))
+ #+os-windows
+ (list
+ #+allegro (escape-windows-command command)
+ #-allegro command)))
+
+ (defun %active-io-specifier-p (specifier)
+ "Determines whether a run-program I/O specifier requires Lisp-side processing
+via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
+or whether it's already taken care of by the implementation's underlying run-program."
+ (not (typep specifier '(or null string pathname (member :interactive :output)
+ #+(or cmu (and sbcl os-unix) scl) (or stream (eql t))
+ #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
+
+ (defun %normalize-io-specifier (specifier &optional role)
+ "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
+argument to pass to the internal RUN-PROGRAM"
+ (declare (ignorable role))
+ (etypecase specifier
+ (null (or #+(or allegro lispworks) (null-device-pathname)))
+ (string (parse-native-namestring specifier))
+ (pathname specifier)
+ (stream specifier)
+ ((eql :stream) :stream)
+ ((eql :interactive)
+ #+allegro nil
+ #+clisp :terminal
+ #+(or clozure cmu ecl mkcl sbcl scl) t)
+ #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl)
+ ((eql :output)
+ (if (eq role :error-output)
+ :output
+ (error "Wrong specifier ~S for role ~S" specifier role)))))
+
+ (defun %interactivep (input output error-output)
+ (member :interactive (list input output error-output)))
+
+ #+clisp
+ (defun clisp-exit-code (raw-exit-code)
+ (typecase raw-exit-code
+ (null 0) ; no error
+ (integer raw-exit-code) ; negative: signal
+ (t -1)))
+
+ (defun %run-program (command
+ &rest keys
+ &key input (if-input-does-not-exist :error)
+ output (if-output-exists :overwrite)
+ error-output (if-error-output-exists :overwrite)
+ directory wait
+ #+allegro separate-streams
+ &allow-other-keys)
+ "A portable abstraction of a low-level call to the implementation's run-program or equivalent.
+It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
+INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
+to be normalized by %NORMALIZE-IO-SPECIFIER.
+It returns a process-info plist with possible keys:
+ PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
+ ;; NB: these implementations have unix vs windows set at compile-time.
+ (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
+ (assert (not (and wait (member :stream (list input output error-output)))))
+ #-(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
+ (progn command keys directory
+ (error "run-program not available"))
+ #+(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl)
+ (let* ((%command (%normalize-command command))
+ (%input (%normalize-io-specifier input :input))
+ (%output (%normalize-io-specifier output :output))
+ (%error-output (%normalize-io-specifier error-output :error-output))
+ #+(and allegro os-windows) (interactive (%interactivep input output error-output))
+ (process*
+ #+allegro
+ (multiple-value-list
+ (apply
+ 'excl:run-shell-command
+ #+os-unix (coerce (cons (first %command) %command) 'vector)
+ #+os-windows %command
+ :input %input
+ :output %output
+ :error-output %error-output
+ :directory directory :wait wait
+ #+os-windows :show-window #+os-windows (if interactive nil :hide)
+ :allow-other-keys t keys))
+ #-allegro
+ (with-current-directory (#-(or sbcl mkcl) directory)
+ #+clisp
+ (flet ((run (f x &rest args)
+ (multiple-value-list
+ (apply f x :input %input :output %output
+ :allow-other-keys t `(,@args ,@keys)))))
+ (assert (eq %error-output :terminal))
+ ;;; since we now always return a code, we can't use this code path, anyway!
+ (etypecase %command
+ #+os-windows (string (run 'ext:run-shell-command %command))
+ (list (run 'ext:run-program (car %command)
+ :arguments (cdr %command)))))
+ #+(or clozure cmu ecl mkcl sbcl scl)
+ (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list
+ (apply
+ '#+(or cmu ecl scl) ext:run-program
+ #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program
+ (car %command) (cdr %command)
+ :input %input
+ :output %output
+ :error %error-output
+ :wait wait
+ :allow-other-keys t
+ (append
+ #+(or clozure cmu mkcl sbcl scl)
+ `(:if-input-does-not-exist ,if-input-does-not-exist
+ :if-output-exists ,if-output-exists
+ :if-error-exists ,if-error-output-exists)
+ #+sbcl `(:search t
+ :if-output-does-not-exist :create
+ :if-error-does-not-exist :create)
+ #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys)))))
+ #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case
+ (multiple-value-list
+ (apply
+ 'system:run-shell-command
+ (cons "/usr/bin/env" %command) ; lispworks wants a full path.
+ :input %input :if-input-does-not-exist if-input-does-not-exist
+ :output %output :if-output-exists if-output-exists
+ :error-output %error-output :if-error-output-exists if-error-output-exists
+ :wait wait :save-exit-status t :allow-other-keys t keys))))
+ (process-info-r ()))
+ (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
+ #+allegro
+ (cond
+ (wait (prop :exit-code (first process*)))
+ (separate-streams
+ (destructuring-bind (in out err pid) process*
+ (prop :process pid)
+ (when (eq input :stream) (prop :input-stream in))
+ (when (eq output :stream) (prop :output-stream out))
+ (when (eq error-output :stream) (prop :error-stream err))))
+ (t
+ (prop :process (third process*))
+ (let ((x (first process*)))
+ (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
+ (0)
+ (1 (prop :input-stream x))
+ (2 (prop :output-stream x))
+ (3 (prop :bidir-stream x))))
+ (when (eq error-output :stream)
+ (prop :error-stream (second process*)))))
+ #+clisp
+ (cond
+ (wait (prop :exit-code (clisp-exit-code (first process*))))
+ (t
+ (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
+ (0)
+ (1 (prop :input-stream (first process*)))
+ (2 (prop :output-stream (first process*)))
+ (3 (prop :bidir-stream (pop process*))
+ (prop :input-stream (pop process*))
+ (prop :output-stream (pop process*))))))
+ #+(or clozure cmu sbcl scl)
+ (progn
+ (prop :process process*)
+ (when (eq input :stream)
+ (prop :input-stream
+ #+clozure (ccl:external-process-input-stream process*)
+ #+(or cmu scl) (ext:process-input process*)
+ #+sbcl (sb-ext:process-input process*)))
+ (when (eq output :stream)
+ (prop :output-stream
+ #+clozure (ccl:external-process-output-stream process*)
+ #+(or cmu scl) (ext:process-output process*)
+ #+sbcl (sb-ext:process-output process*)))
+ (when (eq error-output :stream)
+ (prop :error-output-stream
+ #+clozure (ccl:external-process-error-stream process*)
+ #+(or cmu scl) (ext:process-error process*)
+ #+sbcl (sb-ext:process-error process*))))
+ #+(or ecl mkcl)
+ (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process*
+ (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
+ (cond
+ ((zerop mode))
+ ((null process*) (prop :exit-code -1))
+ (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream))))
+ (when code (prop :exit-code code))
+ (when process (prop :process process)))
+ #+lispworks
+ (if wait
+ (prop :exit-code (first process*))
+ (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
+ (if (zerop mode)
+ (prop :process (first process*))
+ (destructuring-bind (x err pid) process*
+ (prop :process pid)
+ (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x)
+ (when (eq error-output :stream) (prop :error-stream err))))))
+ (nreverse process-info-r))))
+
+ (defun %process-info-pid (process-info)
+ (let ((process (getf process-info :process)))
+ (declare (ignorable process))
+ #+(or allegro lispworks) process
+ #+clozure (ccl::external-process-pid process)
+ #+ecl (si:external-process-pid process)
+ #+(or cmu scl) (ext:process-pid process)
+ #+mkcl (mkcl:process-id process)
+ #+sbcl (sb-ext:process-pid process)
+ #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid)))
+
+ (defun %wait-process-result (process-info)
+ (or (getf process-info :exit-code)
+ (let ((process (getf process-info :process)))
+ (when process
+ ;; 1- wait
+ #+clozure (ccl::external-process-wait process)
+ #+(or cmu scl) (ext:process-wait process)
+ #+(and ecl os-unix) (ext:external-process-wait process)
+ #+sbcl (sb-ext:process-wait process)
+ ;; 2- extract result
+ #+allegro (sys:reap-os-subprocess :pid process :wait t)
+ #+clozure (nth-value 1 (ccl:external-process-status process))
+ #+(or cmu scl) (ext:process-exit-code process)
+ #+ecl (nth-value 1 (ext:external-process-status process))
+ #+lispworks
+ (if-let ((stream (or (getf process-info :input-stream)
+ (getf process-info :output-stream)
+ (getf process-info :bidir-stream)
+ (getf process-info :error-stream))))
+ (system:pipe-exit-status stream :wait t)
+ (if-let ((f (find-symbol* :pid-exit-status :system nil)))
+ (funcall f process :wait t)))
+ #+sbcl (sb-ext:process-exit-code process)
+ #+mkcl (mkcl:join-process process)))))
+
+ (defun %check-result (exit-code &key command process ignore-error-status)
+ (unless ignore-error-status
+ (unless (eql exit-code 0)
+ (cerror "IGNORE-ERROR-STATUS"
+ 'subprocess-error :command command :code exit-code :process process)))
+ exit-code)
+
+ (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
+ &key element-type external-format &allow-other-keys)
+ ;; handle redirection for run-program and system
+ ;; SPEC is the specification for the subprocess's input or output or error-output
+ ;; TVAL is the value used if the spec is T
+ ;; GF is the generic function to call to handle arbitrary values of SPEC
+ ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
+ ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
+ ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
+ ;; FUN is a function of the new reduced spec and an activity function to call with a stream
+ ;; when the subprocess is active and communicating through that stream.
+ ;; ACTIVEP is a boolean true if we will get to run code while the process is running
+ ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
+ ;; RETURNER is a function called with the value of the activity.
+ ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
+ (declare (ignorable stream-easy-p))
+ (let* ((actual-spec (if (eq spec t) tval spec))
+ (activity-spec (if (eq actual-spec :output)
+ (ecase direction
+ ((:input :output)
+ (error "~S not allowed as a ~S ~S spec"
+ :output 'run-program direction))
+ ((:error-output)
+ nil))
+ actual-spec)))
+ (labels ((activity (stream)
+ (call-function returner (call-stream-processor gf activity-spec stream)))
+ (easy-case ()
+ (funcall fun actual-spec nil))
+ (hard-case ()
+ (if activep
+ (funcall fun :stream #'activity)
+ (with-temporary-file (:pathname tmp)
+ (ecase direction
+ (:input
+ (with-output-file (s tmp :if-exists :overwrite
+ :external-format external-format
+ :element-type element-type)
+ (activity s))
+ (funcall fun tmp nil))
+ ((:output :error-output)
+ (multiple-value-prog1 (funcall fun tmp nil)
+ (with-input-file (s tmp
+ :external-format external-format
+ :element-type element-type)
+ (activity s)))))))))
+ (typecase activity-spec
+ ((or null string pathname (eql :interactive))
+ (easy-case))
+ #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
+ (stream
+ (if stream-easy-p (easy-case) (hard-case)))
+ (t
+ (hard-case))))))
+
+ (defmacro place-setter (place)
+ (when place
+ (let ((value (gensym)))
+ `#'(lambda (,value) (setf ,place ,value)))))
+
+ (defmacro with-program-input (((reduced-input-var
+ &optional (input-activity-var (gensym) iavp))
+ input-form &key setf stream-easy-p active keys) &body body)
+ `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
+ #'(lambda (,reduced-input-var ,input-activity-var)
+ ,@(unless iavp `((declare (ignore ,input-activity-var))))
+ ,@body)
+ :input ,input-form ,active (place-setter ,setf) ,keys))
+
+ (defmacro with-program-output (((reduced-output-var
+ &optional (output-activity-var (gensym) oavp))
+ output-form &key setf stream-easy-p active keys) &body body)
+ `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
+ #'(lambda (,reduced-output-var ,output-activity-var)
+ ,@(unless oavp `((declare (ignore ,output-activity-var))))
+ ,@body)
+ :output ,output-form ,active (place-setter ,setf) ,keys))
+
+ (defmacro with-program-error-output (((reduced-error-output-var
+ &optional (error-output-activity-var (gensym) eoavp))
+ error-output-form &key setf stream-easy-p active keys)
+ &body body)
+ `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
+ #'(lambda (,reduced-error-output-var ,error-output-activity-var)
+ ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
+ ,@body)
+ :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
+
+ (defun %use-run-program (command &rest keys
+ &key input output error-output ignore-error-status &allow-other-keys)
+ ;; helper for RUN-PROGRAM when using %run-program
+ #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl)
+ (progn
+ command keys input output error-output ignore-error-status ;; ignore
+ (error "Not implemented on this platform"))
+ (assert (not (member :stream (list input output error-output))))
+ (let* ((active-input-p (%active-io-specifier-p input))
+ (active-output-p (%active-io-specifier-p output))
+ (active-error-output-p (%active-io-specifier-p error-output))
+ (activity
+ (cond
+ (active-output-p :output)
+ (active-input-p :input)
+ (active-error-output-p :error-output)
+ (t nil)))
+ (wait (not activity))
+ output-result error-output-result exit-code)
+ (with-program-output ((reduced-output output-activity)
+ output :keys keys :setf output-result
+ :stream-easy-p t :active (eq activity :output))
+ (with-program-error-output ((reduced-error-output error-output-activity)
+ error-output :keys keys :setf error-output-result
+ :stream-easy-p t :active (eq activity :error-output))
+ (with-program-input ((reduced-input input-activity)
+ input :keys keys
+ :stream-easy-p t :active (eq activity :input))
+ (let ((process-info
+ (apply '%run-program command
+ :wait wait :input reduced-input :output reduced-output
+ :error-output (if (eq error-output :output) :output reduced-error-output)
+ keys)))
+ (labels ((get-stream (stream-name &optional fallbackp)
+ (or (getf process-info stream-name)
+ (when fallbackp
+ (getf process-info :bidir-stream))))
+ (run-activity (activity stream-name &optional fallbackp)
+ (if-let (stream (get-stream stream-name fallbackp))
+ (funcall activity stream)
+ (error 'subprocess-error
+ :code `(:missing ,stream-name)
+ :command command :process process-info))))
+ (unwind-protect
+ (ecase activity
+ ((nil))
+ (:input (run-activity input-activity :input-stream t))
+ (:output (run-activity output-activity :output-stream t))
+ (:error-output (run-activity error-output-activity :error-output-stream)))
+ (loop :for (() val) :on process-info :by #'cddr
+ :when (streamp val) :do (ignore-errors (close val)))
+ (setf exit-code
+ (%check-result (%wait-process-result process-info)
+ :command command :process process-info
+ :ignore-error-status ignore-error-status))))))))
+ (values output-result error-output-result exit-code)))
+
+ (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
+ (etypecase command
+ (string command)
+ (list (escape-shell-command
+ (if (os-unix-p) (cons "exec" command) command)))))
+
+ (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
+ (flet ((redirect (spec operator)
+ (let ((pathname
+ (typecase spec
+ (null (null-device-pathname))
+ (string (parse-native-namestring spec))
+ (pathname spec)
+ ((eql :output)
+ (assert (equal operator " 2>"))
+ (return-from redirect '(" 2>&1"))))))
+ (when pathname
+ (list operator " "
+ (escape-shell-token (native-namestring pathname)))))))
+ (multiple-value-bind (before after)
+ (let ((normalized (%normalize-system-command command)))
+ (if (os-unix-p)
+ (values '("exec") (list " ; " normalized))
+ (values (list normalized) ())))
+ (reduce/strcat
+ (append
+ before (redirect in " <") (redirect out " >") (redirect err " 2>")
+ (when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory
+ `(" ; cd " ,(escape-shell-token (native-namestring directory))))
+ after)))))
+
+ (defun %system (command &rest keys
+ &key input output error-output directory &allow-other-keys)
+ "A portable abstraction of a low-level call to libc's system()."
+ (declare (ignorable input output error-output directory keys))
+ #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
+ (%wait-process-result
+ (apply '%run-program (%normalize-system-command command) :wait t keys))
+ #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl)
+ (let ((%command (%redirected-system-command command input output error-output directory)))
+ #+(and lispworks os-windows)
+ (system:call-system %command :current-directory directory :wait t)
+ #+clisp
+ (%wait-process-result
+ (apply '%run-program %command :wait t
+ :input :interactive :output :interactive :error-output :interactive keys))
+ #-(or clisp (and lispworks os-windows))
+ (with-current-directory ((unless (os-unix-p) directory))
+ #+abcl (ext:run-shell-command %command)
+ #+cormanlisp (win32:system %command)
+ #+ecl (let ((*standard-input* *stdin*)
+ (*standard-output* *stdout*)
+ (*error-output* *stderr*))
+ (ext:system %command))
+ #+gcl (system:system %command)
+ #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
+ #+mkcl (mkcl:system %command)
+ #+xcl (system:%run-shell-command %command))))
+
+ (defun %use-system (command &rest keys
+ &key input output error-output ignore-error-status &allow-other-keys)
+ ;; helper for RUN-PROGRAM when using %system
+ (let (output-result error-output-result exit-code)
+ (with-program-output ((reduced-output)
+ output :keys keys :setf output-result)
+ (with-program-error-output ((reduced-error-output)
+ error-output :keys keys :setf error-output-result)
+ (with-program-input ((reduced-input) input :keys keys)
+ (setf exit-code
+ (%check-result (apply '%system command
+ :input reduced-input :output reduced-output
+ :error-output reduced-error-output keys)
+ :command command
+ :ignore-error-status ignore-error-status)))))
+ (values output-result error-output-result exit-code)))
+
+ (defun run-program (command &rest keys
+ &key ignore-error-status force-shell
+ (input nil inputp) (if-input-does-not-exist :error)
+ output (if-output-exists :overwrite)
+ (error-output nil error-output-p) (if-error-output-exists :overwrite)
+ (element-type #-clozure *default-stream-element-type* #+clozure 'character)
+ (external-format *utf-8-external-format*)
+ &allow-other-keys)
+ "Run program specified by COMMAND,
+either a list of strings specifying a program and list of arguments,
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
+
+Always call a shell (rather than directly execute the command when possible)
+if FORCE-SHELL is specified.
+
+Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
+unless IGNORE-ERROR-STATUS is specified.
+
+If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
+the file at that path is used as output.
+If it's :INTERACTIVE, output is inherited from the current process;
+beware that this may be different from your *STANDARD-OUTPUT*,
+and under SLIME will be on your *inferior-lisp* buffer.
+If it's T, output goes to your current *STANDARD-OUTPUT* stream.
+Otherwise, OUTPUT should be a value that is a suitable first argument to
+SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
+In this case, RUN-PROGRAM will create a temporary stream for the program output;
+the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
+using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
+The primary value resulting from that call (or NIL if no call was needed)
+will be the first value returned by RUN-PROGRAM.
+E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
+And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
+stripped of any ending newline.
+
+ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
+as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
+Also :OUTPUT means redirecting the error output to the output stream,
+in which case NIL is returned.
+
+INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
+no value is returned, and T designates the *STANDARD-INPUT*.
+
+Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
+to your Lisp implementation, when applicable, for creation of the output stream.
+
+One and only one of the stream slurping or vomiting may or may not happen
+in parallel in parallel with the subprocess,
+depending on options and implementation,
+and with priority being given to output processing.
+Other streams are completely produced or consumed
+before or after the subprocess is spawned, using temporary files.
+
+RUN-PROGRAM returns 3 values:
+0- the result of the OUTPUT slurping if any, or NIL
+1- the result of the ERROR-OUTPUT slurping if any, or NIL
+2- either 0 if the subprocess exited with success status,
+or an indication of failure via the EXIT-CODE of the process"
+ (declare (ignorable ignore-error-status))
+ #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
+ (error "RUN-PROGRAM not implemented for this Lisp")
+ (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive))))
+ (apply (if (or force-shell
+ #+(or clisp ecl) (or (not ignore-error-status) t)
+ #+clisp (eq error-output :interactive)
+ #+(or abcl clisp) (eq :error-output :output)
+ #+(and lispworks os-unix) (%interactivep input output error-output)
+ #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t)
+ '%use-system '%use-run-program)
+ command
+ :input (default input inputp output)
+ :error-output (default error-output error-output-p output)
+ :if-input-does-not-exist if-input-does-not-exist
+ :if-output-exists if-output-exists
+ :if-error-output-exists if-error-output-exists
+ :element-type element-type :external-format external-format
+ keys))))
+;;;; -------------------------------------------------------------------------
+;;;; Support to build (compile and load) Lisp files
(uiop/package:define-package :uiop/lisp-build
(:nicknames :asdf/lisp-build)
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
#:*output-translation-function*
#:*optimization-settings* #:*previous-optimization-settings*
+ #:*base-build-directory*
#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
#:compile-warned-warning #:compile-failed-warning
#:check-lisp-compile-results #:check-lisp-compile-warnings
- #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
+ #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
+ #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
;; Types
#+sbcl #:sb-grovel-unknown-constant-condition
;; Functions & Macros
- #:get-optimization-settings #:proclaim-optimization-settings
+ #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:reify-simple-sexp #:unreify-simple-sexp
#:enable-deferred-warnings-check #:disable-deferred-warnings-check
#:current-lisp-file-pathname #:load-pathname
#:lispize-pathname #:compile-file-type #:call-around-hook
- #:compile-file* #:compile-file-pathname*
+ #:compile-file* #:compile-file-pathname* #:*compile-check*
#:load* #:load-from-string #:combine-fasls)
(:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
(in-package :uiop/lisp-build)
"How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
when compiling a file, which includes any non-style-warning warning.
Valid values are :error, :warn, and :ignore.
-Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling."))
+Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
+ (defvar *base-build-directory* nil
+ "When set to a non-null value, it should be an absolute directory pathname,
+which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
+what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
+This can help you produce more deterministic output for FASLs."))
;;; Optimization settings
(with-upgradability ()
- (defvar *optimization-settings* nil)
- (defvar *previous-optimization-settings* nil)
+ (defvar *optimization-settings* nil
+ "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
+ (defvar *previous-optimization-settings* nil
+ "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
+ (defparameter +optimization-variables+
+ ;; TODO: allegro genera corman mcl
+ (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
+ #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
+ #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
+ ccl::*nx-debug* ccl::*nx-cspeed*)
+ #+(or cmu scl) '(c::*default-cookie*)
+ #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
+ #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
+ #+lispworks '(compiler::*optimization-level*)
+ #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
+ #+sbcl '(sb-c::*policy*)))
(defun get-optimization-settings ()
"Get current compiler optimization settings, ready to PROCLAIM again"
- #-(or clisp clozure cmu ecl sbcl scl)
- (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
- #+clozure (ccl:declaration-information 'optimize nil)
- #+(or clisp cmu ecl sbcl scl)
+ #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
+ (warn "~S does not support ~S. Please help me fix that."
+ 'get-optimization-settings (implementation-type))
+ #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
(let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
- #.`(loop :for x :in settings
- ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
- #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
- :for y = (or #+clisp (gethash x system::*optimize*)
- #+(or ecl) (symbol-value v)
- #+(or cmu scl) (funcall f c::*default-cookie*)
+ #.`(loop #+(or allegro clozure)
+ ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
+ #+clozure (ccl:declaration-information 'optimize nil))
+ :for x :in settings
+ ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
+ :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
+ #+clisp (gethash x system::*optimize* 1)
+ #+(or abcl ecl mkcl xcl) (symbol-value v)
+ #+(or cmu scl) (slot-value c::*default-cookie*
+ (case x (compilation-speed 'c::cspeed)
+ (otherwise x)))
+ #+lispworks (slot-value compiler::*optimization-level* x)
#+sbcl (cdr (assoc x sb-c::*policy*)))
:when y :collect (list x y))))
(defun proclaim-optimization-settings ()
(proclaim `(optimize ,@*optimization-settings*))
(let ((settings (get-optimization-settings)))
(unless (equal *previous-optimization-settings* settings)
- (setf *previous-optimization-settings* settings)))))
+ (setf *previous-optimization-settings* settings))))
+ (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
+ #+(or allegro clisp)
+ (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
+ `(let ((,previous-settings (get-optimization-settings)))
+ ,@(when settings `((proclaim `(optimize ,@,settings))))
+ (unwind-protect (progn ,@body)
+ (proclaim `(optimize ,@,previous-settings)))))
+ #-(or allegro clisp)
+ `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
+ ,@(when settings `((proclaim `(optimize ,@,settings))))
+ ,@body)))
;;; Condition control
#+sbcl
(progn
(defun sb-grovel-unknown-constant-condition-p (c)
+ "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
(and (typep c 'sb-int:simple-style-warning)
(string-enclosed-p
"Couldn't grovel for "
;;;; ----- Filtering conditions while building -----
(with-upgradability ()
(defun call-with-muffled-compiler-conditions (thunk)
+ "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
(call-with-muffled-conditions
thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
(defmacro with-muffled-compiler-conditions ((&optional) &body body)
- "Run BODY where uninteresting compiler conditions are muffled"
+ "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
`(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
(defun call-with-muffled-loader-conditions (thunk)
+ "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
(call-with-muffled-conditions
thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
(defmacro with-muffled-loader-conditions ((&optional) &body body)
- "Run BODY where uninteresting compiler and additional loader conditions are muffled"
+ "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
`(call-with-muffled-loader-conditions #'(lambda () ,@body))))
(defun check-lisp-compile-warnings (warnings-p failure-p
&optional context-format context-arguments)
+ "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
+raise an error or warning as appropriate"
(when failure-p
(case *compile-file-failure-behaviour*
(:warn (warn 'compile-failed-warning
(defun check-lisp-compile-results (output warnings-p failure-p
&optional context-format context-arguments)
+ "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
(unless output
(error 'compile-file-error :context-format context-format :context-arguments context-arguments))
(check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
;;; See their respective docstrings.
(with-upgradability ()
(defun reify-simple-sexp (sexp)
+ "Given a simple SEXP, return a representation of it as a portable SEXP.
+Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
(etypecase sexp
(symbol (reify-symbol sexp))
((or number character simple-string pathname) sexp)
(simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
(defun unreify-simple-sexp (sexp)
+ "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
(etypecase sexp
((or symbol number character simple-string pathname) sexp)
(cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
#+allegro
(list :functions-defined excl::.functions-defined.
- :functions-called excl::.functions-called.)
+ :functions-called excl::.functions-called.)
#+clozure
(mapcar 'reify-deferred-warning
(if-let (dw ccl::*outstanding-deferred-warnings*)
(declare (ignorable reified-deferred-warnings))
#+allegro
(destructuring-bind (&key functions-defined functions-called)
- reified-deferred-warnings
+ reified-deferred-warnings
(setf excl::.functions-defined.
(append functions-defined excl::.functions-defined.)
excl::.functions-called.
(terpri s))))
(defun warnings-file-type (&optional implementation-type)
+ "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
+where NIL designates the current one"
(case (or implementation-type *implementation-type*)
((:acl :allegro) "allegro-warnings")
;;((:clisp) "clisp-warnings")
((:scl) "scl-warnings")))
(defvar *warnings-file-type* nil
- "Type for warnings files")
+ "Pathname type for warnings files, or NIL if disabled")
(defun enable-deferred-warnings-check ()
+ "Enable the saving of deferred warnings"
(setf *warnings-file-type* (warnings-file-type)))
(defun disable-deferred-warnings-check ()
+ "Disable the saving of deferred warnings"
(setf *warnings-file-type* nil))
(defun warnings-file-p (file &optional implementation-type)
+ "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
+If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
(if-let (type (if implementation-type
(warnings-file-type implementation-type)
*warnings-file-type*))
(equal (pathname-type file) type)))
(defun check-deferred-warnings (files &optional context-format context-arguments)
+ "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
+re-intern and raise any warnings that are still meaningful."
(let ((file-errors nil)
(failure-p nil)
(warnings-p nil))
(macroexpand-1 '(with-compilation-unit () foo))
|#
- (defun call-with-saved-deferred-warnings (thunk warnings-file)
+ (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
+ "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
+and save those warnings to the given file for latter use,
+possibly in a different process. Otherwise just call THUNK."
+ (declare (ignorable source-namestring))
(if warnings-file
- (with-compilation-unit (:override t)
+ (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
(unwind-protect
(let (#+sbcl (sb-c::*undefined-warnings* nil))
(multiple-value-prog1
(reset-deferred-warnings)))
(funcall thunk)))
- (defmacro with-saved-deferred-warnings ((warnings-file) &body body)
- "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
-and saves those warnings to the given file for latter use,
-possibly in a different process. Otherwise just run the BODY."
- `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)))
+ (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
+ "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
+ `(call-with-saved-deferred-warnings
+ #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
;;; from ASDF
(with-upgradability ()
(defun current-lisp-file-pathname ()
+ "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
(or *compile-file-pathname* *load-pathname*))
(defun load-pathname ()
- *load-pathname*)
+ "Portably return the LOAD-PATHNAME of the current source file or fasl"
+ *load-pathname*) ;; magic no longer needed for GCL.
(defun lispize-pathname (input-file)
+ "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
(make-pathname :type "lisp" :defaults input-file))
(defun compile-file-type (&rest keys)
#+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
(defun call-around-hook (hook function)
+ "Call a HOOK around the execution of FUNCTION"
(call-function (or hook 'funcall) function))
(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
+ "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
(let* ((keys
- (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
+ (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
,@(unless output-file '(:output-file))) keys)))
(if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp
(funcall *output-translation-function*
(apply 'compile-file-pathname input-file keys)))))
+ (defvar *compile-check* nil
+ "A hook for user-defined compile-time invariants")
+
(defun* (compile-file*) (input-file &rest keys
- &key compile-check output-file warnings-file
- #+clisp lib-file #+(or ecl mkcl) object-file
+ &key (compile-check *compile-check*) output-file warnings-file
+ #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
&allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and
(rotatef output-file object-file))
(let* ((keywords (remove-plist-keys
`(:output-file :compile-check :warnings-file
- #+clisp :lib-file #+(or ecl mkcl) :object-file
- #+gcl2.6 ,@'(:external-format :print :verbose)) keys))
+ #+clisp :lib-file #+(or ecl mkcl) :object-file) keys))
(output-file
(or output-file
(apply 'compile-file-pathname* input-file :output-file output-file keywords)))
(or object-file
(compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file))
+ #+sbcl
+ (cfasl-file (etypecase emit-cfasl
+ (null nil)
+ ((eql t) (make-pathname :type "cfasl" :defaults output-file))
+ (string (parse-namestring emit-cfasl))
+ (pathname emit-cfasl)))
+ #+sbcl
+ (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
#+clisp
(tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
(multiple-value-bind (output-truename warnings-p failure-p)
- (with-saved-deferred-warnings (warnings-file)
- (with-muffled-compiler-conditions ()
- (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
- #+ecl (apply 'compile-file input-file :output-file
- (if object-file
- (list* object-file :system-p t keywords)
- (list* tmp-file keywords)))
- #+mkcl (apply 'compile-file input-file
- :output-file object-file :fasl-p nil keywords))))
+ (with-enough-pathname (input-file :defaults *base-build-directory*)
+ (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
+ (with-muffled-compiler-conditions ()
+ (or #-(or ecl mkcl)
+ (apply 'compile-file input-file :output-file tmp-file
+ #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
+ #-sbcl keywords)
+ #+ecl (apply 'compile-file input-file :output-file
+ (if object-file
+ (list* object-file :system-p t keywords)
+ (list* tmp-file keywords)))
+ #+mkcl (apply 'compile-file input-file
+ :output-file object-file :fasl-p nil keywords)))))
(cond
((and output-truename
(flet ((check-flag (flag behaviour)
(delete-file-if-exists output-file)
(when output-truename
#+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
+ #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
(rename-file-overwriting-target output-truename output-file)
(setf output-truename (truename output-file)))
#+clisp (delete-file-if-exists tmp-lib))
(t ;; error or failed check
(delete-file-if-exists output-truename)
+ #+clisp (delete-file-if-exists tmp-lib)
+ #+sbcl (delete-file-if-exists tmp-cfasl)
(setf output-truename nil)))
(values output-truename warnings-p failure-p))))
(defun load* (x &rest keys &key &allow-other-keys)
- (etypecase x
- ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
- (apply 'load x
- #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys)))
- ;; GCL 2.6, Genera can't load from a string-input-stream
- ;; ClozureCL 1.6 can only load from file input stream
- ;; Allegro 5, I don't remember but it must have been broken when I tested.
- #+(or allegro clozure gcl2.6 genera)
- (stream ;; make do this way
- (let ((*package* *package*)
- (*readtable* *readtable*)
- (*load-pathname* nil)
- (*load-truename* nil))
- (eval-input x)))))
+ "Portable wrapper around LOAD that properly handles loading from a stream."
+ (with-muffled-loader-conditions ()
+ (etypecase x
+ ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
+ (apply 'load x keys))
+ ;; Genera can't load from a string-input-stream
+ ;; ClozureCL 1.6 can only load from file input stream
+ ;; Allegro 5, I don't remember but it must have been broken when I tested.
+ #+(or allegro clozure genera)
+ (stream ;; make do this way
+ (let ((*package* *package*)
+ (*readtable* *readtable*)
+ (*load-pathname* nil)
+ (*load-truename* nil))
+ (eval-input x))))))
(defun load-from-string (string)
"Portably read and evaluate forms from a STRING."
;;; Links FASLs together
(with-upgradability ()
(defun combine-fasls (inputs output)
+ "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
#-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
(error "~A does not support ~S~%inputs ~S~%output ~S"
(implementation-type) 'combine-fasls inputs output)
(condition-arguments c))))))
(defun get-folder-path (folder)
- (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
- #+(and lispworks mswindows) (sys:get-folder-path folder)
+ "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
+this function tries to locate the Windows FOLDER for one of
+:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA."
+ (or #+(and lispworks mswindows) (sys:get-folder-path folder)
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
(ecase folder
(:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
(subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
(defun user-configuration-directories ()
+ "Determine user configuration directories"
(let ((dirs
`(,@(when (os-unix-p)
(cons
:from-end t :test 'equal)))
(defun system-configuration-directories ()
+ "Determine system user configuration directories"
(cond
((os-unix-p) '(#p"/etc/common-lisp/"))
((os-windows-p)
(list it)))))
(defun in-first-directory (dirs x &key (direction :input))
+ "Determine system user configuration directories"
(loop :with fun = (ecase direction
((nil :input :probe) 'probe-file*)
((:output :io) 'identity))
:for dir :in dirs
- :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+ :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x)))))
(defun in-user-configuration-directory (x &key (direction :input))
+ "return pathname under user configuration directory, subpathname X"
(in-first-directory (user-configuration-directories) x :direction direction))
(defun in-system-configuration-directory (x &key (direction :input))
+ "return pathname under system configuration directory, subpathname X"
(in-first-directory (system-configuration-directories) x :direction direction))
(defun configuration-inheritance-directive-p (x)
+ "Is X a configuration inheritance directive?"
(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
(or (member x kw)
(and (length=n-p x 1) (member (car x) kw)))))
(defun report-invalid-form (reporter &rest args)
+ "Report an invalid form according to REPORTER and various ARGS"
(etypecase reporter
(null
(apply 'error 'invalid-configuration args))
(cons
(apply 'apply (append reporter args)))))
- (defvar *ignored-configuration-form* nil)
+ (defvar *ignored-configuration-form* nil
+ "Have configuration forms been ignored while parsing the configuration?")
(defun validate-configuration-form (form tag directive-validator
&key location invalid-form-reporter)
+ "Validate a configuration FORM"
(unless (and (consp form) (eq (car form) tag))
(setf *ignored-configuration-form* t)
(report-invalid-form invalid-form-reporter :form form :location location)
:finally
(unless (= inherit 1)
(report-invalid-form invalid-form-reporter
- :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
- :inherit-configuration :ignore-inherited-configuration)))
+ :form form :location location
+ ;; we throw away the form and location arguments, hence the ~2*
+ ;; this is necessary because of the report in INVALID-CONFIGURATION
+ :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
+ One and only one of ~S or ~S is required.~@:>")
+ :arguments '(:inherit-configuration :ignore-inherited-configuration)))
(return (nreverse x))))
(defun validate-configuration-file (file validator &key description)
+ "Validate a configuration file for conformance of its form with the validator function"
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
:inherit-configuration)))
(defun resolve-relative-location (x &key ensure-directory wilden)
+ "Given a designator X for an relative location, resolve it to a pathname"
(ensure-pathname
(etypecase x
(pathname x)
"A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
(defun compute-user-cache ()
+ "Compute the location of the default user-cache for translate-output objects"
(setf *user-cache*
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
(register-image-restore-hook 'compute-user-cache)
(defun resolve-absolute-location (x &key ensure-directory wilden)
+ "Given a designator X for an absolute location, resolve it to a pathname"
(ensure-pathname
(etypecase x
(pathname x)
(:ensure-directory boolean)) t) resolve-location))
(defun* (resolve-location) (x &key ensure-directory wilden directory)
+ "Resolve location designator X into a PATHNAME"
;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(loop* :with dirp = (or directory ensure-directory)
:with (first . rest) = (if (atom x) (list x) x)
:finally (return path)))
(defun location-designator-p (x)
+ "Is X a designator for a location?"
(flet ((absolute-component-p (c)
(typep c '(or string pathname
(member :root :home :here :user-cache))))
(and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
(defun location-function-p (x)
+ "Is X the specification of a location function?"
(and
(length=n-p x 2)
- (eq (car x) :function)
- (or (symbolp (cadr x))
- (and (consp (cadr x))
- (eq (caadr x) 'lambda)
- (length=n-p (cadadr x) 2)))))
+ (eq (car x) :function)))
(defvar *clear-configuration-hook* '())
(defun register-clear-configuration-hook (hook-function &optional call-now-p)
+ "Register a function to be called when clearing configuration"
(register-hook-function '*clear-configuration-hook* hook-function call-now-p))
(defun clear-configuration ()
+ "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
(call-functions *clear-configuration-hook*))
(register-image-dump-hook 'clear-configuration)
- ;; If a previous version of ASDF failed to read some configuration, try again.
(defun upgrade-configuration ()
+ "If a previous version of ASDF failed to read some configuration, try again now."
(when *ignored-configuration-form*
(clear-configuration)
(setf *ignored-configuration-form* nil))))
#+(or ecl mkcl)
(defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
;;;; ---------------------------------------------------------------------------
-;;;; Re-export all the functionality in asdf/driver
+;;;; Re-export all the functionality in UIOP
(uiop/package:define-package :uiop/driver
(:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils)
- (:use :uiop/common-lisp :uiop/package :uiop/utility
- :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
- :uiop/run-program :uiop/lisp-build
- :uiop/configuration :uiop/backward-driver)
- (:reexport
- ;; NB: excluding asdf/common-lisp
- ;; which include all of CL with compatibility modifications on select platforms.
+ (:use :uiop/common-lisp)
+ ;; NB: not reexporting uiop/common-lisp
+ ;; which include all of CL with compatibility modifications on select platforms,
+ ;; that could cause potential conflicts for packages that would :use (cl uiop)
+ ;; or :use (closer-common-lisp uiop), etc.
+ (:use-reexport
:uiop/package :uiop/utility
:uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
:uiop/run-program :uiop/lisp-build
:uiop/configuration :uiop/backward-driver))
+
+#+mkcl (provide :uiop)
;;;; -------------------------------------------------------------------------
;;;; Handle upgrade as forward- and backward-compatibly as possible
;; See https://bugs.launchpad.net/asdf/+bug/485687
-(asdf/package:define-package :asdf/upgrade
+(uiop/package:define-package :asdf/upgrade
(:recycle :asdf/upgrade :asdf)
- (:use :asdf/common-lisp :asdf/driver)
+ (:use :uiop/common-lisp :uiop)
(:export
#:asdf-version #:*previous-asdf-versions* #:*asdf-version*
#:asdf-message #:*verbose-out*
- #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
+ #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter*
#:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
;; There will be no symbol left behind!
#:intern*)
- (:import-from :asdf/package #:intern* #:find-symbol*))
+ (:import-from :uiop/package #:intern* #:find-symbol*))
(in-package :asdf/upgrade)
;;; Special magic to detect if this is an upgrade
(string rev)
(cons (format nil "~{~D~^.~}" rev))
(null "1.0"))))))
+ ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly.
+ (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous)))
(defvar *asdf-version* nil)
- (defvar *previous-asdf-versions* nil)
+ ;; We need to clear systems from versions yet older than the below:
+ (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component.
(defvar *verbose-out* nil)
(defun asdf-message (format-string &rest format-args)
(when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
(defvar *post-upgrade-cleanup-hook* ())
(defvar *post-upgrade-restart-hook* ())
- (defun upgrading-p ()
- (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
- (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
+ (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
+ (and *previous-asdf-versions*
+ (version< (first *previous-asdf-versions*) oldest-compatible-version)))
+ (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
+ (let* ((name (string-trim "*" var))
+ (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
+ `(progn
+ (defun ,valfun () ,value)
+ (defvar ,var (,valfun) ,@(ensure-list docstring))
+ (when (upgrading-p ,version)
+ (setf ,var (,valfun))))))
+ (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
+ (upgrading-p `(upgrading-p ,version)) when) &body body)
+ "A wrapper macro for code that should only be run when upgrading a
+previously-loaded version of ASDF."
`(with-upgradability ()
(when (and ,upgrading-p ,@(when when `(,when)))
(handler-bind ((style-warning #'muffle-warning))
(let* (;; For bug reporting sanity, please always bump this version when you modify this file.
;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
;; 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.
+ ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp.
;; "3.4" would be the general branch for major version 3, minor version 4.
;; "3.4.5" would be an official release in the 3.4 branch.
- ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
+ ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
- (asdf-version "2.33.10")
+ (asdf-version "3.1.2")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
(push existing-version *previous-asdf-versions*)
- (when (or *load-verbose* *verbose-out*)
- (format *trace-output*
+ (when (or *verbose-out* *load-verbose*)
+ (format (or *verbose-out* *trace-output*)
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version)))))
(when-upgrading ()
(let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
+ ;; NB: it's too late to do anything about functions in UIOP!
+ ;; If you introduce some critically incompatibility there, you must change name.
'(#:component-relative-pathname #:component-parent-pathname ;; component
#:source-file-type
#:find-system #:system-source-file #:system-relative-pathname ;; system
- #:find-component ;; find-component
- #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
- #:component-depends-on #:operation-done-p #:component-depends-on
- #:traverse ;; plan
- #:operate ;; operate
- #:parse-component-form ;; defsystem
- #:apply-output-translations ;; output-translations
- #:process-output-translations-directive
- #:inherit-source-registry #:process-source-registry ;; source-registry
- #:process-source-registry-directive
- #:trivial-system-p ;; bundle
- ;; NB: it's too late to do anything about asdf-driver functions!
- ))
- (uninterned-symbols
- '(#:*asdf-revision* #:around #:asdf-method-combination
- #:split #:make-collector #:do-dep #:do-one-dep
- #:component-self-dependencies
- #:resolve-relative-location-component #:resolve-absolute-location-component
- #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
- (declare (ignorable redefined-functions uninterned-symbols))
- (loop :for name :in (append redefined-functions)
+ #:find-component ;; find-component
+ #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
+ #:component-depends-on #:operation-done-p #:component-depends-on
+ #:traverse ;; backward-interface
+ #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan
+ #:operate ;; operate
+ #:parse-component-form ;; defsystem
+ #:apply-output-translations ;; output-translations
+ #:process-output-translations-directive
+ #:inherit-source-registry #:process-source-registry ;; source-registry
+ #:process-source-registry-directive
+ #:trivial-system-p)) ;; bundle
+ (redefined-classes
+ ;; redefining the classes causes interim circularities
+ ;; with the old ASDF during upgrade, and many implementations bork
+ '((#:compile-concatenated-source-op (#:operation) ()))))
+ (loop :for name :in redefined-functions
:for sym = (find-symbol* name :asdf nil) :do
(when sym
;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
#-clisp (fmakunbound sym)))
- (loop :with asdf = (find-package :asdf)
- :for name :in uninterned-symbols
- :for sym = (find-symbol* name :asdf nil)
- :for base-pkg = (and sym (symbol-package sym)) :do
- (when sym
- (cond
- ((or (eq base-pkg asdf) (not base-pkg))
- (unintern* sym asdf)
- (intern* sym asdf))
- (t
- (unintern* sym base-pkg)
- (let ((new (intern* sym base-pkg)))
- (shadowing-import new asdf))))))))
+ (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf))
+ (find-symbol* s p nil)))
+ (asyms (l) (mapcar #'asym l)))
+ (loop* :for (name superclasses slots) :in redefined-classes
+ :for sym = (find-symbol* name :asdf nil)
+ :when (and sym (find-class sym))
+ :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))))))
;;; Self-upgrade functions
old-version new-version)
(asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
old-version new-version))
- (call-functions (reverse *post-upgrade-cleanup-hook*))
+ ;; In case the previous version was too old to be forward-compatible, clear systems.
+ ;; TODO: if needed, we may have to define a separate hook to run
+ ;; in case of forward-compatible upgrade.
+ ;; Or to move the tests forward-compatibility test inside each hook function?
+ (unless (version<= *oldest-forward-compatible-asdf-version* old-version)
+ (call-functions (reverse *post-upgrade-cleanup-hook*)))
t))))
(defun upgrade-asdf ()
;;;; -------------------------------------------------------------------------
;;;; Components
-(asdf/package:define-package :asdf/component
- (:recycle :asdf/component :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+(uiop/package:define-package :asdf/component
+ (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export
#:component #:component-find-path
#:component-name #:component-pathname #:component-relative-pathname
#:module-components ;; backward-compatibility. DO NOT USE.
#:sub-components
+ ;; conditions
+ #:system-definition-error ;; top level, moved here because this is the earliest place for it.
+ #:duplicate-names
+
;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
#:name #:version #:description #:long-description #:author #:maintainer #:licence
- #:components-by-name #:components
- #:children #:children-by-name #:default-component-class
- #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
+ #:components-by-name #:components #:children #:children-by-name
+ #:default-component-class #:source-file
+ #:defsystem-depends-on ; This symbol retained for backward compatibility.
#:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
#:relative-pathname #:absolute-pathname #:operation-times #:around-compile
#:%encoding #:properties #:component-properties #:parent))
(defgeneric component-version (component))
(defgeneric (setf component-version) (new-version component))
(defgeneric component-parent (component))
- (defmethod component-parent ((component null)) (declare (ignorable component)) nil)
+ (defmethod component-parent ((component null)) nil)
;; Backward compatible way of computing the FILE-TYPE of a component.
;; TODO: find users, have them stop using that, remove it for ASDF4.
- (defgeneric (source-file-type) (component system)))
+ (defgeneric (source-file-type) (component system))
+
+ (define-condition system-definition-error (error) ()
+ ;; [this use of :report should be redundant, but unfortunately it's not.
+ ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
+ ;; over print-object; this is always conditions::%print-condition for
+ ;; condition objects, which in turn does inheritance of :report options at
+ ;; run-time. fortunately, inheritance means we only need this kludge here in
+ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
+ #+cmu (:report print-object))
+
+ (define-condition duplicate-names (system-definition-error)
+ ((name :initarg :name :reader duplicate-names-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
+ (duplicate-names-name c))))))
-(when-upgrading (:when (find-class 'component nil))
- (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
- (declare (ignorable c initargs)) (values)))
(with-upgradability ()
(defclass component ()
:initarg :build-operation :initform nil :reader component-build-operation)))
(defun component-find-path (component)
+ "Return a path from a root system to the COMPONENT.
+The return value is a list of component NAMES; a list of strings."
(check-type component (or null component))
(reverse
(loop :for c = component :then (component-parent c)
;;;; Component hierarchy within a system
;; The tree typically but not necessarily follows the filesystem hierarchy.
(with-upgradability ()
- (defclass child-component (component) ())
+ (defclass child-component (component) ()
+ (:documentation "A CHILD-COMPONENT is a component that may be part of
+a PARENT-COMPONENT."))
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(default-component-class
:initform nil
:initarg :default-component-class
- :accessor module-default-component-class))))
+ :accessor module-default-component-class))
+ (:documentation "A PARENT-COMPONENT is a component that may have
+children.")))
(with-upgradability ()
(defun compute-children-by-name (parent &key only-if-needed-p)
(setf (gethash name hash) c))
hash))))
-(when-upgrading (:when (find-class 'module nil))
- (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
- (declare (ignorable m initargs)) (values))
- (defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable m added deleted plist))
- (when (and (member 'children added) (member 'components deleted))
- (setf (slot-value m 'children)
- ;; old ECLs provide an alist instead of a plist(!)
- (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
- (getf plist 'components)))
- (compute-children-by-name m))))
-
(with-upgradability ()
(defclass module (child-component parent-component)
(#+clisp (components)))) ;; backward compatibility during upgrade only
pathname)))
(defmethod component-relative-pathname ((component component))
- ;; source-file-type is backward-compatibility with ASDF1;
- ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
- ;; TODO: track who uses it, and have them not use it anymore.
+ ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
+ ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE.
+ ;; TODO: track who uses it, and have them not use it anymore;
+ ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
(parse-unix-namestring
(or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname))
:type (source-file-type component (component-system component))
:defaults (component-parent-pathname component)))
- (defmethod source-file-type ((component parent-component) system)
- (declare (ignorable component system))
+ (defmethod source-file-type ((component parent-component) (system parent-component))
:directory)
- (defmethod source-file-type ((component file-component) system)
- (declare (ignorable system))
+ (defmethod source-file-type ((component file-component) (system parent-component))
(file-type component)))
;;;; version-satisfies
(with-upgradability ()
+ ;; short-circuit testing of null version specifications.
+ ;; this is an all-pass, without warning
+ (defmethod version-satisfies :around ((c t) (version null))
+ t)
(defmethod version-satisfies ((c component) version)
- (unless (and version (slot-boundp c 'version))
+ (unless (and version (slot-boundp c 'version) (component-version c))
(when version
- (warn "Requested version ~S but component ~S has no version" version c))
- (return-from version-satisfies t))
+ (warn "Requested version ~S but ~S has no version" version c))
+ (return-from version-satisfies nil))
(version-satisfies (component-version c) version))
(defmethod version-satisfies ((cver string) version)
- (version-compatible-p cver version)))
+ (version<= version cver)))
;;; all sub-components (of a given type)
;;;; -------------------------------------------------------------------------
;;;; Systems
-(asdf/package:define-package :asdf/system
+(uiop/package:define-package :asdf/system
(:recycle :asdf :asdf/system)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
(:export
#:system #:proto-system
#:system-source-file #:system-source-directory #:system-relative-pathname
#:reset-system
#:system-description #:system-long-description
#:system-author #:system-maintainer #:system-licence #:system-license
- #:system-defsystem-depends-on
+ #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on
#:component-build-pathname #:build-pathname
#:component-entry-point #:entry-point
#:homepage #:system-homepage
(with-upgradability ()
(defgeneric* (find-system) (system &optional error-p))
- (defgeneric* (system-source-file) (system)
+ (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system)
(:documentation "Return the source file in which system is defined."))
(defgeneric component-build-pathname (component))
(defgeneric component-entry-point (component))
(defmethod component-entry-point ((c component))
- (declare (ignorable c))
nil))
(entry-point
:initform nil :initarg :entry-point :accessor component-entry-point)
(source-file :initform nil :initarg :source-file :accessor system-source-file)
- (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
+ (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
+ :initform nil)
+ ;; these two are specially set in parse-component-form, so have no :INITARGs.
+ (depends-on :reader system-depends-on :initform nil)
+ (weakly-depends-on :reader system-weakly-depends-on :initform nil)))
(defun reset-system (system &rest keys &key &allow-other-keys)
(change-class (change-class system 'proto-system) 'system)
(system-source-directory system))
(defmethod component-build-pathname ((c component))
- (declare (ignorable c))
nil))
;;;; -------------------------------------------------------------------------
;;;; Stamp cache
-(asdf/package:define-package :asdf/cache
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+(uiop/package:define-package :asdf/cache
+ (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
- #:consult-asdf-cache #:do-asdf-cache
+ #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
+ #:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(in-package :asdf/cache)
(setf (gethash key *asdf-cache*) value-list)
value-list)))
+ (defun unset-asdf-cache-entry (key)
+ (when *asdf-cache*
+ (remhash key *asdf-cache*)))
+
(defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
- (defun call-with-asdf-cache (thunk &key override)
- (if (and *asdf-cache* (not override))
- (funcall thunk)
- (let ((*asdf-cache* (make-hash-table :test 'equal)))
- (funcall thunk))))
+ (defun call-with-asdf-cache (thunk &key override key)
+ (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
+ (if (and *asdf-cache* (not override))
+ (funcall fun)
+ (let ((*asdf-cache* (make-hash-table :test 'equal)))
+ (funcall fun)))))
- (defmacro with-asdf-cache ((&key override) &body body)
- `(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
+ (defmacro with-asdf-cache ((&key key override) &body body)
+ `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key))
- (defun compute-file-stamp (file)
- (safe-file-write-date file))
+ (defun normalize-namestring (pathname)
+ (let ((resolved (resolve-symlinks*
+ (ensure-absolute-pathname
+ (physicalize-pathname pathname)
+ 'get-pathname-defaults))))
+ (with-pathname-defaults () (namestring resolved))))
- (defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
- (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
+ (defun compute-file-stamp (normalized-namestring)
+ (with-pathname-defaults ()
+ (safe-file-write-date normalized-namestring)))
- (defun get-file-stamp (file)
- (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))))
+ (defun register-file-stamp (file &optional (stamp nil stampp))
+ (let* ((namestring (normalize-namestring file))
+ (stamp (if stampp stamp (compute-file-stamp namestring))))
+ (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
+ (defun get-file-stamp (file)
+ (when file
+ (let ((namestring (normalize-namestring file)))
+ (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))))
;;;; -------------------------------------------------------------------------
;;;; Finding systems
-(asdf/package:define-package :asdf/find-system
+(uiop/package:define-package :asdf/find-system
(:recycle :asdf/find-system :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/cache)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
+ :asdf/cache :asdf/component :asdf/system)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
#:coerce-name #:primary-system-name #:coerce-filename
- #:find-system #:locate-system #:load-asd #:with-system-definitions
+ #:find-system #:locate-system #:load-asd
#:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
- #:system-definition-error #:missing-component #:missing-requires #:missing-parent
+ #:missing-component #:missing-requires #:missing-parent
#:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
#:load-system-definition-error #:error-name #:error-pathname #:error-condition
#:*system-definition-search-functions* #:search-for-system-definition
#:*central-registry* #:probe-asd #:sysdef-central-registry-search
- #:find-system-if-being-defined #:*systems-being-defined*
+ #:find-system-if-being-defined
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
- #:clear-defined-systems #:*defined-systems*
+ #:clear-defined-system #:clear-defined-systems #:*defined-systems*
+ #:*immutable-systems*
;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
(in-package :asdf/find-system)
(with-upgradability ()
(declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference
- (define-condition system-definition-error (error) ()
- ;; [this use of :report should be redundant, but unfortunately it's not.
- ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
- ;; over print-object; this is always conditions::%print-condition for
- ;; condition objects, which in turn does inheritance of :report options at
- ;; run-time. fortunately, inheritance means we only need this kludge here in
- ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
- #+cmu (:report print-object))
-
(define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
(parent :initform nil :reader missing-parent :initarg :parent)))
(get-file-stamp file))
system)))))
+ (defun clear-defined-system (system)
+ (let ((name (coerce-name system)))
+ (remhash name *defined-systems*)
+ (unset-asdf-cache-entry `(locate-system ,name))
+ (unset-asdf-cache-entry `(find-system ,name))
+ nil))
+
(defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered.
- (let ((asdf (cdr (system-registered-p :asdf))))
- (setf *defined-systems* (make-hash-table :test 'equal))
- (when asdf
- (setf (component-version asdf) *asdf-version*)
- (setf (builtin-system-p asdf) t)
- (register-system asdf)))
- (values))
+ (loop :for name :being :the :hash-keys :of *defined-systems*
+ :unless (equal name "asdf")
+ :do (clear-defined-system name)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
(setf *system-definition-search-functions*
(append
;; Remove known-incompatible sysdef functions from old versions of asdf.
- (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf)))
+ (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search)))
*system-definition-search-functions*)
;; Tuck our defaults at the end of the list if they were absent.
;; This is imperfect, in case they were removed on purpose,
;; to upgrade asdf before he does such a thing rather than after.
(remove-if #'(lambda (x) (member x *system-definition-search-functions*))
'(sysdef-central-registry-search
- sysdef-source-registry-search
- sysdef-preloaded-system-search)))))
+ sysdef-source-registry-search)))))
(cleanup-system-definition-search-functions)
(defun search-for-system-definition (system)
- (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
- (cons 'find-system-if-being-defined
- *system-definition-search-functions*)))
+ (let ((name (coerce-name system)))
+ (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
+ (try 'find-system-if-being-defined)
+ (try 'sysdef-immutable-system-search)
+ (map () #'try *system-definition-search-functions*)
+ (try 'sysdef-preloaded-system-search))))
(defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems.
:truename truename))
(return file))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
- (when (os-windows-p)
+ (when (and (os-windows-p) (physical-pathname-p defaults))
(let ((shortcut
(make-pathname
:defaults defaults :case :local
:name (strcat name ".asd")
:type "lnk")))
(when (probe-file* shortcut)
- (let ((target (parse-windows-shortcut shortcut)))
- (when target
- (return (pathname target))))))))))
+ (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
(defun sysdef-central-registry-search (system)
(let ((name (primary-system-name system))
(defun register-preloaded-system (system-name &rest keys)
(setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
- (register-preloaded-system "asdf" :version *asdf-version*)
- (register-preloaded-system "asdf-driver" :version *asdf-version*)
+ (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system"))
+ ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle"
+ (register-preloaded-system s :version *asdf-version*))
(defmethod find-system ((name null) &optional (error-p t))
- (declare (ignorable name))
(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*
- (call-with-asdf-cache thunk)
- (let ((*systems-being-defined* (make-hash-table :test 'equal)))
- (call-with-asdf-cache thunk))))
-
- (defun clear-systems-being-defined ()
- (when *systems-being-defined*
- (clrhash *systems-being-defined*)))
-
- (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
-
- (defmacro with-system-definitions ((&optional) &body body)
- `(call-with-system-definitions #'(lambda () ,@body)))
+ ;; notable side effect: mark the system as being defined, to avoid infinite loops
+ (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
(defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
;; Tries to load system definition with canonical NAME from PATHNAME.
- (with-system-definitions ()
+ (with-asdf-cache ()
(with-standard-io-syntax
(let ((*package* (find-package :asdf-user))
;; Note that our backward-compatible *readtable* is
(*print-readably* nil)
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
- (pathname-directory-pathname (translate-logical-pathname pathname))))
+ (pathname-directory-pathname (physicalize-pathname pathname))))
(handler-bind
((error #'(lambda (condition)
(error 'load-system-definition-error
:condition condition))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
name pathname)
- (with-muffled-loader-conditions ()
- (load* pathname :external-format external-format)))))))
+ (load* pathname :external-format external-format))))))
(defvar *old-asdf-systems* (make-hash-table :test 'equal))
(version (and (probe-file* version-pathname :truename nil)
(read-file-form version-pathname)))
(old-version (asdf-version)))
- (or (version<= old-version version)
- (let ((old-pathname
- (if-let (pair (system-registered-p "asdf"))
- (system-source-file (cdr pair))))
- (key (list pathname old-version)))
- (unless (gethash key *old-asdf-systems*)
- (setf (gethash key *old-asdf-systems*) t)
- (warn "~@<~
+ (cond
+ ((version< old-version version) t) ;; newer version: good!
+ ((equal old-version version) nil) ;; same version: don't load, but don't warn
+ (t ;; old version: bad
+ (ensure-gethash
+ (list (namestring pathname) version) *old-asdf-systems*
+ #'(lambda ()
+ (let ((old-pathname
+ (if-let (pair (system-registered-p "asdf"))
+ (system-source-file (cdr pair)))))
+ (warn "~@<~
You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
then you might indeed want to either install and register a more recent version, ~
or use :ignore-inherited-configuration to avoid registering the old one. ~
Please consult ASDF documentation and/or experts.~@:>~%"
- old-version old-pathname version pathname)))))))
+ old-version old-pathname version pathname))))
+ nil))))) ;; only issue the warning the first time, but always return nil
+
+ (defvar *immutable-systems* nil
+ "An hash-set (equal hash-table mapping keys to T) of systems that are immutable,
+i.e. already loaded in memory and not to be refreshed from the filesystem.
+They will be treated specially by find-system, and passed as :force-not argument to make-plan.
+
+If you deliver an image with many systems precompiled, *and* do not want to check the filesystem
+for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic
+downgrade, before you dump an image, use:
+ (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))")
+
+ (defun sysdef-immutable-system-search (requested)
+ (let ((name (coerce-name requested)))
+ (when (and *immutable-systems* (gethash name *immutable-systems*))
+ (or (cdr (system-registered-p requested))
+ (error 'formatted-system-definition-error
+ :format-control "Requested system ~A is in the *immutable-systems* set, ~
+but not loaded in memory"
+ :format-arguments (list name))))))
(defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
either associated with FOUND-SYSTEM, or with the PREVIOUS system.
PREVIOUS when not null is a previously loaded SYSTEM object of same name.
PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
- (let* ((name (coerce-name name))
- (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 (ensure-pathname
- (or (and (typep found '(or pathname string)) (pathname found))
- (and found-system (system-source-file found-system))
- (and previous (system-source-file previous)))
- :want-absolute t :resolve-symlinks *resolve-symlinks*))
- (foundp (and (or found-system pathname previous) t)))
- (check-type found (or null pathname system))
- (unless (check-not-old-asdf-system name pathname)
- (cond
- (previous (setf found nil pathname nil))
- (t
- (setf found (sysdef-preloaded-system-search "asdf"))
- (assert (typep found 'system))
- (setf found-system found pathname nil))))
- (values foundp found-system pathname previous previous-time)))
+ (with-asdf-cache (:key `(locate-system ,name))
+ (let* ((name (coerce-name name))
+ (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 (ensure-pathname
+ (or (and (typep found '(or pathname string)) (pathname found))
+ (and found-system (system-source-file found-system))
+ (and previous (system-source-file previous)))
+ :want-absolute t :resolve-symlinks *resolve-symlinks*))
+ (foundp (and (or found-system pathname previous) t)))
+ (check-type found (or null pathname system))
+ (unless (check-not-old-asdf-system name pathname)
+ (cond
+ (previous (setf found nil pathname nil))
+ (t
+ (setf found (sysdef-preloaded-system-search "asdf"))
+ (assert (typep found 'system))
+ (setf found-system found pathname nil))))
+ (values foundp found-system pathname previous previous-time))))
(defmethod find-system ((name string) &optional (error-p t))
- (with-system-definitions ()
+ (with-asdf-cache (:key `(find-system ,name))
+ (let ((primary-name (primary-system-name name)))
+ (unless (equal name primary-name)
+ (find-system primary-name nil)))
(loop
(restart-case
(multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name)
+ (when (and found-system (eq found-system previous)
+ (or (first (gethash `(find-system ,name) *asdf-cache*))
+ (and *immutable-systems* (gethash name *immutable-systems*))))
+ (return found-system))
(assert (eq foundp (and (or found-system pathname previous) t)))
(let ((previous-pathname (and previous (system-source-file previous)))
(system (or previous found-system)))
(or (pathname-equal pathname previous-pathname)
(and pathname previous-pathname
(pathname-equal
- (translate-logical-pathname pathname)
- (translate-logical-pathname previous-pathname))))
+ (physicalize-pathname pathname)
+ (physicalize-pathname previous-pathname))))
(stamp<= stamp previous-time))))))
;; only load when it's a pathname that is different or has newer content, and not an old asdf
(load-asd pathname :name name)))
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
+ (unset-asdf-cache-entry `(locate-system ,name))
(initialize-source-registry)))))))
;;;; -------------------------------------------------------------------------
;;;; Finding components
-(asdf/package:define-package :asdf/find-component
+(uiop/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system)
(:export
#:find-component
(defmethod find-component ((c component) (name cons))
(find-component (find-component c (car name)) (cdr name)))
- (defmethod find-component (base (actual component))
- (declare (ignorable base))
+ (defmethod find-component ((base t) (actual component))
actual)
(defun resolve-dependency-name (component name &optional version)
(or (null c)
(and (typep c 'missing-dependency)
(eq (missing-required-by c) component)
- (equal (missing-requires c) name))))))))
+ (equal (missing-requires c) name))))
+ (unless (component-parent component)
+ (let ((name (coerce-name name)))
+ (unset-asdf-cache-entry `(find-system ,name))
+ (unset-asdf-cache-entry `(locate-system ,name))))))))
+
(defun resolve-dependency-spec (component dep-spec)
(let ((component (find-component () component)))
(cons combinator arguments) component))
(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
- (declare (ignorable combinator))
(when (featurep (first arguments))
(resolve-dependency-spec component (second arguments))))
(defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
- (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788
- (resolve-dependency-name component (first arguments) (second arguments))))
+ (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
;;;; -------------------------------------------------------------------------
;;;; Operations
-(asdf/package:define-package :asdf/operation
+(uiop/package:define-package :asdf/operation
(:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:export
#:operation
#:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
- #:build-op ;; THE generic operation
- #:*operations* #:make-operation #:find-operation #:feature))
+ #:*operations* #:make-operation #:find-operation
+ #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
(in-package :asdf/operation)
;;; Operation Classes
(when-upgrading (:when (find-class 'operation nil))
- (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
- (declare (ignorable o slot-names initargs)) (values)))
+ ;; override any obsolete shared-initialize method when upgrading from ASDF2.
+ (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
+ (values)))
(with-upgradability ()
(defclass operation ()
((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
:initform nil :initarg :original-initargs :accessor operation-original-initargs)))
+ ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not
+ ;; already bound.
(defmethod initialize-instance :after ((o operation) &rest initargs
&key force force-not system verbose &allow-other-keys)
- (declare (ignorable force force-not system verbose))
+ (declare (ignore force force-not system verbose))
(unless (slot-boundp o 'original-initargs)
(setf (operation-original-initargs o) initargs)))
;;; make-operation, find-operation
(with-upgradability ()
- (defparameter *operations* (make-hash-table :test 'equal))
+ (defparameter* *operations* (make-hash-table :test 'equal))
+
(defun make-operation (operation-class &rest initargs)
- (let ((key (cons operation-class initargs)))
- (multiple-value-bind (operation foundp) (gethash key *operations*)
- (if foundp operation
- (setf (gethash key *operations*)
- (apply 'make-instance operation-class initargs))))))
+ (let ((class (coerce-class operation-class
+ :package :asdf/interface :super 'operation :error 'sysdef-error)))
+ (ensure-gethash (cons class initargs) *operations*
+ (list* 'make-instance class initargs))))
(defgeneric find-operation (context spec)
(:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
- (defmethod find-operation (context (spec operation))
- (declare (ignorable context))
+ (defmethod find-operation ((context t) (spec operation))
spec)
(defmethod find-operation (context (spec symbol))
- (unless (member spec '(nil feature))
- ;; NIL designates itself, i.e. absence of operation
- ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS
+ (when spec ;; NIL designates itself, i.e. absence of operation
(apply 'make-operation spec (operation-original-initargs context))))
+ (defmethod find-operation (context (spec string))
+ (apply 'make-operation spec (operation-original-initargs context)))
(defmethod operation-original-initargs ((context symbol))
(declare (ignorable context))
- nil)
-
- (defclass build-op (operation) ()))
-
+ nil))
;;;; -------------------------------------------------------------------------
;;;; Actions
-(asdf/package:define-package :asdf/action
+(uiop/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
(:export
#:action #:define-convenience-action-methods
#:explain #:action-description
- #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
+ #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
#:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept
#:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
- #:action-path #:find-action #:stamp #:done-p))
+ #:action-path #:find-action #:stamp #:done-p
+ #:operation-definition-warning #:operation-definition-error ;; condition
+ ))
(in-package :asdf/action)
-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
- (deftype action () '(cons operation component))) ;; a step to be performed while building
+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
+ (deftype action () '(cons operation component)) ;; a step to be performed while building
+
+ (deftype operation-designator ()
+ ;; an operation designates itself,
+ ;; nil designates a context-dependent current operation, and
+ ;; class-name or class designates an instance of the designated class.
+ '(or operation null symbol class)))
(with-upgradability ()
(defgeneric traverse-actions (actions &key &allow-other-keys))
;;;; Convenience methods
(with-upgradability ()
(defmacro define-convenience-action-methods
- (function (operation component &optional keyp)
- &key if-no-operation if-no-component operation-initargs)
+ (function formals &key if-no-operation if-no-component operation-initargs)
(let* ((rest (gensym "REST"))
(found (gensym "FOUND"))
+ (keyp (equal (last formals) '(&key)))
+ (formals-no-key (if keyp (butlast formals) formals))
+ (len (length formals-no-key))
+ (operation 'operation)
+ (component 'component)
+ (opix (position operation formals))
+ (coix (position component formals))
+ (prefix (subseq formals 0 opix))
+ (suffix (subseq formals (1+ coix) len))
(more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
+ (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
(flet ((next-method (o c)
(if keyp
- `(apply ',function ,o ,c ,rest)
- `(,function ,o ,c))))
+ `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
+ `(,function ,@prefix ,o ,c ,@suffix))))
`(progn
- (defmethod ,function ((,operation symbol) ,component ,@more-args)
+ (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
+ (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
+ ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
+ (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)
(if ,operation
,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
`(make-operation ,operation))
`(or (find-component () ,component) ,if-no-component))
,if-no-operation))
- (defmethod ,function ((,operation operation) ,component ,@more-args)
+ (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
(if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component))
- (let ((,found (find-component () ,component)))
- (if ,found
- ,(next-method operation found)
- ,if-no-component)))))))))
+ (if-let (,found (find-component () ,component))
+ ,(next-method operation found)
+ ,if-no-component))))))))
;;;; self-description
and each <component> is a component designator with respect to
FIND-COMPONENT in the context of the COMPONENT argument,
and means that the component depends on
- <operation> having been performed on each <component>; or
+ <operation> having been performed on each <component>;
- (FEATURE <feature>), which means that the component depends
- on the <feature> expression satisfying FEATUREP.
- (This is DEPRECATED -- use :IF-FEATURE instead.)
+ [Note: an <operation> is an operation designator -- it can be either an
+ operation name or an operation object. Similarly, a <component> may be
+ a component name or a component object. Also note that, the degenerate
+ case of (<operation>) is a no-op.]
Methods specialized on subclasses of existing component types
should usually append the results of CALL-NEXT-METHOD to the list."))
(defmethod component-depends-on :around ((o operation) (c component))
(do-asdf-cache `(component-depends-on ,o ,c)
- (call-next-method)))
-
- (defmethod component-depends-on ((o operation) (c component))
- (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
+ (call-next-method))))
-;;;; upward-operation, downward-operation
-;; These together handle actions that propagate along the component hierarchy.
-;; Downward operations like load-op or compile-op propagate down the hierarchy:
-;; operation on a parent depends-on operation on its children.
-;; By default, an operation propagates itself, but it may propagate another one instead.
+;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
+;; These together handle actions that propagate along the component hierarchy or operation universe.
(with-upgradability ()
(defclass downward-operation (operation)
((downward-operation
- :initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
+ :initform nil :reader downward-operation
+ :type operation-designator :allocation :class))
+ (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
+I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
+the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
+The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
+E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
+children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
+ (defun downward-operation-depends-on (o c)
+ `((,(or (downward-operation o) o) ,@(component-children c))))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
- `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
- ;; Upward operations like prepare-op propagate up the component hierarchy:
- ;; operation on a child depends-on operation on its parent.
- ;; By default, an operation propagates itself, but it may propagate another one instead.
+ `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
+
(defclass upward-operation (operation)
((upward-operation
- :initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
+ :initform nil :reader upward-operation
+ :type operation-designator :allocation :class))
+ (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
+I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
+then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
+The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
+E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
+must first be prepared for loading or compiling with PREPARE-OP."))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
+ (defun upward-operation-depends-on (o c)
+ (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
(defmethod component-depends-on ((o upward-operation) (c child-component))
- `(,@(if-let (p (component-parent c))
- `((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
- ;; Sibling operations propagate to siblings in the component hierarchy:
- ;; operation on a child depends-on operation on its parent.
- ;; By default, an operation propagates itself, but it may propagate another one instead.
+ `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
+
(defclass sideway-operation (operation)
((sideway-operation
- :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
+ :initform nil :reader sideway-operation
+ :type operation-designator :allocation :class))
+ (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
+that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
+designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
+depends on each of (S . D) where D is a declared dependency of C.
+E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
+each of its declared dependencies must first be loaded as by LOAD-OP."))
+ (defun sideway-operation-depends-on (o c)
+ `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
(defmethod component-depends-on ((o sideway-operation) (c component))
- `((,(or (sideway-operation o) o)
- ,@(loop :for dep :in (component-sideway-dependencies c)
- :collect (resolve-dependency-spec c dep)))
- ,@(call-next-method)))
- ;; Selfward operations propagate to themselves a sub-operation:
- ;; they depend on some other operation being acted on the same component.
+ `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
+
(defclass selfward-operation (operation)
((selfward-operation
- :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
+ ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
+ :type (or operation-designator list) :reader selfward-operation :allocation :class))
+ (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
+I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
+then the action (O . C) of O on component C depends on each (S . C) for S in L.
+E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
+A operation-designator designates a singleton list of the designated operation;
+a list of operation-designators designates the list of designated operations;
+NIL is not a valid operation designator in that context. Note that any dependency
+ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
+in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
+ (defun selfward-operation-depends-on (o c)
+ (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
(defmethod component-depends-on ((o selfward-operation) (c component))
- `(,@(loop :for op :in (ensure-list (selfward-operation o))
- :collect `(,op ,c))
- ,@(call-next-method))))
+ `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
+
+ (defclass non-propagating-operation (operation)
+ ()
+ (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
+no dependencies whatsoever. It is supplied in order that the programmer be able
+to specify that s/he is intentionally specifying an operation which invokes no
+dependencies.")))
+
+
+;;;---------------------------------------------------------------------------
+;;; Help programmers catch obsolete OPERATION subclasses
+;;;---------------------------------------------------------------------------
+(with-upgradability ()
+ (define-condition operation-definition-warning (simple-warning)
+ ()
+ (:documentation "Warning condition related to definition of obsolete OPERATION objects."))
+
+ (define-condition operation-definition-error (simple-error)
+ ()
+ (:documentation "Error condition related to definition of incorrect OPERATION objects."))
+
+ (defmethod initialize-instance :before ((o operation) &key)
+ (unless (typep o '(or downward-operation upward-operation sideway-operation
+ selfward-operation non-propagating-operation))
+ (warn 'operation-definition-warning
+ :format-control
+ "No dependency propagating scheme specified for operation class ~S.
+The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
+ :format-arguments (list (type-of o)))))
+
+ (defmethod initialize-instance :before ((o non-propagating-operation) &key)
+ (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
+ (error 'operation-definition-error
+ :format-control
+ "Inconsistent class: ~S
+ NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
+ :format-arguments
+ (list (type-of o)))))
+
+ (defmethod component-depends-on ((o operation) (c component))
+ `(;; Normal behavior, to allow user-specified in-order-to dependencies
+ ,@(cdr (assoc (type-of o) (component-in-order-to c)))
+ ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
+ ;; or non-propagation through an appropriate mixin will be downward and sideway.
+ ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
+ selfward-operation non-propagating-operation))
+ `(,@(sideway-operation-depends-on o c)
+ ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))))
+
+ (defmethod downward-operation ((o operation)) nil)
+ (defmethod sideway-operation ((o operation)) nil))
+
+
+;;;---------------------------------------------------------------------------
+;;; End of OPERATION class checking
+;;;---------------------------------------------------------------------------
;;;; Inputs, Outputs, and invisible dependencies
(define-convenience-action-methods operation-done-p (operation component))
(defmethod operation-done-p ((o operation) (c component))
- (declare (ignorable o c))
t)
(defmethod output-files :around (operation component)
(mapcar *output-translation-function* absolute-pathnames))))
t)))
(defmethod output-files ((o operation) (c component))
- (declare (ignorable o c))
nil)
(defun output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(call-next-method)))
(defmethod input-files ((o operation) (c component))
- (declare (ignorable o c))
nil)
(defmethod input-files ((o selfward-operation) (c component))
(defmethod perform :after ((o operation) (c component))
(mark-operation-done o c))
(defmethod perform ((o operation) (c parent-component))
- (declare (ignorable o c))
nil)
(defmethod perform ((o operation) (c source-file))
- (sysdef-error
- (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
- (class-of o) (class-of c)))
+ ;; For backward compatibility, don't error on operations that don't specify propagation.
+ (when (typep o '(or downward-operation upward-operation sideway-operation
+ selfward-operation non-propagating-operation))
+ (sysdef-error
+ (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
+ 'perform (cons o c))))
(defmethod perform-with-restarts (operation component)
;; TOO verbose, especially as the default. Add your own :before method
(action-description operation component)))
(mark-operation-done operation component)
(return))))))
-
-;;; Generic build operation
-(with-upgradability ()
- (defmethod component-depends-on ((o build-op) (c component))
- `((,(or (component-build-operation c) 'load-op) ,c))))
-
;;;; -------------------------------------------------------------------------
;;;; Actions to build Common Lisp software
-(asdf/package:define-package :asdf/lisp-action
+(uiop/package:define-package :asdf/lisp-action
(:recycle :asdf/lisp-action :asdf)
(:intern #:proclamations #:flags)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
+ :asdf/component :asdf/system :asdf/find-component :asdf/find-system
:asdf/operation :asdf/action)
(:export
#:try-recompiling
(defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
- (flags :initarg :flags :accessor compile-op-flags
- :initform nil))))
+ (flags :initarg :flags :accessor compile-op-flags :initform nil))))
;;; Our default operations: loading into the current lisp image
(with-upgradability ()
(defclass prepare-op (upward-operation sideway-operation)
- ((sideway-operation :initform 'load-op)))
- (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
- ;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p,
+ ((sideway-operation :initform 'load-op :allocation :class))
+ (:documentation "Load dependencies necessary for COMPILE-OP or LOAD-OP of a given COMPONENT."))
+ (defclass load-op (basic-load-op downward-operation selfward-operation)
+ ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
;; so we need to directly depend on prepare-op for its side-effects in the current image.
- ((selfward-operation :initform '(prepare-op compile-op))))
+ ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)))
(defclass compile-op (basic-compile-op downward-operation selfward-operation)
- ((selfward-operation :initform 'prepare-op)
- (downward-operation :initform 'load-op)))
+ ((selfward-operation :initform 'prepare-op :allocation :class)))
(defclass prepare-source-op (upward-operation sideway-operation)
- ((sideway-operation :initform 'load-source-op)))
+ ((sideway-operation :initform 'load-source-op :allocation :class)))
(defclass load-source-op (basic-load-op downward-operation selfward-operation)
- ((selfward-operation :initform 'prepare-source-op)))
+ ((selfward-operation :initform 'prepare-source-op :allocation :class)))
(defclass test-op (selfward-operation)
- ((selfward-operation :initform 'load-op))))
+ ((selfward-operation :initform 'load-op :allocation :class))))
;;;; prepare-op, compile-op and load-op
;;; prepare-op
(with-upgradability ()
(defmethod action-description ((o prepare-op) (c component))
- (declare (ignorable o))
(format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
(defmethod perform ((o prepare-op) (c component))
- (declare (ignorable o c))
- nil)
- (defmethod input-files ((o prepare-op) (c component))
- (declare (ignorable o c))
nil)
(defmethod input-files ((o prepare-op) (s system))
- (declare (ignorable o))
(if-let (it (system-source-file s)) (list it))))
;;; compile-op
(with-upgradability ()
(defmethod action-description ((o compile-op) (c component))
- (declare (ignorable o))
(format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
(defmethod action-description ((o compile-op) (c parent-component))
- (declare (ignorable o))
(format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
(defgeneric call-with-around-compile-hook (component thunk))
(defmethod call-with-around-compile-hook ((c component) function)
warnings-file) outputs
(call-with-around-compile-hook
c #'(lambda (&rest flags)
- (with-muffled-compiler-conditions ()
- (apply 'compile-file* input-file
- :output-file output-file
- :external-format (component-external-format c)
- :warnings-file warnings-file
- (append
- #+clisp (list :lib-file lib-file)
- #+(or ecl mkcl) (list :object-file object-file)
- flags (compile-op-flags o)))))))
+ (apply 'compile-file* input-file
+ :output-file output-file
+ :external-format (component-external-format c)
+ :warnings-file warnings-file
+ (append
+ #+clisp (list :lib-file lib-file)
+ #+(or ecl mkcl) (list :object-file object-file)
+ flags (compile-op-flags o))))))
(check-lisp-compile-results output warnings-p failure-p
"~/asdf-action::format-action/" (list (cons o c))))))
(defmethod output-files ((o compile-op) (c cl-source-file))
(lisp-compilation-output-files o c))
(defmethod perform ((o compile-op) (c static-file))
- (declare (ignorable o c))
- nil)
- (defmethod output-files ((o compile-op) (c static-file))
- (declare (ignorable o c))
nil)
(defmethod perform ((o compile-op) (c system))
(when (and *warnings-file-type* (not (builtin-system-p c)))
;;; load-op
(with-upgradability ()
(defmethod action-description ((o load-op) (c cl-source-file))
- (declare (ignorable o))
(format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
(defmethod action-description ((o load-op) (c parent-component))
- (declare (ignorable o))
(format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
- (defmethod action-description ((o load-op) component)
- (declare (ignorable o))
- (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
- component))
+ (defmethod action-description ((o load-op) (c component))
+ (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
(loop
(restart-case
(perform (find-operation o 'compile-op) c)))))
(defun perform-lisp-load-fasl (o c)
(if-let (fasl (first (input-files o c)))
- (with-muffled-loader-conditions () (load* fasl))))
+ (load* fasl)))
(defmethod perform ((o load-op) (c cl-source-file))
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
- (declare (ignorable o c))
nil))
;;; prepare-source-op
(with-upgradability ()
(defmethod action-description ((o prepare-source-op) (c component))
- (declare (ignorable o))
(format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
- (defmethod input-files ((o prepare-source-op) (c component))
- (declare (ignorable o c))
- nil)
(defmethod input-files ((o prepare-source-op) (s system))
- (declare (ignorable o))
(if-let (it (system-source-file s)) (list it)))
(defmethod perform ((o prepare-source-op) (c component))
- (declare (ignorable o c))
nil))
;;; load-source-op
(with-upgradability ()
- (defmethod action-description ((o load-source-op) c)
- (declare (ignorable o))
+ (defmethod action-description ((o load-source-op) (c component))
(format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
(defmethod action-description ((o load-source-op) (c parent-component))
- (declare (ignorable o))
(format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
(defun perform-lisp-load-source (o c)
(call-with-around-compile-hook
c #'(lambda ()
- (with-muffled-loader-conditions ()
- (load* (first (input-files o c))
- :external-format (component-external-format c))))))
+ (load* (first (input-files o c))
+ :external-format (component-external-format c)))))
(defmethod perform ((o load-source-op) (c cl-source-file))
(perform-lisp-load-source o c))
(defmethod perform ((o load-source-op) (c static-file))
- (declare (ignorable o c))
- nil)
- (defmethod output-files ((o load-source-op) (c component))
- (declare (ignorable o c))
nil))
;;;; test-op
(with-upgradability ()
(defmethod perform ((o test-op) (c component))
- (declare (ignorable o c))
nil)
(defmethod operation-done-p ((o test-op) (c system))
"Testing a system is _never_ done."
- (declare (ignorable o c))
nil))
;;;; -------------------------------------------------------------------------
;;;; Plan
-(asdf/package:define-package :asdf/plan
+(uiop/package:define-package :asdf/plan
(:recycle :asdf/plan :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/operation :asdf/system
:asdf/cache :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action)
(:export
#:component-operation-time #:mark-operation-done
- #:plan-traversal #:sequential-plan #:*default-plan-class*
+ #:plan #:plan-traversal #:sequential-plan #:*default-plan-class*
#:planned-action-status #:plan-action-status #:action-already-done-p
#:circular-dependency #:circular-dependency-actions
#:node-for #:needed-in-image-p
#:plan-record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
- #:visit-dependencies #:compute-action-stamp #:traverse-action
+ #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action
- #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
+ #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:total-action-count
#:planned-action-count #:planned-output-action-count #:visited-actions
#:visiting-action-set #:visiting-action-list #:plan-actions-r
;;;; Generic plan traversal class
(with-upgradability ()
- (defclass plan-traversal ()
+ (defclass plan () ())
+ (defclass plan-traversal (plan)
((system :initform nil :initarg :system :accessor plan-system)
(forced :initform nil :initarg :force :accessor plan-forced)
(forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
(with-slots (stamp done-p planned-p index) status
(format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index))))
- (defmethod action-planned-p (action-status)
- (declare (ignorable action-status)) ; default method for non planned-action-status objects
- t)
+ (defmethod action-planned-p ((action-status t))
+ t) ; default method for non planned-action-status objects
;; TODO: eliminate NODE-FOR, use CONS.
;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION.
(action-done-p (plan-action-status plan operation component)))
(defmethod plan-action-status ((plan null) (o operation) (c component))
- (declare (ignorable plan))
(multiple-value-bind (stamp done-p) (component-operation-time o c)
(make-instance 'action-status :stamp stamp :done-p done-p)))
(defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
- (declare (ignorable plan))
(let ((to (type-of o))
(times (component-operation-times c)))
(if (action-done-p new-status)
(defun normalize-forced-systems (x system)
(etypecase x
- ((member nil :all) x)
+ ((or (member nil :all) hash-table function) x)
(cons (list-to-hash-set (mapcar #'coerce-name x)))
((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
+ (defun normalize-forced-not-systems (x system)
+ (let ((requested
+ (etypecase x
+ ((or (member nil :all) hash-table function) x)
+ (cons (list-to-hash-set (mapcar #'coerce-name x)))
+ ((eql t) (if system (let ((name (coerce-name system)))
+ #'(lambda (x) (not (equal x name))))
+ t)))))
+ (if (and *immutable-systems* requested)
+ #'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x)))
+ (or *immutable-systems* requested))))
+
(defun action-override-p (plan operation component override-accessor)
- (declare (ignorable operation))
- (let* ((override (funcall override-accessor plan)))
- (and override
- (if (typep override 'hash-table)
- (gethash (coerce-name (component-system (find-component () component))) override)
- t))))
+ (declare (ignore operation))
+ (call-function (funcall override-accessor plan)
+ (coerce-name (component-system (find-component () component)))))
(defmethod action-forced-p (plan operation component)
(and
(not (eq system (plan-system plan))))))))
(defmethod action-forced-not-p (plan operation component)
- (and
- ;; Did the user ask us to not re-perform the action?
- (action-override-p plan operation component 'plan-forced-not)
- ;; Force takes precedence over force-not
- (not (action-forced-p plan operation component))))
+ ;; Did the user ask us to not re-perform the action?
+ ;; NB: force-not takes precedence over force, as it should
+ (action-override-p plan operation component 'plan-forced-not))
- (defmethod action-forced-p ((plan null) operation component)
- (declare (ignorable plan operation component))
+ (defmethod action-forced-p ((plan null) (operation operation) (component component))
nil)
- (defmethod action-forced-not-p ((plan null) operation component)
- (declare (ignorable plan operation component))
+ (defmethod action-forced-not-p ((plan null) (operation operation) (component component))
nil))
(with-upgradability ()
(defgeneric action-valid-p (plan operation component)
(:documentation "Is this action valid to include amongst dependencies?"))
- (defmethod action-valid-p (plan operation (c component))
- (declare (ignorable plan operation))
+ (defmethod action-valid-p ((plan t) (o operation) (c component))
(if-let (it (component-if-feature c)) (featurep it) t))
- (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil)
- (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil)
- (defmethod action-valid-p ((plan null) operation component)
- (declare (ignorable plan operation component))
- (and operation component t)))
-
+ (defmethod action-valid-p ((plan t) (o null) (c t)) nil)
+ (defmethod action-valid-p ((plan t) (o t) (c null)) nil)
+ (defmethod action-valid-p ((plan null) (o operation) (c component)) t))
;;;; Is the action needed in this image?
(with-upgradability ()
;;;; Visiting dependencies of an action and computing action stamps
(with-upgradability ()
- (defun map-direct-dependencies (operation component fun)
+ (defun (map-direct-dependencies) (plan operation component fun)
(loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
:for dep-o = (find-operation operation dep-o-spec)
:when dep-o
:do (loop :for dep-c-spec :in dep-c-specs
:for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
- :when dep-c
+ :when (and dep-c (action-valid-p plan dep-o dep-c))
:do (funcall fun dep-o dep-c))))
- (defun reduce-direct-dependencies (operation component combinator seed)
+ (defun (reduce-direct-dependencies) (plan operation component combinator seed)
(map-direct-dependencies
- operation component
+ plan operation component
#'(lambda (dep-o dep-c)
(setf seed (funcall combinator dep-o dep-c seed))))
seed)
- (defun direct-dependencies (operation component)
- (reduce-direct-dependencies operation component #'acons nil))
+ (defun (direct-dependencies) (plan operation component)
+ (reduce-direct-dependencies plan operation component #'acons nil))
- (defun visit-dependencies (plan operation component dependency-stamper &aux stamp)
- (map-direct-dependencies
- operation component
- #'(lambda (dep-o dep-c)
- (when (action-valid-p plan dep-o dep-c)
- (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
- stamp)
+ ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
+ ;; shall also be parametrized by the plan, or by a second model object,
+ ;; so they need not refer to the state of the filesystem,
+ ;; and the stamps could be cryptographic checksums rather than timestamps.
+ ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.
(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
- ;; In a distant future, get-file-stamp and component-operation-time
- ;; shall also be parametrized by the plan, or by a second model object.
- (let* ((stamp-lookup #'(lambda (o c)
- (if-let (it (plan-action-status plan o c)) (action-stamp it) t)))
- (out-files (output-files o c))
- (in-files (input-files o c))
- ;; Three kinds of actions:
- (out-op (and out-files t)) ; those that create files on the filesystem
- ;(image-op (and in-files (null out-files))) ; those that load stuff into the image
- ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing
- ;; When was the thing last actually done? (Now, or ask.)
- (op-time (or just-done (component-operation-time o c)))
- ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
- (dep-stamp (visit-dependencies plan o c stamp-lookup))
- ;; Time stamps from the files at hand, and whether any is missing
- (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
- (in-stamps (mapcar #'get-file-stamp in-files))
- (missing-in
- (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
- (missing-out
- (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
- (all-present (not (or missing-in missing-out)))
- ;; Has any input changed since we last generated the files?
- (earliest-out (stamps-earliest out-stamps))
- (latest-in (stamps-latest (cons dep-stamp in-stamps)))
- (up-to-date-p (stamp<= latest-in earliest-out))
- ;; If everything is up to date, the latest of inputs and outputs is our stamp
- (done-stamp (stamps-latest (cons latest-in out-stamps))))
- ;; Warn if some files are missing:
- ;; either our model is wrong or some other process is messing with our files.
- (when (and just-done (not all-present))
- (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
- ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
- (action-description o c)
- missing-in (length missing-in) (and missing-in missing-out)
- missing-out (length missing-out)))
- ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
- ;; Any race condition is intrinsic to the limited timestamp resolution.
- (if (or just-done ;; The done-stamp is valid: if we're just done, or
- ;; if all filesystem effects are up-to-date and there's no invalidating reason.
- (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
- (values done-stamp ;; return the hard-earned timestamp
- (or just-done
- out-op ;; a file-creating op is done when all files are up to date
- ;; a image-effecting a placeholder op is done when it was actually run,
- (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
- ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
- (values t nil)))))
+ ;; Given an action, figure out at what time in the past it has been done,
+ ;; or if it has just been done, return the time that it has.
+ ;; Returns two values:
+ ;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
+ ;; or T is either hasn't been done or is out of date.
+ ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
+ ;; in the current image, or NIL if it hasn't.
+ ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
+ ;; hasn't been done in the current image yet, then it can have a non-T timestamp,
+ ;; yet a NIL done-in-image-p flag.
+ (nest
+ (block ())
+ (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date)
+ (reduce-direct-dependencies
+ plan o c
+ #'(lambda (o c stamp)
+ (if-let (it (plan-action-status plan o c))
+ (latest-stamp stamp (action-stamp it))
+ t))
+ nil)))
+ ;; out-of-date dependency: don't bother expensively querying the filesystem
+ (when (and (eq dep-stamp t) (not just-done)) (return (values t nil))))
+ ;; collect timestamps from inputs, and exit early if any is missing
+ (let* ((in-files (input-files o c))
+ (in-stamps (mapcar #'get-file-stamp in-files))
+ (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
+ (latest-in (stamps-latest (cons dep-stamp in-stamps))))
+ (when (and missing-in (not just-done)) (return (values t nil))))
+ ;; collect timestamps from outputs, and exit early if any is missing
+ (let* ((out-files (output-files o c))
+ (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
+ (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
+ (earliest-out (stamps-earliest out-stamps)))
+ (when (and missing-out (not just-done)) (return (values t nil))))
+ (let* (;; There are three kinds of actions:
+ (out-op (and out-files t)) ; those that create files on the filesystem
+ ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
+ ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
+ ;; When was the thing last actually done? (Now, or ask.)
+ (op-time (or just-done (component-operation-time o c)))
+ ;; Time stamps from the files at hand, and whether any is missing
+ (all-present (not (or missing-in missing-out)))
+ ;; Has any input changed since we last generated the files?
+ (up-to-date-p (stamp<= latest-in earliest-out))
+ ;; If everything is up to date, the latest of inputs and outputs is our stamp
+ (done-stamp (stamps-latest (cons latest-in out-stamps))))
+ ;; Warn if some files are missing:
+ ;; either our model is wrong or some other process is messing with our files.
+ (when (and just-done (not all-present))
+ (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
+ ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
+ (action-description o c)
+ missing-in (length missing-in) (and missing-in missing-out)
+ missing-out (length missing-out))))
+ ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
+ ;; Any race condition is intrinsic to the limited timestamp resolution.
+ (if (or just-done ;; The done-stamp is valid: if we're just done, or
+ ;; if all filesystem effects are up-to-date and there's no invalidating reason.
+ (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
+ (values done-stamp ;; return the hard-earned timestamp
+ (or just-done
+ out-op ;; a file-creating op is done when all files are up to date
+ ;; a image-effecting a placeholder op is done when it was actually run,
+ (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
+ ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
+ (values t nil)))))
;;;; Generic support for plan-traversal
(:documentation "Detect circular dependencies"))
(defmethod initialize-instance :after ((plan plan-traversal)
- &key (force () fp) (force-not () fnp) system
+ &key force force-not system
&allow-other-keys)
(with-slots (forced forced-not) plan
- (when fp (setf forced (normalize-forced-systems force system)))
- (when fnp (setf forced-not (normalize-forced-systems force-not system)))))
+ (setf forced (normalize-forced-systems force system))
+ (setf forced-not (normalize-forced-not-systems force-not system))))
(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component))
(setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
(defgeneric traverse-action (plan operation component needed-in-image-p))
+ ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
+ ;; visits the action defined by its OPERATION and COMPONENT arguments,
+ ;; and all its transitive dependencies (unless already visited),
+ ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P,
+ ;; i.e. needs to be done in the current image vs merely have been done in a previous image.
+ ;; For actions that are up-to-date, it returns a STAMP identifying the state of the action
+ ;; (that's timestamp, but it could be a cryptographic digest in some ASDF extension),
+ ;; or T if the action needs to be done again.
+ ;;
+ ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action,
+ ;; the below method would be insufficient, since it assumes a single image
+ ;; to traverse each node at most twice; non-niip actions would be traversed only once,
+ ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
+
(defmethod traverse-action (plan operation component needed-in-image-p)
(block nil
+ ;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT,
+ ;; and IF-FEATURE filtering.
(unless (action-valid-p plan operation component) (return nil))
+ ;; the following hook is needed by POIU, which tracks a full dependency graph,
+ ;; instead of just a dependency order as in vanilla ASDF
(plan-record-dependency plan operation component)
- (let* ((aniip (needed-in-image-p operation component))
+ ;; needed in image distinguishes b/w things that must happen in the
+ ;; current image and those things that simply need to have been done in a previous one.
+ (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
+ ;; effective niip: meaningful for the action and required by the plan as traversed
(eniip (and aniip needed-in-image-p))
+ ;; status: have we traversed that action previously, and if so what was its status?
(status (plan-action-status plan operation component)))
(when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
- ;; Already visited with sufficient need-in-image level: just return the stamp.
- (return (action-stamp status)))
- (labels ((visit-action (niip)
- (visit-dependencies plan operation component
- #'(lambda (o c) (traverse-action plan o c niip)))
- (multiple-value-bind (stamp done-p)
- (compute-action-stamp plan operation component)
+ (return (action-stamp status))) ; Already visited with sufficient need-in-image level!
+ (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
+ (map-direct-dependencies ; recursively traverse dependencies
+ plan operation component #'(lambda (o c) (traverse-action plan o c niip)))
+ (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed,
+ (compute-action-stamp plan operation component) ; compute action stamp
(let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))
- (cond
- ((and add-to-plan-p (not niip)) ;; if we need to do it,
- (visit-action t)) ;; then we need to do it in the image!
+ (cond ; it needs be done if it's out of date or needed in image but absent
+ ((and add-to-plan-p (not niip)) ; if we need to do it,
+ (visit-action t)) ; then we need to do it *in the (current) image*!
(t
- (setf (plan-action-status plan operation component)
+ (setf (plan-action-status plan operation component) ; update status:
(make-instance
'planned-action-status
- :stamp stamp
- :done-p (and done-p (not add-to-plan-p))
- :planned-p add-to-plan-p
- :index (if status (action-index status) (incf (plan-total-action-count plan)))))
- (when add-to-plan-p
- (incf (plan-planned-action-count plan))
- (unless aniip
- (incf (plan-planned-output-action-count plan))))
- stamp))))))
+ :stamp stamp ; computed stamp
+ :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date?
+ :planned-p add-to-plan-p ; included in list of things to be done?
+ :index (if status ; index of action amongst all nodes in traversal
+ (action-index status) ;; if already visited, keep index
+ (incf (plan-total-action-count plan))))) ; else new index
+ (when add-to-plan-p ; if it needs to be added to the plan,
+ (incf (plan-planned-action-count plan)) ; count it
+ (unless aniip ; if it's output-producing,
+ (incf (plan-planned-output-action-count plan)))) ; count it
+ stamp)))))) ; return the stamp
(while-visiting-action (plan operation component) ; maintain context, handle circularity.
- (visit-action eniip)))))))
+ (visit-action eniip))))))) ; visit the action
;;;; Sequential plans (the default)
((actions-r :initform nil :accessor plan-actions-r)))
(defgeneric plan-actions (plan))
+ (defmethod plan-actions ((plan list))
+ plan)
(defmethod plan-actions ((plan sequential-plan))
(reverse (plan-actions-r plan)))
- (defmethod plan-record-dependency ((plan sequential-plan)
- (operation operation) (component component))
- (declare (ignorable plan operation component))
+ (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component))
(values))
(defmethod (setf plan-action-status) :after
(when (action-planned-p new-status)
(push (cons o c) (plan-actions-r p)))))
-
-;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
+;;;; High-level interface: traverse, perform-plan, plan-operates-on-p
(with-upgradability ()
- (defgeneric* (traverse) (operation component &key &allow-other-keys)
+ (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
(: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."))
- (define-convenience-action-methods traverse (operation component &key))
+ "Generate and return a plan for performing OPERATION on COMPONENT."))
+ (define-convenience-action-methods make-plan (plan-class operation component &key))
(defgeneric perform-plan (plan &key))
(defgeneric plan-operates-on-p (plan component))
(defvar *default-plan-class* 'sequential-plan)
- (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
- (let ((plan (apply 'make-instance
- (or plan-class *default-plan-class*)
- :system (component-system c) (remove-plist-key :plan-class keys))))
+ (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
+ (let ((plan (apply 'make-instance (or plan-class *default-plan-class*)
+ :system (component-system c) keys)))
(traverse-action plan o c t)
- (plan-actions plan)))
+ plan))
- (defmethod perform-plan :around (plan &key)
- (declare (ignorable plan))
+ (defmethod perform-plan :around ((plan t) &key)
+ #+xcl (declare (ignorable plan))
(let ((*package* *package*)
(*readtable* *readtable*))
(with-compilation-unit () ;; backward-compatibility.
(call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
+ (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
+ (apply 'perform-plan (plan-actions plan) keys))
+
(defmethod perform-plan ((steps list) &key force &allow-other-keys)
(loop* :for (o . c) :in steps
:when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
:do (perform-with-restarts o c)))
+ (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
+ (plan-operates-on-p (plan-actions plan) component-path))
+
(defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan)
:test 'equal :key 'component-find-path)))
-;;;; Incidental traversals
+;;;; Incidental traversals
+
+;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source
+;;; files required by a bundling operation.
(with-upgradability ()
(defclass filtered-sequential-plan (sequential-plan)
((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
(keep-component :initform t :initarg :keep-component :reader plan-keep-component)))
(defmethod initialize-instance :after ((plan filtered-sequential-plan)
- &key (force () fp) (force-not () fnp)
+ &key force force-not
other-systems)
(declare (ignore force force-not))
(with-slots (forced forced-not action-filter system) plan
- (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system)))
- (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system)))
+ (setf forced (normalize-forced-systems (if other-systems :all t) system))
+ (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system))
(setf action-filter (ensure-function action-filter))))
(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
(defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
- (loop* :for (o . c) :in actions :do
- (traverse-action plan o c t))
- (plan-actions plan)))
+ (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
+ plan))
- (define-convenience-action-methods traverse-sub-actions (o c &key))
- (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
- (apply 'traverse-actions (direct-dependencies operation component)
+ (define-convenience-action-methods traverse-sub-actions (operation component &key))
+ (defmethod traverse-sub-actions ((operation operation) (component component)
+ &rest keys &key &allow-other-keys)
+ (apply 'traverse-actions (direct-dependencies t operation component)
:system (component-system component) keys))
(defmethod plan-actions ((plan filtered-sequential-plan))
(with-slots (keep-operation keep-component) plan
(loop* :for (o . c) :in (call-next-method)
- :when (and (typep o keep-operation)
- (typep c keep-component))
+ :when (and (typep o keep-operation) (typep c keep-component))
:collect (cons o c))))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(remove-duplicates
- (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system
- (remove-plist-key :goal-operation keys)))
+ (mapcar 'cdr (plan-actions
+ (apply 'traverse-sub-actions goal-operation system
+ (remove-plist-key :goal-operation keys))))
:from-end t)))
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
-(asdf/package:define-package :asdf/operate
+(uiop/package:define-package :asdf/operate
(:recycle :asdf/operate :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/operation :asdf/action
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
(:export
#:operate #:oos
#:*systems-being-operated*
- #:build-system
- #:load-system #:load-systems #:compile-system #:test-system #:require-system
+ #:build-op #:make
+ #:load-system #:load-systems #:load-systems*
+ #:compile-system #:test-system #:require-system
#:*load-system-operation* #:module-provide-asdf
#:component-loaded-p #:already-loaded-systems))
(in-package :asdf/operate)
1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk).
-3. It then calls TRAVERSE with the operation and system as arguments
+3. It then calls MAKE-PLAN with the operation and system as arguments
-The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code.
-If a VERSION argument is supplied, then operate also ensures that the system found
-satisfies it using the VERSION-SATISFIES method.
+The operation of making a plan is wrapped in WITH-COMPILATION-UNIT and error
+handling code. If a VERSION argument is supplied, then operate also ensures
+that the system found satisfies it using the VERSION-SATISFIES method.
Note that dependencies may cause the operation to invoke other operations on the system
or its components: the new operations will be created with the same initargs as the original one.
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
- (declare (ignorable operation component))
(let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
- (operation-name (reify-symbol (etypecase operation
- (operation (type-of operation))
- (symbol operation))))
- (component-path (typecase component
+ (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
+ (etypecase operation
+ (operation (let ((name (type-of operation))
+ (initargs (operation-original-initargs operation)))
+ #'(lambda () (make-operation name :original-initargs initargs initargs))))
+ ((or symbol string) (constantly operation))))
+ (component-path (typecase component ;; to remake the component after ASDF upgrade
(component (component-find-path component))
(t component))))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined, its symbol uninterned, its package deleted.
(return-from operate
- (apply (find-symbol* 'operate :asdf)
- (unreify-symbol operation-name)
- component-path keys))))
+ (apply 'operate (funcall operation-remaker) component-path keys))))
;; Setup proper bindings around any operate call.
- (with-system-definitions ()
+ (with-asdf-cache ()
(let* ((*verbose-out* (and verbose *standard-output*))
(*compile-file-warnings-behaviour* on-warnings)
(*compile-file-failure-behaviour* on-failure))
(error 'missing-component-of-version :requires component :version version)))
(defmethod operate ((operation operation) (component component)
- &rest keys &key &allow-other-keys)
- (let ((plan (apply 'traverse operation component keys)))
+ &rest keys &key plan-class &allow-other-keys)
+ (let ((plan (apply 'make-plan plan-class operation component keys)))
(apply 'perform-plan plan keys)
(values operation plan)))
(with-upgradability ()
(defvar *load-system-operation* 'load-op
"Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
-You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
+You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle
or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
-This may change in the future as we will implement component-based strategy
-for how to load or compile stuff")
+The default operation may change in the future if we implement a
+component-directed strategy for how to load or compile systems.")
- (defun build-system (system &rest keys)
- "Shorthand for `(operate 'asdf:build-op system)`."
+ (defmethod component-depends-on ((o prepare-op) (s system))
+ `((,*load-system-operation* ,@(component-sideway-dependencies s))))
+
+ (defclass build-op (non-propagating-operation) ()
+ (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
+to operate by default on a system or component, via the function BUILD.
+Its meaning is configurable via the :BUILD-OPERATION option of a component.
+which typically specifies the name of a specific operation to which to delegate the build,
+as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
+if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
+that will load the system in the current image, and its typically LOAD-OP."))
+ (defmethod component-depends-on ((o build-op) (c component))
+ `((,(or (component-build-operation c) *load-system-operation*) ,c)))
+
+ (defun make (system &rest keys)
+ "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
+It will build system FOO using the operation BUILD-OP,
+the meaning of which is configurable by the system, and
+defaults to *LOAD-SYSTEM-OPERATION*, usually LOAD-OP,
+to load it in current image."
(apply 'operate 'build-op system keys)
t)
(apply 'operate *load-system-operation* system keys)
t)
+ (defun load-systems* (systems &rest keys)
+ "Loading multiple systems at once."
+ (dolist (s systems) (apply 'load-system s keys)))
+
(defun load-systems (&rest systems)
"Loading multiple systems at once."
- (map () 'load-system systems))
+ (load-systems* systems))
(defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
"Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
(defvar *modules-being-required* nil)
(defclass require-system (system)
- ((module :initarg :module :initform nil :accessor required-module)))
+ ((module :initarg :module :initform nil :accessor required-module))
+ (:documentation "A SYSTEM subclass whose processing is handled by
+the implementation's REQUIRE rather than by internal ASDF mechanisms."))
(defmethod perform ((o compile-op) (c require-system))
- (declare (ignorable o c))
nil)
(defmethod perform ((o load-op) (s require-system))
- (declare (ignorable o))
(let* ((module (or (required-module s) (coerce-name s)))
(*modules-being-required* (cons module *modules-being-required*)))
(assert (null (component-children s)))
(require module)))
(defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
- (declare (ignorable component combinator))
(unless (length=n-p arguments 1)
(error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
(cons combinator arguments) component combinator))
(with-upgradability ()
(defun restart-upgraded-asdf ()
;; If we're in the middle of something, restart it.
- (when *systems-being-defined*
- (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
- (clrhash *systems-being-defined*)
+ (when *asdf-cache*
+ (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
+ :when (eq x 'find-system) :collect y)))
+ (clrhash *asdf-cache*)
(dolist (s l) (find-system s nil)))))
-
(register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
-;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility
+;;;; ---------------------------------------------------------------------------
+;;;; asdf-output-translations
-(asdf/package:define-package :asdf/backward-internals
- (:recycle :asdf/backward-internals :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/system :asdf/component :asdf/operation
- :asdf/find-system :asdf/action :asdf/lisp-action)
- (:export ;; for internal use
- #:load-sysdef #:make-temporary-package
- #:%refresh-component-inline-methods
- #:%resolve-if-component-dep-fails
- #:make-sub-operation
- #:load-sysdef #:make-temporary-package))
-(in-package :asdf/backward-internals)
+(uiop/package:define-package :asdf/output-translations
+ (:recycle :asdf/output-translations :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade)
+ (:export
+ #:*output-translations* #:*output-translations-parameter*
+ #:invalid-output-translation
+ #:output-translations #:output-translations-initialized-p
+ #:initialize-output-translations #:clear-output-translations
+ #:disable-output-translations #:ensure-output-translations
+ #:apply-output-translations
+ #:validate-output-translations-directive #:validate-output-translations-form
+ #:validate-output-translations-file #:validate-output-translations-directory
+ #:parse-output-translations-string #:wrapping-output-translations
+ #:user-output-translations-pathname #:system-output-translations-pathname
+ #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
+ #:environment-output-translations #:process-output-translations
+ #:compute-output-translations
+ #+abcl #:translate-jar-pathname
+ ))
+(in-package :asdf/output-translations)
+
+(when-upgrading () (undefine-function '(setf output-translations)))
-;;;; Backward compatibility with "inline methods"
(with-upgradability ()
- (defparameter +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
+ (define-condition invalid-output-translation (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
- (defun %remove-component-inline-methods (component)
- (dolist (name +asdf-methods+)
- (map ()
- ;; 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))
- (component-inline-methods component)))
- (component-inline-methods component) nil)
+ (defvar *output-translations* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a sorted list of mappings.
+Each mapping is a pair of a source pathname and destination pathname,
+and the order is by decreasing length of namestring of the source pathname.")
- (defun %define-component-inline-methods (ret rest)
- (loop* :for (key value) :on rest :by #'cddr
- :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
- :when name :do
- (destructuring-bind (op &rest body) value
- (loop :for arg = (pop body)
- :while (atom arg)
- :collect arg :into qualifiers
- :finally
- (destructuring-bind (o c) arg
- (pushnew
- (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
- (component-inline-methods ret)))))))
+ (defun output-translations ()
+ (car *output-translations*))
- (defun %refresh-component-inline-methods (component rest)
- ;; clear methods, then add the new ones
- (%remove-component-inline-methods component)
- (%define-component-inline-methods component rest)))
+ (defun set-output-translations (new-value)
+ (setf *output-translations*
+ (list
+ (stable-sort (copy-list new-value) #'>
+ :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* ((setf output-translations)) (new-value) (set-output-translations new-value))
-;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
-;; and the companion asdf:feature pseudo-dependency.
-;; This won't recurse into dependencies to accumulate feature conditions.
-;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
-;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
-(with-upgradability ()
- (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
- (asdf-message "The system definition for ~S uses deprecated ~
- ASDF option :IF-COMPONENT-DEP-DAILS. ~
- Starting with ASDF 3, please use :IF-FEATURE instead"
- (coerce-name (component-system component)))
- ;; This only supports the pattern of use of the "feature" seen in the wild
- (check-type component parent-component)
- (check-type if-component-dep-fails (member :fail :ignore :try-next))
- (unless (eq if-component-dep-fails :fail)
- (loop :with o = (make-operation 'compile-op)
- :for c :in (component-children component) :do
- (loop* :for (feature? feature) :in (component-depends-on o c)
- :when (eq feature? 'feature) :do
- (setf (component-if-feature c) feature))))))
+ (defun output-translations-initialized-p ()
+ (and *output-translations* t))
-(when-upgrading (:when (fboundp 'make-sub-operation))
- (defun make-sub-operation (c o dep-c dep-o)
- (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
+ (defun clear-output-translations ()
+ "Undoes any initialization of the output translations."
+ (setf *output-translations* '())
+ (values))
+ (register-clear-configuration-hook 'clear-output-translations)
+ (defun validate-output-translations-directive (directive)
+ (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)))))))
-;;;; load-sysdef
-(with-upgradability ()
- (defun load-sysdef (name pathname)
- (load-asd pathname :name name))
+ (defun validate-output-translations-form (form &key location)
+ (validate-configuration-form
+ form
+ :output-translations
+ 'validate-output-translations-directive
+ :location location :invalid-form-reporter 'invalid-output-translation))
- (defun make-temporary-package ()
- ;; For loading a .asd file, we dont't make a temporary package anymore,
- ;; but use ASDF-USER. I'd like to have this function do this,
- ;; but since whoever uses it is likely to delete-package the result afterwards,
- ;; this would be a bad idea, so preserve the old behavior.
- (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
+ (defun validate-output-translations-file (file)
+ (validate-configuration-file
+ file 'validate-output-translations-form :description "output translations"))
+ (defun validate-output-translations-directory (directory)
+ (validate-configuration-directory
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
-;;;; -------------------------------------------------------------------------
-;;;; Defsystem
+ (defun parse-output-translations-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:output-translations :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((eql (char string 0) #\")
+ (parse-output-translations-string (read-from-string string) :location location))
+ ((eql (char string 0) #\()
+ (validate-output-translations-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with source = nil
+ :with separator = (inter-directory-separator)
+ :for i = (or (position separator string :start start) end) :do
+ (let ((s (subseq string start i)))
+ (cond
+ (source
+ (push (list source (if (equal "" s) nil s)) directives)
+ (setf source nil))
+ ((equal "" s)
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push :inherit-configuration directives))
+ (t
+ (setf source s)))
+ (setf start (1+ i))
+ (when (> start end)
+ (when source
+ (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)))))))))
-(asdf/package:define-package :asdf/defsystem
- (:recycle :asdf/defsystem :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/cache
- :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
- :asdf/backward-internals)
- (:export
- #:defsystem #:register-system-definition
- #:class-for-type #:*default-component-class*
- #:determine-system-directory #:parse-component-form
- #:duplicate-names #:non-toplevel-system #:non-system-system
- #:sysdef-error-component #:check-component-input))
-(in-package :asdf/defsystem)
+ (defparameter* *default-output-translations*
+ '(environment-output-translations
+ user-output-translations-pathname
+ user-output-translations-directory-pathname
+ system-output-translations-pathname
+ system-output-translations-directory-pathname))
-;;; Pathname
-(with-upgradability ()
- (defun determine-system-directory (pathname)
- ;; The defsystem macro calls this function to determine
- ;; the pathname of a system as follows:
- ;; 1. if the pathname argument is an pathname object (NOT a namestring),
- ;; that is already an absolute pathname, return it.
- ;; 2. otherwise, the directory containing the LOAD-PATHNAME
- ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
- ;; if it is indeed available and an absolute pathname, then
- ;; the PATHNAME argument is normalized to a relative pathname
- ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
- ;; and merged into that DIRECTORY as per SUBPATHNAME.
- ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
- ;; and may be from within the EVAL-WHEN of a file compilation.
- ;; If no absolute pathname was found, we return NIL.
- (check-type pathname (or null string pathname))
- (pathname-directory-pathname
- (resolve-symlinks*
- (ensure-absolute-pathname
- (parse-unix-namestring pathname :type :directory)
- #'(lambda () (ensure-absolute-pathname
- (load-pathname) 'get-pathname-defaults nil))
- nil)))))
+ (defun wrapping-output-translations ()
+ `(:output-translations
+ ;; Some implementations have precompiled ASDF systems,
+ ;; so we must disable translations for implementation paths.
+ #+(or #|clozure|# ecl mkcl sbcl)
+ ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
+ (when h `(((,h ,*wild-path*) ()))))
+ #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
+ ;; 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))
+ ;; We enable the user cache by default, and here is the place we do:
+ :enable-user-cache))
+ (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
+ (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
-;;; Component class
-(with-upgradability ()
- (defvar *default-component-class* 'cl-source-file)
+ (defun user-output-translations-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-file* :direction direction))
+ (defun system-output-translations-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-file* :direction direction))
+ (defun user-output-translations-directory-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-directory* :direction direction))
+ (defun system-output-translations-directory-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-directory* :direction direction))
+ (defun environment-output-translations ()
+ (getenv "ASDF_OUTPUT_TRANSLATIONS"))
- (defun class-for-type (parent type)
- (or (loop :for symbol :in (list
- type
- (find-symbol* type *package* nil)
- (find-symbol* type :asdf/interface nil)
- (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
- :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
- :when (and class
- (#-cormanlisp subtypep #+cormanlisp cl::subclassp
- class (find-class* 'component)))
- :return class)
- (and (eq type :file)
- (find-class*
- (or (loop :for p = parent :then (component-parent p) :while p
- :thereis (module-default-component-class p))
- *default-component-class*) nil))
- (sysdef-error "don't recognize component type ~A" type))))
+ (defgeneric process-output-translations (spec &key inherit collect))
+ (defun inherit-output-translations (inherit &key collect)
+ (when inherit
+ (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
-;;; Check inputs
-(with-upgradability ()
- (define-condition duplicate-names (system-definition-error)
- ((name :initarg :name :reader duplicate-names-name))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
- (duplicate-names-name c)))))
+ (defun* (process-output-translations-directive) (directive &key inherit collect)
+ (if (atom directive)
+ (ecase directive
+ ((:enable-user-cache)
+ (process-output-translations-directive '(t :user-cache) :collect collect))
+ ((:disable-cache)
+ (process-output-translations-directive '(t t) :collect collect))
+ ((:inherit-configuration)
+ (inherit-output-translations inherit :collect collect))
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
+ nil))
+ (let ((src (first directive))
+ (dst (second directive)))
+ (if (eq src :include)
+ (when dst
+ (process-output-translations (pathname dst) :inherit nil :collect collect))
+ (when src
+ (let ((trusrc (or (eql src t)
+ (let ((loc (resolve-location src :ensure-directory t :wilden t)))
+ (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
+ (cond
+ ((location-function-p dst)
+ (funcall collect
+ (list trusrc (ensure-function (second dst)))))
+ ((eq dst t)
+ (funcall collect (list trusrc t)))
+ (t
+ (let* ((trudst (if dst
+ (resolve-location dst :ensure-directory t :wilden t)
+ trusrc)))
+ (funcall collect (list trudst t))
+ (funcall collect (list trusrc trudst)))))))))))
- (define-condition non-system-system (system-definition-error)
- ((name :initarg :name :reader non-system-system-name)
- (class-name :initarg :class-name :reader non-system-system-class-name))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
- (non-system-system-name c) (non-system-system-class-name c) 'system))))
+ (defmethod process-output-translations ((x symbol) &key
+ (inherit *default-output-translations*)
+ collect)
+ (process-output-translations (funcall x) :inherit inherit :collect collect))
+ (defmethod process-output-translations ((pathname pathname) &key inherit collect)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-output-translations (validate-output-translations-directory pathname)
+ :inherit inherit :collect collect))
+ ((probe-file* pathname :truename *resolve-symlinks*)
+ (process-output-translations (validate-output-translations-file pathname)
+ :inherit inherit :collect collect))
+ (t
+ (inherit-output-translations inherit :collect collect))))
+ (defmethod process-output-translations ((string string) &key inherit collect)
+ (process-output-translations (parse-output-translations-string string)
+ :inherit inherit :collect collect))
+ (defmethod process-output-translations ((x null) &key inherit collect)
+ (inherit-output-translations inherit :collect collect))
+ (defmethod process-output-translations ((form cons) &key inherit collect)
+ (dolist (directive (cdr (validate-output-translations-form form)))
+ (process-output-translations-directive directive :inherit inherit :collect collect)))
- (define-condition non-toplevel-system (system-definition-error)
- ((parent :initarg :parent :reader non-toplevel-system-parent)
- (name :initarg :name :reader non-toplevel-system-name))
- (:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
- (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
+ (defun compute-output-translations (&optional parameter)
+ "read the configuration, return it"
+ (remove-duplicates
+ (while-collecting (c)
+ (inherit-output-translations
+ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
+ :test 'equal :from-end t))
- (defun sysdef-error-component (msg type name value)
- (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
- type name value))
+ (defvar *output-translations-parameter* nil)
- (defun check-component-input (type name weakly-depends-on
- depends-on components)
- "A partial test of the values of a component."
- (unless (listp depends-on)
- (sysdef-error-component ":depends-on must be a list."
+ (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
+ "read the configuration, initialize the internal configuration variable,
+return the configuration"
+ (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,
+effectively disabling the output translation facility."
+ (initialize-output-translations
+ '(:output-translations :disable-cache :ignore-inherited-configuration)))
+
+ ;; checks an initial variable to see whether the state is initialized
+ ;; or cleared. In the former case, return current configuration; in
+ ;; the latter, initialize. ASDF will call this function at the start
+ ;; of (asdf:find-system).
+ (defun ensure-output-translations ()
+ (if (output-translations-initialized-p)
+ (output-translations)
+ (initialize-output-translations)))
+
+ (defun* (apply-output-translations) (path)
+ (etypecase path
+ (logical-pathname
+ path)
+ ((or pathname string)
+ (ensure-output-translations)
+ (loop* :with p = (resolve-symlinks* path)
+ :for (source destination) :in (car *output-translations*)
+ :for root = (when (or (eq source t)
+ (and (pathnamep source)
+ (not (absolute-pathname-p source))))
+ (pathname-root p))
+ :for absolute-source = (cond
+ ((eq source t) (wilden root))
+ (root (merge-pathnames* source root))
+ (t source))
+ :when (or (eq source t) (pathname-match-p p absolute-source))
+ :return (translate-pathname* p absolute-source destination root source)
+ :finally (return p)))))
+
+ ;; Hook into uiop's output-translation mechanism
+ #-cormanlisp
+ (setf *output-translation-function* 'apply-output-translations)
+
+ #+abcl
+ (defun translate-jar-pathname (source wildcard)
+ (declare (ignore wildcard))
+ (flet ((normalize-device (pathname)
+ (if (find :windows *features*)
+ pathname
+ (make-pathname :defaults pathname :device :unspecific))))
+ (let* ((jar
+ (pathname (first (pathname-device source))))
+ (target-root-directory-namestring
+ (format nil "/___jar___file___root___/~@[~A/~]"
+ (and (find :windows *features*)
+ (pathname-device jar))))
+ (relative-source
+ (relativize-pathname-directory source))
+ (relative-jar
+ (relativize-pathname-directory (ensure-directory-pathname jar)))
+ (target-root-directory
+ (normalize-device
+ (pathname-directory-pathname
+ (parse-namestring target-root-directory-namestring))))
+ (target-root
+ (merge-pathnames* relative-jar target-root-directory))
+ (target
+ (merge-pathnames* relative-source target-root)))
+ (normalize-device (apply-output-translations target))))))
+
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
+
+(uiop/package:define-package :asdf/source-registry
+ (:recycle :asdf/source-registry :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
+ (:export
+ #:*source-registry-parameter* #:*default-source-registries*
+ #:invalid-source-registry
+ #:source-registry-initialized-p
+ #:initialize-source-registry #:clear-source-registry #:*source-registry*
+ #:ensure-source-registry #:*source-registry-parameter*
+ #:*default-source-registry-exclusions* #:*source-registry-exclusions*
+ #:*wild-asd* #:directory-asd-files #:register-asd-directory
+ #:collect-asds-in-directory #:collect-sub*directories-asd-files
+ #:validate-source-registry-directive #:validate-source-registry-form
+ #:validate-source-registry-file #:validate-source-registry-directory
+ #:parse-source-registry-string #:wrapping-source-registry
+ #:default-user-source-registry #:default-system-source-registry
+ #:user-source-registry #:system-source-registry
+ #:user-source-registry-directory #:system-source-registry-directory
+ #:environment-source-registry #:process-source-registry
+ #:compute-source-registry #:flatten-source-registry
+ #:sysdef-source-registry-search))
+(in-package :asdf/source-registry)
+
+(with-upgradability ()
+ (define-condition invalid-source-registry (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
+
+ ;; Using ack 1.2 exclusions
+ (defvar *default-source-registry-exclusions*
+ '(".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 builds stuff under the debian directory... BAD.
+
+ (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
+
+ (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 ()
+ (typep *source-registry* 'hash-table))
+
+ (defun clear-source-registry ()
+ "Undoes any initialization of the source registry."
+ (setf *source-registry* nil)
+ (values))
+ (register-clear-configuration-hook 'clear-source-registry)
+
+ (defparameter *wild-asd*
+ (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
+
+ (defun directory-asd-files (directory)
+ (directory-files directory *wild-asd*))
+
+ (defun collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
+
+ (defun collect-sub*directories-asd-files
+ (directory &key (exclude *default-source-registry-exclusions*) collect)
+ (collect-sub*directories
+ directory
+ (constantly t)
+ #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
+ #'(lambda (dir) (collect-asds-in-directory dir collect))))
+
+ (defun validate-source-registry-directive (directive)
+ (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
+ :location location :invalid-form-reporter 'invalid-source-registry))
+
+ (defun validate-source-registry-file (file)
+ (validate-configuration-file
+ 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
+ :invalid-form-reporter 'invalid-source-registry))
+
+ (defun parse-source-registry-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((find (char string 0) "\"(")
+ (validate-source-registry-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with separator = (inter-directory-separator)
+ :for pos = (position separator string :start start) :do
+ (let ((s (subseq string start (or pos end))))
+ (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))
+ ((string-suffix-p 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)))
+ (t
+ (unless inherit
+ (push '(:ignore-inherited-configuration) directives))
+ (return `(:source-registry ,@(nreverse directives))))))))))
+
+ (defun register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect)))
+
+ (defparameter* *default-source-registries*
+ '(environment-source-registry
+ user-source-registry
+ user-source-registry-directory
+ default-user-source-registry
+ system-source-registry
+ system-source-registry-directory
+ default-system-source-registry)
+ "List of default source registries" "3.1.0.102")
+
+ (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
+ (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
+
+ (defun wrapping-source-registry ()
+ `(:source-registry
+ #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
+ :inherit-configuration
+ #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
+ #+cmu (:tree #p"modules:")
+ #+scl (:tree #p"file://modules/")))
+ (defun default-user-source-registry ()
+ `(:source-registry
+ (:tree (:home "common-lisp/"))
+ #+sbcl (:directory (:home ".sbcl/systems/"))
+ ,@(loop :for dir :in
+ `(,@(when (os-unix-p)
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+ (subpathname (user-homedir-pathname) ".local/share/"))))
+ ,@(when (os-windows-p)
+ (mapcar 'get-folder-path '(:local-appdata :appdata))))
+ :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+ :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ :inherit-configuration))
+ (defun default-system-source-registry ()
+ `(:source-registry
+ ,@(loop :for dir :in
+ `(,@(when (os-unix-p)
+ (or (getenv-absolute-directories "XDG_DATA_DIRS")
+ '("/usr/local/share" "/usr/share")))
+ ,@(when (os-windows-p)
+ (list (get-folder-path :common-appdata))))
+ :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+ :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ :inherit-configuration))
+ (defun user-source-registry (&key (direction :input))
+ (in-user-configuration-directory *source-registry-file* :direction direction))
+ (defun system-source-registry (&key (direction :input))
+ (in-system-configuration-directory *source-registry-file* :direction direction))
+ (defun user-source-registry-directory (&key (direction :input))
+ (in-user-configuration-directory *source-registry-directory* :direction direction))
+ (defun system-source-registry-directory (&key (direction :input))
+ (in-system-configuration-directory *source-registry-directory* :direction direction))
+ (defun environment-source-registry ()
+ (getenv "CL_SOURCE_REGISTRY"))
+
+ (defgeneric* (process-source-registry) (spec &key inherit register))
+
+ (defun* (inherit-source-registry) (inherit &key register)
+ (when inherit
+ (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+
+ (defun* (process-source-registry-directive) (directive &key inherit register)
+ (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
+ (ecase kw
+ ((:include)
+ (destructuring-bind (pathname) rest
+ (process-source-registry (resolve-location pathname) :inherit nil :register register)))
+ ((:directory)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :ensure-directory t)))))
+ ((:tree)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :ensure-directory t)
+ :recurse t :exclude *source-registry-exclusions*))))
+ ((:exclude)
+ (setf *source-registry-exclusions* rest))
+ ((:also-exclude)
+ (appendf *source-registry-exclusions* rest))
+ ((:default-registry)
+ (inherit-source-registry '(default-source-registry) :register register))
+ ((:inherit-configuration)
+ (inherit-source-registry inherit :register register))
+ ((:ignore-inherited-configuration)
+ nil)))
+ nil)
+
+ (defmethod process-source-registry ((x symbol) &key inherit register)
+ (process-source-registry (funcall x) :inherit inherit :register register))
+ (defmethod process-source-registry ((pathname pathname) &key inherit register)
+ (cond
+ ((directory-pathname-p pathname)
+ (let ((*here-directory* (resolve-symlinks* pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
+ ((probe-file* pathname :truename *resolve-symlinks*)
+ (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)
+ (process-source-registry (parse-source-registry-string string)
+ :inherit inherit :register register))
+ (defmethod process-source-registry ((x null) &key inherit register)
+ (inherit-source-registry inherit :register register))
+ (defmethod process-source-registry ((form cons) &key inherit register)
+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
+ (dolist (directive (cdr (validate-source-registry-form form)))
+ (process-source-registry-directive directive :inherit inherit :register register))))
+
+ (defun flatten-source-registry (&optional parameter)
+ (remove-duplicates
+ (while-collecting (collect)
+ (with-pathname-defaults () ;; be location-independent
+ (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.
+ (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
+ #'(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 *verbose-out*
+ (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))
+
+ (defvar *source-registry-parameter* nil)
+
+ (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
+ ;; Record the parameter used to configure the registry
+ (setf *source-registry-parameter* parameter)
+ ;; Clear the previous registry database:
+ (setf *source-registry* (make-hash-table :test 'equal))
+ ;; Do it!
+ (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
+ ;; the latter, initialize. ASDF will call this function at the start
+ ;; of (asdf:find-system) to make sure the source registry is initialized.
+ ;; However, it will do so *without* a parameter, at which point it
+ ;; will be too late to provide a parameter to this function, though
+ ;; you may override the configuration explicitly by calling
+ ;; initialize-source-registry directly with your parameter.
+ (defun ensure-source-registry (&optional parameter)
+ (unless (source-registry-initialized-p)
+ (initialize-source-registry parameter))
+ (values))
+
+ (defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (values (gethash (primary-system-name system) *source-registry*))))
+
+
+;;;; -------------------------------------------------------------------------
+;;; Internal hacks for backward-compatibility
+
+(uiop/package:define-package :asdf/backward-internals
+ (:recycle :asdf/backward-internals :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
+ :asdf/system :asdf/component :asdf/operation
+ :asdf/find-system :asdf/action :asdf/lisp-action)
+ (:export ;; for internal use
+ #:load-sysdef #:make-temporary-package
+ #:%refresh-component-inline-methods
+ #:make-sub-operation
+ #:load-sysdef #:make-temporary-package))
+(in-package :asdf/backward-internals)
+
+;;;; Backward compatibility with "inline methods"
+(with-upgradability ()
+ (defparameter* +asdf-methods+
+ '(perform-with-restarts perform explain output-files operation-done-p))
+
+ (defun %remove-component-inline-methods (component)
+ (dolist (name +asdf-methods+)
+ (map ()
+ ;; 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))
+ (component-inline-methods component)))
+ (component-inline-methods component) nil)
+
+ (defun %define-component-inline-methods (ret rest)
+ (loop* :for (key value) :on rest :by #'cddr
+ :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
+ :when name :do
+ (destructuring-bind (op &rest body) value
+ (loop :for arg = (pop body)
+ :while (atom arg)
+ :collect arg :into qualifiers
+ :finally
+ (destructuring-bind (o c) arg
+ (pushnew
+ (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
+ (component-inline-methods ret)))))))
+
+ (defun %refresh-component-inline-methods (component rest)
+ ;; clear methods, then add the new ones
+ (%remove-component-inline-methods component)
+ (%define-component-inline-methods component rest)))
+
+(when-upgrading (:when (fboundp 'make-sub-operation))
+ (defun make-sub-operation (c o dep-c dep-o)
+ (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
+
+
+;;;; load-sysdef
+(with-upgradability ()
+ (defun load-sysdef (name pathname)
+ (load-asd pathname :name name))
+
+ (defun make-temporary-package ()
+ ;; For loading a .asd file, we don't make a temporary package anymore,
+ ;; but use ASDF-USER. I'd like to have this function do this,
+ ;; but since whoever uses it is likely to delete-package the result afterwards,
+ ;; this would be a bad idea, so preserve the old behavior.
+ (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
+
+
+;;;; -------------------------------------------------------------------------
+;;;; Defsystem
+
+(uiop/package:define-package :asdf/parse-defsystem
+ (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
+ (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
+ (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/cache :asdf/component :asdf/system
+ :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
+ :asdf/backward-internals)
+ (:import-from :asdf/system #:depends-on #:weakly-depends-on)
+ (:export
+ #:defsystem #:register-system-definition
+ #:class-for-type #:*default-component-class*
+ #:determine-system-directory #:parse-component-form
+ #:non-toplevel-system #:non-system-system
+ #:sysdef-error-component #:check-component-input))
+(in-package :asdf/parse-defsystem)
+
+;;; Pathname
+(with-upgradability ()
+ (defun determine-system-directory (pathname)
+ ;; The defsystem macro calls this function to determine
+ ;; the pathname of a system as follows:
+ ;; 1. if the pathname argument is an pathname object (NOT a namestring),
+ ;; that is already an absolute pathname, return it.
+ ;; 2. otherwise, the directory containing the LOAD-PATHNAME
+ ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
+ ;; if it is indeed available and an absolute pathname, then
+ ;; the PATHNAME argument is normalized to a relative pathname
+ ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
+ ;; and merged into that DIRECTORY as per SUBPATHNAME.
+ ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
+ ;; and may be from within the EVAL-WHEN of a file compilation.
+ ;; If no absolute pathname was found, we return NIL.
+ (check-type pathname (or null string pathname))
+ (pathname-directory-pathname
+ (resolve-symlinks*
+ (ensure-absolute-pathname
+ (parse-unix-namestring pathname :type :directory)
+ #'(lambda () (ensure-absolute-pathname
+ (load-pathname) 'get-pathname-defaults nil))
+ nil)))))
+
+
+;;; Component class
+(with-upgradability ()
+ (defvar *default-component-class* 'cl-source-file)
+
+ (defun class-for-type (parent type)
+ (or (coerce-class type :package :asdf/interface :super 'component :error nil)
+ (and (eq type :file)
+ (coerce-class
+ (or (loop :for p = parent :then (component-parent p) :while p
+ :thereis (module-default-component-class p))
+ *default-component-class*)
+ :package :asdf/interface :super 'component :error nil))
+ (sysdef-error "don't recognize component type ~S" type))))
+
+
+;;; Check inputs
+(with-upgradability ()
+ (define-condition non-system-system (system-definition-error)
+ ((name :initarg :name :reader non-system-system-name)
+ (class-name :initarg :class-name :reader non-system-system-class-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
+ (non-system-system-name c) (non-system-system-class-name c) 'system))))
+
+ (define-condition non-toplevel-system (system-definition-error)
+ ((parent :initarg :parent :reader non-toplevel-system-parent)
+ (name :initarg :name :reader non-toplevel-system-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
+ (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
+
+ (defun sysdef-error-component (msg type name value)
+ (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+ type name value))
+
+ (defun check-component-input (type name weakly-depends-on
+ depends-on components)
+ "A partial test of the values of a component."
+ (unless (listp depends-on)
+ (sysdef-error-component ":depends-on must be a list."
type name depends-on))
(unless (listp weakly-depends-on)
(sysdef-error-component ":weakly-depends-on must be a list."
(warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
form component parent pathname continuation))
(invalid-parse (control &rest args)
- (unless (builtin-system-p (find-component parent component))
+ (unless (if-let (target (find-component parent component)) (builtin-system-p target))
(apply 'warn control args)
(invalid))))
(if-let (v (typecase form
(case (first form)
((:read-file-form)
(destructuring-bind (subpath &key (at 0)) (rest form)
- (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
+ (safe-read-file-form (subpathname pathname subpath)
+ :at at :package :asdf-user)))
((:read-file-line)
(destructuring-bind (subpath &key (at 0)) (rest form)
- (read-file-lines (subpathname pathname subpath) :at at)))
+ (safe-read-file-line (subpathname pathname subpath)
+ :at at)))
(otherwise
(invalid))))
(t
;;; Main parsing function
(with-upgradability ()
+ (defun* parse-dependency-def (dd)
+ (if (listp dd)
+ (case (first dd)
+ (:feature
+ (unless (= (length dd) 3)
+ (sysdef-error "Ill-formed feature dependency: ~s" dd))
+ (let ((embedded (parse-dependency-def (third dd))))
+ `(:feature ,(second dd) ,embedded)))
+ (feature
+ (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
+ (:require
+ (unless (= (length dd) 2)
+ (sysdef-error "Ill-formed require dependency: ~s" dd))
+ dd)
+ (:version
+ (unless (= (length dd) 3)
+ (sysdef-error "Ill-formed version dependency: ~s" dd))
+ `(:version ,(coerce-name (second dd)) ,(third dd)))
+ (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
+ (coerce-name dd)))
+
+ (defun* parse-dependency-defs (dd-list)
+ "Parse the dependency defs in DD-LIST into canonical form by translating all
+system names contained using COERCE-NAME. Return the result."
+ (mapcar 'parse-dependency-def dd-list))
+
(defun* (parse-component-form) (parent options &key previous-serial-component)
(destructuring-bind
(type name &rest rest &key
do-first if-component-dep-fails version
;; list ends
&allow-other-keys) options
- (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
+ (declare (ignore perform explain output-files operation-done-p builtin-system-p))
(check-component-input type name weakly-depends-on depends-on components)
(when (and parent
(find-component parent name)
(apply 'reinitialize-instance component args)
(setf component (apply 'make-instance class args)))
(component-pathname component) ; eagerly compute the absolute pathname
+ (when (typep component 'system)
+ ;; cache information for introspection
+ (setf (slot-value component 'depends-on)
+ (parse-dependency-defs depends-on)
+ (slot-value component 'weakly-depends-on)
+ ;; these must be a list of systems, cannot be features or versioned systems
+ (mapcar 'coerce-name weakly-depends-on)))
(let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
(when (and (typep component 'system) (not bspp))
(setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
(setf (component-sideway-dependencies component) depends-on)
(%refresh-component-inline-methods component rest)
(when if-component-dep-fails
- (%resolve-if-component-dep-fails if-component-dep-fails component))
+ (error "The system definition for ~S uses deprecated ~
+ ASDF option :IF-COMPONENT-DEP-FAILS. ~
+ Starting with ASDF 3, please use :IF-FEATURE instead"
+ (coerce-name (component-system component))))
component)))
(defun register-system-definition
;; 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 ()
+ ;; we also need to remember it in the asdf-cache.
+ (with-asdf-cache ()
(let* ((name (coerce-name name))
(source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
(registered (system-registered-p name))
(make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
:name name :source-file source-file))
- (component-options (remove-plist-key :class options))
+ (component-options
+ (remove-plist-keys '(:defsystem-depends-on :class) options))
(defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
(resolve-dependency-spec nil spec))))
- (setf (gethash name *systems-being-defined*) system)
- (apply 'load-systems defsystem-dependencies)
+ ;; cache defsystem-depends-on in canonical form
+ (when defsystem-depends-on
+ (setf component-options
+ (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on))
+ component-options)))
+ (set-asdf-cache-entry `(find-system ,name) (list system))
+ (load-systems* defsystem-dependencies)
;; We change-class AFTER we loaded the defsystem-depends-on
;; since the class might be defined as part of those.
(let ((class (class-for-type nil class)))
;;;; -------------------------------------------------------------------------
;;;; ASDF-Bundle
-(asdf/package:define-package :asdf/bundle
+(uiop/package:define-package :asdf/bundle
(:recycle :asdf/bundle :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
- :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
+ :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
(:export
- #:bundle-op #:bundle-op-build-args #:bundle-type
+ #:bundle-op #:bundle-type #:program-system
#:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
#:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
- #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
+ #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op
+ #:basic-compile-bundle-op #:prepare-bundle-op
+ #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
#:lib-op #:monolithic-lib-op
#:dll-op #:monolithic-dll-op
- #:binary-op #:monolithic-binary-op
- #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
+ #:deliver-asd-op #:monolithic-deliver-asd-op
+ #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
#:user-system-p #:user-system #:trivial-system-p
- #+ecl #:make-build
- #:register-pre-built-system
+ #:make-build
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
(in-package :asdf/bundle)
(with-upgradability ()
- (defclass bundle-op (operation)
- ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
+ (defclass bundle-op (basic-compile-op)
+ ((build-args :initarg :args :initform nil :accessor extra-build-args)
(name-suffix :initarg :name-suffix :initform nil)
(bundle-type :initform :no-output-file :reader bundle-type)
- #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
- #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
- #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
+ #+ecl (lisp-files :initform nil :accessor extra-object-files)))
- (defclass bundle-compile-op (bundle-op basic-compile-op)
- ()
- (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
+ (defclass monolithic-op (operation) ()
+ (:documentation "A MONOLITHIC operation operates on a system *and all of its
+dependencies*. So, for example, a monolithic concatenate operation will
+concatenate together a system's components and all of its dependencies, but a
+simple concatenate operation will concatenate only the components of the system
+itself.")) ;; operation on a system and its dependencies
+
+ (defclass monolithic-bundle-op (monolithic-op bundle-op)
+ ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
+ ((prologue-code :initform nil :accessor prologue-code)
+ (epilogue-code :initform nil :accessor epilogue-code)))
+
+ (defclass program-system (system)
+ ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
+ ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
+ (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
+ (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
+ (prefix-lisp-object-files :initarg :prefix-lisp-object-files
+ :initform nil :accessor prefix-lisp-object-files)
+ (postfix-lisp-object-files :initarg :postfix-lisp-object-files
+ :initform nil :accessor postfix-lisp-object-files)
+ (extra-object-files :initarg :extra-object-files
+ :initform nil :accessor extra-object-files)
+ (extra-build-args :initarg :extra-build-args
+ :initform nil :accessor extra-build-args)))
+
+ (defmethod prologue-code ((x t)) nil)
+ (defmethod epilogue-code ((x t)) nil)
+ (defmethod no-uiop ((x t)) nil)
+ (defmethod prefix-lisp-object-files ((x t)) nil)
+ (defmethod postfix-lisp-object-files ((x t)) nil)
+ (defmethod extra-object-files ((x t)) nil)
+ (defmethod extra-build-args ((x t)) nil)
+
+ (defclass link-op (bundle-op) ()
+ (:documentation "Abstract operation for linking files together"))
+
+ (defclass gather-op (bundle-op)
+ ((gather-op :initform nil :allocation :class :reader gather-op))
+ (:documentation "Abstract operation for gathering many input files from a system"))
+
+ (defun operation-monolithic-p (op)
+ (typep op 'monolithic-op))
+
+ (defmethod component-depends-on ((o gather-op) (s system))
+ (let* ((mono (operation-monolithic-p o))
+ (deps
+ (required-components
+ s :other-systems mono :component-type (if mono 'system '(not system))
+ :goal-operation (find-operation o 'load-op)
+ :keep-operation 'compile-op)))
+ ;; NB: the explicit make-operation on ECL and MKCL
+ ;; ensures that we drop the original-initargs and its magic flags when recursing.
+ `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps)
+ ,@(call-next-method))))
;; create a single fasl for the entire library
- (defclass basic-fasl-op (bundle-compile-op)
+ (defclass basic-compile-bundle-op (bundle-op)
((bundle-type :initform :fasl)))
- (defclass prepare-fasl-op (sideway-operation)
- ((sideway-operation :initform 'load-fasl-op)))
- (defclass fasl-op (basic-fasl-op selfward-operation)
- ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
- (defclass load-fasl-op (basic-load-op selfward-operation)
- ((selfward-operation :initform '(prepare-op fasl-op))))
- ;; NB: since the monolithic-op's can't be sideway-operation's,
- ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
- ;; we'd have to have the monolithic-op not inherit from the main op,
- ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
+ (defclass prepare-bundle-op (sideway-operation)
+ ((sideway-operation :initform #+(or ecl mkcl) 'load-bundle-op #-(or ecl mkcl) 'load-op
+ :allocation :class)))
- (defclass lib-op (bundle-compile-op)
- ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
- (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
- #-(or ecl mkcl) "just compile the system"))
+ (defclass lib-op (link-op gather-op non-propagating-operation)
+ ((bundle-type :initform :lib))
+ (:documentation "compile the system and produce linkable (.a) library for it."))
- (defclass dll-op (bundle-op basic-compile-op)
- ((bundle-type :initform :dll))
- (:documentation "Link together all the dynamic library used by this system into a single one."))
+ (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
+ #+(or ecl mkcl) link-op #-ecl gather-op)
+ ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class)))
- (defclass binary-op (basic-compile-op selfward-operation)
- ((selfward-operation :initform '(fasl-op lib-op)))
- (:documentation "produce fasl and asd files for the system"))
+ (defclass load-bundle-op (basic-load-op selfward-operation)
+ ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)))
+
+ ;; NB: since the monolithic-op's can't be sideway-operation's,
+ ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
+ ;; we'd have to have the monolithic-op not inherit from the main op,
+ ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
- (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
+ (defclass dll-op (link-op gather-op non-propagating-operation)
+ ((bundle-type :initform :dll))
+ (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
- (defclass monolithic-bundle-op (monolithic-op bundle-op)
- ((prologue-code :accessor monolithic-op-prologue-code)
- (epilogue-code :accessor monolithic-op-epilogue-code)))
+ (defclass deliver-asd-op (basic-compile-op selfward-operation)
+ ((selfward-operation :initform '(compile-bundle-op #+(or ecl mkcl) lib-op) :allocation :class))
+ (:documentation "produce an asd file for delivering the system as a single fasl"))
- (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
- ()
- (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
- (defclass monolithic-binary-op (monolithic-op binary-op)
- ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
+ (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
+ ((selfward-operation :initform '(monolithic-compile-bundle-op #+(or ecl mkcl) monolithic-lib-op)
+ :allocation :class))
(:documentation "produce fasl and asd files for combined system and dependencies."))
- (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
+ (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op
+ #+(or ecl mkcl) link-op gather-op non-propagating-operation)
+ ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class))
(:documentation "Create a single fasl for the system and its dependencies."))
- (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op)
- ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
- (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
- #-(or ecl mkcl) "Compile a system and its dependencies."))
+ (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
+ ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
+ (:documentation "Load a single fasl for the system and its dependencies."))
- (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
- ((bundle-type :initform :dll)
- (selfward-operation :initform 'dll-op)
- (sideway-operation :initform 'dll-op)))
+ (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) ()
+ (:documentation "Create a single linkable library for the system and its dependencies."))
- (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
- #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
- ((bundle-type :initform :program)
- #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
+ (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
+ ((bundle-type :initform :dll))
+ (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
+
+ (defclass image-op (monolithic-bundle-op selfward-operation
+ #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op)
+ ((bundle-type :initform :image)
+ (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class))
+ (:documentation "create an image file from the system and its dependencies"))
+
+ (defclass program-op (image-op)
+ ((bundle-type :initform :program))
(:documentation "create an executable file from the system and its dependencies"))
(defun bundle-pathname-type (bundle-type)
((or null string) bundle-type)
((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
#+ecl
- ((member :binary :dll :lib :static-library :program :object :program)
+ ((member :dll :lib :shared-library :static-library :program :object :program)
(compile-file-type :type bundle-type))
- ((eql :binary) "image")
- ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
- ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
+ ((member :image) #-allegro "image" #+allegro "dxl")
+ ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
+ ((member :lib :static-library) (cond ((os-unix-p) "a")
+ ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
(defun bundle-output-files (o c)
- (when (input-files o c)
- (let ((bundle-type (bundle-type o)))
- (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
- (let ((name (or (component-build-pathname c)
- (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
- (type (bundle-pathname-type bundle-type)))
- (values (list (subpathname (component-pathname c) name :type type))
- (eq (type-of o) (component-build-operation c))))))))
+ (let ((bundle-type (bundle-type o)))
+ (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
+ (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
+ (let ((name (or (component-build-pathname c)
+ (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
+ (type (bundle-pathname-type bundle-type)))
+ (values (list (subpathname (component-pathname c) name :type type))
+ (eq (type-of o) (component-build-operation c)))))))
(defmethod output-files ((o bundle-op) (c system))
(bundle-output-files o c))
#-(or ecl mkcl)
- (defmethod perform ((o program-op) (c system))
- (let ((output-file (output-file o c)))
- (setf *image-entry-point* (ensure-function (component-entry-point c)))
- (dump-image output-file :executable t)))
+ (progn
+ (defmethod perform ((o image-op) (c system))
+ (dump-image (output-file o c) :executable (typep o 'program-op)))
+ (defmethod perform :before ((o program-op) (c system))
+ (setf *image-entry-point* (ensure-function (component-entry-point c)))))
(defclass compiled-file (file-component)
((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
;;; The different targets are defined by specialization.
;;;
(with-upgradability ()
- (defun operation-monolithic-p (op)
- (typep op 'monolithic-op))
-
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
&key (name-suffix nil name-suffix-p)
&allow-other-keys)
- (declare (ignorable initargs name-suffix))
+ (declare (ignore initargs name-suffix))
(unless name-suffix-p
(setf (slot-value instance 'name-suffix)
(unless (typep instance 'program-op)
- (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
+ (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames
(when (typep instance 'monolithic-bundle-op)
- (destructuring-bind (&rest original-initargs
- &key lisp-files prologue-code epilogue-code
+ (destructuring-bind (&key lisp-files prologue-code epilogue-code
&allow-other-keys)
(operation-original-initargs instance)
- (setf (operation-original-initargs instance)
- (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
- (monolithic-op-prologue-code instance) prologue-code
- (monolithic-op-epilogue-code instance) epilogue-code)
- #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
- #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
- (setf (bundle-op-build-args instance)
- (remove-plist-keys '(:type :monolithic :name-suffix)
- (operation-original-initargs instance))))
-
- (defmethod bundle-op-build-args :around ((o lib-op))
- (declare (ignorable o))
- (let ((args (call-next-method)))
- (remf args :ld-flags)
- args))
+ (setf (prologue-code instance) prologue-code
+ (epilogue-code instance) epilogue-code)
+ #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
+ #+ecl (setf (extra-object-files instance) lisp-files)))
+ (setf (extra-build-args instance)
+ (remove-plist-keys
+ '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
+ :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
+ (operation-original-initargs instance))))
(defun bundlable-file-p (pathname)
(let ((type (pathname-type pathname)))
(declare (ignorable type))
(or #+ecl (or (equalp type (compile-file-type :type :object))
(equalp type (compile-file-type :type :static-library)))
- #+mkcl (equalp type (compile-file-type :fasl-p nil))
+ #+mkcl (or (equalp type (compile-file-type :fasl-p nil))
+ #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW
+ #+(and windows (not (or mingw32 mingw64))) (equalp type "lib"))
#+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
(defgeneric* (trivial-system-p) (component))
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
(with-upgradability ()
- (defmethod component-depends-on ((o bundle-compile-op) (c system))
- `(,(if (operation-monolithic-p o)
- `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
- ,@(required-components c :other-systems t :component-type 'system
- :goal-operation (find-operation o 'load-op)
- :keep-operation 'compile-op))
- `(compile-op
- ,@(required-components c :other-systems nil :component-type '(not system)
- :goal-operation (find-operation o 'load-op)
- :keep-operation 'compile-op)))
- ,@(call-next-method)))
-
- (defmethod component-depends-on :around ((o bundle-op) (c component))
- (declare (ignorable o c))
- (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
- `((,op ,c))
- (call-next-method)))
-
(defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
;; This file selects output files from direct dependencies;
;; your component-depends-on method better gathered the correct dependencies in the correct order.
(while-collecting (collect)
(map-direct-dependencies
- o c #'(lambda (sub-o sub-c)
- (loop :for f :in (funcall key sub-o sub-c)
- :when (funcall test f) :do (collect f))))))
+ t o c #'(lambda (sub-o sub-c)
+ (loop :for f :in (funcall key sub-o sub-c)
+ :when (funcall test f) :do (collect f))))))
- (defmethod input-files ((o bundle-compile-op) (c system))
+ (defmethod input-files ((o gather-op) (c system))
(unless (eq (bundle-type o) :no-output-file)
(direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
(defun select-bundle-operation (type &optional monolithic)
(ecase type
- ((:binary)
- (if monolithic 'monolithic-binary-op 'binary-op))
((:dll :shared-library)
(if monolithic 'monolithic-dll-op 'dll-op))
((:lib :static-library)
(if monolithic 'monolithic-lib-op 'lib-op))
((:fasl)
- (if monolithic 'monolithic-fasl-op 'fasl-op))
+ (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
+ ((:image)
+ 'image-op)
((:program)
'program-op)))
+ ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
(defun make-build (system &rest args &key (monolithic nil) (type :fasl)
(move-here nil move-here-p)
&allow-other-keys)
(let* ((operation-name (select-bundle-operation type monolithic))
(move-here-path (if (and move-here
(typep move-here '(or pathname string)))
- (pathname move-here)
+ (ensure-pathname move-here :namestring :lisp :ensure-directory t)
(system-relative-pathname system "asdf-output/")))
(operation (apply #'operate operation-name
system
(system (find-system system))
(files (and system (output-files operation system))))
(if (or move-here (and (null move-here-p)
- (member operation-name '(:program :binary))))
+ (member operation-name '(:program :image))))
(loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
:for f :in files
:for new-f = (make-pathname :name (pathname-name f)
:defaults dest-path)
:do (rename-file-overwriting-target f new-f)
:collect new-f)
- files))))
+ files)))
+
+ ;; DEPRECATED. Does anyone use this?
+ (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
+ (declare (ignore force verbose version))
+ (apply #'operate 'deliver-asd-op system args)))
;;;
-;;; LOAD-FASL-OP
+;;; LOAD-BUNDLE-OP
;;;
-;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
+;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
;;;
(with-upgradability ()
- (defmethod component-depends-on ((o load-fasl-op) (c system))
- (declare (ignorable o))
- `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
- :collect (resolve-dependency-spec c dep)))
- (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
+ (defmethod component-depends-on ((o load-bundle-op) (c system))
+ `((,o ,@(component-sideway-dependencies c))
+ (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
,@(call-next-method)))
- (defmethod input-files ((o load-fasl-op) (c system))
+ (defmethod input-files ((o load-bundle-op) (c system))
(when (user-system-p c)
- (output-files (find-operation o 'fasl-op) c)))
-
- (defmethod perform ((o load-fasl-op) c)
- (declare (ignorable o c))
- nil)
+ (output-files (find-operation o 'compile-bundle-op) c)))
- (defmethod perform ((o load-fasl-op) (c system))
+ (defmethod perform ((o load-bundle-op) (c system))
(when (input-files o c)
(perform-lisp-load-fasl o c)))
- (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
+ (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
(mark-operation-done (find-operation o 'load-op) c)))
;;;
(defmethod trivial-system-p ((s system))
(every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
- (defmethod output-files (o (c compiled-file))
- (declare (ignorable o c))
- nil)
- (defmethod input-files (o (c compiled-file))
- (declare (ignorable o))
- (component-pathname c))
+ (defmethod input-files ((o operation) (c compiled-file))
+ (list (component-pathname c)))
(defmethod perform ((o load-op) (c compiled-file))
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-source-op) (c compiled-file))
(perform (find-operation o 'load-op) c))
- (defmethod perform ((o load-fasl-op) (c compiled-file))
- (perform (find-operation o 'load-op) c))
(defmethod perform ((o operation) (c compiled-file))
- (declare (ignorable o c))
- nil))
-
-;;;
-;;; Pre-built systems
-;;;
-(with-upgradability ()
- (defmethod trivial-system-p ((s prebuilt-system))
- (declare (ignorable s))
- t)
-
- (defmethod perform ((o lib-op) (c prebuilt-system))
- (declare (ignorable o c))
- nil)
-
- (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
- (declare (ignorable o c))
- nil)
-
- (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
- (declare (ignorable o))
nil))
+;;;
+;;; Pre-built systems
+;;;
+(with-upgradability ()
+ (defmethod trivial-system-p ((s prebuilt-system))
+ t)
-;;;
-;;; PREBUILT SYSTEM CREATOR
-;;;
-(with-upgradability ()
- (defmethod output-files ((o binary-op) (s system))
- (list (make-pathname :name (component-name s) :type "asd"
- :defaults (component-pathname s))))
-
- (defmethod perform ((o binary-op) (s system))
- (let* ((inputs (input-files o s))
- (fasl (first inputs))
- (library (second inputs))
- (asd (first (output-files o s)))
- (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
- (dependencies
- (if (operation-monolithic-p o)
- (remove-if-not 'builtin-system-p
- (required-components s :component-type 'system
- :keep-operation 'load-op))
- (while-collecting (x) ;; resolve the sideway-dependencies of s
- (map-direct-dependencies
- 'load-op s
- #'(lambda (o c)
- (when (and (typep o 'load-op) (typep c 'system))
- (x c)))))))
- (depends-on (mapcar 'coerce-name dependencies)))
- (when (pathname-equal asd (system-source-file s))
- (cerror "overwrite the asd file"
- "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
- (cons o s) asd))
- (with-open-file (s asd :direction :output :if-exists :supersede
- :if-does-not-exist :create)
- (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
- (operation-monolithic-p o) name)
- (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
- (lisp-implementation-type)
- (lisp-implementation-version)
- (software-type)
- (machine-type)
- (software-version))
- (let ((*package* (find-package :asdf-user)))
- (pprint `(defsystem ,name
- :class prebuilt-system
- :depends-on ,depends-on
- :components ((:compiled-file ,(pathname-name fasl)))
- ,@(when library `(:lib ,(file-namestring library))))
- s)
- (terpri s)))))
-
- #-(or ecl mkcl)
- (defmethod perform ((o bundle-compile-op) (c system))
- (let* ((input-files (input-files o c))
- (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
- (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
- (output-files (output-files o c))
- (output-file (first output-files)))
- (assert (eq (not input-files) (not output-files)))
- (when input-files
- (when non-fasl-files
- (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
- (implementation-type) non-fasl-files))
- (when (and (typep o 'monolithic-bundle-op)
- (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
- (error "prologue-code and epilogue-code are not supported on ~A"
- (implementation-type)))
- (with-staging-pathname (output-file)
- (combine-fasls fasl-files output-file)))))
-
- (defmethod input-files ((o load-op) (s precompiled-system))
- (declare (ignorable o))
- (bundle-output-files (find-operation o 'fasl-op) s))
-
- (defmethod perform ((o load-op) (s precompiled-system))
- (perform-lisp-load-fasl o s))
-
- (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
- (declare (ignorable o))
- `((load-op ,s) ,@(call-next-method))))
-
- #| ;; Example use:
-(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
-(asdf:load-system :precompiled-asdf-utils)
-|#
-
-#+(or ecl mkcl)
-(with-upgradability ()
- (defun uiop-library-file ()
- (or (and (find-system :uiop nil)
- (system-source-directory :uiop)
- (progn
- (operate 'lib-op :uiop)
- (output-file 'lib-op :uiop)))
- (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
- (defmethod input-files :around ((o program-op) (c system))
- (let ((files (call-next-method))
- (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
- (unless (or (and (find-system :uiop nil)
- (system-source-directory :uiop)
- (plan-operates-on-p plan '("uiop")))
- (and (system-source-directory :asdf)
- (plan-operates-on-p plan '("asdf"))))
- (pushnew (uiop-library-file) files :test 'pathname-equal))
- files))
-
- (defun register-pre-built-system (name)
- (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
-
-#+ecl
-(with-upgradability ()
- (defmethod perform ((o bundle-compile-op) (c system))
- (let* ((object-files (input-files o c))
- (output (output-files o c))
- (bundle (first output))
- (kind (bundle-type o)))
- (when output
- (create-image
- bundle (append object-files (bundle-op-lisp-files o))
- :kind kind
- :entry-point (component-entry-point c)
- :prologue-code
- (when (typep o 'monolithic-bundle-op)
- (monolithic-op-prologue-code o))
- :epilogue-code
- (when (typep o 'monolithic-bundle-op)
- (monolithic-op-epilogue-code o))
- :build-args (bundle-op-build-args o))))))
-
-#+mkcl
-(with-upgradability ()
- (defmethod perform ((o lib-op) (s system))
- (apply #'compiler::build-static-library (output-file o c)
- :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-
- (defmethod perform ((o basic-fasl-op) (s system))
- (apply #'compiler::build-bundle (output-file o c) ;; second???
- :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-
- (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
- (declare (ignore force verbose version))
- (apply #'operate 'binary-op system args)))
-;;;; -------------------------------------------------------------------------
-;;;; Concatenate-source
-
-(asdf/package:define-package :asdf/concatenate-source
- (:recycle :asdf/concatenate-source :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/operation
- :asdf/system :asdf/find-system :asdf/defsystem
- :asdf/action :asdf/lisp-action :asdf/bundle)
- (:export
- #:concatenate-source-op
- #:load-concatenated-source-op
- #:compile-concatenated-source-op
- #:load-compiled-concatenated-source-op
- #:monolithic-concatenate-source-op
- #:monolithic-load-concatenated-source-op
- #:monolithic-compile-concatenated-source-op
- #:monolithic-load-compiled-concatenated-source-op))
-(in-package :asdf/concatenate-source)
-
-;;;
-;;; Concatenate sources
-;;;
-(with-upgradability ()
- (defclass basic-concatenate-source-op (bundle-op)
- ((bundle-type :initform "lisp")))
- (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
- (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
- (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
-
- (defclass concatenate-source-op (basic-concatenate-source-op) ())
- (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
- ((selfward-operation :initform '(prepare-op concatenate-source-op))))
- (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
- ((selfward-operation :initform '(prepare-op concatenate-source-op))))
- (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
- ((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
-
- (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
- (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
- ((selfward-operation :initform 'monolithic-concatenate-source-op)))
- (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
- ((selfward-operation :initform 'monolithic-concatenate-source-op)))
- (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
- ((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
-
- (defmethod input-files ((operation basic-concatenate-source-op) (s system))
- (loop :with encoding = (or (component-encoding s) *default-encoding*)
- :with other-encodings = '()
- :with around-compile = (around-compile-hook s)
- :with other-around-compile = '()
- :for c :in (required-components
- s :goal-operation 'compile-op
- :keep-operation 'compile-op
- :other-systems (operation-monolithic-p operation))
- :append
- (when (typep c 'cl-source-file)
- (let ((e (component-encoding c)))
- (unless (equal e encoding)
- (pushnew e other-encodings :test 'equal)))
- (let ((a (around-compile-hook c)))
- (unless (equal a around-compile)
- (pushnew a other-around-compile :test 'equal)))
- (input-files (make-operation 'compile-op) c)) :into inputs
- :finally
- (when other-encodings
- (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
- operation encoding other-encodings))
- (when other-around-compile
- (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
- operation around-compile other-around-compile))
- (return inputs)))
- (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
- (lisp-compilation-output-files o s))
-
- (defmethod perform ((o basic-concatenate-source-op) (s system))
- (let ((inputs (input-files o s))
- (output (output-file o s)))
- (concatenate-files inputs output)))
- (defmethod perform ((o basic-load-concatenated-source-op) (s system))
- (perform-lisp-load-source o s))
- (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
- (perform-lisp-compilation o s))
- (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
- (perform-lisp-load-fasl o s)))
-
-;;;; ---------------------------------------------------------------------------
-;;;; asdf-output-translations
-
-(asdf/package:define-package :asdf/output-translations
- (:recycle :asdf/output-translations :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
- (:export
- #:*output-translations* #:*output-translations-parameter*
- #:invalid-output-translation
- #:output-translations #:output-translations-initialized-p
- #:initialize-output-translations #:clear-output-translations
- #:disable-output-translations #:ensure-output-translations
- #:apply-output-translations
- #:validate-output-translations-directive #:validate-output-translations-form
- #:validate-output-translations-file #:validate-output-translations-directory
- #:parse-output-translations-string #:wrapping-output-translations
- #:user-output-translations-pathname #:system-output-translations-pathname
- #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
- #:environment-output-translations #:process-output-translations
- #:compute-output-translations
- #+abcl #:translate-jar-pathname
- ))
-(in-package :asdf/output-translations)
-
-(when-upgrading () (undefine-function '(setf output-translations)))
-
-(with-upgradability ()
- (define-condition invalid-output-translation (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- (defvar *output-translations* ()
- "Either NIL (for uninitialized), or a list of one element,
-said element itself being a sorted list of mappings.
-Each mapping is a pair of a source pathname and destination pathname,
-and the order is by decreasing length of namestring of the source pathname.")
-
- (defun output-translations ()
- (car *output-translations*))
-
- (defun set-output-translations (new-value)
- (setf *output-translations*
- (list
- (stable-sort (copy-list new-value) #'>
- :key #'(lambda (x)
- (etypecase (car x)
- ((eql t) -1)
- (pathname
- (let ((directory (pathname-directory (car x))))
- (if (listp directory) (length directory) 0))))))))
- new-value)
- #-gcl2.6
- (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
- #+gcl2.6
- (defsetf output-translations set-output-translations)
-
- (defun output-translations-initialized-p ()
- (and *output-translations* t))
-
- (defun clear-output-translations ()
- "Undoes any initialization of the output translations."
- (setf *output-translations* '())
- (values))
- (register-clear-configuration-hook 'clear-output-translations)
-
- (defun validate-output-translations-directive (directive)
- (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
- :location location :invalid-form-reporter 'invalid-output-translation))
+ (defmethod perform ((o link-op) (c prebuilt-system))
+ nil)
- (defun validate-output-translations-file (file)
- (validate-configuration-file
- file 'validate-output-translations-form :description "output translations"))
+ (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
+ nil)
- (defun validate-output-translations-directory (directory)
- (validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive
- :invalid-form-reporter 'invalid-output-translation))
+ (defmethod perform ((o lib-op) (c prebuilt-system))
+ nil)
- (defun parse-output-translations-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:output-translations :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string) :location location))
- ((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with source = nil
- :with separator = (inter-directory-separator)
- :for i = (or (position separator string :start start) end) :do
- (let ((s (subseq string start i)))
- (cond
- (source
- (push (list source (if (equal "" s) nil s)) directives)
- (setf source nil))
- ((equal "" s)
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push :inherit-configuration directives))
- (t
- (setf source s)))
- (setf start (1+ i))
- (when (> start end)
- (when source
- (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)))))))))
+ (defmethod perform ((o dll-op) (c prebuilt-system))
+ nil)
- (defparameter *default-output-translations*
- '(environment-output-translations
- user-output-translations-pathname
- user-output-translations-directory-pathname
- system-output-translations-pathname
- system-output-translations-directory-pathname))
+ (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
+ nil)
- (defun wrapping-output-translations ()
- `(:output-translations
- ;; Some implementations have precompiled ASDF systems,
- ;; so we must disable translations for implementation paths.
- #+(or #|clozure|# ecl mkcl sbcl)
- ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
- (when h `(((,h ,*wild-path*) ()))))
- #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
- ;; 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))
- ;; We enable the user cache by default, and here is the place we do:
- :enable-user-cache))
+ (defmethod output-files ((o lib-op) (c prebuilt-system))
+ (values (list (prebuilt-system-static-library c)) t)))
- (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
- (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
- (defun user-output-translations-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-file* :direction direction))
- (defun system-output-translations-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-file* :direction direction))
- (defun user-output-translations-directory-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-directory* :direction direction))
- (defun system-output-translations-directory-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-directory* :direction direction))
- (defun environment-output-translations ()
- (getenv "ASDF_OUTPUT_TRANSLATIONS"))
+;;;
+;;; PREBUILT SYSTEM CREATOR
+;;;
+(with-upgradability ()
+ (defmethod output-files ((o deliver-asd-op) (s system))
+ (list (make-pathname :name (component-name s) :type "asd"
+ :defaults (component-pathname s))))
- (defgeneric process-output-translations (spec &key inherit collect))
+ (defmethod perform ((o deliver-asd-op) (s system))
+ (let* ((inputs (input-files o s))
+ (fasl (first inputs))
+ (library (second inputs))
+ (asd (first (output-files o s)))
+ (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
+ (version (component-version s))
+ (dependencies
+ (if (operation-monolithic-p o)
+ (remove-if-not 'builtin-system-p
+ (required-components s :component-type 'system
+ :keep-operation 'load-op))
+ (while-collecting (x) ;; resolve the sideway-dependencies of s
+ (map-direct-dependencies
+ t 'load-op s
+ #'(lambda (o c)
+ (when (and (typep o 'load-op) (typep c 'system))
+ (x c)))))))
+ (depends-on (mapcar 'coerce-name dependencies)))
+ (when (pathname-equal asd (system-source-file s))
+ (cerror "overwrite the asd file"
+ "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
+ (cons o s) asd))
+ (with-open-file (s asd :direction :output :if-exists :supersede
+ :if-does-not-exist :create)
+ (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
+ (operation-monolithic-p o) name)
+ (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (software-type)
+ (machine-type)
+ (software-version))
+ (let ((*package* (find-package :asdf-user)))
+ (pprint `(defsystem ,name
+ :class prebuilt-system
+ :version ,version
+ :depends-on ,depends-on
+ :components ((:compiled-file ,(pathname-name fasl)))
+ ,@(when library `(:lib ,(file-namestring library))))
+ s)
+ (terpri s)))))
- (defun inherit-output-translations (inherit &key collect)
- (when inherit
- (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
+ #-(or ecl mkcl)
+ (defmethod perform ((o basic-compile-bundle-op) (c system))
+ (let* ((input-files (input-files o c))
+ (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
+ (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
+ (output-files (output-files o c))
+ (output-file (first output-files)))
+ (assert (eq (not input-files) (not output-files)))
+ (when input-files
+ (when non-fasl-files
+ (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
+ (implementation-type) non-fasl-files))
+ (when (or (prologue-code o) (epilogue-code o)
+ (prologue-code c) (epilogue-code c))
+ (error "prologue-code and epilogue-code are not supported on ~A"
+ (implementation-type)))
+ (with-staging-pathname (output-file)
+ (combine-fasls fasl-files output-file)))))
- (defun* (process-output-translations-directive) (directive &key inherit collect)
- (if (atom directive)
- (ecase directive
- ((:enable-user-cache)
- (process-output-translations-directive '(t :user-cache) :collect collect))
- ((:disable-cache)
- (process-output-translations-directive '(t t) :collect collect))
- ((:inherit-configuration)
- (inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration :ignore-invalid-entries nil)
- nil))
- (let ((src (first directive))
- (dst (second directive)))
- (if (eq src :include)
- (when dst
- (process-output-translations (pathname dst) :inherit nil :collect collect))
- (when src
- (let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :ensure-directory t :wilden t)))
- (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
- (cond
- ((location-function-p dst)
- (funcall collect
- (list trusrc
- (if (symbolp (second dst))
- (fdefinition (second dst))
- (eval (second dst))))))
- ((eq dst t)
- (funcall collect (list trusrc t)))
- (t
- (let* ((trudst (if dst
- (resolve-location dst :ensure-directory t :wilden t)
- trusrc)))
- (funcall collect (list trudst t))
- (funcall collect (list trusrc trudst)))))))))))
+ (defmethod input-files ((o load-op) (s precompiled-system))
+ (bundle-output-files (find-operation o 'compile-bundle-op) s))
- (defmethod process-output-translations ((x symbol) &key
- (inherit *default-output-translations*)
- collect)
- (process-output-translations (funcall x) :inherit inherit :collect collect))
- (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
- (cond
- ((directory-pathname-p pathname)
- (process-output-translations (validate-output-translations-directory pathname)
- :inherit inherit :collect collect))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (process-output-translations (validate-output-translations-file pathname)
- :inherit inherit :collect collect))
- (t
- (inherit-output-translations inherit :collect collect))))
- (defmethod process-output-translations ((string string) &key inherit collect)
- (process-output-translations (parse-output-translations-string string)
- :inherit inherit :collect collect))
- (defmethod process-output-translations ((x null) &key inherit collect)
- (declare (ignorable x))
- (inherit-output-translations inherit :collect collect))
- (defmethod process-output-translations ((form cons) &key inherit collect)
- (dolist (directive (cdr (validate-output-translations-form form)))
- (process-output-translations-directive directive :inherit inherit :collect collect)))
+ (defmethod perform ((o load-op) (s precompiled-system))
+ (perform-lisp-load-fasl o s))
- (defun compute-output-translations (&optional parameter)
- "read the configuration, return it"
- (remove-duplicates
- (while-collecting (c)
- (inherit-output-translations
- `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
- :test 'equal :from-end t))
+ (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
+ #+xcl (declare (ignorable o))
+ `((load-op ,s) ,@(call-next-method))))
- (defvar *output-translations-parameter* nil)
+#| ;; Example use:
+(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
+(asdf:load-system :precompiled-asdf-utils)
+|#
- (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
- "read the configuration, initialize the internal configuration variable,
-return the configuration"
- (setf *output-translations-parameter* parameter
- (output-translations) (compute-output-translations parameter)))
+#+(or ecl mkcl)
+(with-upgradability ()
+ ;; I think that Juanjo intended for this to be,
+ ;; but beware the weird bug in test-xach-update-bug.script,
+ ;; and also it makes mkcl fail test-logical-pathname.script,
+ ;; and ecl fail test-bundle.script.
+ ;;(unless (or #+ecl (use-ecl-byte-compiler-p))
+ ;; (setf *load-system-operation* 'load-bundle-op))
+
+ (defun asdf-library-pathname ()
+ #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
+ (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
+ #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
+
+ (defun compiler-library-pathname ()
+ #+ecl (compile-file-pathname "sys:cmp" :type :lib)
+ #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
+
+ (defun make-library-system (name pathname)
+ (make-instance 'prebuilt-system
+ :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
+
+ (defmethod component-depends-on :around ((o image-op) (c system))
+ (destructuring-bind ((lib-op . deps)) (call-next-method)
+ (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
+ `((,lib-op
+ ,@(unless (or (no-uiop c) (has-it-p "cmp"))
+ `(,(make-library-system
+ "cmp" (compiler-library-pathname))))
+ ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
+ `(,(cond
+ ((system-source-directory :uiop) (find-system :uiop))
+ ((system-source-directory :asdf) (find-system :asdf))
+ (t (make-library-system "asdf" (asdf-library-pathname))))))
+ ,@deps)))))
+
+ (defmethod perform ((o link-op) (c system))
+ (let* ((object-files (input-files o c))
+ (output (output-files o c))
+ (bundle (first output))
+ (programp (typep o 'program-op))
+ (kind (bundle-type o)))
+ (when output
+ (apply 'create-image
+ bundle (append
+ (when programp (prefix-lisp-object-files c))
+ object-files
+ (when programp (postfix-lisp-object-files c)))
+ :kind kind
+ :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
+ :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
+ :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
+ :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
+ :no-uiop (no-uiop c)
+ (when programp `(:entry-point ,(component-entry-point c))))))))
+
+#+(and (not asdf-use-unsafe-mac-bundle-op)
+ (or (and ecl darwin)
+ (and abcl darwin (not abcl-bundle-op-supported))))
+(defmethod perform :before ((o basic-compile-bundle-op) (c component))
+ (unless (featurep :asdf-use-unsafe-mac-bundle-op)
+ (cerror "Continue after modifying *FEATURES*."
+ "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~
+To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
+Please report to ASDF-DEVEL if this works for you.")))
+
+
+;;; Backward compatibility with pre-3.1.1 names
+(defclass fasl-op (selfward-operation)
+ ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
+(defclass load-fasl-op (selfward-operation)
+ ((selfward-operation :initform 'load-bundle-op :allocation :class)))
+(defclass binary-op (selfward-operation)
+ ((selfward-operation :initform 'deliver-asd-op :allocation :class)))
+(defclass monolithic-fasl-op (selfward-operation)
+ ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)))
+(defclass monolithic-load-fasl-op (selfward-operation)
+ ((selfward-operation :initform 'monolithic-load-bundle-op :allocation :class)))
+(defclass monolithic-binary-op (selfward-operation)
+ ((selfward-operation :initform 'monolithic-deliver-asd-op :allocation :class)))
+;;;; -------------------------------------------------------------------------
+;;;; Concatenate-source
+
+(uiop/package:define-package :asdf/concatenate-source
+ (:recycle :asdf/concatenate-source :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
+ :asdf/component :asdf/operation
+ :asdf/system :asdf/find-system
+ :asdf/action :asdf/lisp-action :asdf/bundle)
+ (:export
+ #:concatenate-source-op
+ #:load-concatenated-source-op
+ #:compile-concatenated-source-op
+ #:load-compiled-concatenated-source-op
+ #:monolithic-concatenate-source-op
+ #:monolithic-load-concatenated-source-op
+ #:monolithic-compile-concatenated-source-op
+ #:monolithic-load-compiled-concatenated-source-op))
+(in-package :asdf/concatenate-source)
- (defun disable-output-translations ()
- "Initialize output translations in a way that maps every file to itself,
-effectively disabling the output translation facility."
- (initialize-output-translations
- '(:output-translations :disable-cache :ignore-inherited-configuration)))
+;;;
+;;; Concatenate sources
+;;;
+(with-upgradability ()
+ (defclass basic-concatenate-source-op (bundle-op)
+ ((bundle-type :initform "lisp")))
+ (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
+ (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
+ (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
- ;; checks an initial variable to see whether the state is initialized
- ;; or cleared. In the former case, return current configuration; in
- ;; the latter, initialize. ASDF will call this function at the start
- ;; of (asdf:find-system).
- (defun ensure-output-translations ()
- (if (output-translations-initialized-p)
- (output-translations)
- (initialize-output-translations)))
+ (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ())
+ (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
+ (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)))
+ (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)))
- (defun* (apply-output-translations) (path)
- (etypecase path
- (logical-pathname
- path)
- ((or pathname string)
- (ensure-output-translations)
- (loop* :with p = (resolve-symlinks* path)
- :for (source destination) :in (car *output-translations*)
- :for root = (when (or (eq source t)
- (and (pathnamep source)
- (not (absolute-pathname-p source))))
- (pathname-root p))
- :for absolute-source = (cond
- ((eq source t) (wilden root))
- (root (merge-pathnames* source root))
- (t source))
- :when (or (eq source t) (pathname-match-p p absolute-source))
- :return (translate-pathname* p absolute-source destination root source)
- :finally (return p)))))
+ (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ())
+ (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
+ (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)))
+ (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)))
- ;; Hook into asdf/driver's output-translation mechanism
- #-cormanlisp
- (setf *output-translation-function* 'apply-output-translations)
+ (defmethod input-files ((operation basic-concatenate-source-op) (s system))
+ (loop :with encoding = (or (component-encoding s) *default-encoding*)
+ :with other-encodings = '()
+ :with around-compile = (around-compile-hook s)
+ :with other-around-compile = '()
+ :for c :in (required-components
+ s :goal-operation 'compile-op
+ :keep-operation 'compile-op
+ :other-systems (operation-monolithic-p operation))
+ :append
+ (when (typep c 'cl-source-file)
+ (let ((e (component-encoding c)))
+ (unless (equal e encoding)
+ (let ((a (assoc e other-encodings)))
+ (if a (push (component-find-path c) (cdr a))
+ (push (list a (component-find-path c)) other-encodings)))))
+ (unless (equal around-compile (around-compile-hook c))
+ (push (component-find-path c) other-around-compile))
+ (input-files (make-operation 'compile-op) c)) :into inputs
+ :finally
+ (when other-encodings
+ (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
+ operation encoding
+ (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
+ other-encodings)))
+ (when other-around-compile
+ (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
+ operation around-compile other-around-compile))
+ (return inputs)))
+ (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
+ (lisp-compilation-output-files o s))
- #+abcl
- (defun translate-jar-pathname (source wildcard)
- (declare (ignore wildcard))
- (flet ((normalize-device (pathname)
- (if (find :windows *features*)
- pathname
- (make-pathname :defaults pathname :device :unspecific))))
- (let* ((jar
- (pathname (first (pathname-device source))))
- (target-root-directory-namestring
- (format nil "/___jar___file___root___/~@[~A/~]"
- (and (find :windows *features*)
- (pathname-device jar))))
- (relative-source
- (relativize-pathname-directory source))
- (relative-jar
- (relativize-pathname-directory (ensure-directory-pathname jar)))
- (target-root-directory
- (normalize-device
- (pathname-directory-pathname
- (parse-namestring target-root-directory-namestring))))
- (target-root
- (merge-pathnames* relative-jar target-root-directory))
- (target
- (merge-pathnames* relative-source target-root)))
- (normalize-device (apply-output-translations target))))))
+ (defmethod perform ((o basic-concatenate-source-op) (s system))
+ (let* ((ins (input-files o s))
+ (out (output-file o s))
+ (tmp (tmpize-pathname out)))
+ (concatenate-files ins tmp)
+ (rename-file-overwriting-target tmp out)))
+ (defmethod perform ((o basic-load-concatenated-source-op) (s system))
+ (perform-lisp-load-source o s))
+ (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
+ (perform-lisp-compilation o s))
+ (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
+ (perform-lisp-load-fasl o s)))
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces
-(asdf/package:define-package :asdf/backward-interface
+(uiop/package:define-package :asdf/backward-interface
(:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
- :asdf/lisp-action :asdf/operate :asdf/output-translations)
+ :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
(:export
#:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned
- #:error-component #:error-operation
+ #:error-component #:error-operation #:traverse
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
#:operation-forced
(defgeneric operation-on-warnings (operation))
(defgeneric operation-on-failure (operation))
- #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
- #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
+ (defgeneric (setf operation-on-warnings) (x operation))
+ (defgeneric (setf operation-on-failure) (x operation))
(defmethod operation-on-warnings ((o operation))
- (declare (ignorable o)) *compile-file-warnings-behaviour*)
+ *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
- (declare (ignorable o)) *compile-file-failure-behaviour*)
+ *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
- (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
+ (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
- (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
+ (setf *compile-file-failure-behaviour* x))
(defun system-definition-pathname (x)
;; As of 2.014.8, we mean to make this function obsolete,
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)))
+ (system-source-file x))
+
+ (defgeneric* (traverse) (operation component &key &allow-other-keys)
+ (: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."))
+ (define-convenience-action-methods traverse (operation component &key))
+
+ (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
+ (plan-actions (apply 'make-plan plan-class o c keys))))
;;;; ASDF-Binary-Locations compatibility
`(:output-translations
,@source-to-target-mappings
#+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
- ,@(loop :for pattern :in patterns
- :collect `((:root ,*wild-inferiors* ,pattern)
- (,@destination-directory ,pattern)))
- (t t)
- :ignore-inherited-configuration))))
-
- (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 nil)
- (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."))))
-
-
-;;; run-shell-command
-;; WARNING! The function below is not just deprecated but also dysfunctional.
-;; Please use asdf/run-program:run-program instead.
-(with-upgradability ()
- (defun run-shell-command (control-string &rest args)
- "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.
-
-PLEASE DO NOT USE.
-Deprecated function, for backward-compatibility only.
-Please use UIOP:RUN-PROGRAM instead."
- (let ((command (apply 'format nil control-string args)))
- (asdf-message "; $ ~A~%" command)
- (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
-
-(with-upgradability ()
- (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
-
-;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
-(with-upgradability ()
- (defgeneric component-property (component property))
- (defgeneric (setf component-property) (new-value component property))
-
- (defmethod component-property ((c component) property)
- (cdr (assoc property (slot-value c 'properties) :test #'equal)))
-
- (defmethod (setf component-property) (new-value (c component) property)
- (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
- (if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties)))))
- new-value))
-;;;; -----------------------------------------------------------------
-;;;; Source Registry Configuration, by Francois-Rene Rideau
-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
-
-(asdf/package:define-package :asdf/source-registry
- (:recycle :asdf/source-registry :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
- (:export
- #:*source-registry-parameter* #:*default-source-registries*
- #:invalid-source-registry
- #:source-registry-initialized-p
- #:initialize-source-registry #:clear-source-registry #:*source-registry*
- #:ensure-source-registry #:*source-registry-parameter*
- #:*default-source-registry-exclusions* #:*source-registry-exclusions*
- #:*wild-asd* #:directory-asd-files #:register-asd-directory
- #:collect-asds-in-directory #:collect-sub*directories-asd-files
- #:validate-source-registry-directive #:validate-source-registry-form
- #:validate-source-registry-file #:validate-source-registry-directory
- #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
- #:user-source-registry #:system-source-registry
- #:user-source-registry-directory #:system-source-registry-directory
- #:environment-source-registry #:process-source-registry
- #:compute-source-registry #:flatten-source-registry
- #:sysdef-source-registry-search))
-(in-package :asdf/source-registry)
-
-(with-upgradability ()
- (define-condition invalid-source-registry (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- ;; Using ack 1.2 exclusions
- (defvar *default-source-registry-exclusions*
- '(".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 builds stuff under the debian directory... BAD.
-
- (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
-
- (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 ()
- (typep *source-registry* 'hash-table))
-
- (defun clear-source-registry ()
- "Undoes any initialization of the source registry."
- (setf *source-registry* nil)
- (values))
- (register-clear-configuration-hook 'clear-source-registry)
-
- (defparameter *wild-asd*
- (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
-
- (defun directory-asd-files (directory)
- (directory-files directory *wild-asd*))
-
- (defun collect-asds-in-directory (directory collect)
- (map () collect (directory-asd-files directory)))
-
- (defun collect-sub*directories-asd-files
- (directory &key (exclude *default-source-registry-exclusions*) collect)
- (collect-sub*directories
- directory
- (constantly t)
- #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
- #'(lambda (dir) (collect-asds-in-directory dir collect))))
-
- (defun validate-source-registry-directive (directive)
- (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
- :location location :invalid-form-reporter 'invalid-source-registry))
-
- (defun validate-source-registry-file (file)
- (validate-configuration-file
- file 'validate-source-registry-form :description "a source registry"))
+ #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
+ ,@(loop :for pattern :in patterns
+ :collect `((:root ,*wild-inferiors* ,pattern)
+ (,@destination-directory ,pattern)))
+ (t t)
+ :ignore-inherited-configuration))))
- (defun validate-source-registry-directory (directory)
- (validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive
- :invalid-form-reporter 'invalid-source-registry))
+ (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+ (declare (ignore operation-class system args))
+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
+ (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 parse-source-registry-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:source-registry :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with separator = (inter-directory-separator)
- :for pos = (position separator string :start start) :do
- (let ((s (subseq string start (or pos end))))
- (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))
- ((string-suffix-p 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)))
- (t
- (unless inherit
- (push '(:ignore-inherited-configuration) directives))
- (return `(:source-registry ,@(nreverse directives))))))))))
- (defun register-asd-directory (directory &key recurse exclude collect)
- (if (not recurse)
- (collect-asds-in-directory directory collect)
- (collect-sub*directories-asd-files
- directory :exclude exclude :collect collect)))
+;;; run-shell-command
+;; WARNING! The function below is not just deprecated but also dysfunctional.
+;; Please use asdf/run-program:run-program instead.
+(with-upgradability ()
+ (defun run-shell-command (control-string &rest args)
+ "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.
- (defparameter *default-source-registries*
- '(environment-source-registry
- user-source-registry
- user-source-registry-directory
- system-source-registry
- system-source-registry-directory
- default-source-registry))
+PLEASE DO NOT USE.
+Deprecated function, for backward-compatibility only.
+Please use UIOP:RUN-PROGRAM instead."
+ (let ((command (apply 'format nil control-string args)))
+ (asdf-message "; $ ~A~%" command)
+ (let ((exit-code
+ (ignore-errors
+ (nth-value 2 (run-program command :force-shell t :ignore-error-status t
+ :output *verbose-out*)))))
+ (typecase exit-code
+ ((integer 0 255) exit-code)
+ (t 255))))))
- (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
- (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
+(with-upgradability ()
+ (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
- (defun wrapping-source-registry ()
- `(:source-registry
- #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
- #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
- :inherit-configuration
- #+cmu (:tree #p"modules:")
- #+scl (:tree #p"file://modules/")))
- (defun default-source-registry ()
- `(:source-registry
- #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
- (subpathname (user-homedir-pathname) ".local/share/"))
- ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share"))))
- ,@(when (os-windows-p)
- (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
- :inherit-configuration))
- (defun user-source-registry (&key (direction :input))
- (in-user-configuration-directory *source-registry-file* :direction direction))
- (defun system-source-registry (&key (direction :input))
- (in-system-configuration-directory *source-registry-file* :direction direction))
- (defun user-source-registry-directory (&key (direction :input))
- (in-user-configuration-directory *source-registry-directory* :direction direction))
- (defun system-source-registry-directory (&key (direction :input))
- (in-system-configuration-directory *source-registry-directory* :direction direction))
- (defun environment-source-registry ()
- (getenv "CL_SOURCE_REGISTRY"))
+;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
+(with-upgradability ()
+ (defgeneric component-property (component property))
+ (defgeneric (setf component-property) (new-value component property))
- (defgeneric* (process-source-registry) (spec &key inherit register))
+ (defmethod component-property ((c component) property)
+ (cdr (assoc property (slot-value c 'properties) :test #'equal)))
- (defun* (inherit-source-registry) (inherit &key register)
- (when inherit
- (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+ (defmethod (setf component-property) (new-value (c component) property)
+ (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
+ (if a
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties)))))
+ new-value))
+;;;; -------------------------------------------------------------------------
+;;;; Package systems in the style of quick-build or faslpath
- (defun* (process-source-registry-directive) (directive &key inherit register)
- (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
- (ecase kw
- ((:include)
- (destructuring-bind (pathname) rest
- (process-source-registry (resolve-location pathname) :inherit nil :register register)))
- ((:directory)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)))))
- ((:tree)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)
- :recurse t :exclude *source-registry-exclusions*))))
- ((:exclude)
- (setf *source-registry-exclusions* rest))
- ((:also-exclude)
- (appendf *source-registry-exclusions* rest))
- ((:default-registry)
- (inherit-source-registry '(default-source-registry) :register register))
- ((:inherit-configuration)
- (inherit-source-registry inherit :register register))
- ((:ignore-inherited-configuration)
- nil)))
- nil)
+(uiop:define-package :asdf/package-inferred-system
+ (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
+ (:use :uiop/common-lisp :uiop
+ :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
+ :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
+ (:export
+ #:package-inferred-system #:sysdef-package-inferred-system-search
+ #:package-system ;; backward compatibility only. To be removed.
+ #:register-system-packages
+ #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
+(in-package :asdf/package-inferred-system)
- (defmethod process-source-registry ((x symbol) &key inherit register)
- (process-source-registry (funcall x) :inherit inherit :register register))
- (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
- (cond
- ((directory-pathname-p pathname)
- (let ((*here-directory* (resolve-symlinks* pathname)))
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register)))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (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)
- (process-source-registry (parse-source-registry-string string)
- :inherit inherit :register register))
- (defmethod process-source-registry ((x null) &key inherit register)
- (declare (ignorable x))
- (inherit-source-registry inherit :register register))
- (defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
- (dolist (directive (cdr (validate-source-registry-form form)))
- (process-source-registry-directive directive :inherit inherit :register register))))
+(with-upgradability ()
+ (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))
- (defun flatten-source-registry (&optional parameter)
- (remove-duplicates
- (while-collecting (collect)
- (with-pathname-defaults () ;; be location-independent
- (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))
+ (defun initial-package-inferred-systems-table ()
+ (let ((h (make-hash-table :test 'equal)))
+ (dolist (p (list-all-packages))
+ (dolist (n (package-names p))
+ (setf (gethash n h) t)))
+ h))
- ;; Will read the configuration and initialize all internal variables.
- (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
- #'(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 *verbose-out*
- (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))
+ (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
- (defvar *source-registry-parameter* nil)
+ (defclass package-inferred-system (system)
+ ())
- (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
- ;; Record the parameter used to configure the registry
- (setf *source-registry-parameter* parameter)
- ;; Clear the previous registry database:
- (setf *source-registry* (make-hash-table :test 'equal))
- ;; Do it!
- (compute-source-registry parameter))
+ ;; For backward compatibility only. To be removed in an upcoming release:
+ (defclass package-system (package-inferred-system) ())
- ;; Checks an initial variable to see whether the state is initialized
- ;; or cleared. In the former case, return current configuration; in
- ;; the latter, initialize. ASDF will call this function at the start
- ;; of (asdf:find-system) to make sure the source registry is initialized.
- ;; However, it will do so *without* a parameter, at which point it
- ;; will be too late to provide a parameter to this function, though
- ;; you may override the configuration explicitly by calling
- ;; initialize-source-registry directly with your parameter.
- (defun ensure-source-registry (&optional parameter)
- (unless (source-registry-initialized-p)
- (initialize-source-registry parameter))
- (values))
+ (defun defpackage-form-p (form)
+ (and (consp form)
+ (member (car form) *defpackage-forms*)))
- (defun sysdef-source-registry-search (system)
- (ensure-source-registry)
- (values (gethash (primary-system-name system) *source-registry*))))
+ (defun stream-defpackage-form (stream)
+ (loop :for form = (read stream nil nil) :while form
+ :when (defpackage-form-p form) :return form))
+ (defun file-defpackage-form (file)
+ "Return the first DEFPACKAGE form in FILE."
+ (with-input-file (f file)
+ (stream-defpackage-form f)))
+ (define-condition package-inferred-system-missing-package-error (system-definition-error)
+ ((system :initarg :system :reader error-system)
+ (pathname :initarg :pathname :reader error-pathname))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<No package form found while ~
+ trying to define package-inferred-system ~A from file ~A~>")
+ (error-system c) (error-pathname c)))))
+
+ (defun package-dependencies (defpackage-form)
+ "Return a list of packages depended on by the package
+defined in DEFPACKAGE-FORM. A package is depended upon if
+the DEFPACKAGE-FORM uses it or imports a symbol from it."
+ (assert (defpackage-form-p defpackage-form))
+ (remove-duplicates
+ (while-collecting (dep)
+ (loop* :for (option . arguments) :in (cddr defpackage-form) :do
+ (ecase option
+ ((:use :mix :reexport :use-reexport :mix-reexport)
+ (dolist (p arguments) (dep (string p))))
+ ((:import-from :shadowing-import-from)
+ (dep (string (first arguments))))
+ ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
+ :from-end t :test 'equal))
+
+ (defun package-designator-name (package)
+ (etypecase package
+ (package (package-name package))
+ (string package)
+ (symbol (string package))))
+
+ (defun register-system-packages (system packages)
+ "Register SYSTEM as providing PACKAGES."
+ (let ((name (or (eq system t) (coerce-name system))))
+ (dolist (p (ensure-list packages))
+ (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
+
+ (defun package-name-system (package-name)
+ "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
+otherwise return a default system name computed from PACKAGE-NAME."
+ (check-type package-name string)
+ (if-let ((system-name (gethash package-name *package-inferred-systems*)))
+ system-name
+ (string-downcase package-name)))
+
+ (defun package-inferred-system-file-dependencies (file &optional system)
+ (if-let (defpackage-form (file-defpackage-form file))
+ (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
+ (error 'package-inferred-system-missing-package-error :system system :pathname file)))
+
+ (defun same-package-inferred-system-p (system name directory subpath dependencies)
+ (and (eq (type-of system) 'package-inferred-system)
+ (equal (component-name system) name)
+ (pathname-equal directory (component-pathname system))
+ (equal dependencies (component-sideway-dependencies system))
+ (let ((children (component-children system)))
+ (and (length=n-p children 1)
+ (let ((child (first children)))
+ (and (eq (type-of child) 'cl-source-file)
+ (equal (component-name child) "lisp")
+ (and (slot-boundp child 'relative-pathname)
+ (equal (slot-value child 'relative-pathname) subpath))))))))
+
+ (defun sysdef-package-inferred-system-search (system)
+ (let ((primary (primary-system-name system)))
+ (unless (equal primary system)
+ (let ((top (find-system primary nil)))
+ (when (typep top 'package-inferred-system)
+ (if-let (dir (system-source-directory top))
+ (let* ((sub (subseq system (1+ (length primary))))
+ (f (probe-file* (subpathname dir sub :type "lisp")
+ :truename *resolve-symlinks*)))
+ (when (file-pathname-p f)
+ (let ((dependencies (package-inferred-system-file-dependencies f system))
+ (previous (cdr (system-registered-p system))))
+ (if (same-package-inferred-system-p previous system dir sub dependencies)
+ previous
+ (eval `(defsystem ,system
+ :class package-inferred-system
+ :source-file nil
+ :pathname ,dir
+ :depends-on ,dependencies
+ :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))
+
+(with-upgradability ()
+ (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
+ (setf *system-definition-search-functions*
+ (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
+ *system-definition-search-functions*)))
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
-(asdf/package:define-package :asdf/interface
+(uiop/package:define-package :asdf/interface
(:nicknames :asdf :asdf-utilities)
(:recycle :asdf/interface :asdf)
(:unintern
- #:*asdf-revision* #:around #:asdf-method-combination
- #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p
- #:split #:make-collector
#:loaded-systems ; makes for annoying SLIME completion
- #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache
+ #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system :asdf/find-component
:asdf/operation :asdf/action :asdf/lisp-action
:asdf/output-translations :asdf/source-registry
- :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source
- :asdf/backward-internals :asdf/backward-interface)
- ;; TODO: automatically generate interface with reexport?
+ :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source
+ :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
+ ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
+ ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
(:export
- #:defsystem #:find-system #:locate-system #:coerce-name
- #:oos #:operate #:traverse #:perform-plan #:sequential-plan
- #:system-definition-pathname #:with-system-definitions
+ #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name
+ #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
+ #:system-definition-pathname
#:search-for-system-definition #:find-component #:component-find-path
- #:compile-system #:load-system #:load-systems
+ #:compile-system #:load-system #:load-systems #:load-systems*
#:require-system #:test-system #:clear-system
#:operation #:make-operation #:find-operation
#:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
- #:build-system #:build-op
+ #:non-propagating-operation
+ #:build-op #:make
#:load-op #:prepare-op #:compile-op
#:prepare-source-op #:load-source-op #:test-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
- #:input-files #:output-files #:output-file #:perform
+ #:input-files #:output-files #:output-file #:perform #:perform-with-restarts
#:operation-done-p #:explain #:action-description #:component-sideway-dependencies
#:needed-in-image-p
- ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
#:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
- #+ecl #:make-build
- #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
- #:lib-op #:dll-op #:binary-op #:program-op
- #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op
+ #:program-system #:make-build
+ #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op
+ #:basic-compile-bundle-op #:prepare-bundle-op
+ #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
+ #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op
+ #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op
#:concatenate-source-op
#:load-concatenated-source-op
#:compile-concatenated-source-op
#:file-component #:source-file #:c-source-file #:java-source-file
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
#:static-file #:doc-file #:html-file
- #:file-type
- #:source-file-type
+ #:file-type #:source-file-type
+
+ #:package-inferred-system #:register-system-packages
+ #:package-system ;; backward-compatibility during migration, to be removed in a further release.
#:component-children ; component accessors
#:component-children-by-name
#:module-components ; backward-compatibility
#:operation-on-warnings #:operation-on-failure ; backward-compatibility
#:component-property ; backward-compatibility
+ #:traverse ; backward-compatibility
#:system-description
#:system-long-description
#:system-long-name
#:system-source-control
#:map-systems
+ #:system-defsystem-depends-on
+ #:system-depends-on
+ #:system-weakly-depends-on
#:*system-definition-search-functions* ; variables
#:*central-registry*
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
- #:*load-system-operation*
+ #:*load-system-operation* #:*immutable-systems*
#:*asdf-verbose* ;; unused. For backward-compatibility only.
#:*verbose-out*
#:missing-dependency-of-version
#:circular-dependency ; errors
#:duplicate-names #:non-toplevel-system #:non-system-system
+ #:package-inferred-system-missing-package-error
+ #:operation-definition-warning #:operation-definition-error
#:try-recompiling
#:retry
;;;; ---------------------------------------------------------------------------
;;;; ASDF-USER, where the action happens.
-(asdf/package:define-package :asdf/user
+(uiop/package:define-package :asdf/user
(:nicknames :asdf-user)
- (:use :asdf/common-lisp :asdf/package :asdf/interface))
+ ;; NB: releases before 3.1.1 this :use'd only uiop/package instead of uiop below.
+ ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
+ ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.
+ ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package
+ ;; that only :use's :cl and :asdf
+ (:use :uiop/common-lisp :uiop :asdf/interface))
;;;; -----------------------------------------------------------------------
;;;; ASDF Footer: last words and cleanup
-(asdf/package:define-package :asdf/footer
+(uiop/package:define-package :asdf/footer
(:recycle :asdf/footer :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action
- :asdf/operate :asdf/bundle :asdf/concatenate-source
- :asdf/output-translations :asdf/source-registry
- :asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
+ (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/operate :asdf/bundle))
(in-package :asdf/footer)
;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
-
+#+(or abcl clisp clozure cmu ecl mkcl sbcl)
(with-upgradability ()
- #+(or abcl clisp clozure cmu ecl mkcl sbcl)
(if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
#+(or ecl mkcl)
(progn
- (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car)
+ (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car)
#+(or (and ecl win32) (and mkcl windows))
(unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
(and (first l) (register-pre-built-system (coerce-name name)))
(values-list l))))))))
+#+cmu ;; Hook into the CMUCL herald.
+(with-upgradability ()
+ (defun herald-asdf (stream)
+ (format stream " ASDF ~A" (asdf-version)))
+ (setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
+
;;;; Done!
(with-upgradability ()
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)
(setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*))
- (dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*))
+ (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*))
- (provide :asdf)
+ ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users.
+ (provide "asdf") (provide "ASDF")
(cleanup-upgraded-asdf))
(when *load-verbose*
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
-
\input texinfo @c -*- texinfo -*-
@c %**start of header
@setfilename asdf.info
-@settitle asdf Manual
+@settitle ASDF Manual
@c %**end of header
+@c We use @&key, etc to escape & from TeX in lambda lists --
+@c so we need to define them for info as well.
+@macro AallowOtherKeys
+&allow-other-keys
+@end macro
+@macro Aoptional
+&optional
+@end macro
+@macro Arest
+&rest
+@end macro
+@macro Akey
+&key
+@end macro
+@macro Abody
+&body
+@end macro
+
@c for install-info
@dircategory Software development
@direntry
-* asdf: (asdf). another system definition facility
+* asdf: (asdf). Another System Definition Facility (for Common Lisp)
@end direntry
@copying
-This manual describes asdf, a system definition facility for Common
-Lisp programs and libraries.
-
-asdf Copyright @copyright{} 2001-2004 Daniel Barlow and contributors
+This manual describes ASDF, a system definition facility
+for Common Lisp programs and libraries.
+
+You can find the latest version of this manual at
+@url{http://common-lisp.net/project/asdf/asdf.html}.
+
+ASDF Copyright @copyright{} 2001-2014 Daniel Barlow and contributors.
+
+This manual Copyright @copyright{} 2001-2014 Daniel Barlow and contributors.
-This manual Copyright @copyright{} 2001-2004 Daniel Barlow and
-contributors
+This manual revised @copyright{} 2009-2014 Robert P. Goldman and Francois-Rene Rideau.
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
@titlepage
-@title asdf: another system definition facility
-
+@title ASDF: Another System Definition Facility
+
@c The following two commands start the copyright page.
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
-
+
@c Output the table of contents at the beginning.
@contents
@ifnottex
-@node Top, Using asdf to load systems, (dir), (dir)
-@top asdf: another system definition facility
-
+@node Top, Introduction, (dir), (dir)
+@top ASDF: Another System Definition Facility
+
@insertcopying
@menu
-* Using asdf to load systems::
-* Defining systems with defsystem::
-* The object model of asdf::
-* Error handling::
-* Compilation error and warning handling::
-* Getting the latest version::
-* TODO list::
-* missing bits in implementation::
-* Inspiration::
-* Concept Index::
-* Function and Class Index::
-* Variable Index::
+* Introduction::
+* Quick start summary::
+* Loading ASDF::
+* Configuring ASDF::
+* Using ASDF::
+* Defining systems with defsystem::
+* The object model of ASDF::
+* Controlling where ASDF searches for systems::
+* Controlling where ASDF saves compiled files::
+* Error handling::
+* Miscellaneous additional functionality::
+* Getting the latest version::
+* FAQ::
+* Ongoing Work::
+* Bibliography::
+* Concept Index::
+* Function and Class Index::
+* Variable Index:: @c @detailmenu
+@c
@detailmenu
--- The Detailed Node Listing ---
+Loading ASDF
+
+* Loading a pre-installed ASDF::
+* Checking whether ASDF is loaded::
+* Upgrading ASDF::
+* Loading ASDF from source::
+
+Upgrading ASDF
+
+* Upgrading your implementation's ASDF::
+* Issues with upgrading ASDF::
+
+Configuring ASDF
+
+* Configuring ASDF to find your systems::
+* Configuring ASDF to find your systems --- old style::
+* Configuring where ASDF stores object files::
+* Resetting the ASDF configuration::
+
+Using ASDF
+
+* Loading a system::
+* Other Operations::
+* Moving on::
+
Defining systems with defsystem
-* The defsystem form::
-* A more involved example::
-* The defsystem grammar::
+* The defsystem form::
+* A more involved example::
+* The defsystem grammar::
+* Other code in .asd files::
+* The package-inferred-system extension::
-The object model of asdf
+The Object model of ASDF
-* Operations::
-* Components::
+* Operations::
+* Components::
+* Dependencies::
+* Functions::
Operations
-* Predefined operations of asdf::
-* Creating new operations::
+* Predefined operations of ASDF::
+* Creating new operations::
Components
-* Common attributes of components::
-* Pre-defined subclasses of component::
-* Creating new component types::
+* Common attributes of components::
+* Pre-defined subclasses of component::
+* Creating new component types::
properties
-* Pre-defined subclasses of component::
-* Creating new component types::
+* Pre-defined subclasses of component::
+* Creating new component types::
-@end detailmenu
-@end menu
+Controlling where ASDF searches for systems
-@end ifnottex
+* Configurations::
+* Truenames and other dangers::
+* XDG base directory::
+* Backward Compatibility::
+* Configuration DSL::
+* Configuration Directories::
+* Shell-friendly syntax for configuration::
+* Search Algorithm::
+* Caching Results::
+* Configuration API::
+* Introspection::
+* Status::
+* Rejected ideas::
+* TODO::
+* Credits for the source-registry::
-@c -------------------
+Configuration Directories
+* The here directive::
-@node Using asdf to load systems, Defining systems with defsystem, Top, Top
-@comment node-name, next, previous, up
-@chapter Using asdf to load systems
-@cindex system directory designator
-@vindex *central-registry*
-
-This chapter describes how to use asdf to compile and load ready-made
-Lisp programs and libraries.
-
-@section Downloading asdf
-
-Some Lisp implementations (such as SBCL and OpenMCL) come with asdf
-included already, so you don't need to download it separately.
-Consult your Lisp system's documentation. If you need to download
-asdf and install it by hand, the canonical source is the cCLan CVS
-repository at
-@url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/}.
-
-@section Setting up asdf
-
-The single file @file{asdf.lisp} is all you need to use asdf normally.
-Once you load it in a running Lisp, you're ready to use asdf. For
-maximum convenience you might want to have asdf loaded whenever you
-start your Lisp implementation, for example by loading it from the
-startup script or dumping a custom core -- check your Lisp
-implementation's manual for details.
-
-The variable @code{asdf:*central-registry*} is a list of ``system
-directory designators''@footnote{When we say ``directory'' here, we
-mean ``designator for a pathname with a supplied DIRECTORY
-component''.}. A @dfn{system directory designator} is a form which
-will be evaluated whenever a system is to be found, and must evaluate
-to a directory to look in. You might want to set or augment
-@code{*central-registry*} in your Lisp init file, for example:
+Introspection
-@lisp
-(setf asdf:*central-registry*
- (list* '*default-pathname-defaults*
- #p"/home/me/cl/systems/"
- #p"/usr/share/common-lisp/systems/"
- asdf:*central-registry*))
-@end lisp
+* *source-registry-parameter* variable::
+* Information about system dependencies::
-@section Setting up a system to be loaded
+Controlling where ASDF saves compiled files
-To compile and load a system, you need to ensure that a symbolic link to its
-system definition is in one of the directories in
-@code{*central-registry*}@footnote{It is possible to customize the
-system definition file search. That's considered advanced use, and
-covered later: search forward for
-@code{*system-definition-search-functions*}. @xref{Defining systems
-with defsystem}.}.
+* Output Configurations::
+* Output Backward Compatibility::
+* Output Configuration DSL::
+* Output Configuration Directories::
+* Output Shell-friendly syntax for configuration::
+* Semantics of Output Translations::
+* Output Caching Results::
+* Output location API::
+* Credits for output translations::
-For example, if @code{#p"/home/me/cl/systems/"} (note the trailing
-slash) is a member of @code{*central-registry*}, you would set up a
-system @var{foo} that is stored in a directory
-@file{/home/me/src/foo/} for loading with asdf with the following
-commands at the shell (this has to be done only once):
+Miscellaneous additional functionality
-@example
-$ cd /home/me/cl/systems/
-$ ln -s ~/src/foo/foo.asd .
-@end example
+* Controlling file compilation::
+* Controlling source file character encoding::
+* Some Utility Functions::
-@section Loading a system
+FAQ
-The system @var{foo} is loaded (and compiled, if necessary) by
-evaluating the following form in your Lisp implementation:
+* Where do I report a bug?::
+* What has changed between ASDF 1 and ASDF 2?::
+* Issues with installing the proper version of ASDF::
+* Issues with configuring ASDF::
+* Issues with using and extending ASDF to define systems::
+* ASDF development FAQs::
-@example
-(asdf:operate 'asdf:load-op '@var{foo})
-@end example
+``What has changed between ASDF 1, ASDF 2 and ASDF 3?''
-That's all you need to know to use asdf to load systems written by
-others. The rest of this manual deals with writing system
-definitions for Lisp software you write yourself.
+* What are ASDF 1 2 3?::
+* How do I detect the ASDF version?::
+* ASDF can portably name files in subdirectories::
+* Output translations::
+* Source Registry Configuration::
+* Usual operations are made easier to the user::
+* Many bugs have been fixed::
+* ASDF itself is versioned::
+* ASDF can be upgraded::
+* Decoupled release cycle::
+* Pitfalls of the transition to ASDF 2::
-@node Defining systems with defsystem, The object model of asdf, Using asdf to load systems, Top
-@comment node-name, next, previous, up
-@chapter Defining systems with defsystem
+Issues with installing the proper version of ASDF
-This chapter describes how to use asdf to define systems and develop
-software.
+* My Common Lisp implementation comes with an outdated version of ASDF. What to do?::
+* I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?::
+Issues with configuring ASDF
-@menu
-* The defsystem form::
-* A more involved example::
-* The defsystem grammar::
-@end menu
+* How can I customize where fasl files are stored?::
+* How can I wholly disable the compiler output cache?::
-@node The defsystem form, A more involved example, Defining systems with defsystem, Defining systems with defsystem
-@comment node-name, next, previous, up
-@section The defsystem form
+Issues with using and extending ASDF to define systems
-Systems can be constructed programmatically by instantiating
-components using make-instance. Most of the time, however, it is much
-more practical to use a static @code{defsystem} form. This section
-begins with an example of a system definition, then gives the full
-grammar of @code{defsystem}.
+* How can I cater for unit-testing in my system?::
+* How can I cater for documentation generation in my system?::
+* How can I maintain non-Lisp (e.g. C) source files?::
+* I want to put my module's files at the top level. How do I do this?::
+* How do I create a system definition where all the source files have a .cl extension?::
+* How do I mark a source file to be loaded only and not compiled?::
+* How do I work with readtables?::
-Let's look at a simple system. This is a complete file that would
-usually be saved as @file{hello-lisp.asd}:
+ASDF development FAQs
-@lisp
-(defpackage hello-lisp-system
- (:use :common-lisp :asdf))
+* How do run the tests interactively in a REPL?::
+
+@end detailmenu
+@end menu
-(in-package :hello-lisp-system)
+@end ifnottex
-(defsystem "hello-lisp"
- :description "hello-lisp: a sample Lisp system."
- :version "0.2"
- :author "Joe User <joe@@example.com>"
- :licence "Public Domain"
- :components ((:file "packages")
- (:file "macros" :depends-on ("packages"))
- (:file "hello" :depends-on ("macros"))))
-@end lisp
+@c -------------------
-Some notes about this example:
+@node Introduction, Quick start summary, Top, Top
+@comment node-name, next, previous, up
+@chapter Introduction
+@cindex ASDF-related features
+@vindex *features*
+@cindex Testing for ASDF
+@cindex ASDF versions
+@cindex :asdf
+@cindex :asdf2
+@cindex :asdf3
+
+ASDF is Another System Definition Facility:
+a tool for specifying how systems of Common Lisp software
+are made up of components (sub-systems and files),
+and how to operate on these components in the right order
+so that they can be compiled, loaded, tested, etc.
+If you are new to ASDF, @pxref{Quick start summary,,the quick start
+guide}.
+
+ASDF presents three faces:
+one for users of Common Lisp software who want to reuse other people's code,
+one for writers of Common Lisp software who want to specify how to build their systems,
+and one for implementers of Common Lisp extensions who want to extend
+the build system.
+For more specifics,
+@pxref{Using ASDF,,Loading a system},
+to learn how to use ASDF to load a system.
+@xref{Defining systems with defsystem},
+to learn how to define a system of your own.
+@xref{The object model of ASDF}, for a description of
+the ASDF internals and how to extend ASDF.
+
+Note that
+ASDF is @emph{not} a tool for library and system @emph{installation}; it
+plays a role like @t{make} or @t{ant}, not like a package manager.
+In particular, ASDF should not to be confused with ASDF-Install, which attempts to find and
+download ASDF systems for you.
+Despite the name, ASDF-Install is not part of ASDF, but a separate piece of software.
+ASDF-Install is also unmaintained and obsolete.
+We recommend you use Quicklisp
+(@uref{http://www.quicklisp.org}) instead,
+a Common Lisp package manager which works well and is being actively maintained.
+If you want to download software from version control instead of tarballs,
+so you may more easily modify it, we recommend clbuild (@uref{http://common-lisp.net/project/clbuild/}).
+We recommend @file{~/common-lisp/}
+as a place into which to install Common Lisp software;
+starting with ASDF 3.1.1, it is included in the default source-registry configuration.
+
+@node Quick start summary, Loading ASDF, Introduction, Top
+@chapter Quick start summary
@itemize
-@item
-The file starts with @code{defpackage} and @code{in-package} forms to
-make and use a package expressly for defining this system in. This
-package is named by taking the system name and suffixing
-@code{-system} - note that it is @emph{not} the same package as you
-will use for the application code.
+@item To load an ASDF system:
-This is not absolutely required by asdf, but helps avoid namespace
-pollution and so is considered good form.
+@itemize
+@item
+Load ASDF itself into your Lisp image, either through
+@code{(require "asdf")} (if it's supplied by your lisp implementation)
+or else through
+@code{(load "/path/to/asdf.lisp")}. For more details, @ref{Loading ASDF}.
@item
-The defsystem form defines a system named "hello-lisp" that contains
-three source files: @file{packages}, @file{macros} and @file{hello}.
+Make sure ASDF can find system definitions
+through proper source-registry configuration.
+For more details, @xref{Configuring ASDF to find your systems}.
+The simplest way is simply to put all your lisp code in subdirectories of
+@file{~/common-lisp/} (starting with ASDF 3.1.1),
+or @file{~/.local/share/common-lisp/source/}
+(for ASDF 2 and later, or if you want to keep source in a hidden directory).
+Such code will automatically be found.
@item
-The file @file{macros} depends on @file{packages} (presumably because
-the package it's in is defined in @file{packages}), and the file
-@file{hello} depends on @file{macros} (and hence, transitively on
-@file{packages}). This means that asdf will compile and load
-@file{packages} and @file{macros} before starting the compilation of
-file @file{hello}.
+Load a system with @code{(asdf:load-system :system)}. @xref{Using ASDF}.
+
+@end itemize
+@item To make your own ASDF system:
+@itemize
@item
-The files are located in the same directory as the file with the
-system definition. asdf resolves symbolic links before loading the system
-definition file and stores its location in the resulting
-system@footnote{It is possible, though almost never necessary, to
-override this behaviour.}. This is a good thing because the user can
-move the system sources without having to edit the system definition.
+As above, load and configure ASDF.
-@end itemize
+@item
+Make a new directory for your system, @code{my-system/} in a location
+where ASDF can find it (@pxref{Configuring ASDF to find your systems}).
+All else being equal, the easiest location is probably
+@file{~/common-lisp/my-system/}.
-@node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem
-@comment node-name, next, previous, up
-@section A more involved example
-Let's illustrate some more involved uses of @code{defsystem} via a
-slightly convoluted example:
+@item
+Create an ASDF system definition listing the dependencies of
+your system, its components, and their interdependencies,
+and put it in @file{my-system.asd}.
+This file must have the same name as your system.
+@xref{Defining systems with defsystem}.
-@lisp
-(defsystem "foo"
- :version "1.0"
- :components ((:module "foo" :components ((:file "bar") (:file"baz")
- (:file "quux"))
- :perform (compile-op :after (op c)
- (do-something c))
- :explain (compile-op :after (op c)
- (explain-something c)))
- (:file "blah")))
-@end lisp
+@item
+Use @code{(asdf:load-system :my-system)}
+to make sure it's all working properly. @xref{Using ASDF}.
-The method-form tokens need explaining: essentially, this part:
+@end itemize
+@end itemize
-@lisp
- :perform (compile-op :after (op c)
- (do-something c))
- :explain (compile-op :after (op c)
- (explain-something c))
-@end lisp
+@c FIXME: (1) add a sample project that the user can cut and paste to
+@c get started. (2) discuss the option of starting with Quicklisp.
-has the effect of
-@lisp
-(defmethod perform :after ((op compile-op) (c (eql ...)))
- (do-something c))
-(defmethod explain :after ((op compile-op) (c (eql ...)))
- (explain-something c))
-@end lisp
-where @code{...} is the component in question; note that although this
-also supports @code{:before} methods, they may not do what you want
-them to -- a @code{:before} method on perform @code{((op compile-op) (c
-(eql ...)))} will run after all the dependencies and sub-components
-have been processed, but before the component in question has been
-compiled.
-@node The defsystem grammar, , A more involved example, Defining systems with defsystem
+
+@node Loading ASDF, Configuring ASDF, Quick start summary, Top
@comment node-name, next, previous, up
-@section The defsystem grammar
+@chapter Loading ASDF
-@verbatim
-system-definition := ( defsystem system-designator {option}* )
+@menu
+* Loading a pre-installed ASDF::
+* Checking whether ASDF is loaded::
+* Upgrading ASDF::
+* Loading ASDF from source::
+@end menu
-option := :components component-list
- | :pathname pathname
- | :default-component-class
- | :perform method-form
- | :explain method-form
- | :output-files method-form
- | :operation-done-p method-form
- | :depends-on ( {simple-component-name}* )
- | :serial [ t | nil ]
- | :in-order-to ( {dependency}+ )
+@node Loading a pre-installed ASDF, Checking whether ASDF is loaded, Loading ASDF, Loading ASDF
+@section Loading a pre-installed ASDF
-component-list := ( {component-def}* )
-
-component-def := simple-component-name
- | ( component-type name {option}* )
+Most recent Lisp implementations include a copy of ASDF 3,
+or at least ASDF 2.
+You can usually load this copy using Common Lisp's @code{require} function.@footnote{
+NB: all implementations except GNU CLISP also accept
+@code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}.
+For portability's sake, you should use @code{(require "asdf")}.
+}
-component-type := :module | :file | :system | other-component-type
+@lisp
+(require "asdf")
+@end lisp
-dependency := (dependent-op {requirement}+)
-requirement := (required-op {required-component}+)
- | (feature feature-name)
-dependent-op := operation-name
-required-op := operation-name | feature
-@end verbatim
+As of the writing of this manual,
+the following implementations provide ASDF 3 this way:
+ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL, SBCL.
+The following implementations only provide ASDF 2:
+LispWorks, mocl, XCL.
+The following implementations don't provide ASDF:
+Corman CL, GCL, Genera, MCL, SCL.
+The latter implementations are not actively maintained;
+if some of them are ever released again, they probably will include ASDF 3.
-@subsection Serial dependencies
+If the implementation you are using doesn't provide ASDF 2 or ASDF 3,
+see @pxref{Loading ASDF,,Loading ASDF from source} below.
+If that implementation is still actively maintained,
+you may also send a bug report to your Lisp vendor and complain
+about their failing to provide ASDF.
-If the @code{:serial t} option is specified for a module, asdf will add
-dependencies for each each child component, on all the children
-textually preceding it. This is done as if by @code{:depends-on}.
+@node Checking whether ASDF is loaded, Upgrading ASDF, Loading a pre-installed ASDF, Loading ASDF
+@section Checking whether ASDF is loaded
+
+To check whether ASDF is properly loaded in your current Lisp image,
+you can run this form:
@lisp
-:components ((:file "a") (:file "b") (:file "c"))
-:serial t
+(asdf:asdf-version)
@end lisp
-is equivalent to
+If it returns a string,
+that is the version of ASDF that is currently installed.
+
+If it raises an error,
+then either ASDF is not loaded, or
+you are using a very old version of ASDF,
+and need to install ASDF 3.
+
+You can check whether an old version is loaded
+by checking if the ASDF package is present.
+The form below will allow you to programmatically determine
+whether a recent version is loaded, an old version is loaded,
+or none at all:
@lisp
-:components ((:file "a")
- (:file "b" :depends-on ("a"))
- (:file "c" :depends-on ("a" "b")))
+(when (find-package :asdf)
+ (let ((ver (symbol-value
+ (or (find-symbol (string :*asdf-version*) :asdf)
+ (find-symbol (string :*asdf-revision*) :asdf)))))
+ (etypecase ver
+ (string ver)
+ (cons (with-output-to-string (s)
+ (loop for (n . m) on ver
+ do (princ n s)
+ (when m (princ "." s)))))
+ (null "1.0"))))
@end lisp
+If it returns @code{nil} then ASDF is not installed.
+Otherwise it should return a string.
+If it returns @code{"1.0"}, then it can actually be
+any version before 1.77 or so, or some buggy variant of 1.x.
-@subsection Source location
+If you are experiencing problems with ASDF,
+please try upgrading to the latest released version,
+using the method below,
+before you contact us and raise an issue.
-The @code{:pathname} option is optional in all cases for systems
-defined via @code{defsystem}, and in the usual case the user is
-recommended not to supply it.
+@node Upgrading ASDF, Loading ASDF from source, Checking whether ASDF is loaded, Loading ASDF
+@section Upgrading ASDF
+@c FIXME: tighten this up a bit -- there's a lot of stuff here that
+@c doesn't matter to almost anyone. Move discussion of updating antique
+@c versions of ASDF down, or encapsulate it.
-Instead, asdf follows a hairy set of rules that are designed so that
-@enumerate
-@item @code{find-system} will load a system from disk and have its pathname
-default to the right place
-@item this pathname information will not be
-overwritten with @code{*default-pathname-defaults*} (which could be
-somewhere else altogether) if the user loads up the @file{.asd} file
-into his editor and interactively re-evaluates that form.
-@end enumerate
+If you want to upgrade to a more recent ASDF version,
+you need to install and configure your ASDF just like any other system
+(@pxref{Configuring ASDF to find your systems}).
-If a system is being loaded for the first time, its top-level pathname
-will be set to:
+If your implementation provides ASDF 3 or later,
+you only need to @code{(require "asdf")}:
+ASDF will automatically look whether an updated version of itself is available
+amongst the regularly configured systems, before it compiles anything else.
-@itemize
-@item The host/device/directory parts of @code{*load-truename*}, if it is bound
-@item @code{*default-pathname-defaults*}, otherwise
-@end itemize
+@menu
+* Upgrading your implementation's ASDF::
+* Issues with upgrading ASDF::
+@end menu
-If a system is being redefined, the top-level pathname will be
+@node Upgrading your implementation's ASDF, Issues with upgrading ASDF, Upgrading ASDF, Upgrading ASDF
+@subsection Upgrading your implementation's ASDF
+
+Most implementations provide a recent ASDF 3 in their latest release.
+If yours doesn't, we recommend upgrading your implementation.
+If the latest version of your implementation still doesn't provide ASDF,
+or provides an old version, we recommend installing a recent ASDF so your implementation provides it,
+as explained below.
+If all fails, we recommend you load ASDF from source
+@pxref{Loading ASDF,,Loading ASDF from source}.
+
+The ASDF source repository contains a script
+@file{bin/install-asdf-as-module} that can help you upgrade your implementation's ASDF.
+It works on
+Allegro CL, Clozure CL, CMU CL, ECL, GNU CLISP, LispWorks, MKCL, SBCL, SCL, XCL.
+That's all known implementations except ABCL, Corman CL, GCL, Genera, MCL, MOCL.
+Happily, ABCL is usually pretty up to date and shouldn't need that script.
+GCL would be supported, except that so far is still lacking usable support for @code{require}.
+Corman CL, Genera, MCL are obsolete anyway.
+MOCL is under development.
+On an old version of an implementation that does not provide ASDF,
+you may have to load ASDF 3 from source before you load that script.
+
+The script relies on @code{cl-launch} 4 for command-line invocation,
+which may depend on ASDF being checked out in @file{~/common-lisp/asdf/}
+(which we recommend anyway)
+if your implementation doesn't even have an ASDF 2.
+If you don't have @code{cl-launch},
+you can instead @code{(load "bin/install-asdf-as-module")}
+from your implementation's REPL after loading ASDF from source.
+
+Finally, if your implementation only provides ASDF 2,
+and you can't or won't upgrade it or override its ASDF module,
+you may simply configure ASDF to find a proper upgrade;
+however, to avoid issues with a self-upgrade in mid-build,
+you @emph{must} make sure to upgrade ASDF immediately
+after requiring the builtin ASDF 2:
+
+@lisp
+(require "asdf")
+;; <--- insert programmatic configuration here if needed
+(asdf:load-system :asdf)
+@end lisp
+
+@node Issues with upgrading ASDF, , Upgrading your implementation's ASDF, Upgrading ASDF
+@subsection Issues with upgrading ASDF
+Note that there are some limitations to upgrading ASDF:
@itemize
@item
-changed, if explicitly supplied or obtained from
-@code{*load-truename*} (so that an updated source location is
-reflected in the system definition)
+Previously loaded ASDF extensions become invalid, and will need to be reloaded.
+Examples include CFFI-Grovel, hacks used by ironclad, etc.
+Since it isn't possible to automatically detect what extensions
+need to be invalidated,
+ASDF will invalidate @emph{all} previously loaded systems
+when it is loaded on top of a forward-incompatible ASDF version.
+@footnote{
+@vindex *oldest-forward-compatible-asdf-version*
+Forward incompatibility can be determined using the variable
+@code{asdf/upgrade::*oldest-forward-compatible-asdf-version*},
+which is 2.33 at the time of this writing.}
+
+Starting with ASDF 3 (2.27 or later),
+this self-upgrade will be automatically attempted as the first step
+to any system operation, to avoid any possibility of
+a catastrophic attempt to self-upgrade in mid-build.
+
+@c FIXME: Fix grammar below.
@item
-changed if it had previously been set from
-@code{*default-pathname-defaults*}
+For this and many other reasons,
+you should load, configure and upgrade ASDF
+as one of the very first things done by your build and startup scripts.
+It is safer if you upgrade ASDF and its extensions as a special step
+at the very beginning of whatever script you are running,
+before you start using ASDF to load anything else.
+
@item
-left as before, if it had previously been set from
-@code{*load-truename*} and @code{*load-truename*} is currently
-unbound (so that a developer can evaluate a @code{defsystem} form from
-within an editor without clobbering its source location)
+Until all implementations provide ASDF 3 or later,
+it is unsafe to upgrade ASDF as part of loading a system
+that depends on a more recent version of ASDF,
+since the new one might shadow the old one while the old one is running,
+and the running old one will be confused
+when extensions are loaded into the new one.
+In the meantime, we recommend that your systems should @emph{not} specify
+@code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "3.0.1"))},
+but instead that they check that a recent enough ASDF is installed,
+with such code as:
+@example
+(unless (or #+asdf2 (asdf:version-satisfies
+ (asdf:asdf-version) *required-asdf-version*))
+ (error "FOO requires ASDF ~A or later." *required-asdf-version*))
+@end example
+@item
+Until all implementations provide ASDF 3 or later,
+it is unsafe for a system to transitively depend on ASDF
+and not directly depend on ASDF;
+if any of the system you use either depends-on asdf,
+system-depends-on asdf, or transitively does,
+you should also do as well.
@end itemize
+@node Loading ASDF from source, , Upgrading ASDF, Loading ASDF
+@section Loading ASDF from source
+If your implementation doesn't include ASDF,
+if for some reason the upgrade somehow fails,
+does not or cannot apply to your case,
+you will have to install the file @file{asdf.lisp}
+somewhere and load it with:
-@node The object model of asdf, Error handling, Defining systems with defsystem, Top
-@comment node-name, next, previous, up
-@chapter The object model of asdf
-
-asdf is designed in an object-oriented way from the ground up. Both a
-system's structure and the operations that can be performed on systems
-follow a protocol. asdf is extensible to new operations and to new
-component types. This allows the addition of behaviours: for example,
-a new component could be added for Java JAR archives, and methods
-specialised on @code{compile-op} added for it that would accomplish the
-relevant actions.
+@lisp
+(load "/path/to/your/installed/asdf.lisp")
+@end lisp
-This chapter deals with @emph{components}, the building blocks of a
-system, and @emph{operations}, the actions that can be performed on a
-system.
+The single file @file{asdf.lisp} is all you normally need to use ASDF.
+You can extract this file from latest release tarball on the
+@url{http://common-lisp.net/project/asdf/,ASDF website}.
+If you are daring and willing to report bugs, you can get
+the latest and greatest version of ASDF from its git repository.
+@xref{Getting the latest version}.
+For maximum convenience you might want to have ASDF loaded
+whenever you start your Lisp implementation,
+for example by loading it from the startup script or dumping a custom core
+--- check your Lisp implementation's manual for details.
-@menu
-* Operations::
-* Components::
-@end menu
-@node Operations, Components, The object model of asdf, The object model of asdf
+@node Configuring ASDF, Using ASDF, Loading ASDF, Top
@comment node-name, next, previous, up
-@section Operations
-@cindex operation
-
-An @dfn{operation} object of the appropriate type is instantiated
-whenever the user wants to do something with a system like
-
-@itemize
-@item compile all its files
-@item load the files into a running lisp environment
-@item copy its source files somewhere else
-@end itemize
+@chapter Configuring ASDF
-Operations can be invoked directly, or examined to see what their
-effects would be without performing them. @emph{FIXME: document how!} There
-are a bunch of methods specialised on operation and component type
-that actually do the grunt work.
+For standard use cases, ASDF should work pretty much out of the box.
+We recommend you skim the sections on configuring ASDF to find your systems
+and choose the method of installing Lisp software that works best for you.
+Then skip directly to @xref{Using ASDF}. That will probably be enough.
+You are unlikely to have to worry about the way ASDF stores object files,
+and resetting the ASDF configuration is usually only needed in corner cases.
-The operation object contains whatever state is relevant for this
-purpose (perhaps a list of visited nodes, for example) but primarily
-is a nice thing to specialise operation methods on and easier than
-having them all be EQL methods.
-Operations are invoked on systems via @code{operate}.
+@menu
+* Configuring ASDF to find your systems::
+* Configuring ASDF to find your systems --- old style::
+* Configuring where ASDF stores object files::
+* Resetting the ASDF configuration::
+@end menu
-@deffn {Generic function} operate operation system &rest initargs
-@deffnx {Generic function} oos operation system &rest initargs
-@code{operate} invokes @var{operation} on @var{system}. @code{oos}
-is a synonym for @code{operate}.
+@node Configuring ASDF to find your systems, Configuring ASDF to find your systems --- old style, Configuring ASDF, Configuring ASDF
+@section Configuring ASDF to find your systems
-@var{operation} is a symbol that is passed, along with the supplied
-@var{initargs}, to @code{make-instance} to create the operation object.
-@var{system} is a system designator.
+In order to compile and load your systems, ASDF must be configured to find
+the @file{.asd} files that contain system definitions.
-The initargs are passed to the @code{make-instance} call when creating
-the operation object. Note that dependencies may cause the operation
-to invoke other operations on the system or its components: the new
-operations will be created with the same initargs as the original one.
+There are a number of different techniques for setting yourself up with
+ASDF, starting from easiest to the most complex:
-@end deffn
+@itemize @bullet
-@menu
-* Predefined operations of asdf::
-* Creating new operations::
-@end menu
+@item
+Put all of your systems in one of the standard locations, subdirectories
+of
+@itemize
+@item
+@file{~/common-lisp/} or
+@item
+@file{~/.local/share/common-lisp/source/}.
+@end itemize
+If you install software there, you don't need further
+configuration.@footnote{@file{~/common-lisp/} is only included in
+the default configuration
+starting with ASDF 3.1.1 or later.}
-@node Predefined operations of asdf, Creating new operations, Operations, Operations
-@comment node-name, next, previous, up
-@subsection Predefined operations of asdf
+@item
+If you're using some tool to install software (e.g. Quicklisp),
+the authors of that tool should already have configured ASDF.
-All the operations described in this section are in the @code{asdf}
-package. They are invoked via the @code{operate} generic function.
+@item
+If you have more specific desires about how to lay out your software on
+disk, the preferred way to configure where ASDF finds your systems is
+the @code{source-registry} facility,
+fully described in its own chapter of this manual.
+@xref{Controlling where ASDF searches for systems}. Here is a quick
+recipe for getting started:
+
+The simplest way to add a path to your search path,
+say @file{/home/luser/.asd-link-farm/}
+is to create the directory
+@file{~/.config/common-lisp/source-registry.conf.d/}
+and there create a file with any name of your choice,
+and with the type @file{conf}@footnote{By requiring the @file{.conf}
+extension, and ignoring other files, ASDF allows you to have disabled files,
+editor backups, etc. in the same directory with your active
+configuration files.
+
+ASDF will also ignore files whose names start with a @file{.} character.
+
+It is customary to start the filename with two digits, to control the
+sorting of the @code{conf} files in the source registry directory, and
+thus the order in which the directories will be scanned.},
+for instance @file{42-asd-link-farm.conf},
+containing the line:
+
+@kbd{(:directory "/home/luser/.asd-link-farm/")}
+
+If you want all the subdirectories under @file{/home/luser/lisp/}
+to be recursively scanned for @file{.asd} files, instead use:
+
+@kbd{(:tree "/home/luser/lisp/")}
+
+ASDF will automatically read your configuration
+the first time you try to find a system.
+If necessary, you can reset the source-registry configuration with:
@lisp
-(asdf:operate 'asdf:@var{operation-name} '@var{system-name} @{@var{operation-options ...}@})
+(asdf:clear-source-registry)
@end lisp
-@deffn Operation compile-op &key proclamations
+@item
+In earlier versions of ASDF, the system source registry was configured
+using a global variable, @code{asdf:*central-registry*}.
+For more details about this, see the following section,
+@ref{Configuring ASDF to find your systems --- old style}.
+Unless you need to understand this,
+skip directly to @ref{Configuring where ASDF stores object files}.
-This operation compiles the specified component. If proclamations are
-supplied, they will be proclaimed. This is a good place to specify
-optimization settings.
+@end itemize
-When creating a new component type, you should provide methods for
-@code{compile-op}.
+Note that your Operating System distribution or your system administrator
+may already have configured system-managed libraries for you.
-When @code{compile-op} is invoked, component dependencies often cause
-some parts of the system to be loaded as well as compiled. Invoking
-@code{compile-op} does not necessarily load all the parts of the
-system, though; use @code{load-op} to load a system.
-@end deffn
-@deffn Operation load-op &key proclamations
-This operation loads a system.
+@node Configuring ASDF to find your systems --- old style, Configuring where ASDF stores object files, Configuring ASDF to find your systems, Configuring ASDF
+@section Configuring ASDF to find your systems --- old style
-The default methods for @code{load-op} compile files before loading them.
-For parity, your own methods on new component types should probably do
-so too.
-@end deffn
-@deffn Operation load-source-op
+@c FIXME: this section should be moved elsewhere. The novice user
+@c should not be burdened with it. [2014/02/27:rpg]
-This operation will load the source for the files in a module even if
-the source files have been compiled. Systems sometimes have knotty
-dependencies which require that sources are loaded before they can be
-compiled. This is how you do that.
-If you are creating a component type, you need to implement this
-operation - at least, where meaningful.
-@end deffn
+The old way to configure ASDF to find your systems is by
+@code{push}ing directory pathnames onto the variable
+@code{asdf:*central-registry*}.
-@deffn Operation test-system-version &key minimum
+You must configure this variable between the time you load ASDF
+and the time you first try to use it.
+Loading and configuring ASDF presumably happen
+as part of some initialization script that builds or starts
+your Common Lisp software system.
+(For instance, some SBCL users used to put it in their @file{~/.sbclrc}.)
-Asks the system whether it satisfies a version requirement.
+The @code{asdf:*central-registry*} is empty by default in ASDF 2 or ASDF 3,
+but is still supported for compatibility with ASDF 1.
+When used, it takes precedence over the above source-registry.@footnote{
+It is possible to further customize
+the system definition file search.
+That's considered advanced use, and covered later:
+search forward for
+@code{*system-definition-search-functions*}.
+@xref{Defining systems with defsystem}.}
-The default method accepts a string, which is expected to contain of a
-number of integers separated by #\. characters. The method is not
-recursive. The component satisfies the version dependency if it has
-the same major number as required and each of its sub-versions is
-greater than or equal to the sub-version number required.
+For example, let's say you want ASDF to find the @file{.asd} file
+@file{/home/me/src/foo/foo.asd}.
+In your lisp initialization file, you could have the following:
@lisp
-(defun version-satisfies (x y)
- (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))
- (or (not (cdr y)) (bigger (cdr x) (cdr y))))))
+(require "asdf")
+(push "/home/me/src/foo/" asdf:*central-registry*)
@end lisp
-If that doesn't work for your system, you can override it. I hope
-you have as much fun writing the new method as @verb{|#lisp|} did
-reimplementing this one.
-@end deffn
+Note the trailing slash: when searching for a system,
+ASDF will evaluate each entry of the central registry
+and coerce the result to a pathname.@footnote{
+ASDF will indeed call @code{eval} on each entry.
+It will skip entries that evaluate to @code{nil}.
+
+Strings and pathname objects are self-evaluating,
+in which case the @code{eval} step does nothing;
+but you may push arbitrary s-expressions onto the central registry.
+These s-expressions may be evaluated to compute context-dependent
+entries, e.g. things that depend
+on the value of shell variables or the identity of the user.
+
+The variable @code{asdf:*central-registry*} is thus a list of
+``system directory designators''.
+A @dfn{system directory designator} is a form
+which will be evaluated whenever a system is to be found,
+and must evaluate to a directory to look in (or @code{NIL}).
+By ``directory'', we mean
+``designator for a pathname with a non-empty DIRECTORY component''.
+}
+The trailing directory name separator
+is necessary to tell Lisp that you're discussing a directory
+rather than a file. If you leave it out, ASDF is likely to look in
+@code{/home/me/src/} instead of @code{/home/me/src/foo/} as you
+intended, and fail to find your system definition.
+
+Typically there are a lot of @file{.asd} files, and
+a common idiom was to put
+@emph{symbolic links} to all of one's @file{.asd} files
+in a common directory
+and push @emph{that} directory (the ``link farm'')
+onto
+@code{asdf:*central-registry*},
+instead of pushing each individual system directory.
+
+ASDF knows to follow @emph{symlinks}
+to the actual location of the systems.@footnote{
+On Windows, you can use Windows shortcuts instead of POSIX symlinks.
+if you try aliases under MacOS, we are curious to hear about your experience.}
+
+For example, if @code{#p"/home/me/cl/systems/"}
+is an element of @code{*central-registry*}, you could set up the
+system @var{foo} as follows:
+
+@example
+$ cd /home/me/cl/systems/
+$ ln -s ~/src/foo/foo.asd .
+@end example
-@deffn Operation feature-dependent-op
+This old style for configuring ASDF is not recommended for new users,
+but it is supported for old users, and for users who want to programmatically
+control what directories are added to the ASDF search path.
+
+
+@node Configuring where ASDF stores object files, Resetting the ASDF configuration, Configuring ASDF to find your systems --- old style, Configuring ASDF
+@section Configuring where ASDF stores object files
+@findex clear-output-translations
+
+ASDF lets you configure where object files will be stored.
+Sensible defaults are provided and
+you shouldn't normally have to worry about it.
+
+This allows the same source code repository to be shared
+between several versions of several Common Lisp implementations,
+between several users using different compilation options,
+with users who lack write privileges on shared source directories, etc.
+This also keeps source directories from being cluttered
+with object/fasl files.
+
+Starting with ASDF 2, the @code{asdf-output-translations} facility
+was added to ASDF itself. This facility controls where object files will be stored.
+This facility is fully described in a chapter of this manual,
+@ref{Controlling where ASDF saves compiled files}.
+
+@c FIXME: possibly this should be moved elsewhere. It's redundant here,
+@c and makes this section of the manual too long and daunting for the
+@c new user. [2014/02/27:rpg]
+@c The simplest way to add a translation to your search path,
+@c say from @file{/foo/bar/baz/quux/}
+@c to @file{/where/i/want/my/fasls/}
+@c is to create the directory
+@c @file{~/.config/common-lisp/asdf-output-translations.conf.d/}
+@c and there create a file with any name of your choice and the type @file{conf},
+@c for instance @file{42-bazquux.conf}
+@c containing the line:
+
+@c @kbd{("/foo/bar/baz/quux/" "/where/i/want/my/fasls/")}
+
+@c To disable output translations for source under a given directory,
+@c say @file{/toto/tata/}
+@c you can create a file @file{40-disable-toto.conf}
+@c with the line:
+
+@c @kbd{("/toto/tata/")}
+
+@c To wholly disable output translations for all directories,
+@c you can create a file @file{00-disable.conf}
+@c with the line:
+
+@c @kbd{(t t)}
+
+@c Note that your Operating System distribution or your system administrator
+@c may already have configured translations for you.
+@c In absence of any configuration, the default is to redirect everything
+@c under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}.
+@c @xref{Controlling where ASDF searches for systems}, for full details.
+
+@c The required @file{.conf} extension allows you to have disabled files
+@c or editor backups (ending in @file{~}), and works portably
+@c (for instance, it is a pain to allow both empty and non-empty extension on CLISP).
+@c Excluded are files the name of which start with a @file{.} character.
+@c It is customary to start the filename with two digits
+@c that specify the order in which the directories will be scanned.
+
+@c ASDF will automatically read your configuration
+@c the first time you try to find a system.
+@c You can reset the source-registry configuration with:
+
+@c @lisp
+@c (asdf:clear-output-translations)
+@c @end lisp
+
+@c And you probably should do so before you dump your Lisp image,
+@c if the configuration may change
+@c between the machine where you save it at the time you save it
+@c and the machine you resume it at the time you resume it.
+@c (Once again, you should use @code{(asdf:clear-configuration)}
+@c before you dump your Lisp image, which includes the above.)
+
+Note that before ASDF 2,
+other ASDF add-ons offered the same functionality,
+each in subtly different and incompatible ways:
+ASDF-Binary-Locations, cl-launch, common-lisp-controller.
+ASDF-Binary-Locations is now not needed anymore and should not be used.
+cl-launch 3.000 and common-lisp-controller 7.2 have been updated
+to delegate object file placement to ASDF.
+
+@node Resetting the ASDF configuration, , Configuring where ASDF stores object files, Configuring ASDF
+@section Resetting the ASDF configuration
+
+@c FIXME: this should probably be moved out of the "quickstart" part of
+@c the manual. [2014/02/27:rpg]
+
+
+When you dump and restore an image, or when you tweak your configuration,
+you may want to reset the ASDF configuration.
+For that you may use the following function:
+
+@defun clear-configuration
+ Undoes any ASDF configuration
+ regarding source-registry or output-translations.
+@end defun
-An instance of @code{feature-dependent-op} will ignore any components
-which have a @code{features} attribute, unless the feature combination
-it designates is satisfied by @code{*features*}. This operation is
-not intended to be instantiated directly, but other operations may
-inherit from it.
+This function is pushed onto the @code{uiop:*image-dump-hook*} by default,
+which means that if you save an image using @code{uiop:dump-image},
+or via @code{asdf:image-op} and @code{asdf:program-op},
+it will be automatically called to clear your configuration.
+If for some reason you prefer to call your implementation's underlying functionality,
+be sure to call @code{clear-configuration} manually,
+or push it into your implementation's equivalent of @code{uiop:*image-dump-hook*},
+e.g. @code{sb-ext:*save-hooks*} on SBCL, or @code{ext:*before-save-initializations*}
+on CMUCL and SCL, etc.
-@end deffn
+@node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top
+@chapter Using ASDF
-@node Creating new operations, , Predefined operations of asdf, Operations
-@comment node-name, next, previous, up
-@subsection Creating new operations
+@menu
+* Loading a system::
+* Other Operations::
+* Moving on::
+@end menu
-asdf was designed to be extensible in an object-oriented fashion. To
-teach asdf new tricks, a programmer can implement the behaviour he
-wants by creating a subclass of @code{operation}.
+@node Loading a system, Other Operations, Using ASDF, Using ASDF
+@section Loading a system
+The system @var{foo} is loaded (and compiled, if necessary)
+by evaluating the following Lisp form:
-asdf's pre-defined operations are in no way ``privileged'', but it is
-requested that developers never use the @code{asdf} package for
-operations they develop themselves. The rationale for this rule is
-that we don't want to establish a ``global asdf operation name
-registry'', but also want to avoid name clashes.
+@example
+(asdf:load-system :@var{foo})
+@end example
-An operation must provide methods for the following generic functions
-when invoked with an object of type @code{source-file}: @emph{FIXME describe
-this better}
+On some implementations (namely recent versions of
+ABCL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL and SBCL),
+ASDF hooks into the @code{CL:REQUIRE} facility
+and you can just use:
-@itemize
+@example
+(require :@var{foo})
+@end example
-@item @code{output-files}
-@item @code{perform}
-The @code{perform} method must call @code{output-files} to find out
-where to put its files, because the user is allowed to override
-@item @code{output-files} for local policy @code{explain}
-@item @code{operation-done-p}, if you don't like the default one
+In older versions of ASDF, you needed to use
+@code{(asdf:oos 'asdf:load-op :@var{foo})}.
+If your ASDF is too old to provide @code{asdf:load-system} though
+we recommend that you upgrade to ASDF 3.
+@xref{Loading ASDF,,Loading ASDF from source}.
+
+Note the name of a system is specified as a string or a symbol.
+If a symbol (including a keyword), its name is taken and lowercased.
+The name must be a suitable value for the @code{:name} initarg
+to @code{make-pathname} in whatever filesystem the system is to be
+found.
+
+The lower-casing-symbols behaviour is unconventional,
+but was selected after some consideration.
+The type of systems we want to support
+either have lowercase as customary case (Unix, Mac, Windows)
+or silently convert lowercase to uppercase (lpns).
+@c so this makes more sense than attempting to use @code{:case :common},
+@c which is reported not to work on some implementations
+
+@node Other Operations, Moving on, Loading a system, Using ASDF
+@section Other Operations
+
+@findex load-system
+@findex compile-system
+@findex test-system
+@findex requrie-system
+
+ASDF provides three commands for the most common system operations:
+@code{load-system}, @code{compile-system}, and @code{test-system}.
+It also provides @code{require-system}, a version of @code{load-system}
+that skips trying to update systems that are already loaded.
+
+@c FIXME: We seem to export @findex bundle-system also.
+
+@findex operate
+@findex oos
+
+Because ASDF is an extensible system
+for defining @emph{operations} on @emph{components},
+it also provides a generic function @code{operate}
+(which is usually abbreviated by @code{oos},
+which stands for operate-on-system).
+You'll use @code{oos} whenever you want to do something beyond
+compiling, loading and testing.
+
+Output from ASDF and ASDF extensions are sent
+to the CL stream @code{*standard-output*},
+so rebinding that stream around calls to @code{asdf:operate}
+should redirect all output from ASDF operations.
+
+@c Reminder: before ASDF can operate on a system, however,
+@c it must be able to find and load that system's definition.
+@c @xref{Configuring ASDF,,Configuring ASDF to find your systems}.
+
+@c FIXME: the following is too complicated for here, especially since
+@c :force hasn't been defined yet. Move it. [2014/02/27:rpg]
+
+@findex already-loaded-systems
+@findex require-system
+@findex load-system
+@vindex *load-system-operation*
+For advanced users, note that
+@code{require-system} calls @code{load-system}
+with keyword arguments @code{:force-not (already-loaded-systems)}.
+@code{already-loaded-systems} returns a list of the names of loaded systems.
+@code{load-system} applies @code{operate} with the operation from
+@code{*load-system-operation*} (which by default is @code{load-op}),
+the system, and any provided keyword arguments.
+
+
+@node Moving on, , Other Operations, Using ASDF
+@section Moving on
+
+That's all you need to know to use ASDF to load systems written by others.
+The rest of this manual deals with writing system definitions
+for Common Lisp software you write yourself,
+including how to extend ASDF to define new operation and component types.
+
+
+@node Defining systems with defsystem, The object model of ASDF, Using ASDF, Top
+@comment node-name, next, previous, up
+@chapter Defining systems with defsystem
-@end itemize
+This chapter describes how to use ASDF to define systems and develop
+software.
+
+
+@menu
+* The defsystem form::
+* A more involved example::
+* The defsystem grammar::
+* Other code in .asd files::
+* The package-inferred-system extension::
+@end menu
-@node Components, , Operations, The object model of asdf
+@node The defsystem form, A more involved example, Defining systems with defsystem, Defining systems with defsystem
@comment node-name, next, previous, up
-@section Components
-@cindex component
-@cindex system
-@cindex system designator
-@vindex *system-definition-search-functions*
+@section The defsystem form
+@findex defsystem
+@cindex asdf-user
+@findex load-asd
-A @dfn{component} represents a source file or (recursively) a
-collection of components. A @dfn{system} is (roughly speaking) a
-top-level component that can be found via @code{find-system}.
+This section begins with an example of a system definition,
+then gives the full grammar of @code{defsystem}.
-A @dfn{system designator} is a string or symbol and behaves just like
-any other component name (including with regard to the case conversion
-rules for component names).
+Let's look at a simple system.
+This is a complete file that should be saved as @file{hello-lisp.asd}
+(in order that ASDF can find it
+when ordered to operate on the system named @code{"hello-lisp"}).
+@c FIXME: the first example should have an outside dependency, e.g.,
+@c CL-PPCRE.
-@defun find-system system-designator &optional (error-p t)
+@lisp
+(in-package :asdf-user)
-Given a system designator, @code{find-system} finds and returns a
-system. If no system is found, an error of type
-@code{missing-component} is thrown, or @code{nil} is returned if
-@code{error-p} is false.
+(defsystem "hello-lisp"
+ :description "hello-lisp: a sample Lisp system."
+ :version "0.0.1"
+ :author "Joe User <joe@@example.com>"
+ :licence "Public Domain"
+ :components ((:file "packages")
+ (:file "macros" :depends-on ("packages"))
+ (:file "hello" :depends-on ("macros"))))
+@end lisp
-To find and update systems, @code{find-system} funcalls each element
-in the @code{*system-definition-search-functions*} list, expecting a
-pathname to be returned. The resulting pathname is loaded if either
-of the following conditions is true:
+Some notes about this example:
@itemize
-@item there is no system of that name in memory
-@item the file's last-modified time exceeds the last-modified time of the
- system in memory
-@end itemize
-
-When system definitions are loaded from @file{.asd} files, a new
-scratch package is created for them to load into, so that different
-systems do not overwrite each others operations. The user may also
-wish to (and is recommended to) include @code{defpackage} and
-@code{in-package} forms in his system definition files, however, so
-that they can be loaded manually if need be.
-
-The default value of @code{*system-definition-search-functions*} is a
-function that looks in each of the directories given by evaluating
-members of @code{*central-registry*} for a file whose name is the
-name of the system and whose type is @file{asd}. The first such file
-is returned, whether or not it turns out to actually define the
-appropriate system. Hence, it is strongly advised to define a system
-@var{foo} in the corresponding file @var{foo.asd}.
-@end defun
+@item
+The file starts with an @code{in-package} form
+for package @code{asdf-user}. Quick summary: just do this, because it
+helps make interactive development of @code{defsystem} forms behave in
+the same was as when these forms are loaded by ASDF. If that's enough
+for you, skip the rest of this item. Otherwise read on for the gory details.
+
+If your file is loaded by ASDF 3, it will be loaded into the
+@code{asdf-user} package. The @code{in-package} form
+will ensure that the system definition is read the
+same as within ASDF when you load it interactively with @code{cl:load}.
+However, we recommend that you load @file{.asd} files
+through function @code{asdf::load-asd} rather than through @code{cl:load},
+in which case this form is unnecessary.
+Recent versions of SLIME (2013-02 and later) know to do that.
-@menu
-* Common attributes of components::
-* Pre-defined subclasses of component::
-* Creating new component types::
-@end menu
+@item
+You can always rely on symbols
+from both package @code{asdf} and @code{common-lisp} being available in
+@code{.asd} files --
+most importantly including @code{defsystem}.
+
+@c FIXME: the following should be inserted in a more advanced
+@c bit of the manual. For now, it is simply elided.
+@c Starting with ASDF 3.1,
+@c @file{.asd} files are read in the package @code{asdf-user}
+@c that uses @code{asdf}, @code{uiop} and @code{uiop/common-lisp}
+@c (a variant of @code{common-lisp}
+@c that has some portability fixes on old implementations).
+@c ASDF 3 releases before 3.1 also read in package @code{asdf-user}
+@c but that package don't use the full @code{uiop}, only @code{uiop/package}.
+@c ASDF 1 and ASDF 2 releases (up until 2.26) instead read @file{.asd} files
+@c in a temporary package @code{asdf@emph{N}}
+@c that uses @code{asdf} and @code{common-lisp}.
+@c You may thus have to package-qualify some symbols with @code{uiop:}
+@c to support older variants of ASDF 3,
+@c and/or package-qualify them with @code{asdf::}
+@c to be compatible with even older variants of ASDF 2
+@c (and then only use the few already available in ASDF 2).
-@node Common attributes of components, Pre-defined subclasses of component, Components, Components
-@comment node-name, next, previous, up
-@subsection Common attributes of components
-All components, regardless of type, have the following attributes.
-All attributes except @code{name} are optional.
+@item
+The @code{defsystem} form defines a system named @code{hello-lisp}
+that contains three source files:
+@file{packages}, @file{macros} and @file{hello}.
-@subsubsection Name
+@c FIXME: The first example system should probably use just :serial T.
+@item
+The file @file{macros} depends on @file{packages}
+(presumably because the package it's in is defined in @file{packages}),
+and the file @file{hello} depends on @file{macros}
+(and hence, transitively on @file{packages}).
+This means that ASDF will compile and load @file{packages} and @file{macros}
+before starting the compilation of file @file{hello}.
-A component name is a string or a symbol. If a symbol, its name is
-taken and lowercased. The name must be a suitable value for the
-@code{:name} initarg to @code{make-pathname} in whatever filesystem
-the system is to be found.
+@item
+System source files should be located in the same directory
+as the @code{.asd} file with the system definition.
+@c FIXME: the following should live somewhere, but not in the quickstart
+@c page. [2014/05/03:rpg]
+@c ASDF resolves symbolic links (or Windows shortcuts)
+@c before loading the system definition file and
+@c stores its location in the resulting system@footnote{
+@c It is possible, though almost never necessary, to override this behaviour.}.
+@c This is a good thing because the user can move the system sources
+@c without having to edit the system definition.
+
+@c FIXME: Should have cross-reference to "Version specifiers" in the
+@c defsystem grammar, but the cross-referencing is so broken by
+@c insufficient node breakdown that I have not put one in.
+@c FIXME: this is way too detailed for the first example!
+@c move it!
+@item
+Make sure you know how the @code{:version} numbers will be parsed!
+Only period-separated non-negative integers are accepted.
+See below Version specifiers in @ref{The defsystem grammar}.
+@cindex :version
-The lower-casing-symbols behaviour is unconventional, but was selected
-after some consideration. Observations suggest that the type of
-systems we want to support either have lowercase as customary case
-(Unix, Mac, windows) or silently convert lowercase to uppercase
-(lpns), so this makes more sense than attempting to use @code{:case
-:common} as argument to @code{make-pathname}, which is reported not to
-work on some implementations
+@end itemize
-@subsubsection Version identifier
+@node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem
+@comment node-name, next, previous, up
+@section A more involved example
+@findex defsystem
-This optional attribute is used by the test-system-version
-operation. @xref{Predefined operations of asdf}. For the default method of
-test-system-version, the version should be a string of intergers
-separated by dots, for example @samp{1.0.11}.
+Let's illustrate some more involved uses of @code{defsystem} via a
+slightly convoluted example:
-@subsubsection Required features
+@lisp
+(in-package :asdf-user)
-Traditionally defsystem users have used reader conditionals to include
-or exclude specific per-implementation files. This means that any
-single implementation cannot read the entire system, which becomes a
-problem if it doesn't wish to compile it, but instead for example to
-create an archive file containing all the sources, as it will omit to
-process the system-dependent sources for other systems.
+(defsystem "foo"
+ :version "1.0.0"
+ :components ((:module "mod"
+ :components ((:file "bar")
+ (:file"baz")
+ (:file "quux"))
+ :perform (compile-op :after (op c)
+ (do-something c))
+ :explain (compile-op :after (op c)
+ (explain-something c)))
+ (:file "blah")))
+@end lisp
-Each component in an asdf system may therefore specify features using
-the same syntax as #+ does, and it will (somehow) be ignored for
-certain operations unless the feature conditional is a member of
-@code{*features*}.
+The @code{:module} component named @code{"mod"} is a collection of three files,
+which will be located in a subdirectory of the main code directory named
+@file{mod} (this location can be overridden; see the discussion of the
+@code{:pathname} option in @ref{The defsystem grammar}).
+The method-form tokens provide a shorthand for defining methods on
+particular components. This part
-@subsubsection Dependencies
+@lisp
+ :perform (compile-op :after (op c)
+ (do-something c))
+ :explain (compile-op :after (op c)
+ (explain-something c))
+@end lisp
-This attribute specifies dependencies of the component on its
-siblings. It is optional but often necessary.
+has the effect of
-There is an excitingly complicated relationship between the initarg
-and the method that you use to ask about dependencies
+@lisp
+(defmethod perform :after ((op compile-op) (c (eql ...)))
+ (do-something c))
+(defmethod explain :after ((op compile-op) (c (eql ...)))
+ (explain-something c))
+@end lisp
-Dependencies are between (operation component) pairs. In your
-initargs for the component, you can say
+where @code{...} is the component in question.
+In this case @code{...} would expand to something like
@lisp
-:in-order-to ((compile-op (load-op "a" "b") (compile-op "c"))
- (load-op (load-op "foo")))
+(find-component "foo" "mod")
@end lisp
-This means the following things:
-@itemize
-@item
-before performing compile-op on this component, we must perform
-load-op on @var{a} and @var{b}, and compile-op on @var{c},
-@item
-before performing @code{load-op}, we have to load @var{foo}
-@end itemize
+For more details on the syntax of such forms, see @ref{The defsystem
+grammar}.
+For more details on what these methods do, @pxref{Operations} in
+@ref{The object model of ASDF}.
-The syntax is approximately
+@c FIXME: The following plunge into detail weeds is not appropriate in this
+@c location. [2010/10/03:rpg]
+@c note that although this also supports @code{:before} methods,
+@c they may not do what you want them to ---
+@c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
+@c will run after all the dependencies and sub-components have been processed,
+@c but before the component in question has been compiled.
-@verbatim
-(this-op {(other-op required-components)}+)
-required-components := component-name
- | (required-components required-components)
+@c FIXME: There should be YA example that shows definitions of functions
+@c and classes. The following material should go there.
+@c @item
+@c If in addition to simply using @code{defsystem},
+@c you are going to define functions,
+@c create ASDF extension, globally bind symbols, etc.,
+@c it is recommended that to avoid namespace pollution between systems,
+@c you should create your own package for that purpose, with:
-component-name := string
- | (:version string minimum-version-object)
-@end verbatim
+@c @lisp
+@c (defpackage :hello-lisp-system
+@c (:use :cl :asdf))
-Side note:
+@c (in-package :hello-lisp-system)
+@c @end lisp
-This is on a par with what ACL defsystem does. mk-defsystem is less
-general: it has an implied dependency
-@verbatim
- for all x, (load x) depends on (compile x)
-@end verbatim
+@node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem
+@comment node-name, next, previous, up
+@section The defsystem grammar
+@findex defsystem
+@cindex DEFSYSTEM grammar
-and using a @code{:depends-on} argument to say that @var{b} depends on
-@var{a} @emph{actually} means that
+@c FIXME: @var typesetting not consistently used here. We should either expand
+@c its use to everywhere, or we should kill it everywhere.
-@verbatim
- (compile b) depends on (load a)
-@end verbatim
-This is insufficient for e.g. the McCLIM system, which requires that
-all the files are loaded before any of them can be compiled ]
+@example
+system-definition := ( defsystem system-designator @var{system-option}* )
-End side note
+system-option := :defsystem-depends-on system-list
+ | :weakly-depends-on @var{system-list}
+ | :class class-name (see discussion below)
+ | module-option
+ | option
-In asdf, the dependency information for a given component and
-operation can be queried using @code{(component-depends-on operation
-component)}, which returns a list
+module-option := :components component-list
+ | :serial [ t | nil ]
-@lisp
-((load-op "a") (load-op "b") (compile-op "c") ...)
+option :=
+ | :pathname pathname-specifier
+ | :default-component-class class-name
+ | :perform method-form
+ | :explain method-form
+ | :output-files method-form
+ | :operation-done-p method-form
+ | :if-feature feature-expression
+ | :depends-on ( @var{dependency-def}* )
+ | :in-order-to ( @var{dependency}+ )
+
+
+system-list := ( @var{simple-component-name}* )
+
+component-list := ( @var{component-def}* )
+
+component-def := ( component-type simple-component-name @var{option}* )
+
+component-type := :module | :file | :static-file | other-component-type
+
+other-component-type := symbol-by-name
+ (@pxref{The defsystem grammar,,Component types})
+
+# This is used in :depends-on, as opposed to ``dependency,''
+# which is used in :in-order-to
+dependency-def := simple-component-name
+ | ( :feature @var{feature-expression} dependency-def )
+ | ( :version simple-component-name version-specifier )
+ | ( :require module-name )
+
+# ``dependency'' is used in :in-order-to, as opposed to
+# ``dependency-def''
+dependency := (dependent-op @var{requirement}+)
+requirement := (required-op @var{required-component}+)
+dependent-op := operation-name
+required-op := operation-name
+
+simple-component-name := string
+ | symbol
+
+pathname-specifier := pathname | string | symbol
+
+method-form := (operation-name qual lambda-list @Arest{} body)
+qual := method qualifier
+
+component-dep-fail-option := :fail | :try-next | :ignore
+
+feature-expression := keyword
+ | (:and @var{feature-expression}*)
+ | (:or @var{feature-expression}*)
+ | (:not @var{feature-expression})
+@end example
+
+
+@subsection Component names
+
+Component names (@code{simple-component-name})
+may be either strings or symbols.
+
+@subsection Component types
+
+Component type names, even if expressed as keywords, will be looked up
+by name in the current package and in the asdf package, if not found in
+the current package. So a component type @code{my-component-type}, in
+the current package @code{my-system-asd} can be specified as
+@code{:my-component-type}, or @code{my-component-type}.
+
+@code{system} and its subclasses are @emph{not}
+allowed as component types for such children components.
+
+@subsection System class names
+
+A system class name will be looked up
+in the same way as a Component type (see above),
+except that only @code{system} and its subclasses are allowed.
+Typically, one will not need to specify a system
+class name, unless using a non-standard system class defined in some
+ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON},
+see below. For such class names in the ASDF package, we recommend that
+the @code{:class} option be specified using a keyword symbol, such as
+
+@example
+:class :MY-NEW-SYSTEM-SUBCLASS
+@end example
+
+This practice will ensure that package name conflicts are avoided.
+Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into
+the current package @emph{before} it has been exported from the ASDF
+extension loaded by @code{:defsystem-depends-on}, causing a name
+conflict in the current package.
+
+@subsection Defsystem depends on
+@cindex :defsystem-depends-on
+
+The @code{:defsystem-depends-on} option to @code{defsystem} allows the
+programmer to specify another ASDF-defined system or set of systems that
+must be loaded @emph{before} the system definition is processed.
+Typically this is used to load an ASDF extension that is used in the
+system definition.
+
+@subsection Weakly depends on
+@cindex :weakly-depends-on
+
+We do @emph{NOT} recommend you use this feature.
+If you are tempted to write a system @var{foo}
+that weakly-depends-on a system @var{bar},
+we recommend that you should instead
+write system @var{foo} in a parametric way,
+and offer some special variable and/or some hook to specialize its behavior;
+then you should write a system @var{foo+bar}
+that does the hooking of things together.
+
+The (deprecated) @code{:weakly-depends-on} option to @code{defsystem}
+allows the programmer to specify another ASDF-defined system or set of systems
+that ASDF should @emph{try} to load,
+but need not load in order to be successful.
+Typically this is used if there are a number of systems
+that, if present, could provide additional functionality,
+but which are not necessary for basic function.
+
+Currently, although it is specified to be an option only to @code{defsystem},
+this option is accepted at any component, but it probably
+only makes sense at the @code{defsystem} level.
+Programmers are cautioned not
+to use this component option except at the @code{defsystem} level, as
+this anomalous behavior may be removed without warning.
+
+@c Finally, you might look into the @code{asdf-system-connections} extension,
+@c that will let you define additional code to be loaded
+@c when two systems are simultaneously loaded.
+@c It may or may not be considered good style, but at least it can be used
+@c in a way that has deterministic behavior independent of load order,
+@c unlike @code{weakly-depends-on}.
+
+
+@subsection Pathname specifiers
+@cindex pathname specifiers
+
+A pathname specifier (@code{pathname-specifier})
+may be a pathname, a string or a symbol.
+When no pathname specifier is given for a component,
+which is the usual case, the component name itself is used.
+
+If a string is given, which is the usual case,
+the string will be interpreted as a Unix-style pathname
+where @code{/} characters will be interpreted as directory separators.
+Usually, Unix-style relative pathnames are used
+(i.e. not starting with @code{/}, as opposed to absolute pathnames);
+they are relative to the path of the parent component.
+Finally, depending on the @code{component-type},
+the pathname may be interpreted as either a file or a directory,
+and if it's a file,
+a file type may be added corresponding to the @code{component-type},
+or else it will be extracted from the string itself (if applicable).
+
+For instance, the @code{component-type} @code{:module}
+wants a directory pathname, and so a string @code{"foo/bar"}
+will be interpreted as the pathname @file{#p"foo/bar/"}.
+On the other hand, the @code{component-type} @code{:file}
+wants a file of type @code{lisp}, and so a string @code{"foo/bar"}
+will be interpreted as the pathname @file{#p"foo/bar.lisp"},
+and a string @code{"foo/bar.quux"}
+will be interpreted as the pathname @file{#p"foo/bar.quux.lisp"}.
+Finally, the @code{component-type} @code{:static-file}
+wants a file without specifying a type, and so a string @code{"foo/bar"}
+will be interpreted as the pathname @file{#p"foo/bar"},
+and a string @code{"foo/bar.quux"}
+will be interpreted as the pathname @file{#p"foo/bar.quux"}.
+
+ASDF interprets the string @code{".."}
+as the pathname directory component word @code{:back},
+which when merged, goes back one level in the directory hierarchy.
+
+If a symbol is given, it will be translated into a string,
+and downcased in the process.
+The downcasing of symbols is unconventional,
+but was selected after some consideration.
+Observations suggest that the type of systems we want to support
+either have lowercase as customary case (Unix, Mac, windows)
+or silently convert lowercase to uppercase (lpns),
+so this makes more sense than attempting to use @code{:case :common}
+as argument to @code{make-pathname},
+which is reported not to work on some implementations.
+
+Pathname objects may be given to override the path for a component.
+Such objects are typically specified using reader macros such as @code{#p}
+or @code{#.(make-pathname ...)}.
+Note however, that @code{#p...} is
+a shorthand for @code{#.(parse-namestring ...)}
+and that the behavior of @code{parse-namestring} is completely non-portable,
+unless you are using Common Lisp @code{logical-pathname}s,
+which themselves involve other non-portable behavior
+(@pxref{The defsystem grammar,,Using logical pathnames}, below).
+Pathnames made with @code{#.(make-pathname ...)}
+can usually be done more easily with the string syntax above.
+The only case that you really need a pathname object is to override
+the component-type default file type for a given component.
+Therefore, pathname objects should only rarely be used.
+Unhappily, ASDF 1 used not to properly support
+parsing component names as strings specifying paths with directories,
+and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
+An alternative to @code{#.} read-time evaluation is to use
+@code{(eval `(defsystem ... ,pathname ...))}.
+
+Note that when specifying pathname objects,
+ASDF does not do any special interpretation of the pathname
+influenced by the component type, unlike the procedure for
+pathname-specifying strings.
+On the one hand, you have to be careful to provide a pathname that correctly
+fulfills whatever constraints are required from that component type
+(e.g. naming a directory or a file with appropriate type);
+on the other hand, you can circumvent the file type that would otherwise
+be forced upon you if you were specifying a string.
+
+@subsection Version specifiers
+@cindex version specifiers
+@cindex :version
+
+Version specifiers are strings to be parsed as period-separated lists of integers.
+I.e., in the example, @code{"0.2.1"} is to be interpreted,
+roughly speaking, as @code{(0 2 1)}.
+In particular, version @code{"0.2.1"} is interpreted the same as @code{"0.0002.1"},
+though the latter is not canonical and may lead to a warning being issued.
+Also, @code{"1.3"} and @code{"1.4"} are both strictly @code{uiop:version<} to @code{"1.30"},
+quite unlike what would have happened
+had the version strings been interpreted as decimal fractions.
+
+Instead of a string representing the version,
+the @code{:version} argument can be an expression that is resolved to
+such a string using the following trivial domain-specific language:
+in addition to being a literal string, it can be an expression of the form
+@code{(:read-file-form <pathname-or-string> :at <access-at-specifier>)},
+which will be resolved by reading a form in the specified pathname
+(read as a subpathname of the current system if relative or a unix-namestring).
+You may use a @code{uiop:access-at} specifier
+with the (optional) @code{:at} keyword,
+by default the specifier is @code{0}, meaning the first form is returned;
+subforms can also be specified, with e.g. @code{(1 2 2)} specifying
+``the third subform (index 2) of the third subform (index 2) of the second form (index 1)''
+in the file (mind the off-by-one error in the English language).
+
+System definers are encouraged to use version identifiers of the form
+@var{x}.@var{y}.@var{z} for
+major version, minor version and patch level,
+where significant API incompatibilities are signaled by an increased major number.
+
+@xref{Common attributes of components}.
+
+@subsection Require
+@cindex :require dependencies
+
+Use the implementation's own @code{require} to load the @var{module-name}.
+
+
+@subsection Using logical pathnames
+@cindex logical pathnames
+
+We do not generally recommend the use of logical pathnames,
+especially not so to newcomers to Common Lisp.
+However, we do support the use of logical pathnames by old timers,
+when such is their preference.
+
+To use logical pathnames,
+you will have to provide a pathname object as a @code{:pathname} specifier
+to components that use it, using such syntax as
+@code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}.
+
+You only have to specify such logical pathname
+for your system or some top-level component.
+Sub-components' relative pathnames,
+specified using the string syntax for names,
+will be properly merged with the pathnames of their parents.
+The specification of a logical pathname host however is @emph{not}
+otherwise directly supported in the ASDF syntax
+for pathname specifiers as strings.
+
+The @code{asdf-output-translation} layer will
+avoid trying to resolve and translate logical pathnames.
+The advantage of this is that
+you can define yourself what translations you want to use
+with the logical pathname facility.
+The disadvantage is that if you do not define such translations,
+any system that uses logical pathnames will behave differently under
+asdf-output-translations than other systems you use.
+
+If you wish to use logical pathnames you will have to configure the
+translations yourself before they may be used.
+ASDF currently provides no specific support
+for defining logical pathname translations.
+
+Note that the reasons we do not recommend logical pathnames are that
+(1) there is no portable way to set up logical pathnames before they are used,
+(2) logical pathnames are limited to only portably use
+a single character case, digits and hyphens.
+While you can solve the first issue on your own,
+describing how to do it on each of fifteen implementations supported by ASDF
+is more than we can document.
+As for the second issue, mind that the limitation is notably enforced on SBCL,
+and that you therefore can't portably violate the limitations
+but must instead define some encoding of your own and add individual mappings
+to name physical pathnames that do not fit the restrictions.
+This can notably be a problem when your Lisp files are part of a larger project
+in which it is common to name files or directories in a way that
+includes the version numbers of supported protocols,
+or in which files are shared with software written
+in different programming languages where conventions include the use of
+underscores, dots or CamelCase in pathnames.
+
+
+@subsection Serial dependencies
+@cindex serial dependencies
+
+If the @code{:serial t} option is specified for a module,
+ASDF will add dependencies for each child component,
+on all the children textually preceding it.
+This is done as if by @code{:depends-on}.
+
+@lisp
+:serial t
+:components ((:file "a") (:file "b") (:file "c"))
+@end lisp
+
+is equivalent to
+
+@lisp
+:components ((:file "a")
+ (:file "b" :depends-on ("a"))
+ (:file "c" :depends-on ("a" "b")))
+@end lisp
+
+
+@subsection Source location (@code{:pathname})
+
+The @code{:pathname} option is optional in all cases for systems
+defined via @code{defsystem}, and generally is unnecessary. In the
+simple case, source files will be found in the same directory as the
+system or, in the case of modules, in a subdirectory with the same name
+as the module.
+
+@c FIXME: This should be moved elsewhere -- it's too much detail for the
+@c grammar section.
+
+More specifically, ASDF follows a hairy set of rules that are designed so that
+@enumerate
+@item
+@code{find-system}
+will load a system from disk
+and have its pathname default to the right place.
+
+@item
+This pathname information will not be overwritten with
+@code{*default-pathname-defaults*}
+(which could be somewhere else altogether)
+if the user loads up the @file{.asd} file into his editor
+and interactively re-evaluates that form.
+@end enumerate
+
+If a system is being loaded for the first time,
+its top-level pathname will be set to:
+
+@itemize
+@item
+The host/device/directory parts of @code{*load-truename*},
+if it is bound.
+@item
+@code{*default-pathname-defaults*}, otherwise.
+@end itemize
+
+If a system is being redefined, the top-level pathname will be
+
+@itemize
+@item
+changed, if explicitly supplied or obtained from @code{*load-truename*}
+(so that an updated source location is reflected in the system definition)
+
+@item
+changed if it had previously been set from @code{*default-pathname-defaults*}
+
+@item
+left as before, if it had previously been set from @code{*load-truename*}
+and @code{*load-truename*} is currently unbound
+(so that a developer can evaluate a @code{defsystem} form
+from within an editor without clobbering its source location)
+@end itemize
+
+@subsection if-feature option
+@cindex :if-feature component option
+@anchor{if-feature-option} @c redo if this ever becomes a node in
+@c its own right...
+
+This option allows you to specify a feature expression to be evaluated
+as if by @code{#+} to conditionally include a component in your build.
+If the expression is false, the component is dropped
+as well as any dependency pointing to it.
+As compared to using @code{#+} which is expanded at read-time,
+this allows you to have an object in your component hierarchy
+that can be used for manipulations beside building your project, and
+that is accessible to outside code that wishes to reason about system
+structure.
+
+Programmers should be careful to consider @strong{when} the
+@code{:if-feature} is evaluated. Recall that ASDF first computes a
+build plan, and then executes that plan. ASDF will check to see whether
+or not a feature is present @strong{at planning time}, not during the
+build. It follows that one cannot use @code{:if-feature} to check
+features that are set during the course of the build. It can only be
+used to check the state of features before any build operations have
+been performed.
+
+This option was added in ASDF 3. For more information,
+@xref{required-features, Required features}.
+
+@subsection if-component-dep-fails option
+@cindex :if-component-dep-fails component option
+This option was removed in ASDF 3.
+Its semantics was limited in purpose and dubious to explain,
+and its implementation was breaking a hole into the ASDF object model.
+Please use the @code{if-feature} option instead.
+
+@subsection feature requirement
+This requirement was removed in ASDF 3.1. Please do not use it. In
+most cases, @code{:if-feature} (@pxref{if-feature-option}) will provide
+an adequate substitute.
+
+The @code{feature} requirement used to ensure that a chain of component
+dependencies would fail when a key feature was absent.
+Used in conjunction with @code{:if-component-dep-fails}
+this provided
+a roundabout way to express conditional compilation.
+
+
+@node Other code in .asd files, The package-inferred-system extension, The defsystem grammar, Defining systems with defsystem
+@section Other code in .asd files
+
+Files containing @code{defsystem} forms
+are regular Lisp files that are executed by @code{load}.
+Consequently, you can put whatever Lisp code you like into these files.
+However, it is recommended to keep such forms to a minimal,
+and to instead define @code{defsystem} extensions
+that you use with @code{:defsystem-depends-on}.
+
+If however, you might insist on including code in the @file{.asd} file itself,
+e.g., to examine and adjust the compile-time environment,
+possibly adding appropriate features to @code{*features*}.
+If so, here are some conventions we recommend you follow,
+so that users can control certain details of execution
+of the Lisp in @file{.asd} files:
+
+@itemize
+@item
+Any informative output
+(other than warnings and errors,
+which are the condition system's to dispose of)
+should be sent to the standard CL stream @code{*standard-output*},
+so that users can easily control the disposition
+of output from ASDF operations.
+@end itemize
+
+
+@node The package-inferred-system extension, , Other code in .asd files, Defining systems with defsystem
+@section The package-inferred-system extension
+
+Starting with release 3.1.1,
+ASDF supports a one-package-per-file style of programming,
+whereby each file is its own system,
+and dependencies are deduced from the @code{defpackage} form
+(or its variant @code{uiop:define-package}).
+
+
+In this style, packages refer to a system with the same name (downcased);
+and if a system is defined with @code{:class package-inferred-system},
+then system names that start with that name
+(using the slash @code{/} separator)
+refer to files under the filesystem hierarchy where the system is defined.
+For instance, if system @code{my-lib} is defined in
+@file{/foo/bar/my-lib/my-lib.asd}, then system @code{my-lib/src/utility}
+will be found in file @file{/foo/bar/my-lib/src/utility.lisp}.
+
+This style was made popular by @code{faslpath} and @code{quick-build} before,
+and at the cost of a stricter package discipline,
+seems to make for more maintainable code.
+It is used by ASDF itself (starting with ASDF 3) and by @code{lisp-interface-library}.
+
+To use this style, choose a toplevel system name, e.g. @code{my-lib},
+and create a file @file{my-lib.asd}
+with the @code{:class :package-inferred-system} option in its @code{defsystem}.
+For instance:
+@example
+#-asdf (error "my-lib requires ASDF 3")
+(defsystem my-lib
+ :class :package-inferred-system
+ :defsystem-depends-on (:asdf-package-system)
+ :depends-on (:lil/interface/all
+ :lil/pure/all
+ :lil/stateful/all
+ :lil/transform/all)
+ :in-order-to ((test-op (load-op :lil/test/all)))
+ :perform (test-op (o c) (symbol-call :lil/test/all :test-suite)))
+
+(defsystem :lil/test :depends-on (:lil/test/all))
+
+(register-system-packages :lil/interface/all '(:interface))
+(register-system-packages :lil/pure/all '(:pure))
+(register-system-packages :lil/stateful/all '(:stateful))
+(register-system-packages :lil/transform/classy '(:classy))
+(register-system-packages :lil/transform/posh '(:posh))
+(register-system-packages :lil/test/all '(:lil/test))
+
+(register-system-packages
+ :closer-mop
+ '(:c2mop :closer-common-lisp :c2cl :closer-common-lisp-user :c2cl-user))
+@end example
+
+In the code above, the
+@code{:defsystem-depends-on (:asdf-package-system)} is
+for compatibility with older versions of ASDF 3 (ASDF 2 is not supported),
+and requires the @code{asdf-package-system} library to be present
+(it is implicitly provided by ASDF starting with release 3.1.1,
+which can be detected with the feature @code{:asdf3.1}).
+
+The function @code{register-system-packages} has to be called to register
+packages used or provided by your system and its components
+where the name of the system that provides the package
+is not the downcase of the package name.
+
+Then, file @file{interface/order.lisp} under the @code{lil} hierarchy,
+that defines abstract interfaces for order comparisons,
+starts with the following form,
+dependencies being trivially computed from the @code{:use} and @code{:mix} clauses:
+
+@example
+(uiop:define-package :lil/interface/order
+ (:use :closer-common-lisp
+ :lil/interface/definition
+ :lil/interface/base
+ :lil/interface/eq :lil/interface/group)
+ (:mix :fare-utils :uiop :alexandria)
+ (:export ...))
+@end example
+
+ASDF can tell that this file depends on system @code{closer-mop} (registered above),
+@code{lil/interface/definition}, @code{lil/interface/base},
+@code{lil/interface/eq}, and @code{lil/interface/group}
+(package and system names match, and they will be looked up hierarchically).
+
+ASDF also detects dependencies from @code{:import-from} clauses.
+To depend on a system without using a package or importing any symbol from it
+(because you'll fully qualify them when used),
+you may thus use an @code{:import-from} clause with an empty list of symbols, as in:
+
+@example
+(defpackage :foo/bar
+ (:use :cl)
+ (:import-from :foo/baz #:sym1 #:sym2)
+ (:import-from :foo/quux)
+ (:export ...))
+@end example
+
+The form @code{uiop:define-package} is supported as well as @code{defpackage},
+and has many options that prove useful in this context,
+such as @code{:use-reexport} and @code{:mix-reexport}
+that allow for ``inheritance'' of symbols being exported.
+
+@node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top
+@comment node-name, next, previous, up
+@chapter The Object model of ASDF
+@tindex component
+@tindex operation
+
+ASDF is designed in an object-oriented way from the ground up.
+Both a system's structure and the operations that can be performed on systems
+follow a extensible protocol, allowing programmers to add new behaviors to ASDF.
+For example, @code{cffi} adds support for special FFI description files
+that interface with C libraries and for wrapper files that embed C code in Lisp.
+@code{abcl-jar} supports creating Java JAR archives in ABCL.
+@code{poiu} supports compiling code in parallel using background processes.
+
+The key classes in ASDF are @code{component} and @code{operation}.
+A @code{component} represents an individual source file or a group of source files,
+and the products (e.g., fasl files) produced from it.
+An @code{operation} represents a transformation that can be performed on a component,
+turning them from source files to intermediate results to final outputs.
+Components are related by @emph{dependencies}, specified in system
+definitions.
+
+When ordered to @code{operate} with some operation on a component (usually a system),
+ASDF will first compute a @emph{plan}
+by traversing the dependency graph using function @code{make-plan}.@footnote{
+ Historically, the function that built a plan was
+ called @code{traverse}, and returned a list of actions;
+ it was deprecated in favor of @code{make-plan} (that returns a plan object)
+ when the @code{plan} objects were introduced;
+ the old function is kept for backward compatibility and debugging purposes only.
+}
+The resulting plan object contains an ordered list of @emph{actions}.
+An action is a pair of an @code{operation} and a @code{component},
+representing a particular build step to be @code{perform}ed.
+The ordering of the plan ensures that no action is performed before
+all its dependencies have been fulfilled.@footnote{
+ The term @emph{action}
+ was used by Kent Pitman in his article, ``The Description of Large Systems,''
+ (@pxref{Bibliography}).
+ Although the term was only used by ASDF hackers starting with ASDF 2,
+ the concept was there since the very beginning of ASDF 1,
+ just not clearly articulated.
+}
+
+In this chapter, we describe ASDF's object-oriented protocol,
+the classes that make it up, and the generic functions on those classes.
+These generic functions often take
+both an operation and a component as arguments:
+much of the power and configurability of ASDF is provided by
+this use of CLOS's multiple dispatch.
+We will describe the built-in component and operation classes, and
+explain how to extend the ASDF protocol by defining new classes and
+methods for ASDF's generic functions.
+We will also describe the many @emph{hooks} that can be configured to
+customize the behavior of existing @emph{functions}.
+
+@c FIXME: Swap operations and components.
+@c FIXME: Possibly add a description of the PLAN object.
+@c Not critical, since the user isn't expected to interact with it.
+@menu
+* Operations::
+* Components::
+* Dependencies::
+* Functions::
+@end menu
+
+@node Operations, Components, The object model of ASDF, The object model of ASDF
+@comment node-name, next, previous, up
+@section Operations
+@cindex operation
+
+An @dfn{operation} object of the appropriate type is instantiated
+whenever the user wants to do something with a system like
+
+@itemize
+@item compile all its files
+@item load the files into a running lisp environment
+@item copy its source files somewhere else
+@end itemize
+
+Operations can be invoked directly, or examined
+to see what their effects would be without performing them.
+There are a bunch of methods specialised on operation and component type
+that actually do the grunt work.
+Operations are invoked on systems via @code{operate} (@pxref{operate}).
+
+ASDF contains a number of pre-defined @t{operation} classes for common,
+and even fairly uncommon tasks that you might want to do with it.
+In addition, ASDF contains ``abstract'' @t{operation} classes that
+programmers can use as building blocks to define ASDF extensions. We
+discuss these in turn below.
+
+@c The operation object contains whatever state is relevant for this purpose
+@c (perhaps a list of visited nodes, for example)
+@c but primarily is a nice thing to specialise operation methods on
+@c and easier than having them all be @code{EQL} methods.
+
+@menu
+* Predefined operations of ASDF::
+* Creating new operations::
+@end menu
+
+Operations are invoked on systems via @code{operate}.
+@anchor{operate}
+@deffn {Generic function} @code{operate} @var{operation} @var{component} @Arest{} @var{initargs} @Akey{} @code{force} @code{force-not} @code{verbose} @AallowOtherKeys
+@deffnx {Generic function} @code{oos} @var{operation} @var{component} @Arest{} @var{initargs} @Akey{} @AallowOtherKeys{}
+@code{operate} invokes @var{operation} on @var{system}.
+@code{oos} is a synonym for @code{operate} (it stands for operate-on-system).
+
+@var{operation} is a symbol that is passed,
+along with the supplied @var{initargs},
+to @code{make-operation} (which will call @code{make-instance})
+to create the operation object.
+@var{component} is a component designator,
+usually a string or symbol that designates a system,
+sometimes a list of strings or symbols that designate a subcomponent of a system.
+
+The @var{initargs} are passed to the @code{make-instance} call
+when creating the operation object.
+@c We probably want to deprecate that, because
+@c (1) there is a mix of flags for operate, for the operation-class, for the plan-class, etc.
+@c (2) flags to operations have never been well-supported, anyway.
+@c The future solution probably involves having an explicit :operation-options keyword or some such
+@c (if operation options are not wholly eliminated), a separate :plan-options, etc.
+Note that dependencies may cause the operation
+to invoke other operations on the system or its components:
+the new operations will be created
+with the same @var{initargs} as the original one.
+
+If @var{force} is @code{:all}, then all systems
+are forced to be recompiled even if not modified since last compilation.
+If @var{force} is @code{t}, then only the system being loaded
+is forced to be recompiled even if not modified since last compilation,
+but other systems are not affected.
+If @var{force} is a list, then it specifies a list of systems that
+are forced to be recompiled even if not modified since last compilation.
+If @var{force-not} is @code{:all}, then all systems
+are forced not to be recompiled even if modified since last compilation.
+If @var{force-not} is @code{t}, then all systems but the system being loaded
+are forced not to be recompiled even if modified since last compilation
+(note: this was changed in ASDF 3.1.1).
+If @var{force-not} is a list, then it specifies a list of systems that
+are forced not to be recompiled even if modified since last compilation.
+
+Both @var{force} and @var{force-not} apply to systems that are dependencies and were already compiled.
+@var{force-not} takes precedences over @var{force},
+as it should, really, but unhappily only since ASDF 3.1.1.
+Moreover, systems the name of which is member of the set @var{*immutable-systems*}
+(represented as an equal hash-table) are always considered @var{forced-not}, and
+even their @file{.asd} is not refreshed from the filesystem.
+
+To see what @code{operate} would do, you can use:
+@example
+(asdf:traverse operation-class system-name)
+@end example
+
+@end deffn
+
+
+
+@node Predefined operations of ASDF, Creating new operations, Operations, Operations
+@comment node-name, next, previous, up
+@subsection Predefined operations of ASDF
+@c FIXME: All these deffn's should be replaced with deftyp. Also, we
+@c should set up an appropriate index.
+
+All the operations described in this section are in the @code{asdf} package.
+They are invoked via the @code{operate} generic function.
+
+@lisp
+(asdf:operate 'asdf:@var{operation-name} :@var{system-name} @{@var{operation-options ...}@})
+@end lisp
+
+@deffn Operation @code{compile-op}
+
+This operation compiles the specified component.
+A @code{cl-source-file} will be @code{compile-file}'d.
+All the children and dependencies of a system or module
+will be recursively compiled by @code{compile-op}.
+
+@code{compile-op} depends on @code{prepare-op} which
+itself depends on a @code{load-op} of all of a component's dependencies,
+as well as of its parent's dependencies.
+When @code{operate} is called on @code{compile-op},
+all these dependencies will be loaded as well as compiled;
+yet, some parts of the system main remain unloaded,
+because nothing depends on them.
+Use @code{load-op} to load a system.
+@end deffn
+
+@deffn Operation @code{load-op}
+
+This operation loads the compiled code for a specified component.
+A @code{cl-source-file} will have its compiled fasl @code{load}ed,
+which fasl is the output of @code{compile-op} that @code{load-op} depends on.
+
+@code{load-op} will recursively load all the children of a system or module.
+
+@code{load-op} also depends on @code{prepare-op} which
+itself depends on a @code{load-op} of all of a component's dependencies,
+as well as of its parent's dependencies.
+@end deffn
+
+@deffn Operation @code{prepare-op}
+
+This operation ensures that the dependencies of a component
+and its recursive parents are loaded (as per @code{load-op}),
+as a prerequisite before @code{compile-op} and @code{load-op} operations
+may be performed on a given component.
+@end deffn
+
+@deffn Operation @code{load-source-op}, @code{prepare-source-op}
+
+@code{load-source-op} will load the source for the files in a module
+rather than the compiled fasl output.
+It has a @code{prepare-source-op} analog to @code{prepare-op},
+that ensures the dependencies are themselves loaded via @code{load-source-op}.
+
+@end deffn
+
+@anchor{test-op}
+@deffn Operation @code{test-op}
+
+This operation will perform some tests on the module.
+The default method will do nothing.
+The default dependency is to require
+@code{load-op} to be performed on the module first.
+Its @code{operation-done-p} method returns @code{nil},
+which means that the operation is @emph{never} done
+--
+we assume that if you invoke the @code{test-op},
+you want to test the system, even if you have already done so.
+
+The results of this operation are not defined by ASDF.
+It has proven difficult to define how the test operation
+should signal its results to the user
+in a way that is compatible with all of the various test libraries
+and test techniques in use in the community, and
+given the fact that ASDF operations do not return a value indicating
+success or failure.
+For those willing to go to the effort, we suggest defining conditions to
+signal when a @code{test-op} fails, and storing in those conditions
+information that describes which tests fail.
+
+People typically define a separate test @emph{system} to hold the tests.
+Doing this avoids unnecessarily adding a test framework as a dependency
+on a library. For example, one might have
+@lisp
+(defsystem foo
+ :in-order-to ((test-op (test-op "foo/test")))
+ ...)
+
+(defsystem foo/test
+ :depends-on (foo fiveam) ; fiveam is a test framework library
+ ...)
+@end lisp
+
+Then one defines @code{perform} methods on
+@code{test-op} such as the following:
+@lisp
+(defsystem foo/test
+ :depends-on (foo fiveam) ; fiveam is a test framework library
+ :perform (test-op (o s)
+ (uiop:symbol-call :fiveam '#:run!
+ (uiop:find-symbol* '#:foo-test-suite
+ :foo-tests)))
+ ...)
+@end lisp
+
+@end deffn
+
+
+
+@deffn Operation @code{compile-bundle-op}, @code{monolithic-compile-bundle-op}, @code{load-bundle-op}, @code{monolithic-load-bundle-op}, @code{deliver-asd-op}, @code{monolithic-deliver-asd-op}, @code{lib-op}, @code{monolithic-lib-op}, @code{dll-op}, @code{monolithic-dll-op}, @code{image-op}, @code{program-op}
+
+These are ``bundle'' operations, that can create a single-file ``bundle''
+for all the contents of each system in an application,
+or for the entire application.
+
+@code{compile-bundle-op} will create a single fasl file for each of the systems needed,
+grouping all its many fasls in one,
+so you can deliver each system as a single fasl
+@code{monolithic-compile-bundle-op} will create a single fasl file for the target system
+and all its dependencies,
+so you can deliver your entire application as a single fasl.
+@code{load-bundle-op} will load the output of @code{compile-bundle-op}.
+Note that if it the output is not up-to-date,
+@code{compile-bundle-op} may load the intermediate fasls as a side-effect.
+Bundling fasls together matters a lot on ECL,
+where the dynamic linking involved in loading tens of individual fasls
+can be noticeably more expensive than loading a single one.
+
+NB: @code{compile-bundle-op}, @code{monolithic-compile-bundle-op}, @code{load-bundle-op}, @code{monolithic-load-bundle-op}, @code{deliver-asd-op}, @code{monolithic-deliver-asd-op} were respectively called
+@code{fasl-op}, @code{monolithic-fasl-op}, @code{load-fasl-op}, @code{monolithic-load-fasl-op}, @code{binary-op}, @code{monolithic-binary-op} before ASDF 3.1.
+The old names still exist for backward compatibility,
+though they poorly label what is going on.
+
+Once you have created a fasl with @code{compile-bundle-op},
+you can use @code{precompiled-system} to deliver it in a way
+that is compatible with clients having dependencies on your system,
+whether it is distributed as source or as a single binary;
+the @file{.asd} file to be delivered with the fasl will look like this:
+@example
+(defsystem :mysystem :class :precompiled-system
+ :fasl (some expression that will evaluate to a pathname))
+@end example
+Or you can use @code{deliver-asd-op} to let ASDF create such a system for you
+as well as the @code{compile-bundle-op} output,
+or @code{monolithic-deliver-asd-op}.
+This allows you to deliver code for your systems or applications
+as a single file.
+Of course, if you want to test the result in the current image,
+@emph{before} you try to use any newly created @file{.asd} files,
+you should not forget to @code{(asdf:clear-configuration)}
+or at least @code{(asdf:clear-source-registry)},
+so it re-populates the source-registry from the filesystem.
+
+The @code{program-op} operation will create an executable program
+from the specified system and its dependencies.
+You can use UIOP for its pre-image-dump hooks, its post-image-restore hooks,
+and its access to command-line arguments.
+And you can specify an entry point @code{my-app:main}
+by specifying in your @code{defsystem}
+the option @code{:entry-point "my-app:main"}.
+Depending on your implementation,
+running @code{(asdf:operate 'asdf:program-op :my-app)}
+may quit the current Lisp image upon completion.
+See the example in
+@file{test/hello-world-example.asd} and @file{test/hello.lisp},
+as built and tested by
+@file{test/test-program.script} and @file{test/make-hello-world.lisp}.
+@code{image-op} will dump an image that may not be standalone
+and does not start its own function,
+but follows the usual execution convention of the underlying Lisp,
+just with more code pre-loaded,
+for use as an intermediate build result or with a wrapper invocation script.
+
+There is also @code{lib-op}
+for building a linkable @file{.a} file (Windows: @file{.lib})
+from all linkable object dependencies (FFI files, and on ECL, Lisp files too),
+and its monolithic equivalent @code{monolithic-lib-op}.
+And there is also @code{dll-op}
+(respectively its monolithic equivalent @code{monolithic-lib-op})
+for building a linkable @file{.so} file
+(Windows: @file{.dll}, MacOS X: @file{.dynlib})
+to create a single dynamic library
+for all the extra FFI code to be linked into each of your systems
+(respectively your entire application).
+
+All these ``bundle'' operations are available since ASDF 3
+on all actively supported Lisp implementations,
+but may be unavailable on unmaintained legacy implementations.
+This functionality was previously available for select implementations,
+as part of a separate system @code{asdf-bundle},
+itself descended from the ECL-only @code{asdf-ecl}.
+
+The pathname of the output of bundle operations
+is subject to output-translation as usual,
+unless the operation is equal to
+the @code{:build-operation} argument to @code{defsystem}.
+This behavior is not very satisfactory and may change in the future.
+Maybe you have suggestions on how to better configure it?
+@end deffn
+
+@deffn Operation @code{concatenate-source-op}, @code{monolithic-concatenate-source-op}, @code{load-concatenated-source-op}, @code{compile-concatenated-source-op}, @code{load-compiled-concatenated-source-op}, @code{monolithic-load-concatenated-source-op}, @code{monolithic-compile-concatenated-source-op}, @code{monolithic-load-compiled-concatenated-source-op}
+
+These operations, as their respective names indicate,
+will concatenate all the @code{cl-source-file} source files in a system
+(or in a system and all its dependencies, if monolithic),
+in the order defined by dependencies,
+then load the result, or compile and then load the result.
+
+These operations are useful to deliver a system or application
+as a single source file,
+and for testing that said file loads properly, or compiles and then loads properly.
+
+ASDF itself is delivered as a single source file this way,
+using @code{monolithic-concatenate-source-op},
+prepending a prelude and the @code{uiop} library
+before the @code{asdf/defsystem} system itself.
+@end deffn
+
+
+@node Creating new operations, , Predefined operations of ASDF, Operations
+@comment node-name, next, previous, up
+@subsection Creating new operations
+
+ASDF was designed to be extensible in an object-oriented fashion.
+To teach ASDF new tricks, a programmer can implement the behaviour he wants
+by creating a subclass of @code{operation}.
+
+ASDF's pre-defined operations are in no way ``privileged'',
+but it is requested that developers never use the @code{asdf} package
+for operations they develop themselves.
+The rationale for this rule is that we don't want to establish a
+``global asdf operation name registry'',
+but also want to avoid name clashes.
+
+Your operation @emph{must} usually provide methods
+for one or more of the following generic functions:
+
+@itemize
+
+@findex perform
+@item @code{perform}
+Unless your operation, like @code{prepare-op},
+is for dependency propagation only,
+the most important function for which to define a method
+is usually @code{perform},
+which will be called to perform the operation on a specified component,
+after all dependencies have been performed.
+
+The @code{perform} method must call @code{input-files} and @code{output-files} (see below)
+to locate its inputs and outputs,
+because the user is allowed to override the method
+or tweak the output-translation mechanism.
+Perform should only use the primary value returned by @code{output-files}.
+If one and only one output file is expected,
+it can call @code{output-file} that checks that this is the case
+and returns the first and only list element.
+
+@findex output-files
+@item @code{output-files}
+If your perform method has any output,
+you must define a method for this function.
+for ASDF to determine where the outputs of performing operation lie.
+
+Your method may return two values, a list of pathnames, and a boolean.
+If the boolean is @code{nil} (or you fail to return multiple values),
+then enclosing @code{:around} methods may translate these pathnames,
+e.g. to ensure object files are somehow stored
+in some implementation-dependent cache.
+If the boolean is @code{t} then the pathnames are marked
+not be translated by the enclosing @code{:around} method.
+
+@findex component-depends-on
+@item @code{component-depends-on}
+If the action of performing the operation on a component has dependencies,
+you must define a method on @code{component-depends-on}.
+
+Your method will take as specialized arguments
+an operation and a component which together identify an action,
+and return a list of entries describing actions that this action depends on.
+The format of entries is described below.
+
+It is @emph{strongly} advised that
+you should always append the results of @code{(call-next-method)}
+to the results of your method,
+or ``interesting'' failures will likely occur,
+unless you're a true specialist of ASDF internals.
+It is unhappily too late to compatibly use the @code{append} method combination,
+but conceptually that's the protocol that is being manually implemented.
+
+Each entry returned by @code{component-depends-on} is itself a list.
+
+The first element of an entry is an operation designator:
+either an operation object designating itself, or
+a symbol that names an operation class
+(that ASDF will instantiate using @code{make-operation}).
+For instance, @code{load-op}, @code{compile-op} and @code{prepare-op}
+are common such names, denoting the respective operations.
+
+@c FIXME COERCE-NAME is referenced, but not defined.
+@findex coerce-name
+@findex find-component
+The rest of each entry is a list of component designators:
+either a component object designating itself,
+or an identifier to be used with @code{find-component}.
+@code{find-component} will be called with the current component's parent as parent,
+and the identifier as second argument.
+The identifier is typically a string,
+a symbol (to be downcased as per @code{coerce-name}),
+or a list of strings or symbols.
+In particular, the empty list @code{nil} denotes the parent itself.
+
+@end itemize
+
+An operation @emph{may} provide methods for the following generic functions:
+
+@itemize
+
+@item @code{input-files}
+@findex input-files
+A method for this function is often not needed,
+since ASDF has a pretty clever default @code{input-files} mechanism.
+You only need create a method if there are multiple ultimate input files,
+and/or the bottom one doesn't depend
+on the @code{component-pathname} of the component.
+
+@item @code{operation-done-p}
+@findex operation-done-p
+You only need to define a method on that function
+if you can detect conditions that invalidate previous runs of the operation,
+even though no filesystem timestamp has changed,
+in which case you return @code{nil} (the default is @code{t}).
+
+For instance, the method for @code{test-op} always returns @code{nil},
+so that tests are always run afresh.
+Of course, the @code{test-op} for your system could depend
+on a deterministically repeatable @code{test-report-op},
+and just read the results from the report files,
+in which case you could have this method return @code{t}.
+
+@end itemize
+
+Operations that print output should send that output to the standard
+CL stream @code{*standard-output*}, as the Lisp compiler and loader do.
+
+@node Components, Dependencies, Operations, The object model of ASDF
+@comment node-name, next, previous, up
+@section Components
+@cindex component
+@cindex system
+@cindex system designator
+@cindex component designator
+@vindex *system-definition-search-functions*
+
+A @code{component} represents an individual source file or a group of source files,
+and the things that get transformed into.
+A @code{system} is a component at the top level of the component hierarchy,
+that can be found via @code{find-system}.
+A @code{source-file} is a component representing a single source-file
+and the successive output files into which it is transformed.
+A @code{module} is an intermediate component itself grouping several other components,
+themselves source-files or further modules.
+
+A @dfn{system designator} is a system itself,
+or a string or symbol that behaves just like any other component name
+(including with regard to the case conversion rules for component names).
+
+A @dfn{component designator}, relative to a base component,
+is either a component itself,
+or a string or symbol,
+or a list of designators.
+
+@defun find-system system-designator @Aoptional{} (error-p t)
+
+Given a system designator, @code{find-system} finds and returns a system.
+If no system is found, an error of type
+@code{missing-component} is thrown,
+or @code{nil} is returned if @code{error-p} is false.
+
+To find and update systems, @code{find-system} funcalls each element
+in the @code{*system-definition-search-functions*} list,
+expecting a pathname to be returned, or a system object,
+from which a pathname may be extracted, and that will be registered.
+The resulting pathname (if any) is loaded
+if one of the following conditions is true:
+
+@itemize
+@item
+there is no system of that name in memory
+@item
+the pathname is different from that which was previously loaded
+@item
+the file's @code{last-modified} time exceeds the @code{last-modified} time
+of the system in memory
+@end itemize
+
+When system definitions are loaded from @file{.asd} files,
+a new scratch package is created for them to load into,
+so that different systems do not overwrite each others operations.
+The user may also wish to (and is recommended to)
+include @code{defpackage} and @code{in-package} forms
+in his system definition files, however,
+so that they can be loaded manually if need be.
+
+The default value of @code{*system-definition-search-functions*}
+is a list of two functions.
+The first function looks in each of the directories given
+by evaluating members of @code{*central-registry*}
+for a file whose name is the name of the system and whose type is @file{asd}.
+The first such file is returned,
+whether or not it turns out to actually define the appropriate system.
+The second function does something similar,
+for the directories specified in the @code{source-registry}.
+Hence, it is strongly advised to define a system
+@var{foo} in the corresponding file @var{foo.asd}.
+@end defun
+
+@defun find-component base path
+
+Given a @var{base} component (or designator for such),
+and a @var{path}, find the component designated by the @var{path}
+starting from the @var{base}.
+
+If @var{path} is a component object, it designates itself,
+independently from the base.
+
+@findex coerce-name
+If @var{path} is a string, or symbol denoting a string via @code{coerce-name},
+then @var{base} is resolved to a component object,
+which must be a system or module,
+and the designated component is the child named by the @var{path}.
+
+If @var{path} is a @code{cons} cell,
+@code{find-component} with the base and the @code{car} of the @var{path},
+and the resulting object is used as the base for a tail call
+to @code{find-component} with the @code{car} of the @var{path}.
+
+If @var{base} is a component object, it designates itself.
+
+If @var{base} is null, then @var{path} is used as the base, with @code{nil} as the path.
+
+If @var{base} is a string, or symbol denoting a string via @code{coerce-name},
+it designates a system as per @code{find-system}.
+
+If @var{base} is a @code{cons} cell, it designates the component found by
+@code{find-component} with its @code{car} as base and @code{cdr} as path.
+@end defun
+
+
+@menu
+* Common attributes of components::
+* Pre-defined subclasses of component::
+* Creating new component types::
+@end menu
+
+@node Common attributes of components, Pre-defined subclasses of component, Components, Components
+@comment node-name, next, previous, up
+@subsection Common attributes of components
+
+All components, regardless of type, have the following attributes.
+All attributes except @code{name} are optional.
+
+@subsubsection Name
+@findex coerce-name
+A component name is a string or a symbol.
+If a symbol, its name is taken and lowercased. This translation is
+performed by the exported function @code{coerce-name}.
+
+Unless overridden by a @code{:pathname} attribute,
+the name will be interpreted as a pathname specifier according
+to a Unix-style syntax.
+@xref{The defsystem grammar,,Pathname specifiers}.
+
+@subsubsection Version identifier
+@findex version-satisfies
+@cindex :version
+
+This optional attribute specifies a version for the current component.
+The version should typically be a string of integers separated by dots,
+for example @samp{1.0.11}.
+For more information on version specifiers, see @ref{The defsystem grammar}.
+
+A version may then be queried by the generic function @code{version-satisfies},
+to see if @code{:version} dependencies are satisfied,
+and when specifying dependencies, a constraint of minimal version to satisfy
+can be specified using e.g. @code{(:version "mydepname" "1.0.11")}.
+
+Note that in the wild, we typically see version numbering
+only on components of type @code{system}.
+Presumably it is much less useful within a given system,
+wherein the library author is responsible to keep the various files in synch.
+
+@subsubsection Required features
+@anchor{required-features}
+
+Traditionally defsystem users have used @code{#+} reader conditionals
+to include or exclude specific per-implementation files.
+For example, CFFI, the portable C foreign function interface contained
+lines like:
+@lisp
+ #+sbcl (:file "cffi-sbcl")
+@end lisp
+An unfortunate side effect of this approach is that no single
+implementation can read the entire system.
+This causes problems if, for example, one wished to design an @code{archive-op}
+that would create an archive file containing all the sources, since
+for example the file @code{cffi-sbcl.lisp} above would be invisible when
+running the @code{archive-op} on any implementation other than SBCL.
+
+Starting with ASDF 3,
+components may therefore have an @code{:if-feature} option.
+The value of this option should be
+a feature expression using the same syntax as @code{#+} does.
+If that feature expression evaluates to false, any reference to the component will be ignored
+during compilation, loading and/or linking.
+Since the expression is read by the normal reader,
+you must explicitly prefix your symbols with @code{:} so they be read as keywords;
+this is as contrasted with the @code{#+} syntax
+that implicitly reads symbols in the keyword package by default.
+
+For instance, @code{:if-feature (:and :x86 (:or :sbcl :cmu :scl))} specifies that
+the given component is only to be compiled and loaded
+when the implementation is SBCL, CMUCL or Scieneer CL on an x86 machine.
+You cannot write it as @code{:if-feature (and x86 (or sbcl cmu scl))}
+since the symbols would not be read as keywords.
+
+@xref{if-feature-option}.
+
+@subsubsection Dependencies
+
+This attribute specifies dependencies of the component on its siblings.
+It is optional but often necessary.
+
+There is an excitingly complicated relationship between the initarg
+and the method that you use to ask about dependencies
+
+Dependencies are between (operation component) pairs.
+In your initargs for the component, you can say
+
+@lisp
+:in-order-to ((compile-op (load-op "a" "b") (compile-op "c"))
+ (load-op (load-op "foo")))
+@end lisp
+
+This means the following things:
+@itemize
+@item
+before performing compile-op on this component, we must perform
+load-op on @var{a} and @var{b}, and compile-op on @var{c},
+@item
+before performing @code{load-op}, we have to load @var{foo}
+@end itemize
+
+The syntax is approximately
+
+@verbatim
+(this-op @{(other-op required-components)@}+)
+
+simple-component-name := string
+ | symbol
+
+required-components := simple-component-name
+ | (required-components required-components)
+
+component-name := simple-component-name
+ | (:version simple-component-name minimum-version-object)
+@end verbatim
+
+Side note:
+
+This is on a par with what ACL defsystem does.
+mk-defsystem is less general: it has an implied dependency
+
+@verbatim
+ for all source file x, (load x) depends on (compile x)
+@end verbatim
+
+and using a @code{:depends-on} argument to say that @var{b} depends on
+@var{a} @emph{actually} means that
+
+@verbatim
+ (compile b) depends on (load a)
+@end verbatim
+
+This is insufficient for e.g. the McCLIM system, which requires that
+all the files are loaded before any of them can be compiled ]
+
+End side note
+
+In ASDF, the dependency information for a given component and operation
+can be queried using @code{(component-depends-on operation component)},
+which returns a list
+
+@lisp
+((load-op "a") (load-op "b") (compile-op "c") ...)
@end lisp
@code{component-depends-on} can be subclassed for more specific
-component/operation types: these need to @code{(call-next-method)} and
-append the answer to their dependency, unless they have a good reason
-for completely overriding the default dependencies
+component/operation types: these need to @code{(call-next-method)}
+and append the answer to their dependency, unless
+they have a good reason for completely overriding the default dependencies.
+
+If it weren't for CLISP, we'd be using @code{LIST} method
+combination to do this transparently.
+But, we need to support CLISP.
+If you have the time for some CLISP hacking,
+I'm sure they'd welcome your fixes.
+@c Doesn't CLISP now support LIST method combination?
+
+A minimal version can be specified for a component you depend on
+(typically another system), by specifying @code{(:version "other-system" "1.2.3")}
+instead of simply @code{"other-system"} as the dependency.
+See the discussion of the semantics of @code{:version}
+in the defsystem grammar.
+
+@c FIXME: Should have cross-reference to "Version specifiers" in the
+@c defsystem grammar, but the cross-referencing is so broken by
+@c insufficient node breakdown that I have not put one in.
+
+
+@subsubsection pathname
+
+This attribute is optional and if absent (which is the usual case),
+the component name will be used.
+
+@xref{The defsystem grammar,,Pathname specifiers},
+for an explanation of how this attribute is interpreted.
+
+Note that the @code{defsystem} macro (used to create a ``top-level'' system)
+does additional processing to set the filesystem location of
+the top component in that system.
+This is detailed elsewhere. @xref{Defining systems with defsystem}.
+
+
+@subsubsection properties
+
+This attribute is optional.
+
+Packaging systems often require information about files or systems
+in addition to that specified by ASDF's pre-defined component attributes.
+Programs that create vendor packages out of ASDF systems therefore
+have to create ``placeholder'' information to satisfy these systems.
+Sometimes the creator of an ASDF system may know the additional
+information and wish to provide it directly.
+
+@code{(component-property component property-name)} and
+associated @code{setf} method will allow
+the programmatic update of this information.
+Property names are compared as if by @code{EQL},
+so use symbols or keywords or something.
+
+@menu
+* Pre-defined subclasses of component::
+* Creating new component types::
+@end menu
+
+@node Pre-defined subclasses of component, Creating new component types, Common attributes of components, Components
+@comment node-name, next, previous, up
+@subsection Pre-defined subclasses of component
+
+@deffn Component source-file
+
+A source file is any file that the system does not know how to
+generate from other components of the system.
+
+Note that this is not necessarily the same thing as
+``a file containing data that is typically fed to a compiler''.
+If a file is generated by some pre-processor stage
+(e.g. a @file{.h} file from @file{.h.in} by autoconf)
+then it is not, by this definition, a source file.
+Conversely, we might have a graphic file
+that cannot be automatically regenerated,
+or a proprietary shared library that we received as a binary:
+these do count as source files for our purposes.
+
+Subclasses of source-file exist for various languages.
+@emph{FIXME: describe these.}
+@end deffn
+
+@deffn Component module
+
+A module is a collection of sub-components.
+
+A module component has the following extra initargs:
+
+@itemize
+@item
+@code{:components} the components contained in this module
+
+@item
+@code{:default-component-class}
+All children components which don't specify their class explicitly
+are inferred to be of this type.
+
+@item
+@code{:if-component-dep-fails}
+This attribute was removed in ASDF 3. Do not use it.
+Use @code{:if-feature} instead (@pxref{required-features}, and @pxref{if-feature-option}).
+
+@item
+@code{:serial} When this attribute is set,
+each subcomponent of this component is assumed to depend on all subcomponents
+before it in the list given to @code{:components}, i.e.
+all of them are loaded before a compile or load operation is performed on it.
+
+@end itemize
+
+The default operation knows how to traverse a module, so
+most operations will not need to provide methods specialised on modules.
+
+@code{module} may be subclassed to represent components such as
+foreign-language linked libraries or archive files.
+@end deffn
+
+@deffn Component system
+
+@code{system} is a subclass of @code{module}.
+
+A system is a module with a few extra attributes for documentation
+purposes; these are given elsewhere.
+@xref{The defsystem grammar}.
+
+Users can create new classes for their systems:
+the default @code{defsystem} macro takes a @code{:class} keyword argument.
+@end deffn
+
+@node Creating new component types, , Pre-defined subclasses of component, Components
+@comment node-name, next, previous, up
+@subsection Creating new component types
+
+New component types are defined by subclassing one of the existing
+component classes and specializing methods on the new component class.
+
+@emph{FIXME: this should perhaps be explained more throughly,
+not only by example ...}
+
+As an example, suppose we have some implementation-dependent
+functionality that we want to isolate
+in one subdirectory per Lisp implementation our system supports.
+We create a subclass of
+@code{cl-source-file}:
+
+@lisp
+(defclass unportable-cl-source-file (cl-source-file)
+ ())
+@end lisp
+
+Function @code{asdf:implementation-type} (exported since 2.014.14)
+gives us the name of the subdirectory.
+All that's left is to define how to calculate the pathname
+of an @code{unportable-cl-source-file}.
+
+@lisp
+(defmethod component-pathname ((component unportable-cl-source-file))
+ (merge-pathnames*
+ (parse-unix-namestring (format nil "~(~A~)/" (asdf:implementation-type)))
+ (call-next-method)))
+@end lisp
+
+The new component type is used in a @code{defsystem} form in this way:
+
+@lisp
+(defsystem :foo
+ :components
+ ((:file "packages")
+ ...
+ (:unportable-cl-source-file "threads"
+ :depends-on ("packages" ...))
+ ...
+ )
+@end lisp
+
+@node Dependencies, Functions, Components, The object model of ASDF
+@section Dependencies
+@c FIXME: Moved this material here, but it isn't very comfortable
+@c here.... Also needs to be revised to be coherent.
+
+To be successfully buildable, this graph of actions but be acyclic.
+If, as a user, extender or implementer of ASDF, you fail
+to keep the dependency graph without cycles,
+ASDF will fail loudly as it eventually finds one.
+To clearly distinguish the direction of dependencies,
+ASDF 3 uses the words @emph{requiring} and @emph{required}
+as applied to an action depending on the other:
+the requiring action @code{depends-on} the completion of all required actions
+before it may itself be @code{perform}ed.
+
+Using the @code{defsystem} syntax, users may easily express
+direct dependencies along the graph of the object hierarchy:
+between a component and its parent, its children, and its siblings.
+By defining custom CLOS methods, you can express more elaborate dependencies as you wish.
+Most common operations, such as @code{load-op}, @code{compile-op} or @code{load-source-op}
+are automatically propagate ``downward'' the component hierarchy and are ``covariant'' with it:
+to act the operation on the parent module, you must first act it on all the children components,
+with the action on the parent being parent of the action on each child.
+Other operations, such as @code{prepare-op} and @code{prepare-source-op}
+(introduced in ASDF 3) are automatically propagated ``upward'' the component hierarchy
+and are ``contravariant'' with it:
+to perform the operation of preparing for compilation of a child component,
+you must perform the operation of preparing for compilation of its parent component, and so on,
+ensuring that all the parent's dependencies are (compiled and) loaded
+before the child component may be compiled and loaded.
+Yet other operations, such as @code{test-op} or @code{load-bundle-op}
+remain at the system level, and are not propagated along the hierarchy,
+but instead do something global on the system.
+
+
+@node Functions, , Dependencies, The object model of ASDF
+@comment node-name, next, previous, up
+@section Functions
+
+@c FIXME: this does not belong here....
+@defun version-satisfies @var{version} @var{version-spec}
+Does @var{version} satisfy the @var{version-spec}. A generic function.
+ASDF provides built-in methods for @var{version} being a @code{component} or @code{string}.
+@var{version-spec} should be a string.
+If it's a component, its version is extracted as a string before further processing.
+
+A version string satisfies the version-spec if after parsing,
+the former is no older than the latter.
+Therefore @code{"1.9.1"}, @code{"1.9.2"} and @code{"1.10"} all satisfy @code{"1.9.1"},
+but @code{"1.8.4"} or @code{"1.9"} do not.
+For more information about how @code{version-satisfies} parses and interprets
+version strings and specifications,
+@pxref{The defsystem grammar} (version specifiers) and
+@ref{Common attributes of components}.
+
+Note that in versions of ASDF prior to 3.0.1,
+including the entire ASDF 1 and ASDF 2 series,
+@code{version-satisfies} would also require that the version and the version-spec
+have the same major version number (the first integer in the list);
+if the major version differed, the version would be considered as not matching the spec.
+But that feature was not documented, therefore presumably not relied upon,
+whereas it was a nuisance to several users.
+Starting with ASDF 3.0.1,
+@code{version-satisfies} does not treat the major version number specially,
+and returns T simply if the first argument designates a version that isn't older
+than the one specified as a second argument.
+If needs be, the @code{(:version ...)} syntax for specifying dependencies
+could be in the future extended to specify an exclusive upper bound for compatible versions
+as well as an inclusive lower bound.
+@end defun
+
+@node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top
+@comment node-name, next, previous, up
+@chapter Controlling where ASDF searches for systems
+
+
+
+@menu
+* Configurations::
+* Truenames and other dangers::
+* XDG base directory::
+* Backward Compatibility::
+* Configuration DSL::
+* Configuration Directories::
+* Shell-friendly syntax for configuration::
+* Search Algorithm::
+* Caching Results::
+* Configuration API::
+* Introspection::
+* Status::
+* Rejected ideas::
+* TODO::
+* Credits for the source-registry::
+@end menu
+
+@node Configurations, Truenames and other dangers, Controlling where ASDF searches for systems, Controlling where ASDF searches for systems
+@section Configurations
+
+Configurations specify paths where to find system files.
+
+@enumerate
+
+@item
+The search registry may use some hardcoded wrapping registry specification.
+This allows some implementations (notably SBCL) to specify where to find
+some special implementation-provided systems that
+need to precisely match the version of the implementation itself.
+
+@item
+An application may explicitly initialize the source-registry configuration
+using the configuration API
+(@pxref{Controlling where ASDF searches for systems,Configuration API,Configuration API}, below)
+in which case this takes precedence.
+It may itself compute this configuration from the command-line,
+from a script, from its own configuration file, etc.
+
+@item
+The source registry will be configured from
+the environment variable @code{CL_SOURCE_REGISTRY} if it exists.
+
+@item
+The source registry will be configured from
+user configuration file
+@file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf}
+(which defaults to
+@file{~/.config/common-lisp/source-registry.conf})
+if it exists.
+
+@item
+The source registry will be configured from
+user configuration directory
+@file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/}
+(which defaults to
+@file{~/.config/common-lisp/source-registry.conf.d/})
+if it exists.
+
+@item
+The source registry will be configured from
+default user configuration trees
+@file{~/common-lisp/} (since ASDF 3.1.1 only),
+@file{~/.sbcl/systems/} (on SBCL only),
+@file{$XDG_DATA_HOME/common-lisp/systems/} (no recursion, link farm)
+@file{$XDG_DATA_HOME/common-lisp/source/}.
+The @code{XDG_DATA_HOME} directory defaults to @file{~/.local/share/}.
+On Windows, the @code{local-appdata} and @code{appdata} directories are used instead.
+
+@item
+The source registry will be configured from
+system configuration file
+@file{/etc/common-lisp/source-registry.conf}
+if it exists.
+
+@item
+The source registry will be configured from
+system configuration directory
+@file{/etc/common-lisp/source-registry.conf.d/}
+if it exists.
+
+@item
+The source registry will be configured from a default configuration.
+This configuration may allow for implementation-specific systems
+to be found, for systems to be found the current directory
+(at the time that the configuration is initialized) as well as
+@code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and
+@code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/},
+where @code{XDG_DATA_DIRS} defaults to @file{/usr/local/share} and @file{/usr/share} on Unix,
+and the @code{common-appdata} directory on Windows.
+
+@item
+The source registry may include implementation-dependent directories
+that correspond to implementation-provided extensions.
+
+@end enumerate
+
+Each of these configurations is specified as an s-expression
+in a trivial domain-specific language (defined below).
+Additionally, a more shell-friendly syntax is available
+for the environment variable (defined yet below).
+
+Each of these configurations is only used if the previous
+configuration explicitly or implicitly specifies that it
+includes its inherited configuration.
+
+Additionally, some implementation-specific directories
+may be automatically prepended to whatever directories are specified
+in configuration files, no matter if the last one inherits or not.
+
+@node Truenames and other dangers, XDG base directory, Configurations, Controlling where ASDF searches for systems
+@section Truenames and other dangers
+
+One great innovation of the original ASDF was its ability to leverage
+@code{CL:TRUENAME} to locate where your source code was and where to build it,
+allowing for symlink farms as a simple but effective configuration mechanism
+that is easy to control programmatically.
+ASDF 3 still supports this configuration style, and it is enabled by default;
+however we recommend you instead use
+our source-registry configuration mechanism described below,
+because it is easier to setup in a portable way across users and implementations.
+
+Addtionally, some people dislike truename,
+either because it is very slow on their system, or
+because they are using content-addressed storage where the truename of a file
+is related to a digest of its individual contents,
+and not to other files in the same intended project.
+For these people, ASDF 3 allows to eschew the @code{TRUENAME} mechanism,
+by setting the variable @var{asdf:*resolve-symlinks*} to @code{nil}.
+
+PS: Yes, if you haven't read Vernor Vinge's short but great classic
+``True Names... and Other Dangers'' then you're in for a treat.
+
+@node XDG base directory, Backward Compatibility, Truenames and other dangers, Controlling where ASDF searches for systems
+@section XDG base directory
+
+Note that we purport to respect the XDG base directory specification
+as to where configuration files are located,
+where data files are located,
+where output file caches are located.
+Mentions of XDG variables refer to that document.
+
+@url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
+
+This specification allows the user to specify some environment variables
+to customize how applications behave to his preferences.
+
+On Windows platforms, when not using Cygwin,
+instead of the XDG base directory specification,
+we try to use folder configuration from the registry regarding
+@code{Common AppData} and similar directories.
+Since support for querying the Windows registry
+is not possible to do in reasonable amounts of portable Common Lisp code,
+ASDF 3 relies on the environment variables that Windows usually exports.
+
+@node Backward Compatibility, Configuration DSL, XDG base directory, Controlling where ASDF searches for systems
+@section Backward Compatibility
+
+For backward compatibility as well as to provide a practical backdoor for hackers,
+ASDF will first search for @file{.asd} files in the directories specified in
+@code{asdf:*central-registry*}
+before it searches in the source registry above.
+
+@xref{Configuring ASDF,,Configuring ASDF to find your systems --- old style}.
+
+By default, @code{asdf:*central-registry*} will be empty.
+
+This old mechanism will therefore not affect you if you don't use it,
+but will take precedence over the new mechanism if you do use it.
+
+@node Configuration DSL, Configuration Directories, Backward Compatibility, Controlling where ASDF searches for systems
+@section Configuration DSL
+@cindex :inherit-configuration source config directive
+@cindex inherit-configuration source config directive
+@cindex :ignore-invalid-entries source config directive
+@cindex ignore-invalid-entries source config directive
+@cindex :directory source config directive
+@cindex directory source config directive
+@cindex :tree source config directive
+@cindex tree source config directive
+@cindex :exclude source config directive
+@cindex exclude source config directive
+@cindex :also-exclude source config directive
+@cindex also-exclude source config directive
+@cindex :include source config directive
+@cindex include source config directive
+@cindex :default-registry source config directive
+@cindex default-registry source config directive
+
+Here is the grammar of the s-expression (SEXP) DSL for source-registry
+configuration:
+
+@c FIXME: This is too wide for happy compilation into pdf.
+
+@example
+;; A configuration is a single SEXP starting with the keyword
+;; :source-registry followed by a list of directives.
+CONFIGURATION := (:source-registry DIRECTIVE ...)
+
+;; A directive is one of the following:
+DIRECTIVE :=
+ ;; INHERITANCE DIRECTIVE:
+ ;; Your configuration expression MUST contain
+ ;; exactly one of the following:
+ :inherit-configuration |
+ ;; splices inherited configuration (often specified last) or
+ :ignore-inherited-configuration |
+ ;; drop inherited configuration (specified anywhere)
+
+ ;; forward compatibility directive (since ASDF 2.011.4), useful when
+ ;; you want to use new configuration features but have to bootstrap
+ ;; the newer required ASDF from an older release that doesn't
+ ;; support said features:
+ :ignore-invalid-entries |
+
+ ;; add a single directory to be scanned (no recursion)
+ (:directory DIRECTORY-PATHNAME-DESIGNATOR) |
+
+ ;; add a directory hierarchy, recursing but
+ ;; excluding specified patterns
+ (:tree DIRECTORY-PATHNAME-DESIGNATOR) |
+
+ ;; override the defaults for exclusion patterns
+ (:exclude EXCLUSION-PATTERN ...) |
+ ;; augment the defaults for exclusion patterns
+ (:also-exclude EXCLUSION-PATTERN ...) |
+ ;; Note that the scope of a an exclude pattern specification is
+ ;; the rest of the current configuration expression or file.
+
+ ;; splice the parsed contents of another config file
+ (:include REGULAR-FILE-PATHNAME-DESIGNATOR) |
+
+ ;; This directive specifies that some default must be spliced.
+ :default-registry
+
+REGULAR-FILE-PATHNAME-DESIGNATOR
+ := PATHNAME-DESIGNATOR ; interpreted as a file
+DIRECTORY-PATHNAME-DESIGNATOR
+ := PATHNAME-DESIGNATOR ; interpreted as a directory
+
+PATHNAME-DESIGNATOR :=
+ NIL | ;; Special: skip this entry.
+ ABSOLUTE-COMPONENT-DESIGNATOR ;; see pathname DSL
+
+EXCLUSION-PATTERN := a string without wildcards, that will be matched
+ exactly against the name of a any subdirectory in the directory
+ component of a path. e.g. @code{"_darcs"} will match
+ @file{#p"/foo/bar/_darcs/src/bar.asd"}
+@end example
+
+Pathnames are designated using another DSL,
+shared with the output-translations configuration DSL below.
+The DSL is resolved by the function @code{asdf::resolve-location},
+to be documented and exported at some point in the future.
+
+@example
+ABSOLUTE-COMPONENT-DESIGNATOR :=
+ (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
+ STRING |
+ ;; namestring (better be absolute or bust, directory assumed where
+ ;; applicable). In output-translations, directory is assumed and
+ ;; **/*.*.* added if it's last. On MCL, a MacOSX-style POSIX
+ ;; namestring (for MacOS9 style, use #p"..."); Note that none of the
+ ;; above applies to strings used in *central-registry*, which
+ ;; doesn't use this DSL: they are processed as normal namestrings.
+ ;; however, you can compute what you put in the *central-registry*
+ ;; based on the results of say
+ ;; (asdf::resolve-location "/Users/fare/cl/cl-foo/")
+ PATHNAME |
+ ;; pathname (better be an absolute path, or bust)
+ ;; In output-translations, unless followed by relative components,
+ ;; it better have appropriate wildcards, as in **/*.*.*
+ :HOME | ; designates the user-homedir-pathname ~/
+ :USER-CACHE | ; designates the default location for the user cache
+ :HERE |
+ ;; designates the location of the configuration file
+ ;; (or *default-pathname-defaults*, if invoked interactively)
+ :ROOT
+ ;; magic, for output-translations source only: paths that are relative
+ ;; to the root of the source host and device
+
+They keyword :SYSTEM-CACHE is not accepted in ASDF 3.1 and beyond: it
+was a security hazard.
+
+RELATIVE-COMPONENT-DESIGNATOR :=
+ (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
+ STRING |
+ ;; relative directory pathname as interpreted by
+ ;; parse-unix-namestring.
+ ;; In output translations, if last component, **/*.*.* is added
+ PATHNAME | ; pathname; unless last component, directory is assumed.
+ :IMPLEMENTATION |
+ ;; directory based on implementation, e.g. sbcl-1.0.45-linux-x64
+ :IMPLEMENTATION-TYPE |
+ ;; a directory based on lisp-implementation-type only, e.g. sbcl
+ :DEFAULT-DIRECTORY |
+ ;; a relativized version of the default directory
+ :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
+ :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
+ :*.*.* | ;; any file (since ASDF 2.011.4)
+
+The keywords :UID and :USERNAME are no longer supported.
+@end example
+
+For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf},
+which is the default place ASDF looks for this configuration, once contained:
+@example
+(:source-registry
+ (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
+ :inherit-configuration)
+@end example
+
+@node Configuration Directories, Shell-friendly syntax for configuration, Configuration DSL, Controlling where ASDF searches for systems
+@section Configuration Directories
+
+Configuration directories consist in files each containing
+a list of directives without any enclosing @code{(:source-registry ...)} form.
+The files will be sorted by namestring as if by @code{string<} and
+the lists of directives of these files with be concatenated in order.
+An implicit @code{:inherit-configuration} will be included
+at the @emph{end} of the list.
+
+System-wide or per-user Common Lisp software distributions
+such as Debian packages or some future version of @code{clbuild}
+may then include files such as
+@file{/etc/common-lisp/source-registry.conf.d/10-foo.conf} or
+@file{~/.config/common-lisp/source-registry.conf.d/10-foo.conf}
+to easily and modularly register configuration information
+about software being distributed.
+
+The convention is that, for sorting purposes,
+the names of files in such a directory begin with two digits
+that determine the order in which these entries will be read.
+Also, the type of these files must be @file{.conf},
+which not only simplifies the implementation by allowing
+for more portable techniques in finding those files,
+but also makes it trivial to disable a file, by renaming it to a different file type.
+
+Directories may be included by specifying a directory pathname
+or namestring in an @code{:include} directive, e.g.:
+
+@example
+ (:include "/foo/bar/")
+@end example
+
+Hence, to achieve the same effect as
+my example @file{~/.config/common-lisp/source-registry.conf} above,
+I could simply create a file
+@file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf}
+alone in its directory with the following contents:
+@example
+(:tree "/home/fare/cl/")
+@end example
+
+@menu
+* The here directive::
+@end menu
+
+@node The here directive, , Configuration Directories, Configuration Directories
+@subsection The :here directive
+
+The @code{:here} directive is an absolute pathname designator that
+refers to the directory containing the configuration file currently
+being processed.
+
+The @code{:here} directive is intended to simplify the delivery of
+complex CL systems, and for easy configuration of projects shared through
+revision control systems, in accordance with our design principle that
+each participant should be able to provide all and only the information
+available to him or her.
+
+Consider a person X who has set up the source code repository for a
+complex project with a master directory @file{dir/}. Ordinarily, one
+might simply have the user add a directive that would look something
+like this:
+@example
+ (:tree "path/to/dir")
+@end example
+But what if X knows that there are very large subtrees
+under dir that are filled with, e.g., Java source code, image files for
+icons, etc.? All of the asdf system definitions are contained in the
+subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and
+these are the only directories that should be searched.
+
+In this case, X can put into @file{dir/} a file @file{asdf.conf} that
+contains the following:
+@example
+(:source-registry
+ (:tree (:here "src/lisp/"))
+ (:tree (:here "extlib/lisp"))
+ (:directory (:here "outlier/")))
+@end example
+
+Then when someone else (call her Y) checks out a copy of this
+repository, she need only add
+@example
+(:include "/path/to/my/checkout/directory/asdf.conf")
+@end example
+to one of her previously-existing asdf source location configuration
+files, or invoke @code{initialize-source-registry} with a configuration
+form containing that s-expression. ASDF will find the .conf file that X
+has provided, and then set up source locations within the working
+directory according to X's (relative) instructions.
+
+@node Shell-friendly syntax for configuration, Search Algorithm, Configuration Directories, Controlling where ASDF searches for systems
+@section Shell-friendly syntax for configuration
+
+When considering environment variable @code{CL_SOURCE_REGISTRY}
+ASDF will skip to next configuration if it's an empty string.
+It will @code{READ} the string as a SEXP in the DSL
+if it begins with a paren @code{(}
+and it will be interpreted much like @code{TEXINPUTS}
+list of paths, where
+
+ * paths are separated
+ by a @code{:} (colon) on Unix platforms (including cygwin),
+ by a @code{;} (semicolon) on other platforms (mainly, Windows).
+
+ * each entry is a directory to add to the search path.
+
+ * if the entry ends with a double slash @code{//}
+ then it instead indicates a tree in the subdirectories
+ of which to recurse.
+
+ * if the entry is the empty string (which may only appear once),
+ then it indicates that the inherited configuration should be
+ spliced there.
+
+@node Search Algorithm, Caching Results, Shell-friendly syntax for configuration, Controlling where ASDF searches for systems
+@section Search Algorithm
+@vindex *default-source-registry-exclusions*
+
+In case that isn't clear, the semantics of the configuration is that
+when searching for a system of a given name,
+directives are processed in order.
+
+When looking in a directory, if the system is found, the search succeeds,
+otherwise it continues.
+
+When looking in a tree, if one system is found, the search succeeds.
+If multiple systems are found, the consequences are unspecified:
+the search may succeed with any of the found systems,
+or an error may be raised.
+ASDF currently returns the first system found,
+XCVB currently raised an error.
+If none is found, the search continues.
+
+Exclude statements specify patterns of subdirectories
+the systems from which to ignore.
+Typically you don't want to use copies of files kept by such
+version control systems as Darcs.
+Exclude statements are not propagated to further included or inherited
+configuration files or expressions;
+instead the defaults are reset around every configuration statement
+to the default defaults from @code{asdf::*default-source-registry-exclusions*}.
+
+Include statements cause the search to recurse with the path specifications
+from the file specified.
+
+An inherit-configuration statement cause the search to recurse with the path
+specifications from the next configuration
+(@pxref{Controlling where ASDF searches for systems,,Configurations} above).
+
+
+@node Caching Results, Configuration API, Search Algorithm, Controlling where ASDF searches for systems
+@section Caching Results
+
+The implementation is allowed to either eagerly compute the information
+from the configurations and file system, or to lazily re-compute it
+every time, or to cache any part of it as it goes.
+To explicitly flush any information cached by the system, use the API below.
+
+@node Configuration API, Introspection, Caching Results, Controlling where ASDF searches for systems
+@section Configuration API
+
+The specified functions are exported from your build system's package.
+Thus for ASDF the corresponding functions are in package ASDF,
+and for XCVB the corresponding functions are in package XCVB.
+
+@defun initialize-source-registry @Aoptional{} PARAMETER
+ will read the configuration and initialize all internal variables.
+ You may extend or override configuration
+ from the environment and configuration files
+ with the given @var{PARAMETER}, which can be
+ @code{nil} (no configuration override),
+ or a SEXP (in the SEXP DSL),
+ a string (as in the string DSL),
+ a pathname (of a file or directory with configuration),
+ or a symbol (fbound to function that when called returns one of the above).
+@end defun
+
+@defun clear-source-registry
+ undoes any source registry configuration
+ and clears any cache for the search algorithm.
+ You might want to call this function
+ (or better, @code{clear-configuration})
+ before you dump an image that would be resumed
+ with a different configuration,
+ and return an empty configuration.
+ Note that this does not include clearing information about
+ systems defined in the current image, only about
+ where to look for systems not yet defined.
+@end defun
+
+@defun ensure-source-registry @Aoptional{} PARAMETER
+ checks whether a source registry has been initialized.
+ If not, initialize it with the given @var{PARAMETER}.
+@end defun
+
+Every time you use ASDF's @code{find-system}, or
+anything that uses it (such as @code{operate}, @code{load-system}, etc.),
+@code{ensure-source-registry} is called with parameter @code{nil},
+which the first time around causes your configuration to be read.
+If you change a configuration file,
+you need to explicitly @code{initialize-source-registry} again,
+or maybe simply to @code{clear-source-registry} (or @code{clear-configuration})
+which will cause the initialization to happen next time around.
+
+@node Introspection, Status, Configuration API, Controlling where ASDF searches for systems
+@section Introspection
+
+@menu
+* *source-registry-parameter* variable::
+* Information about system dependencies::
+@end menu
+
+@node *source-registry-parameter* variable, Information about system dependencies, Introspection, Introspection
+@subsection *source-registry-parameter* variable
+@vindex *source-registry-parameter*
+
+We have made available the variable @code{*source-registry-parameter*}
+that can be used by code that wishes to introspect about the (past)
+configuration of ASDF's source registry. @strong{This variable should
+never be set!} It will be set as a side-effect of calling
+@code{initialize-source-registry}; user code should treat it as
+read-only.
+
+@node Information about system dependencies, , *source-registry-parameter* variable, Introspection
+@subsection Information about system dependencies
+
+ASDF makes available three functions to read system interdependencies.
+These are intended to aid programmers who wish to perform dependency
+analyses.
+
+@defun system-defsystem-depends-on system
+@end defun
+
+@defun system-depends-on system
+@end defun
+
+@defun system-weakly-depends-on system
+Returns a list of names of systems that are weakly depended on by
+@var{system}. Weakly depended on systems are optionally loaded only if
+ASDF can find them; failure to find such systems does @emph{not} cause an
+error in loading.
+
+Note that the return value for @code{system-weakly-depends-on} is simpler
+than the return values of the other two system dependency introspection
+functions.
+@end defun
+
+@node Status, Rejected ideas, Introspection, Controlling where ASDF searches for systems
+@section Status
+
+This mechanism is vastly successful, and we have declared
+that @code{asdf:*central-registry*} is not recommended anymore,
+though we will continue to support it.
+All hooks into implementation-specific search mechanisms
+have been integrated in the @code{wrapping-source-registry}
+that everyone uses implicitly.
+
+@node Rejected ideas, TODO, Status, Controlling where ASDF searches for systems
+@section Rejected ideas
+
+Alternatives I (FRR) considered and rejected while developing ASDF 2 included:
+
+@enumerate
+@item Keep @code{asdf:*central-registry*} as the master with its current semantics,
+ and somehow the configuration parser expands the new configuration
+ language into a expanded series of directories of subdirectories to
+ lookup, pre-recursing through specified hierarchies. This is kludgy,
+ and leaves little space of future cleanups and extensions.
+
+@item Keep @code{asdf:*central-registry*} as the master but extend its semantics
+ in completely new ways, so that new kinds of entries may be implemented
+ as a recursive search, etc. This seems somewhat backwards.
+
+@item Completely remove @code{asdf:*central-registry*}
+ and break backwards compatibility.
+ Hopefully this will happen in a few years after everyone migrate to
+ a better ASDF and/or to XCVB, but it would be very bad to do it now.
+
+@item Replace @code{asdf:*central-registry*} by a symbol-macro with appropriate magic
+ when you dereference it or setf it. Only the new variable with new
+ semantics is handled by the new search procedure.
+ Complex and still introduces subtle semantic issues.
+@end enumerate
+
+
+I've been suggested the below features, but have rejected them,
+for the sake of keeping ASDF no more complex than strictly necessary.
+
+@itemize
+@item
+ More syntactic sugar: synonyms for the configuration directives, such as
+ @code{(:add-directory X)} for @code{(:directory X)}, or @code{(:add-directory-hierarchy X)}
+ or @code{(:add-directory X :recurse t)} for @code{(:tree X)}.
+
+@item
+ The possibility to register individual files instead of directories.
+
+@item
+ Integrate Xach Beane's tilde expander into the parser,
+ or something similar that is shell-friendly or shell-compatible.
+ I'd rather keep ASDF minimal. But maybe this precisely keeps it
+ minimal by removing the need for evaluated entries that ASDF has?
+ i.e. uses of @code{USER-HOMEDIR-PATHNAME} and @code{$SBCL_HOME}
+ Hopefully, these are already superseded by the @code{:default-registry}
+
+@item
+ Using the shell-unfriendly syntax @code{/**} instead of @code{//} to specify recursion
+ down a filesystem tree in the environment variable.
+ It isn't that Lisp friendly either.
+@end itemize
+
+@node TODO, Credits for the source-registry, Rejected ideas, Controlling where ASDF searches for systems
+@section TODO
+
+@itemize
+@item Add examples
+@end itemize
+
+@node Credits for the source-registry, , TODO, Controlling where ASDF searches for systems
+@section Credits for the source-registry
+
+Thanks a lot to Stelian Ionescu for the initial idea.
+
+Thanks to Rommel Martinez for the initial implementation attempt.
+
+All bad design ideas and implementation bugs are mine, not theirs.
+But so are good design ideas and elegant implementation tricks.
+
+ --- Francois-Rene Rideau @email{fare@@tunes.org}, Mon, 22 Feb 2010 00:07:33 -0500
+
+
+
+@node Controlling where ASDF saves compiled files, Error handling, Controlling where ASDF searches for systems, Top
+@comment node-name, next, previous, up
+@chapter Controlling where ASDF saves compiled files
+@cindex asdf-output-translations
+@vindex ASDF_OUTPUT_TRANSLATIONS
+
+Each Common Lisp implementation has its own format
+for compiled files or fasls.@footnote{``FASL'' is short for ``FASt Loading.''}
+If you use multiple implementations
+(or multiple versions of the same implementation),
+you'll soon find your source directories
+littered with various @file{fasl}s, @file{dfsl}s, @file{cfsl}s and so
+on.
+Worse yet, multiple implementations use the same file extension and
+some implementations maintain the same file extension
+while changing formats from version to version (or platform to
+platform).
+This can lead to many errors and much confusion
+as you switch from one implementation to the next.
+
+Since ASDF 2, ASDF includes the @code{asdf-output-translations} facility
+to mitigate the problem.
+
+@menu
+* Output Configurations::
+* Output Backward Compatibility::
+* Output Configuration DSL::
+* Output Configuration Directories::
+* Output Shell-friendly syntax for configuration::
+* Semantics of Output Translations::
+* Output Caching Results::
+* Output location API::
+* Credits for output translations::
+@end menu
+
+@node Output Configurations, Output Backward Compatibility, Controlling where ASDF saves compiled files, Controlling where ASDF saves compiled files
+@section Configurations
+
+@c FIXME: Explain how configurations work: can't expect reader will have
+@c looked at previous chapter. Probably cut and paste will do.
+
+
+Configurations specify mappings from input locations to output locations.
+Once again we rely on the XDG base directory specification for configuration.
+@xref{Controlling where ASDF searches for systems,,XDG base directory}.
+
+@enumerate
+
+@item
+Some hardcoded wrapping output translations configuration may be used.
+This allows special output translations (or usually, invariant directories)
+to be specified corresponding to the similar special entries in the source registry.
-(If it weren't for CLISP, we'd be using a @code{LIST} method
-combination to do this transparently. But, we need to support CLISP.
-If you have the time for some CLISP hacking, I'm sure they'd welcome
-your fixes)
+@item
+An application may explicitly initialize the output-translations
+configuration using the Configuration API
+in which case this takes precedence.
+(@pxref{Controlling where ASDF saves compiled files,,Configuration API}.)
+It may itself compute this configuration from the command-line,
+from a script, from its own configuration file, etc.
-@subsubsection pathname
+@item
+The source registry will be configured from
+the environment variable @code{ASDF_OUTPUT_TRANSLATIONS} if it exists.
-This attribute is optional and if absent will be inferred from the
-component's name, type (the subclass of source-file), and the location
-of its parent.
+@item
+The source registry will be configured from
+user configuration file
+@file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf}
+(which defaults to
+@file{~/.config/common-lisp/asdf-output-translations.conf})
+if it exists.
-The rules for this inference are:
+@item
+The source registry will be configured from
+user configuration directory
+@file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf.d/}
+(which defaults to
+@file{~/.config/common-lisp/asdf-output-translations.conf.d/})
+if it exists.
-(for source-files)
-@itemize
-@item the host is taken from the parent
-@item pathname type is @code{(source-file-type component system)}
-@item the pathname case option is @code{:local}
-@item the pathname is merged against the parent
-@end itemize
+@item
+The source registry will be configured from
+system configuration file
+@file{/etc/common-lisp/asdf-output-translations.conf}
+if it exists.
-(for modules)
-@itemize
-@item the host is taken from the parent
-@item the name and type are @code{NIL}
-@item the directory is @code{(:relative component-name)}
-@item the pathname case option is @code{:local}
-@item the pathname is merged against the parent
-@end itemize
+@item
+The source registry will be configured from
+system configuration directory
+@file{/etc/common-lisp/asdf-output-translations.conf.d/}
+if it exists.
-Note that the DEFSYSTEM operator (used to create a ``top-level''
-system) does additional processing to set the filesystem location of
-the top component in that system. This is detailed
-elsewhere, @xref{Defining systems with defsystem}.
+@end enumerate
-The answer to the frequently asked question "how do I create a system
-definition where all the source files have a .cl extension" is thus
+Each of these configurations is specified as a SEXP
+in a trivial domain-specific language (@pxref{Configuration DSL}).
+Additionally, a more shell-friendly syntax is available
+for the environment variable (@pxref{Shell-friendly syntax for configuration}).
+
+When processing an entry in the above list of configuration methods,
+ASDF will stop unless that entry
+explicitly or implicitly specifies that it
+includes its inherited configuration.
+
+Note that by default, a per-user cache is used for output files.
+This allows the seamless use of shared installations of software
+between several users, and takes files out of the way of the developers
+when they browse source code,
+at the expense of taking a small toll when developers have to clean up
+output files and find they need to get familiar with output-translations
+first.@footnote{A @code{CLEAN-OP} would be a partial solution to this problem.}
+
+
+@node Output Backward Compatibility, Output Configuration DSL, Output Configurations, Controlling where ASDF saves compiled files
+@section Backward Compatibility
+@cindex ASDF-BINARY-LOCATIONS compatibility
+@c FIXME: Demote this section -- the typical reader doesn't care about
+@c backwards compatibility.
+
+
+We purposely do @emph{not} provide backward compatibility with earlier versions of
+@code{ASDF-Binary-Locations} (8 Sept 2009),
+@code{common-lisp-controller} (7.0) or
+@code{cl-launch} (2.35),
+each of which had similar general capabilities.
+The APIs of these programs were not designed
+for easy user configuration
+through configuration files.
+Recent versions of @code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000)
+use the new @code{asdf-output-translations} API as defined below.
+@code{ASDF-Binary-Locations} is fully superseded and not to be used anymore.
+
+This incompatibility shouldn't inconvenience many people.
+Indeed, few people use and customize these packages;
+these few people are experts who can trivially adapt to the new configuration.
+Most people are not experts, could not properly configure these features
+(except inasmuch as the default configuration of
+@code{common-lisp-controller} and/or @code{cl-launch}
+might have been doing the right thing for some users),
+and yet will experience software that ``just works'',
+as configured by the system distributor, or by default.
+
+Nevertheless, if you are a fan of @code{ASDF-Binary-Locations},
+we provide a limited emulation mode:
+
+@defun enable-asdf-binary-locations-compatibility @Akey{} centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
+This function will initialize the new @code{asdf-output-translations} facility in a way
+that emulates the behavior of the old @code{ASDF-Binary-Locations} facility.
+Where you would previously set global variables
+@var{*centralize-lisp-binaries*},
+@var{*default-toplevel-directory*},
+@var{*include-per-user-information*},
+@var{*map-all-source-files*} or @var{*source-to-target-mappings*}
+you will now have to pass the same values as keyword arguments to this function.
+Note however that as an extension the @code{:source-to-target-mappings} keyword argument
+will accept any valid pathname designator for @code{asdf-output-translations}
+instead of just strings and pathnames.
+@end defun
-@lisp
-(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys))))
- "cl")
-@end lisp
+If you insist, you can also keep using the old @code{ASDF-Binary-Locations}
+(the one available as an extension to load of top of ASDF,
+not the one built into a few old versions of ASDF),
+but first you must disable @code{asdf-output-translations}
+with @code{(asdf:disable-output-translations)},
+or you might experience ``interesting'' issues.
-@subsubsection properties
+Also, note that output translation is enabled by default.
+To disable it, use @code{(asdf:disable-output-translations)}.
-This attribute is optional.
+@node Output Configuration DSL, Output Configuration Directories, Output Backward Compatibility, Controlling where ASDF saves compiled files
+@section Configuration DSL
-Packaging systems often require information about files or systems in
-addition to that specified by asdf's pre-defined component attributes.
-Programs that create vendor packages out of asdf systems therefore
-have to create ``placeholder'' information to satisfy these systems.
-Sometimes the creator of an asdf system may know the additional
-information and wish to provide it directly.
+Here is the grammar of the SEXP DSL
+for @code{asdf-output-translations} configuration:
-(component-property component property-name) and associated setf
-method will allow the programmatic update of this information.
-Property names are compared as if by @code{EQL}, so use symbols or
-keywords or something.
+@verbatim
+;; A configuration is single SEXP starting with keyword :source-registry
+;; followed by a list of directives.
+CONFIGURATION := (:output-translations DIRECTIVE ...)
+
+;; A directive is one of the following:
+DIRECTIVE :=
+ ;; INHERITANCE DIRECTIVE:
+ ;; Your configuration expression MUST contain
+ ;; exactly one of either of these:
+ :inherit-configuration |
+ ;; splices inherited configuration (often specified last)
+ :ignore-inherited-configuration |
+ ;; drop inherited configuration (specified anywhere)
+
+ ;; forward compatibility directive (since ASDF 2.011.4), useful when
+ ;; you want to use new configuration features but have to bootstrap a
+ ;; the newer required ASDF from an older release that doesn't have
+ ;; said features:
+ :ignore-invalid-entries |
+
+ ;; include a configuration file or directory
+ (:include PATHNAME-DESIGNATOR) |
+
+ ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/
+ ;; or something.
+ :enable-user-cache |
+ ;; Disable global cache. Map / to /
+ :disable-cache |
+
+ ;; add a single directory to be scanned (no recursion)
+ (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR)
+
+ ;; use a function to return the translation of a directory designator
+ (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION))
+
+DIRECTORY-DESIGNATOR :=
+ NIL | ; As source: skip this entry. As destination: same as source
+ T | ; as source matches anything, as destination
+ ; maps pathname to itself.
+ ABSOLUTE-COMPONENT-DESIGNATOR ; same as in the source-registry language
+
+TRANSLATION-FUNCTION :=
+ SYMBOL | ;; symbol naming a function that takes two arguments:
+ ;; the pathname to be translated and the matching
+ ;; DIRECTORY-DESIGNATOR
+ LAMBDA ;; A form which evalutates to a function taking two arguments:
+ ;; the pathname to be translated and the matching
+ ;; DIRECTORY-DESIGNATOR
-@menu
-* Pre-defined subclasses of component::
-* Creating new component types::
-@end menu
+@end verbatim
-@node Pre-defined subclasses of component, Creating new component types, Common attributes of components, Components
-@comment node-name, next, previous, up
-@subsection Pre-defined subclasses of component
+Relative components better be either relative
+or subdirectories of the path before them, or bust.
+
+@c FIXME: the following assumes that the reader is familiar with the use
+@c of this pattern in logical pathnames, which may not be a reasonable
+@c assumption. Expand.
+The last component, if not a pathname, is notionally completed by @file{/**/*.*}.
+You can specify more fine-grained patterns
+by using a pathname object as the last component
+e.g. @file{#p"some/path/**/foo*/bar-*.fasl"}
+
+You may use @code{#+features} to customize the configuration file.
+
+The second designator of a mapping may be @code{nil}, indicating that files are not mapped
+to anything but themselves (same as if the second designator was the same as the first).
+
+When the first designator is @code{t},
+the mapping always matches.
+When the first designator starts with @code{:root},
+the mapping matches any host and device.
+In either of these cases, if the second designator
+isn't @code{t} and doesn't start with @code{:root},
+then strings indicating the host and pathname are somehow copied
+in the beginning of the directory component of the source pathname
+before it is translated.
+
+When the second designator is @code{t}, the mapping is the identity.
+When the second designator starts with @code{:root},
+the mapping preserves the host and device of the original pathname.
+Notably, this allows you to map files
+to a subdirectory of the whichever directory the file is in.
+Though the syntax is not quite as easy to use as we'd like,
+you can have an (source destination) mapping entry such as follows
+in your configuration file,
+or you may use @code{enable-asdf-binary-locations-compatibility}
+with @code{:centralize-lisp-binaries nil}
+which will do the same thing internally for you:
+@lisp
+#.(let ((wild-subdir
+ (make-pathname :directory '(:relative :wild-inferiors)))
+ (wild-file
+ (make-pathname :name :wild :version :wild :type :wild)))
+ `((:root ,wild-subdir ,wild-file)
+ (:root ,wild-subdir :implementation ,wild-file)))
+@end lisp
+Starting with ASDF 2.011.4, you can use the simpler:
+ @code{`(:root (:root :**/ :implementation :*.*.*))}
-@deffn Component source-file
-A source file is any file that the system does not know how to
-generate from other components of the system.
-
-Note that this is not necessarily the same thing as ``a file
-containing data that is typically fed to a compiler''. If a file is
-generated by some pre-processor stage (e.g. a @file{.h} file from
-@file{.h.in} by autoconf) then it is not, by this definition, a source
-file. Conversely, we might have a graphic file that cannot be
-automatically regenerated, or a proprietary shared library that we
-received as a binary: these do count as source files for our purposes.
-
-Subclasses of source-file exist for various languages. @emph{FIXME:
-describe these.}
-@end deffn
-@deffn Component module
+@code{:include} statements cause the search to recurse with the path specifications
+from the file specified.
-A module is a collection of sub-components.
+If the @code{translate-pathname} mechanism cannot achieve a desired
+translation, the user may provide a function which provides the
+required algorithim. Such a translation function is specified by
+supplying a list as the second @code{directory-designator}
+the first element of which is the keyword @code{:function},
+and the second element of which is
+either a symbol which designates a function or a lambda expression.
+The function designated by the second argument must take two arguments,
+the first being the pathname of the source file,
+the second being the wildcard that was matched.
+When invoked, the function should return the translated pathname.
-A module component has the following extra initargs:
+An @code{:inherit-configuration} statement causes the search to recurse with the path
+specifications from the next configuration in the bulleted list.
+@xref{Controlling where ASDF saves compiled files,,Configurations}, above.
+@vindex @code{asdf::*user-cache*}
@itemize
@item
-@code{:components} the components contained in this module
-
+@code{:enable-user-cache} is the same as @code{(t :user-cache)}.
@item
-@code{:default-component-class} All child components which don't
-specify their class explicitly are inferred to be of this type.
-
+@code{:disable-cache} is the same as @code{(t t)}.
@item
-@code{:if-component-dep-fails} This attribute takes one of the values
-@code{:fail}, @code{:try-next}, @code{:ignore}, its default value is
-@code{:fail}. The other values can be used for implementing
-conditional compilation based on implementation @code{*features*}, for
-the case where it is not necessary for all files in a module to be
-compiled.
+@code{:user-cache} uses the contents of variable @code{asdf::*user-cache*}
+which by default is the same as using
+@code{(:home ".cache" "common-lisp" :implementation)}.
+@end itemize
-@item
-@code{:serial} When this attribute is set, each subcomponent of this
-component is assumed to depend on all subcomponents before it in the
-list given to @code{:components}, i.e. all of them are loaded before
-a compile or load operation is performed on it.
-@end itemize
+@node Output Configuration Directories, Output Shell-friendly syntax for configuration, Output Configuration DSL, Controlling where ASDF saves compiled files
+@section Configuration Directories
+
+Configuration directories consist of files, each of which contains
+a list of directives without any enclosing
+@code{(:output-translations ...)} form.
+The files will be sorted by namestring as if by @code{string<} and
+the lists of directives of these files with be concatenated in order.
+An implicit @code{:inherit-configuration} will be included
+at the @emph{end} of the list.
+
+System-wide or per-user Common Lisp software distributions
+such as Debian packages or some future version of @code{clbuild}
+may then include files such as
+@file{/etc/common-lisp/asdf-output-translations.conf.d/10-foo.conf} or
+@file{~/.config/common-lisp/asdf-output-translations.conf.d/10-foo.conf}
+to easily and modularly register configuration information
+about software being distributed.
+
+The convention is that, for sorting purposes,
+the names of files in such a directory begin with two digits
+that determine the order in which these entries will be read.
+Also, the type of these files must be @file{.conf},
+which not only simplifies the implementation by allowing
+for more portable techniques in finding those files,
+but also makes it trivial to disable a file, by renaming it to a different file type.
+
+Directories may be included by specifying a directory pathname
+or namestring in an @code{:include} directive, e.g.:
-The default operation knows how to traverse a module, so most
-operations will not need to provide methods specialised on modules.
+@verbatim
+ (:include "/foo/bar/")
+@end verbatim
-@code{module} may be subclassed to represent components such as
-foreign-language linked libraries or archive files.
-@end deffn
+@node Output Shell-friendly syntax for configuration, Semantics of Output Translations, Output Configuration Directories, Controlling where ASDF saves compiled files
+@section Shell-friendly syntax for configuration
+
+When considering environment variable @code{ASDF_OUTPUT_TRANSLATIONS}
+ASDF will skip to the next configuration if it's an empty string.
+It will @code{READ} the string as an SEXP in the DSL
+if it begins with a paren @code{(}
+and it will be interpreted as a list of directories.
+Directories should come by pairs, indicating a mapping directive.
+Entries are separated
+by a @code{:} (colon) on Unix platforms (including cygwin),
+by a @code{;} (semicolon) on other platforms (mainly, Windows).
+
+The magic empty entry,
+if it comes in what would otherwise be the first entry in a pair,
+indicates the splicing of inherited configuration.
+If it comes as the second entry in a pair,
+it indicates that the directory specified first is to be left untranslated
+(which has the same effect as if the directory had been repeated).
+Thus @code{"/foo:/bar::/baz:"} means that
+things under directory @file{/foo/}
+are translated to be under @file{/bar/},
+then include the inherited configuration,
+then specify that things under directory @file{/baz/} are not translated.
+
+@node Semantics of Output Translations, Output Caching Results, Output Shell-friendly syntax for configuration, Controlling where ASDF saves compiled files
+@section Semantics of Output Translations
+
+From the specified configuration,
+a list of mappings is extracted in a straightforward way:
+mappings are collected in order, recursing through
+included or inherited configuration as specified.
+To this list is prepended some implementation-specific mappings,
+and is appended a global default.
+
+The list is then compiled to a mapping table as follows:
+for each entry, in order, resolve the first designated directory
+into an actual directory pathname for source locations.
+If no mapping was specified yet for that location,
+resolve the second designated directory to an output location directory
+add a mapping to the table mapping the source location to the output location,
+and add another mapping from the output location to itself
+(unless a mapping already exists for the output location).
+
+Based on the table, a mapping function is defined,
+mapping source pathnames to output pathnames:
+given a source pathname, locate the longest matching prefix
+in the source column of the mapping table.
+Replace that prefix by the corresponding output column
+in the same row of the table, and return the result.
+If no match is found, return the source pathname.
+(A global default mapping the filesystem root to itself
+may ensure that there will always be a match,
+with same fall-through semantics).
+
+@node Output Caching Results, Output location API, Semantics of Output Translations, Controlling where ASDF saves compiled files
+@section Caching Results
+
+The implementation is allowed to either eagerly compute the information
+from the configurations and file system, or to lazily re-compute it
+every time, or to cache any part of it as it goes.
+To explicitly flush any information cached by the system, use the API below.
+
+
+@node Output location API, Credits for output translations, Output Caching Results, Controlling where ASDF saves compiled files
+@section Output location API
+
+The specified functions are exported from package ASDF.
+
+@defun initialize-output-translations @Aoptional{} PARAMETER
+ will read the configuration and initialize all internal variables.
+ You may extend or override configuration
+ from the environment and configuration files
+ with the given @var{PARAMETER}, which can be
+ @code{nil} (no configuration override),
+ or a SEXP (in the SEXP DSL),
+ a string (as in the string DSL),
+ a pathname (of a file or directory with configuration),
+ or a symbol (fbound to function that when called returns one of the above).
+@end defun
-@deffn Component system
+@defun disable-output-translations
+ will initialize output translations in a way
+ that maps every pathname to itself,
+ effectively disabling the output translation facility.
+@end defun
-@code{system} is a subclass of @code{module}.
+@defun clear-output-translations
+ undoes any output translation configuration
+ and clears any cache for the mapping algorithm.
+ You might want to call this function
+ (or better, @code{clear-configuration})
+ before you dump an image that would be resumed
+ with a different configuration,
+ and return an empty configuration.
+ Note that this does not include clearing information about
+ systems defined in the current image, only about
+ where to look for systems not yet defined.
+@end defun
-A system is a module with a few extra attributes for documentation
-purposes; these are given elsewhere. @xref{The defsystem grammar}.
+@defun ensure-output-translations @Aoptional{} PARAMETER
+ checks whether output translations have been initialized.
+ If not, initialize them with the given @var{PARAMETER}.
+ This function will be called before any attempt to operate on a system.
+@end defun
-Users can create new classes for their systems: the default
-@code{defsystem} macro takes a @code{:classs} keyword
-argument.
-@end deffn
+@defun apply-output-translations PATHNAME
+ Applies the configured output location translations to @var{PATHNAME}
+ (calls @code{ensure-output-translations} for the translations).
+@end defun
-@node Creating new component types, , Pre-defined subclasses of component, Components
-@comment node-name, next, previous, up
-@subsection Creating new component types
+Every time you use ASDF's @code{output-files}, or
+anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.),
+@code{ensure-output-translations} is called with parameter @code{nil},
+which the first time around causes your configuration to be read.
+If you change a configuration file,
+you need to explicitly @code{initialize-output-translations} again,
+or maybe @code{clear-output-translations} (or @code{clear-configuration}),
+which will cause the initialization to happen next time around.
-New component types are defined by subclassing one of the existing
-component classes and specializing methods on the new component class.
-@emph{FIXME: this should perhaps be explained more throughly, not only by
-example ...}
+@node Credits for output translations, , Output location API, Controlling where ASDF saves compiled files
+@section Credits for output translations
-As an example, suppose we have some implementation-dependent
-functionality that we want to isolate in one subdirectory per Lisp
-implementation our system supports. We create a subclass of
-@code{cl-source-file}:
+Thanks a lot to Peter van Eynde for @code{Common Lisp Controller}
+and to Bjorn Lindberg and Gary King for @code{ASDF-Binary-Locations}.
-@lisp
-(defclass unportable-cl-source-file (cl-source-file)
- ())
-@end lisp
+All bad design ideas and implementation bugs are to mine, not theirs.
+But so are good design ideas and elegant implementation tricks.
-A hypothetical function @code{system-dependent-dirname} gives us the
-name of the subdirectory. All that's left is to define how to
-calculate the pathname of an @code{unportable-cl-source-file}.
+ --- Francois-Rene Rideau @email{fare@@tunes.org}
-@lisp
-(defmethod component-pathname ((component unportable-cl-source-file))
- (let ((pathname (call-next-method))
- (name (string-downcase (system-dependent-dirname))))
- (merge-pathnames
- (make-pathname :directory (list :relative name))
- pathname)))
-@end lisp
+@c @section Default locations
+@c @findex output-files-for-system-and-operation
-The new component type is used in a @code{defsystem} form in this way:
+@c The default binary location for each Lisp implementation
+@c is a subdirectory of each source directory.
+@c To account for different Lisps, Operating Systems, Implementation versions,
+@c and so on, ASDF borrows code from SLIME
+@c to create reasonable custom directory names.
+@c Here are some examples:
-@lisp
-(defsystem :foo
- :components
- ((:file "packages")
- ...
- (:unportable-cl-source-file "threads"
- :depends-on ("packages" ...))
- ...
- )
-@end lisp
+@c @itemize
+@c @item
+@c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86}
+
+@c @item
+@c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86}
-@node Error handling, Compilation error and warning handling, The object model of asdf, Top
+@c @item
+@c Franz Allegro, version 8.1, Modern (case sensitive) Common Lisp: @code{allegro-8.1m-macosx-x86}
+@c @end itemize
+
+@c By default, all output file pathnames will be relocated
+@c to some thus-named subdirectory of @file{~/.cache/common-lisp/}.
+
+@c See the document @file{README.asdf-output-translations}
+@c for a full specification on how to configure @code{asdf-output-translations}.
+
+@node Error handling, Miscellaneous additional functionality, Controlling where ASDF saves compiled files, Top
@comment node-name, next, previous, up
@chapter Error handling
@findex SYSTEM-DEFINITION-ERROR
@findex OPERATION-ERROR
-It is an error to define a system incorrectly: an implementation may
-detect this and signal a generalised instance of
+@section ASDF errors
+
+If ASDF detects an incorrect system definition, it will signal a generalised instance of
@code{SYSTEM-DEFINITION-ERROR}.
-Operations may go wrong (for example when source files contain
-errors). These are signalled using generalised instances of
+Operations may go wrong (for example when source files contain errors).
+These are signalled using generalised instances of
@code{OPERATION-ERROR}.
-@node Compilation error and warning handling, Getting the latest version, Error handling, Top
-@comment node-name, next, previous, up
-@chapter Compilation error and warning handling
+@section Compilation error and warning handling
@vindex *compile-file-warnings-behaviour*
@vindex *compile-file-errors-behavior*
-ASDF checks for warnings and errors when a file is compiled. The
-variables @code{*compile-file-warnings-behaviour*} and
-@code{*compile-file-errors-behavior*} controls the handling of any
-such events. The valid values for these variables are @code{:error},
-@code{:warn}, and @code{:ignore}.
+ASDF checks for warnings and errors when a file is compiled.
+The variables @var{*compile-file-warnings-behaviour*} and
+@var{*compile-file-errors-behavior*}
+control the handling of any such events.
+The valid values for these variables are
+@code{:error}, @code{:warn}, and @code{:ignore}.
-@node Getting the latest version, TODO list, Compilation error and warning handling, Top
+@node Miscellaneous additional functionality, Getting the latest version, Error handling, Top
@comment node-name, next, previous, up
-@chapter Getting the latest version
+@chapter Miscellaneous additional functionality
-@enumerate
-@item
-Decide which version you want. HEAD is the newest version and
-usually OK, whereas RELEASE is for cautious people (e.g. who already
-have systems using asdf that they don't want broken), a slightly older
-version about which none of the HEAD users have complained.
+ASDF includes several additional features that are generally
+useful for system definition and development.
-@item
-Check it out from sourceforge cCLan CVS:
+@menu
+* Controlling file compilation::
+* Controlling source file character encoding::
+* Some Utility Functions::
+@end menu
-@kbd{cvs -d:pserver:anonymous@@cvs.cclan.sourceforge.net:/cvsroot/cclan login}
+@node Controlling file compilation, Controlling source file character encoding, Miscellaneous additional functionality, Miscellaneous additional functionality
+@section Controlling file compilation
+@cindex :around-compile
+@cindex around-compile keyword
+@cindex compile-check keyword
+@cindex :compile-check
+@findex compile-file*
+
+@c FIXME: Needs rewrite. Start with motivation -- why are we doing
+@c this? (there is some, but it's buried). Also, all of a sudden in
+@c the middle of the discussion we start talking about a "hook," which
+@c is confusing.
+
+When declaring a component (system, module, file),
+you can specify a keyword argument @code{:around-compile function}.
+If left unspecified (and therefore unbound),
+the value will be inherited from the parent component if any,
+or with a default of @code{nil}
+if no value is specified in any transitive parent.
+
+The argument must be either @code{nil}, an fbound symbol,
+a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk ...) ...)})
+a function object (e.g. using @code{#.#'} but that's discouraged
+because it prevents the introspection done by e.g. asdf-dependency-grovel),
+or a string that when @code{read} yields a symbol or a lambda-expression.
+@code{nil} means the normal compile-file function will be called.
+A non-nil value designates a function of one argument
+that will be called with a function that will
+invoke @code{compile-file*} with various arguments;
+the around-compile hook may supply additional keyword arguments
+to pass to that call to @code{compile-file*}.
+
+One notable argument that is heeded by @code{compile-file*} is
+@code{:compile-check},
+a function called when the compilation was otherwise a success,
+with the same arguments as @code{compile-file};
+the function shall return true if the compilation
+and its resulting compiled file respected all system-specific invariants,
+and false (@code{nil}) if it broke any of those invariants;
+it may issue warnings or errors before it returns @code{nil}.
+(NB: The ability to pass such extra flags
+is only available starting with ASDF 2.22.3.)
+This feature is notably exercised by asdf-finalizers.
+
+By using a string, you may reference
+a function, symbol and/or package
+that will only be created later during the build, but
+isn't yet present at the time the defsystem form is evaluated.
+However, if your entire system is using such a hook, you may have to
+explicitly override the hook with @code{nil} for all the modules and files
+that are compiled before the hook is defined.
+
+Using this hook, you may achieve such effects as:
+locally renaming packages,
+binding @var{*readtables*} and other syntax-controlling variables,
+handling warnings and other conditions,
+proclaiming consistent optimization settings,
+saving code coverage information,
+maintaining meta-data about compilation timings,
+setting gensym counters and PRNG seeds and other sources of non-determinism,
+overriding the source-location and/or timestamping systems,
+checking that some compile-time side-effects were properly balanced,
+etc.
+
+Note that there is no around-load hook. This is on purpose.
+Some implementations such as ECL, GCL or MKCL link object files,
+which allows for no such hook.
+Other implementations allow for concatenating FASL files,
+which doesn't allow for such a hook either.
+We aim to discourage something that's not portable,
+and has some dubious impact on performance and semantics
+even when it is possible.
+Things you might want to do with an around-load hook
+are better done around-compile,
+though it may at times require some creativity
+(see e.g. the @code{package-renaming} system).
+
+
+@node Controlling source file character encoding, Some Utility Functions, Controlling file compilation, Miscellaneous additional functionality
+@section Controlling source file character encoding
+
+Starting with ASDF 2.21, components accept a @code{:encoding} option
+so authors may specify which character encoding should be used
+to read and evaluate their source code.
+When left unspecified, the encoding is inherited
+from the parent module or system;
+if no encoding is specified at any point,
+or if @code{nil} is explicitly specified,
+an extensible protocol described below is followed,
+that ultimately defaults to @code{:utf-8} since ASDF 3.
+
+The protocol to determine the encoding is
+to call the function @code{detect-encoding},
+which itself, if provided a valid file,
+calls the function specified by @var{*encoding-detection-hook*},
+or else defaults to the @var{*default-encoding*}.
+The @var{*encoding-detection-hook*} is by default bound
+to function @code{always-default-encoding},
+that always returns the contents of @var{*default-encoding*}.
+@var{*default-encoding*} is bound to @code{:utf-8} by default
+(before ASDF 3, the default was @code{:default}).
+
+Whichever encoding is returned must be a portable keyword,
+that will be translated to an implementation-specific external-format designator
+by function @code{encoding-external-format},
+which itself simply calls the function specified @var{*encoding-external-format-hook*};
+that function by default is @code{default-encoding-external-format},
+that only recognizes @code{:utf-8} and @code{:default},
+and translates the former to the implementation-dependent @var{*utf-8-external-format*},
+and the latter to itself (that itself is portable but has an implementation-dependent meaning).
+
+In other words, there now are plenty of extension hooks, but
+by default ASDF enforces the previous @emph{de facto} standard behavior
+of using @code{:utf-8}, independently from
+whatever configuration the user may be using.
+Thus, system authors can now rely on @code{:utf-8}
+being used while compiling their files,
+even if the user is currently using @code{:koi8-r} or @code{:euc-jp}
+as their interactive encoding.
+(Before ASDF 3, there was no such guarantee, @code{:default} was used,
+and only plain ASCII was safe to include in source code.)
+
+Some legacy implementations only support 8-bit characters,
+and some implementations provide 8-bit only variants.
+On these implementations, the @var{*utf-8-external-format*}
+gracefully falls back to @code{:default},
+and Unicode characters will be read as multi-character mojibake.
+To detect such situations, UIOP will push the @code{:asdf-unicode} feature
+on implementations that support Unicode, and you can use reader-conditionalization
+to protect any @code{:encoding @emph{encoding}} statement, as in
+@code{#+asdf-unicode :encoding #+asdf-unicode :utf-8}.
+We recommend that you avoid using unprotected @code{:encoding} specifications
+until after ASDF 2.21 or later becomes widespread
+(in April 2014, only LispWorks lags with ASDF 2.019,
+and is scheduled to be updated later this year).
+
+While it offers plenty of hooks for extension,
+and one such extension is available (see @code{asdf-encodings} below),
+ASDF itself only recognizes one encoding beside @code{:default},
+and that is @code{:utf-8}, which is the @emph{de facto} standard,
+already used by the vast majority of libraries that use more than ASCII.
+On implementations that do not support unicode,
+the feature @code{:asdf-unicode} is absent, and
+the @code{:default} external-format is used
+to read even source files declared as @code{:utf-8}.
+On these implementations, non-ASCII characters
+intended to be read as one CL character
+may thus end up being read as multiple CL characters.
+In most cases, this shouldn't affect the software's semantics:
+comments will be skipped just the same, strings with be read and printed
+with slightly different lengths, symbol names will be accordingly longer,
+but none of it should matter.
+But a few systems that actually depend on unicode characters
+may fail to work properly, or may work in a subtly different way.
+See for instance @code{lambda-reader}.
+
+We invite you to embrace UTF-8
+as the encoding for non-ASCII characters starting today,
+even without any explicit specification in your @file{.asd} files.
+Indeed, on some implementations and configurations,
+UTF-8 is already the @code{:default},
+and loading your code may cause errors if it is encoded in anything but UTF-8.
+Therefore, even with the legacy behavior,
+non-UTF-8 is guaranteed to break for some users,
+whereas UTF-8 is pretty much guaranteed not to break anywhere
+(provided you do @emph{not} use a BOM),
+although it might be read incorrectly on some implementations.
+@code{:utf-8} has been the default value of @code{*default-encoding*} since ASDF 3.
+
+If you need non-standard character encodings for your source code,
+use the extension system @code{asdf-encodings}, by specifying
+@code{:defsystem-depends-on (:asdf-encodings)} in your @code{defsystem}.
+This extension system will register support for more encodings using the
+@code{*encoding-external-format-hook*} facility,
+so you can explicitly specify @code{:encoding :latin1}
+in your @file{.asd} file.
+Using the @code{*encoding-detection-hook*} it will also
+eventually implement some autodetection of a file's encoding
+from an emacs-style @code{-*- mode: lisp ; coding: latin1 -*-} declaration,
+or otherwise based on an analysis of octet patterns in the file.
+At this point, @code{asdf-encoding} only supports the encodings
+that are supported as part of your implementation.
+Since the list varies depending on implementations,
+we still recommend you use @code{:utf-8} everywhere,
+which is the most portable (next to it is @code{:latin1}).
+
+Recent versions of Quicklisp include @code{asdf-encodings};
+if you're not using it, you may get this extension using git:
+@kbd{git clone git://common-lisp.net/projects/asdf/asdf-encodings.git}
+or
+@kbd{git clone ssh://common-lisp.net/project/asdf/git/asdf-encodings.git}.
+You can also browse the repository on
+@url{http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git}.
+
+When you use @code{asdf-encodings},
+any @file{.asd} file loaded
+will use the autodetection algorithm to determine its encoding.
+If you depend on this detection happening,
+you should explicitly load @code{asdf-encodings} early in your build.
+Note that @code{:defsystem-depends-on} cannot be used here: by the time
+the @code{:defsystem-depends-on} is loaded, the enclosing
+@code{defsystem} form has already been read.
+
+In practice, this means that the @code{*default-encoding*}
+is usually used for @file{.asd} files.
+Currently, this defaults to @code{:utf-8}, and
+you should be safe using Unicode characters in those files.
+This might matter, for instance, in meta-data about author's names.
+Otherwise, the main data in these files is component (path)names,
+and we don't recommend using non-ASCII characters for these,
+for the result probably isn't very portable.
+
+@section Miscellaneous Functions
+
+These functions are exported by ASDF for your convenience.
+
+@anchor{system-relative-pathname}
+@defun system-relative-pathname system name @Akey{} type
+
+It's often handy to locate a file relative to some system.
+The @code{system-relative-pathname} function meets this need.
+
+It takes two mandatory arguments @var{system} and @var{name}
+and a keyword argument @var{type}:
+@var{system} is name of a system, whereas @var{name} and optionally @var{type}
+specify a relative pathname, interpreted like a component pathname specifier
+by @code{coerce-pathname}. @xref{The defsystem grammar,,Pathname specifiers}.
+
+It returns a pathname built from the location of the system's
+source directory and the relative pathname. For example:
-(no password: just press @key{Enter})
-
-@kbd{cvs -z3 -d:pserver:anonymous@@cvs.cclan.sourceforge.net:/cvsroot/cclan co -r RELEASE asdf}
+@lisp
+> (asdf:system-relative-pathname 'cl-ppcre "regex.data")
+#P"/repository/other/cl-ppcre/regex.data"
+@end lisp
-or for the bleeding edge, instead
+@end defun
-@kbd{cvs -z3 -d:pserver:anonymous@@cvs.cclan.sourceforge.net:/cvsroot/cclan co -A asdf}
+@defun system-source-directory system-designator
-@end enumerate
+ASDF does not provide a turnkey solution for locating
+data (or other miscellaneous) files
+that are distributed together with the source code of a system.
+Programmers can use @code{system-source-directory} to find such files.
+Returns a pathname object.
+The @var{system-designator} may be a string, symbol, or ASDF system object.
+@end defun
-If you are tracking the bleeding edge, you may want to subscribe to
-the cclan-commits mailing list (see
-@url{http://sourceforge.net/mail/?group_id=28536}) to receive commit
-messages and diffs whenever changes are made.
+@defun clear-system system-designator
+
+It is sometimes useful to force recompilation of a previously loaded system.
+For these cases, @code{(asdf:clear-system :foo)}
+will remove the system from the table of currently loaded systems:
+the next time the system @code{foo} or one that depends on it is re-loaded,
+@code{foo} will be loaded again.@footnote{Alternatively, you could touch @code{foo.asd} or
+remove the corresponding fasls from the output file cache.}
+
+Note that this does not and cannot undo
+the previous loading of the system.
+Common Lisp has no provision for such an operation,
+and its reliance on irreversible side-effects to global data structures
+makes such a thing impossible in the general case.
+If the software being re-loaded is not conceived with hot upgrade in mind,
+re-loading may cause many errors, warnings or subtle silent problems,
+as packages, generic function signatures, structures, types, macros, constants, etc.
+are being redefined incompatibly.
+It is up to the user to make sure that reloading is possible and has the desired effect.
+In some cases, extreme measures such as recursively deleting packages,
+unregistering symbols, defining methods on @code{update-instance-for-redefined-class}
+and much more are necessary for reloading to happen smoothly.
+ASDF itself goes to extensive effort to make a hot upgrade possible
+with respect to its own code.
+If you want, you can reuse some of its utilities such as
+@code{uiop:define-package} and @code{uiop:with-upgradability},
+and get inspiration (or disinspiration)
+from what it does in @file{header.lisp} and @file{upgrade.lisp}.
+@end defun
-For more CVS information, look at
-@url{http://sourceforge.net/cvs/?group_id=28536}.
+@defun register-preloaded-system name @Arest{} keys
+A system with name @var{name},
+created by @code{make-instance} with extra keys @var{keys}
+(e.g. @code{:version}),
+is registered as @emph{preloaded}.
+That is, its code has already been loaded into the current image,
+and if at some point some other system @code{:depends-on} it yet no source code is found,
+it is considered as already provided,
+and ASDF will not raise a @code{missing-component} error.
+
+This function is particularly useful if you distribute your code
+as fasls with either @code{compile-bundle-op} or @code{monolithic-compile-bundle-op},
+and want to register systems so that dependencies will work uniformly
+whether you're using your software from source or from fasl.
+@end defun
+@defun run-shell-command control-string @Arest{} args
+
+This function is obsolete and present only for the sake of backwards-compatibility:
+``If it's not backwards, it's not compatible''. We @emph{strongly} discourage its use.
+Its current behavior is only well-defined on Unix platforms
+(which include MacOS X and cygwin). On Windows, anything goes.
+The following documentation is only for the purpose of your migrating away from it
+in a way that preserves semantics.
+
+Instead we recommend the use @code{run-program}, described in the next section, and
+available as part of ASDF since ASDF 3.
+
+@code{run-shell-command} takes as arguments a format @code{control-string}
+and arguments to be passed to @code{format} after this control-string
+to produce a string.
+This string is a command that will be evaluated with a POSIX shell if possible;
+yet, on Windows, some implementations will use CMD.EXE,
+while others (like SBCL) will make an attempt at invoking a POSIX shell
+(and fail if it is not present).
+@end defun
+@node Some Utility Functions, , Controlling source file character encoding, Miscellaneous additional functionality
+@section Some Utility Functions
+
+The below functions are not exported by ASDF itself, but by UIOP, available since ASDF 3.
+Some of them have precursors in ASDF 2, but we recommend
+you rely on ASDF 3 for active developments.
+UIOP provides many, many more utility functions, and we recommend
+you read its README and sources for more information.
+
+
+@defun parse-unix-namestring name @Akey{} type defaults dot-dot ensure-directory @AallowOtherKeys
+Coerce NAME into a PATHNAME using standard Unix syntax.
+
+Unix syntax is used whether or not the underlying system is Unix;
+on non-Unix systems it is only usable for relative pathnames.
+In order to manipulate relative pathnames portably, it is crucial
+to possess a portable pathname syntax independent of the underlying OS.
+This is what @code{parse-unix-namestring} provides, and why we use it in ASDF.
+
+When given a @code{pathname} object, just return it untouched.
+When given @code{nil}, just return @code{nil}.
+When given a non-null @code{symbol}, first downcase its name and treat it as a string.
+When given a @code{string}, portably decompose it into a pathname as below.
+
+@code{#\/} separates directory components.
+
+The last @code{#\/}-separated substring is interpreted as follows:
+1- If @var{type} is @code{:directory} or @var{ensure-directory} is true,
+ the string is made the last directory component, and its @code{name} and @code{type} are @code{nil}.
+ if the string is empty, it's the empty pathname with all slots @code{nil}.
+2- If @var{type} is @code{nil}, the substring is a file-namestring,
+ and its @code{name} and @code{type} are separated by @code{split-name-type}.
+3- If @var{type} is a string, it is the given @code{type}, and the whole string is the @code{name}.
+
+Directory components with an empty name the name @code{.} are removed.
+Any directory named @code{..} is read as @var{dot-dot},
+which must be one of @code{:back} or @code{:up} and defaults to @code{:back}.
+
+@vindex *nil-pathname*
+@code{host}, @code{device} and @code{version} components are taken from @var{defaults},
+which itself defaults to @code{*nil-pathname*}.
+@code{*nil-pathname*} is also used if @var{defaults} is @code{nil}.
+No host or device can be specified in the string itself,
+which makes it unsuitable for absolute pathnames outside Unix.
+
+For relative pathnames, these components (and hence the defaults) won't matter
+if you use @code{merge-pathnames*} but will matter if you use @code{merge-pathnames},
+which is an important reason to always use @code{merge-pathnames*}.
+
+Arbitrary keys are accepted, and the parse result is passed to @code{ensure-pathname}
+with those keys, removing @var{type}, @var{defaults} and @var{dot-dot}.
+When you're manipulating pathnames that are supposed to make sense portably
+even though the OS may not be Unixish, we recommend you use @code{:want-relative t}
+so that @code{parse-unix-namestring} will throw an error if the pathname is absolute.
+@end defun
+@defun merge-pathnames* specified @Aoptional{} defaults
-@node TODO list, missing bits in implementation, Getting the latest version, Top
-@comment node-name, next, previous, up
-@chapter TODO list
+This function is a replacement for @code{merge-pathnames} that uses the host and device
+from the @var{defaults} rather than the @var{specified} pathname when the latter
+is a relative pathname. This allows ASDF and its users to create and use relative pathnames
+without having to know beforehand what are the host and device
+of the absolute pathnames they are relative to.
-* Outstanding spec questions, things to add
+@end defun
-** packaging systems
+@defun subpathname pathname subpath @Akey{} type
-*** manual page component?
+This function takes a @var{pathname} and a @var{subpath} and a @var{type}.
+If @var{subpath} is already a @code{pathname} object (not namestring),
+and is an absolute pathname at that, it is returned unchanged;
+otherwise, @var{subpath} is turned into a relative pathname with given @var{type}
+as per @code{parse-unix-namestring} with @code{:want-relative t :type }@var{type},
+then it is merged with the @code{pathname-directory-pathname} of @var{pathname},
+as per @code{merge-pathnames*}.
-** style guide for .asd files
+We strongly encourage the use of this function
+for portably resolving relative pathnames in your code base.
+@end defun
-You should either use keywords or be careful with the package that you
-evaluate defsystem forms in. Otherwise (defsystem partition ...)
-being read in the cl-user package will intern a cl-user:partition
-symbol, which will then collide with the partition:partition symbol.
+@defun subpathname* pathname subpath @Akey{} type
-Actually there's a hairier packages problem to think about too.
-in-order-to is not a keyword: if you read defsystem forms in a package
-that doesn't use ASDF, odd things might happen
+This function returns @code{nil} if the base @var{pathname} is @code{nil},
+otherwise acts like @code{subpathname}.
+@end defun
-** extending defsystem with new options
+@defun run-program command @Akey{} ignore-error-status force-shell input output @
+error-output if-input-does-not-exist if-output-exists if-error-output-exists @
+element-type external-format @AallowOtherKeys
+
+@code{run-program} takes a @var{command} argument that is either
+a list of a program name or path and its arguments,
+or a string to be executed by a shell.
+It spawns the command, waits for it to return,
+verifies that it exited cleanly (unless told not too below),
+and optionally captures and processes its output.
+It accepts many keyword arguments to configure its behavior.
+
+@code{run-program} returns three values: the first for the output,
+the second for the error-output, and the third for the return value.
+(Beware that before ASDF 3.0.2.11, it didn't handle input or error-output,
+and returned only one value,
+the one for the output if any handler was specified, or else the exit code;
+please upgrade ASDF, or at least UIOP, to rely on the new enhanced behavior.)
+
+@var{output} is its most important argument;
+it specifies how the output is captured and processed.
+If it is @code{nil}, then the output is redirected to the null device,
+that will discard it.
+If it is @code{:interactive}, then it is inherited from the current process
+(beware: this may be different from your @var{*standard-output*},
+and under SLIME will be on your @code{*inferior-lisp*} buffer).
+If it is @code{t}, output goes to your current @var{*standard-output*} stream.
+Otherwise, @var{output} should be a value that is a suitable first argument to
+@code{slurp-input-stream} (see below), or
+a list of such a value and keyword arguments.
+In this case, @code{run-program} will
+create a temporary stream for the program output;
+the program output, in that stream,
+will be processed by a call to @code{slurp-input-stream},
+using @var{output} as the first argument
+(or if it's a list the first element of @var{output} and the rest as keywords).
+The primary value resulting from that call
+(or @code{nil} if no call was needed)
+will be the first value returned by @code{run-program}.
+E.g., using @code{:output :string}
+will have it return the entire output stream as a string.
+And using @code{:output '(:string :stripped t)}
+will have it return the same string stripped of any ending newline.
+
+@var{error-output} is similar to @var{output}, except that
+the resulting value is returned as the second value of @code{run-program}.
+@code{t} designates the @var{*error-output*}.
+Also @code{:output} means redirecting the error output to the output stream,
+in which case @code{nil} is returned.
+
+@var{input} is similar to @var{output}, except that
+@code{vomit-output-stream} is used, no value is returned,
+and @code{t} designates the @var{*standard-input*}.
+
+@code{element-type} and @code{external-format} are passed on
+to your Lisp implementation, when applicable, for creation of the output stream.
+
+One and only one of the stream slurping or vomiting may or may not happen
+in parallel in parallel with the subprocess,
+depending on options and implementation,
+and with priority being given to output processing.
+Other streams are completely produced or consumed
+before or after the subprocess is spawned, using temporary files.
+
+@code{force-shell} forces evaluation of the command through a shell,
+even if it was passed as a list rather than a string.
+If a shell is used, it is @file{/bin/sh} on Unix or @file{CMD.EXE} on Windows,
+except on implementations that (erroneously, IMNSHO)
+insist on consulting @code{$SHELL} like clisp.
+
+@code{ignore-error-status} causes @code{run-program}
+to not raise an error if the spawned program exits in error.
+Following POSIX convention, an error is anything but
+a normal exit with status code zero.
+By default, an error of type @code{subprocess-error} is raised in this case.
+
+@code{run-program} works on all platforms supported by ASDF, except Genera.
+See the source code for more documentation.
-You might not want to write a whole parser, but just to add options to
-the existing syntax. Reinstate parse-option or something akin
+@end defun
-** document all the error classes
+@defun slurp-input-stream processor input-stream @Akey{}
-** what to do with compile-file failure
+@code{slurp-input-stream} is a generic function of two arguments, a target object and an input stream,
+and accepting keyword arguments.
+Predefined methods based on the target object are as follows:
-Should check the primary return value from compile-file and see if
-that gets us any closer to a sensible error handling strategy
+@itemize
+@item
+If the object is a function, the function is called with the stream as argument.
+
+@item If the object is a cons, its first element is applied to its rest appended by
+a list of the input stream.
+
+@item If the object is an output stream, the contents of the input stream are copied to it.
+If the @var{linewise} keyword argument is provided, copying happens line by line,
+and an optional @var{prefix} is printed before each line.
+Otherwise, copying happen based on a buffer of size @var{buffer-size},
+using the specified @var{element-type}.
+
+@item If the object is @code{'string} or @code{:string}, the content is captured into a string.
+Accepted keywords include the @var{element-type} and a flag @var{stripped},
+which when true causes any single line ending to be removed as per @code{uiop:stripln}.
+
+@item If the object is @code{:lines}, the content is captured as a list of strings,
+one per line, without line ending. If the @var{count} keyword argument is provided,
+it is a maximum count of lines to be read.
+
+@item If the object is @code{:line}, the content is captured as with @code{:lines} above,
+and then its sub-object is extracted with the @var{at} argument,
+which defaults to @code{0}, extracting the first line.
+A number will extract the corresponding line.
+See the documentation for @code{uiop:access-at}.
+
+@item If the object is @code{:forms}, the content is captured as a list of S-expressions,
+as read by the Lisp reader.
+If the @var{count} argument is provided,
+it is a maximum count of lines to be read.
+We recommend you control the syntax with such macro as
+@code{uiop:with-safe-io-syntax}.
+
+@item If the object is @code{:form}, the content is captured as with @code{:forms} above,
+and then its sub-object is extracted with the @var{at} argument,
+which defaults to @code{0}, extracting the first form.
+A number will extract the corresponding form.
+See the documentation for @code{uiop:access-at}.
+We recommend you control the syntax with such macro as
+@code{uiop:with-safe-io-syntax}.
+@end itemize
+@end defun
-** foreign files
-lift unix-dso stuff from db-sockets
+@node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
+@comment node-name, next, previous, up
+@chapter Getting the latest version
-** Diagnostics
+Decide which version you want.
+The @code{master} branch is where development happens;
+its @code{HEAD} is usually OK, including the latest fixes and portability tweaks,
+but an occasional regression may happen despite our (limited) test suite.
-A ``dry run'' of an operation can be made with the following form:
+The @code{release} branch is what cautious people should be using;
+it has usually been tested more, and releases are cut at a point
+where there isn't any known unresolved issue.
-@lisp
-(traverse (make-instance '<operation-name>)
- (find-system <system-name>)
- 'explain)
-@end lisp
+You may get the ASDF source repository using git:
+@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
+
+You will find the above referenced tags in this repository.
+You can also browse the repository on
+@url{http://common-lisp.net/gitweb?p=projects/asdf/asdf.git}.
-This uses unexported symbols. What would be a nice interface for this
-functionality?
+Discussion of ASDF development is conducted on the
+mailing list
+@kbd{asdf-devel@@common-lisp.net}.
+@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
-@node missing bits in implementation, Inspiration, TODO list, Top
+
+@node FAQ, Ongoing Work, Getting the latest version, Top
@comment node-name, next, previous, up
-@chapter missing bits in implementation
+@chapter FAQ
+
+@menu
+* Where do I report a bug?::
+* What has changed between ASDF 1 and ASDF 2?::
+* Issues with installing the proper version of ASDF::
+* Issues with configuring ASDF::
+* Issues with using and extending ASDF to define systems::
+* ASDF development FAQs::
+@end menu
-** all of the above
+@node Where do I report a bug?, What has changed between ASDF 1 and ASDF 2?, FAQ, FAQ
+@section ``Where do I report a bug?''
-** reuse the same scratch package whenever a system is reloaded from disk
+ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}.
-** rules for system pathname defaulting are not yet implemented properly
+If you're unsure about whether something is a bug, or for general discussion,
+use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
-** proclamations probably aren't
-** when a system is reloaded with fewer components than it previously
- had, odd things happen
+@node What has changed between ASDF 1 and ASDF 2?, Issues with installing the proper version of ASDF, Where do I report a bug?, FAQ
+@section ``What has changed between ASDF 1, ASDF 2 and ASDF 3?''
-we should do something inventive when processing a defsystem form,
-like take the list of kids and setf the slot to nil, then transfer
-children from old to new list as they're found
+We released ASDF 2.000 on May 31st 2010,
+and ASDF 3.0.0 on May 15th 2013.
+Releases of ASDF 2 and later have since then been included
+in all actively maintained CL implementations that used to bundle ASDF 1,
+plus some implementations that previously did not.
+ASDF has been made to work with all actively maintained CL
+implementations and even a few implementations that are @emph{not}
+actively maintained.
+@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
+Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 or ASDF 3 on the fly
+(though we recommend instead upgrading your implementation or its ASDF module).
+For this reason, we have stopped supporting ASDF 1 and ASDF 2.
+If you are using ASDF 1 or ASDF 2 and are experiencing any kind of issues or limitations,
+we recommend you upgrade to ASDF 3
+--- and we explain how to do that. @xref{Loading ASDF}.
+(In the context of compatibility requirements,
+ASDF 2.27, released on Feb 1st 2013, and further 2.x releases up to 2.33,
+count as pre-releases of ASDF 3, and define the @code{:asdf3} feature;
+still, please use the latest release).
+Release ASDF 3.1.1 and later also define the @code{:asdf3.1} feature.
-** traverse may become a normal function
-If you're defining methods on traverse, speak up.
+@menu
+* What are ASDF 1 2 3?::
+* How do I detect the ASDF version?::
+* ASDF can portably name files in subdirectories::
+* Output translations::
+* Source Registry Configuration::
+* Usual operations are made easier to the user::
+* Many bugs have been fixed::
+* ASDF itself is versioned::
+* ASDF can be upgraded::
+* Decoupled release cycle::
+* Pitfalls of the transition to ASDF 2::
+@end menu
+@node What are ASDF 1 2 3?, How do I detect the ASDF version?, What has changed between ASDF 1 and ASDF 2?, What has changed between ASDF 1 and ASDF 2?
+@subsection What are ASDF 1, ASDF 2, and ASDF 3?
+
+ASDF 1 refers to any release earlier than 1.369 or so (from August 2001 to October 2009),
+and to any development revision earlier than 2.000 (May 2010).
+If your copy of ASDF doesn't even contain version information, it's an old ASDF 1.
+Revisions between 1.656 and 1.728 may count as development releases for ASDF 2.
+
+ASDF 2 refers to releases from 2.000 (May 31st 2010) to 2.26 (Oct 30 2012),
+and any development revision newer than ASDF 1 and older than 2.27 (Feb 1 2013).
+
+ASDF 3 refers to releases from 2.27 (Feb 1 2013) to 2.33 and 3.0.0 onward (May 15 2013).
+2.27 to 2.33 count as pre-releases to ASDF 3.
+
+@node How do I detect the ASDF version?, ASDF can portably name files in subdirectories, What are ASDF 1 2 3?, What has changed between ASDF 1 and ASDF 2?
+@subsection How do I detect the ASDF version?
+@findex asdf-version
+@cindex *features*
+
+All releases of ASDF
+push @code{:asdf} onto @code{*features*}.
+Releases starting with ASDF 2
+push @code{:asdf2} onto @code{*features*}.
+Releases starting with ASDF 3 (including 2.27 and later pre-releases)
+push @code{:asdf3} onto @code{*features*}.
+Furthermore, releases starting with ASDF 3.1.1 (April 2014),
+though they count as ASDF 3, include enough progress that they
+push @code{:asdf3.1} onto @code{*features*}.
+You may depend on the presence or absence of these features
+to write code that takes advantage of recent ASDF functionality
+but still works on older versions, or at least detects the old version and signals an error.
+
+Additionally, all releases starting with ASDF 2
+define a function @code{(asdf:asdf-version)} you may use to query the version.
+All releases starting with 2.013 display the version number prominently
+on the second line of the @file{asdf.lisp} source file.
+
+If you are experiencing problems or limitations of any sort with ASDF 1 or ASDF 2,
+we recommend that you should upgrade to the latest release, be it ASDF 3 or other.
+
+
+@node ASDF can portably name files in subdirectories, Output translations, How do I detect the ASDF version?, What has changed between ASDF 1 and ASDF 2?
+@subsection ASDF can portably name files in subdirectories
+
+Common Lisp namestrings are not portable,
+except maybe for logical pathname namestrings,
+that themselves have various limitations and require a lot of setup
+that is itself ultimately non-portable.
+
+In ASDF 1, the only portable ways to refer to pathnames inside systems and components
+were very awkward, using @code{#.(make-pathname ...)} and
+@code{#.(merge-pathnames ...)}.
+Even the above were themselves were inadequate in the general case
+due to host and device issues, unless horribly complex patterns were used.
+Plenty of simple cases that looked portable actually weren't,
+leading to much confusion and greavance.
+
+ASDF 2 implements its own portable syntax for strings as pathname specifiers.
+Naming files within a system definition becomes easy and portable again.
+@xref{Miscellaneous additional functionality,system-relative-pathname},
+@code{merge-pathnames*},
+@code{coerce-pathname}.
+
+On the other hand, there are places where systems used to accept namestrings
+where you must now use an explicit pathname object:
+@code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
+must now be written with the @code{#p} syntax:
+@code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)}
+
+@xref{The defsystem grammar,,Pathname specifiers}.
+
+
+@node Output translations, Source Registry Configuration, ASDF can portably name files in subdirectories, What has changed between ASDF 1 and ASDF 2?
+@subsection Output translations
+
+A popular feature added to ASDF was output pathname translation:
+@code{asdf-binary-locations}, @code{common-lisp-controller},
+@code{cl-launch} and other hacks were all implementing it in ways
+both mutually incompatible and difficult to configure.
+
+Output pathname translation is essential to share
+source directories of portable systems across multiple implementations
+or variants thereof,
+or source directories of shared installations of systems across multiple users,
+or combinations of the above.
+
+In ASDF 2, a standard mechanism is provided for that,
+@code{asdf-output-translations},
+with sensible defaults, adequate configuration languages,
+a coherent set of configuration files and hooks,
+and support for non-Unix platforms.
+
+@xref{Controlling where ASDF saves compiled files}.
+
+@node Source Registry Configuration, Usual operations are made easier to the user, Output translations, What has changed between ASDF 1 and ASDF 2?
+@subsection Source Registry Configuration
+
+Configuring ASDF used to require special magic
+to be applied just at the right moment,
+between the moment ASDF is loaded and the moment it is used,
+in a way that is specific to the user,
+the implementation he is using and the application he is building.
+
+This made for awkward configuration files and startup scripts
+that could not be shared between users, managed by administrators
+or packaged by distributions.
+
+ASDF 2 provides a well-documented way to configure ASDF,
+with sensible defaults, adequate configuration languages,
+and a coherent set of configuration files and hooks.
+
+We believe it's a vast improvement because it decouples
+application distribution from library distribution.
+The application writer can avoid thinking where the libraries are,
+and the library distributor (dpkg, clbuild, advanced user, etc.)
+can configure them once and for every application.
+Yet settings can be easily overridden where needed,
+so whoever needs control has exactly as much as required.
+
+At the same time, ASDF 2 remains compatible
+with the old magic you may have in your build scripts
+(using @code{*central-registry*} and
+@code{*system-definition-search-functions*})
+to tailor the ASDF configuration to your build automation needs,
+and also allows for new magic, simpler and more powerful magic.
-** a lot of load-op methods can be rewritten to use input-files
+@xref{Controlling where ASDF searches for systems}.
-so should be.
+@node Usual operations are made easier to the user, Many bugs have been fixed, Source Registry Configuration, What has changed between ASDF 1 and ASDF 2?
+@subsection Usual operations are made easier to the user
-** (stuff that might happen later)
+In ASDF 1, you had to use the awkward syntax
+@code{(asdf:oos 'asdf:load-op :foo)}
+to load a system,
+and similarly for @code{compile-op}, @code{test-op}.
-*** david lichteblau's patch for symlink resolution?
+In ASDF 2, you can use shortcuts for the usual operations:
+@code{(asdf:load-system :foo)}, and
+similarly for @code{compile-system}, @code{test-system}.
-*** Propagation of the :force option. ``I notice that
- (oos 'compile-op :araneida :force t)
+@node Many bugs have been fixed, ASDF itself is versioned, Usual operations are made easier to the user, What has changed between ASDF 1 and ASDF 2?
+@subsection Many bugs have been fixed
-also forces compilation of every other system the :araneida system
-depends on. This is rarely useful to me; usually, when I want to force
-recompilation of something more than a single source file, I want to
-recompile only one system. So it would be more useful to have
-make-sub-operation refuse to propagate @code{:force t} to other systems, and
-propagate only something like @code{:force :recursively}.
+The following issues and many others have been fixed:
-Ideally what we actually want is some kind of criterion that says to
-which systems (and which operations) a @code{:force} switch will
-propagate.
+@itemize
+@item
+The infamous TRAVERSE function has been revamped completely
+between ASDF 1 and ASDF 2, with many bugs squashed.
+In particular, dependencies were not correctly propagated
+across modules but now are.
+It has been completely rewritten many times over
+between ASDF 2.000 and ASDF 3,
+with fundamental issues in the original model being fixed.
+Timestamps were not propagated at all, and now are.
+The internal model of how actions depend on each other
+is now both consistent and complete.
+The @code{:version} and
+the @code{:force (system1 .. systemN)} feature have been fixed.
-The problem is perhaps that `force' is a pretty meaningless concept.
-How obvious is it that @code{load :force t} should force
-@emph{compilation}? But we don't really have the right dependency
-setup for the user to compile @code{:force t} and expect it to work
-(files will not be loaded after compilation, so the compile
-environment for subsequent files will be emptier than it needs to be)
+@item
+Performance has been notably improved for large systems
+(say with thousands of components) by using
+hash-tables instead of linear search,
+and linear-time list accumulation instead of cubic time recursive append,
+for an overall @emph{O(n)} complexity vs @emph{O(n^4)}.
-What does the user actually want to do when he forces? Usually, for
-me, update for use with a new version of the lisp compiler. Perhaps
-for recovery when he suspects that something has gone wrong. Or else
-when he's changed compilation options or configuration in some way
-that's not reflected in the dependency graph.
+@item
+Many features used to not be portable,
+especially where pathnames were involved.
+Windows support was notably quirky because of such non-portability.
-Other possible interface: have a 'revert' function akin to 'make clean'
+@item
+The internal test suite used to massively fail on many implementations.
+While still incomplete, it now fully passes
+on all implementations supported by the test suite,
+though some tests are commented out on a few implementations.
-@lisp
-(asdf:revert 'asdf:compile-op 'araneida)
-@end lisp
+@item
+Support was lacking for some implementations.
+ABCL and GCL were notably wholly broken.
+ECL extensions were not integrated with ASDF release.
-would delete any files produced by 'compile-op 'araneida. Of course, it
-wouldn't be able to do much about stuff in the image itself.
+@item
+The documentation was grossly out of date.
-How would this work?
+@end itemize
-traverse
-There's a difference between a module's dependencies (peers) and its
-components (children). Perhaps there's a similar difference in
-operations? For example, @code{(load "use") depends-on (load "macros")} is a
-peer, whereas @code{(load "use") depends-on (compile "use")} is more of a
-`subservient' relationship.
+@node ASDF itself is versioned, ASDF can be upgraded, Many bugs have been fixed, What has changed between ASDF 1 and ASDF 2?
+@subsection ASDF itself is versioned
+
+Between new features, old bugs fixed, and new bugs introduced,
+there were various releases of ASDF in the wild,
+and no simple way to check which release had which feature set.
+People using or writing systems had to either make worst-case assumptions
+as to what features were available and worked,
+or take great pains to have the correct version of ASDF installed.
+
+With ASDF 2, we provide a new stable set of working features
+that everyone can rely on from now on.
+Use @code{#+asdf2} to detect presence of ASDF 2,
+@code{(asdf:version-satisfies (asdf:asdf-version) "2.345.67")}
+to check the availability of a version no earlier than required.
+
+
+@node ASDF can be upgraded, Decoupled release cycle, ASDF itself is versioned, What has changed between ASDF 1 and ASDF 2?
+@subsection ASDF can be upgraded
+
+When an old version of ASDF was loaded,
+it was very hard to upgrade ASDF in your current image
+without breaking everything.
+Instead you had to exit the Lisp process and
+somehow arrange to start a new one from a simpler image.
+Something that can't be done from within Lisp,
+making automation of it difficult,
+which compounded with difficulty in configuration,
+made the task quite hard.
+Yet as we saw before, the task would have been required
+to not have to live with the worst case or non-portable
+subset of ASDF features.
+
+With ASDF 2, it is easy to upgrade
+from ASDF 2 to later versions from within Lisp,
+and not too hard to upgrade from ASDF 1 to ASDF 2 from within Lisp.
+We support hot upgrade of ASDF and any breakage is a bug
+that we will do our best to fix.
+There are still limitations on upgrade, though,
+most notably the fact that after you upgrade ASDF,
+you must also reload or upgrade all ASDF extensions.
+
+@node Decoupled release cycle, Pitfalls of the transition to ASDF 2, ASDF can be upgraded, What has changed between ASDF 1 and ASDF 2?
+@subsection Decoupled release cycle
+
+When vendors were releasing their Lisp implementations with ASDF,
+they had to basically never change version
+because neither upgrade nor downgrade was possible
+without breaking something for someone,
+and no obvious upgrade path was visible and recommendable.
+
+With ASDF 2, upgrade is possible, easy and can be recommended.
+This means that vendors can safely ship a recent version of ASDF,
+confident that if a user isn't fully satisfied,
+he can easily upgrade ASDF and deal
+with a supported recent version of it.
+This means that release cycles will be causally decoupled,
+the practical consequence of which will mean faster convergence
+towards the latest version for everyone.
+
+
+@node Pitfalls of the transition to ASDF 2, , Decoupled release cycle, What has changed between ASDF 1 and ASDF 2?
+@subsection Pitfalls of the transition to ASDF 2
+
+The main pitfalls in upgrading to ASDF 2 seem to be related
+to the output translation mechanism.
-@node Inspiration, Concept Index, missing bits in implementation, Top
-@comment node-name, next, previous, up
-@chapter Inspiration
+@itemize
+
+@item
+Output translations is enabled by default. This may surprise some users,
+most of them in pleasant way (we hope), a few of them in an unpleasant way.
+It is trivial to disable output translations.
+@xref{FAQ,,``How can I wholly disable the compiler output cache?''}.
+
+@item
+Some systems in the large have been known
+not to play well with output translations.
+They were relatively easy to fix.
+Once again, it is also easy to disable output translations,
+or to override its configuration.
+
+@item
+The new ASDF output translations are incompatible with ASDF-Binary-Locations.
+They replace A-B-L, and there is compatibility mode to emulate
+your previous A-B-L configuration.
+See @code{enable-asdf-binary-locations-compatibility} in
+@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
+But thou shalt not load ABL on top of ASDF 2.
+
+@end itemize
+
+Other issues include the following:
+
+@itemize
+
+@item
+ASDF pathname designators are now specified
+in places where they were unspecified,
+and a few small adjustments have to be made to some non-portable defsystems.
+Notably, in the @code{:pathname} argument
+to a @code{defsystem} and its components,
+a logical pathname (or implementation-dependent hierarchical pathname)
+must now be specified with @code{#p} syntax
+where the namestring might have previously sufficed;
+moreover when evaluation is desired @code{#.} must be used,
+where it wasn't necessary in the toplevel @code{:pathname} argument
+(but necessary in other @code{:pathname} arguments).
+
+@item
+There is a slight performance bug, notably on SBCL,
+when initially searching for @file{asd} files,
+the implicit @code{(directory "/configured/path/**/*.asd")}
+for every configured path @code{(:tree "/configured/path/")}
+in your @code{source-registry} configuration can cause a slight pause.
+Try to @code{(time (asdf:initialize-source-registry))}
+to see how bad it is or isn't on your system.
+If you insist on not having this pause,
+you can avoid the pause by overriding the default source-registry configuration
+and not use any deep @code{:tree} entry but only @code{:directory} entries
+or shallow @code{:tree} entries.
+Or you can fix your implementation to not be quite that slow
+when recursing through directories.
+@emph{Update}: This performance bug fixed the hard way in 2.010.
+
+@item
+On Windows, only LispWorks supports proper default configuration pathnames
+based on the Windows registry.
+Other implementations make do with environment variables,
+that you may have to define yourself
+if you're using an older version of Windows.
+Windows support is somewhat less tested than Unix support.
+Please help report and fix bugs.
+@emph{Update}: As of ASDF 2.21, all implementations
+should now use the same proper default configuration pathnames
+and they should actually work, though they haven't all been tested.
+
+@item
+The mechanism by which one customizes a system so that Lisp files
+may use a different extension from the default @file{.lisp} has changed.
+Previously, the pathname for a component
+was lazily computed when operating on a system,
+and you would
+@code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
+ (declare (ignorable component system)) "lis")}.
+Now, the pathname for a component is eagerly computed when defining the system,
+and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))}
+and use @code{:default-component-class cl-source-file.lis}
+as argument to @code{defsystem},
+as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
+
+@findex source-file-type
+
+
+@end itemize
+
+
+@node Issues with installing the proper version of ASDF, Issues with configuring ASDF, What has changed between ASDF 1 and ASDF 2?, FAQ
+@section Issues with installing the proper version of ASDF
+
+@menu
+* My Common Lisp implementation comes with an outdated version of ASDF. What to do?::
+* I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?::
+@end menu
+
+@node My Common Lisp implementation comes with an outdated version of ASDF. What to do?, I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, Issues with installing the proper version of ASDF, Issues with installing the proper version of ASDF
+@subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?''
-@section mk-defsystem (defsystem-3.x)
+We recommend you upgrade ASDF.
+@xref{Loading ASDF,,Upgrading ASDF}.
-We aim to solve basically the same problems as mk-defsystem does.
-However, our architecture for extensibility better exploits CL
-language features (and is documented), and we intend to be portable
-rather than just widely-ported. No slight on the mk-defsystem authors
-and maintainers is intended here; that implementation has the
-unenviable task of supporting pre-ANSI implementations, which is
-no longer necessary.
+If this does not work, it is a bug, and you should report it.
+@xref{FAQ, report-bugs, Where do I report a bug}.
+In the meantime, you can load @file{asdf.lisp} directly.
+@xref{Loading ASDF,Loading an otherwise installed ASDF}.
-The surface defsystem syntax of asdf is more-or-less compatible with
-mk-defsystem, except that we do not support the @code{source-foo} and
-@code{binary-foo} prefixes for separating source and binary files, and
-we advise the removal of all options to specify pathnames.
-The mk-defsystem code for topologically sorting a module's dependency
-list was very useful.
+@node I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, , My Common Lisp implementation comes with an outdated version of ASDF. What to do?, Issues with installing the proper version of ASDF
+@subsection ``I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?''
-@section defsystem-4 proposal
+Since ASDF 2,
+it should always be a good time to upgrade to a recent version of ASDF.
+You may consult with the maintainer for which specific version they recommend,
+but the latest @code{release} should be correct.
+Though we do try to test ASDF releases against all implementations that we can,
+we may not be testing against all variants of your implementation,
+and we may not be running enough tests;
+we trust you to thoroughly test it with your own implementation
+before you release it.
+If there are any issues with the current release,
+it's a bug that you should report upstream and that we will fix ASAP.
-Marco and Peter's proposal for defsystem 4 served as the driver for
-many of the features in here. Notable differences are:
+As to how to include ASDF, we recommend the following:
@itemize
@item
-We don't specify output files or output file extensions as part of the
-system.
+If ASDF isn't loaded yet, then @code{(require "asdf")}
+should load the version of ASDF that is bundled with your system.
+If possible so should @code{(require "ASDF")}.
+You may have it load some other version configured by the user,
+if you allow such configuration.
-If you want to find out what files an operation would create, ask the
-operation.
+@item
+If your system provides a mechanism to hook into @code{CL:REQUIRE},
+then it would be nice to add ASDF to this hook the same way that
+ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it.
+Please send us appropriate code to this end.
+
+@item
+You may, like SBCL since 1.1.13 or MKCL since 1.1.9,
+have ASDF create bundle FASLs
+that are provided as modules by your Lisp distribution.
+You may also, but we don't recommend that anymore,
+have ASDF like SBCL up until 1.1.12 be implicitly used
+when requiring modules that are provided by your Lisp distribution;
+if you do, you should add them in the beginning of both
+@code{wrapping-source-registry} and @code{wrapping-output-translations}.
+
+@item
+If you have magic systems as above, like SBCL used to do,
+then we explicitly ask you to @emph{NOT} distribute
+@file{asdf.asd} as part of those magic systems.
+You should still include the file @file{asdf.lisp} in your source distribution
+and precompile it in your binary distribution,
+but @file{asdf.asd} if included at all,
+should be secluded from the magic systems,
+in a separate file hierarchy.
+Alternatively, you may provide the system
+after renaming it and its @file{.asd} file to e.g.
+@code{asdf-ecl} and @file{asdf-ecl.asd}, or
+@code{sb-asdf} and @file{sb-asdf.asd}.
+Indeed, if you made @file{asdf.asd} a magic system,
+then users would no longer be able to upgrade ASDF using ASDF itself
+to some version of their preference that
+they maintain independently from your Lisp distribution.
@item
-We don't deal with CL packages
+If you do not have any such magic systems, or have other non-magic systems
+that you want to bundle with your implementation,
+then you may add them to the @code{wrapping-source-registry},
+and you are welcome to include @file{asdf.asd} amongst them.
+Non-magic systems should be at the back of the @code{wrapping-source-registry}
+while magic systems are at the front.
+If they are precompiled,
+they should also be in the @code{wrapping-output-translations}.
-If you want to compile in a particular package, use an in-package form
-in that file (ilisp / SLIME will like you more if you do this anyway)
+@item
+Since ASDF 3, the library UIOP comes transcluded in ASDF.
+But if you want to be nice to users who care for UIOP but not for ASDF,
+you may package UIOP separately,
+so that one may @code{(require "uiop")} and not load ASDF,
+or one may @code{(require "asdf")}
+which would implicitly require and load the former.
@item
-There is no proposal here that defsystem does version control.
+Please send us upstream any patches you make to ASDF itself,
+so we can merge them back in for the benefit of your users
+when they upgrade to the upstream version.
-A system has a given version which can be used to check dependencies,
-but that's all.
@end itemize
-The defsystem 4 proposal tends to look more at the external features,
-whereas this one centres on a protocol for system introspection.
-@section kmp's ``The Description of Large Systems'', MIT AI Memu 801
-Available in updated-for-CL form on the web at
-@url{http://world.std.com/~pitman/Papers/Large-Systems.html}
+@node Issues with configuring ASDF, Issues with using and extending ASDF to define systems, Issues with installing the proper version of ASDF, FAQ
+@section Issues with configuring ASDF
+
+@menu
+* How can I customize where fasl files are stored?::
+* How can I wholly disable the compiler output cache?::
+@end menu
+
+@node How can I customize where fasl files are stored?, How can I wholly disable the compiler output cache?, Issues with configuring ASDF, Issues with configuring ASDF
+@subsection ``How can I customize where fasl files are stored?''
-In our implementation we borrow kmp's overall PROCESS-OPTIONS and
-concept to deal with creating component trees from defsystem surface
-syntax. [ this is not true right now, though it used to be and
-probably will be again soon ]
+@xref{Controlling where ASDF saves compiled files}.
+Note that in the past there was an add-on to ASDF called
+@code{ASDF-binary-locations}, developed by Gary King.
+That add-on has been merged into ASDF proper,
+then superseded by the @code{asdf-output-translations} facility.
-@c -------------------
+Note that use of @code{asdf-output-translations}
+can interfere with one aspect of your systems
+--- if your system uses @code{*load-truename*} to find files
+(e.g., if you have some data files stored with your program),
+then the relocation that this ASDF customization performs
+is likely to interfere.
+Use @code{asdf:system-relative-pathname} to locate a file
+in the source directory of some system, and
+use @code{asdf:apply-output-translations} to locate a file
+whose pathname has been translated by the facility.
+
+@node How can I wholly disable the compiler output cache?, , How can I customize where fasl files are stored?, Issues with configuring ASDF
+@subsection ``How can I wholly disable the compiler output cache?''
+
+To permanently disable the compiler output cache
+for all future runs of ASDF, you can:
+
+@example
+mkdir -p ~/.config/common-lisp/asdf-output-translations.conf.d/
+echo ':disable-cache' > ~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf
+@end example
+
+This assumes that you didn't otherwise configure the ASDF files
+(if you did, edit them again),
+and don't somehow override the configuration at runtime
+with a shell variable (see below) or some other runtime command
+(e.g. some call to @code{asdf:initialize-output-translations}).
+
+To disable the compiler output cache in Lisp processes
+run by your current shell, try (assuming @code{bash} or @code{zsh})
+(on Unix and cygwin only):
+
+@example
+export ASDF_OUTPUT_TRANSLATIONS=/:
+@end example
+
+To disable the compiler output cache just in the current Lisp process,
+use (after loading ASDF but before using it):
+
+@example
+(asdf:disable-output-translations)
+@end example
+
+Note that this does @emph{NOT} belong in a @file{.asd} file.
+Please do not tamper with ASDF configuration from a @file{.asd} file,
+and only do this from your personal configuration or build scripts.
+
+@node Issues with using and extending ASDF to define systems, ASDF development FAQs, Issues with configuring ASDF, FAQ
+@section Issues with using and extending ASDF to define systems
+
+@menu
+* How can I cater for unit-testing in my system?::
+* How can I cater for documentation generation in my system?::
+* How can I maintain non-Lisp (e.g. C) source files?::
+* I want to put my module's files at the top level. How do I do this?::
+* How do I create a system definition where all the source files have a .cl extension?::
+* How do I mark a source file to be loaded only and not compiled?::
+* How do I work with readtables?::
+@end menu
+
+@node How can I cater for unit-testing in my system?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems, Issues with using and extending ASDF to define systems
+@subsection ``How can I cater for unit-testing in my system?''
+
+ASDF provides a predefined test operation, @code{test-op}.
+@xref{Predefined operations of ASDF, test-op}.
+The test operation, however, is largely left to the system definer to specify.
+@code{test-op} has been
+a topic of considerable discussion on the
+@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
+and on the
+@url{https://launchpad.net/asdf,launchpad bug-tracker}.
+We provide some guidelines in the discussion of @code{test-op}.
+
+@c cut the following because it's discussed in the discussion of test-op.
+@c Here are some guidelines:
+
+@c @itemize
+@c @item
+@c For a given system, @var{foo}, you will want to define a corresponding
+@c test system, such as @var{foo-test}. The reason that you will want this
+@c separate system is that ASDF does not out of the box supply components
+@c that are conditionally loaded. So if you want to have source files
+@c (with the test definitions) that will not be loaded except when testing,
+@c they should be put elsewhere.
+
+@c @item
+@c The @var{foo-test} system can be defined in an asd file of its own or
+@c together with @var{foo}. An aesthetic preference against cluttering up
+@c the filesystem with extra asd files should be balanced against the
+@c question of whether one might want to directly load @var{foo-test}.
+@c Typically one would not want to do this except in early stages of
+@c debugging.
+
+@c @item
+@c Record that testing is implemented by @var{foo-test}. For example:
+@c @example
+@c (defsystem @var{foo}
+@c :in-order-to ((test-op (test-op @var{foo-test})))
+@c ....)
+
+@c (defsystem @var{foo-test}
+@c :depends-on (@var{foo} @var{my-test-library} ...)
+@c ....)
+@c @end example
+@c @end itemize
+
+@c This procedure will allow you to support users who do not wish to
+@c install your test framework.
+
+@c One oddity of ASDF is that @code{operate} (@pxref{Operations,operate})
+@c does not return a value. So in current versions of ASDF there is no
+@c reliable programmatic means of determining whether or not a set of tests
+@c has passed, or which tests have failed. The user must simply read the
+@c console output. This limitation has been the subject of much
+@c discussion.
+
+@node How can I cater for documentation generation in my system?, How can I maintain non-Lisp (e.g. C) source files?, How can I cater for unit-testing in my system?, Issues with using and extending ASDF to define systems
+@subsection ``How can I cater for documentation generation in my system?''
+
+Various ASDF extensions provide some kind of @code{doc-op} operation.
+See also @url{https://bugs.launchpad.net/asdf/+bug/479470}.
+
+
+@node How can I maintain non-Lisp (e.g. C) source files?, I want to put my module's files at the top level. How do I do this?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems
+@subsection ``How can I maintain non-Lisp (e.g. C) source files?''
+
+See @code{cffi}'s @code{cffi-grovel}.
+
+@anchor{report-bugs}
+
+
+@node I want to put my module's files at the top level. How do I do this?, How do I create a system definition where all the source files have a .cl extension?, How can I maintain non-Lisp (e.g. C) source files?, Issues with using and extending ASDF to define systems
+@subsection ``I want to put my module's files at the top level. How do I do this?''
+
+By default, the files contained in an asdf module go
+in a subdirectory with the same name as the module.
+However, this can be overridden by adding a @code{:pathname ""} argument
+to the module description.
+For example, here is how it could be done
+in the spatial-trees ASDF system definition for ASDF 2:
+
+@example
+(asdf:defsystem :spatial-trees
+ :components
+ ((:module base
+ :pathname ""
+ :components
+ ((:file "package")
+ (:file "basedefs" :depends-on ("package"))
+ (:file "rectangles" :depends-on ("package"))))
+ (:module tree-impls
+ :depends-on (base)
+ :pathname ""
+ :components
+ ((:file "r-trees")
+ (:file "greene-trees" :depends-on ("r-trees"))
+ (:file "rstar-trees" :depends-on ("r-trees"))
+ (:file "rplus-trees" :depends-on ("r-trees"))
+ (:file "x-trees" :depends-on ("r-trees" "rstar-trees"))))
+ (:module viz
+ :depends-on (base)
+ :pathname ""
+ :components
+ ((:static-file "spatial-tree-viz.lisp")))
+ (:module tests
+ :depends-on (base)
+ :pathname ""
+ :components
+ ((:static-file "spatial-tree-test.lisp")))
+ (:static-file "LICENCE")
+ (:static-file "TODO")))
+@end example
+
+All of the files in the @code{tree-impls} module are at the top level,
+instead of in a @file{tree-impls/} subdirectory.
+
+Note that the argument to @code{:pathname} can be either a pathname object or a string.
+A pathname object can be constructed with the @file{#p"foo/bar/"} syntax,
+but this is discouraged because the results of parsing a namestring are not portable.
+A pathname can only be portably constructed with such syntax as
+@code{#.(make-pathname :directory '(:relative "foo" "bar"))},
+and similarly the current directory can only be portably specified as
+@code{#.(make-pathname :directory '(:relative))}.
+However, as of ASDF 2, you can portably use a string to denote a pathname.
+The string will be parsed as a @code{/}-separated path from the current directory,
+such that the empty string @code{""} denotes the current directory, and
+@code{"foo/bar"} (no trailing @code{/} required in the case of modules)
+portably denotes the same subdirectory as above.
+When files are specified, the last @code{/}-separated component is interpreted
+either as the name component of a pathname
+(if the component class specifies a pathname type),
+or as a name component plus optional dot-separated type component
+(if the component class doesn't specifies a pathname type).
+
+@node How do I create a system definition where all the source files have a .cl extension?, How do I mark a source file to be loaded only and not compiled?, I want to put my module's files at the top level. How do I do this?, Issues with using and extending ASDF to define systems
+@subsection How do I create a system definition where all the source files have a .cl extension?
+
+Starting with ASDF 2.014.14, you may just pass
+the builtin class @code{cl-source-file.cl} as
+the @code{:default-component-class} argument to @code{defsystem}:
+
+@lisp
+(defsystem my-cl-system
+ :default-component-class cl-source-file.cl
+ ...)
+@end lisp
+
+Another builtin class @code{cl-source-file.lsp} is offered
+for files ending in @file{.lsp}.
+
+If you want to use a different extension
+for which ASDF doesn't provide builtin support,
+or want to support versions of ASDF
+earlier than 2.014.14 (but later than 2.000),
+you can define a class as follows:
+
+@lisp
+;; Prologue: make sure we're using a sane package.
+(defpackage :my-asdf-extension
+ (:use :asdf :common-lisp)
+ (:export #:cl-source-file.lis))
+(in-package :my-asdf-extension)
+
+(defclass cl-source-file.lis (cl-source-file)
+ ((type :initform "lis")))
+@end lisp
+
+Then you can use it as follows:
+@lisp
+(defsystem my-cl-system
+ :default-component-class my-asdf-extension:cl-source-file.lis
+ ...)
+@end lisp
+
+Of course, if you're in the same package, e.g. in the same file,
+you won't need to use the package qualifier before @code{cl-source-file.lis}.
+Actually, if all you're doing is defining this class
+and using it in the same file without other fancy definitions,
+you might skip package complications:
+
+@lisp
+(in-package :asdf)
+(defclass cl-source-file.lis (cl-source-file)
+ ((type :initform "lis")))
+(defsystem my-cl-system
+ :default-component-class cl-source-file.lis
+ ...)
+@end lisp
+
+It is possible to achieve the same effect
+in a way that supports both ASDF 1 and ASDF 2,
+but really, friends don't let friends use ASDF 1.
+Please upgrade to ASDF 3.
+In short, though: do same as above, but
+@emph{before} you use the class in a @code{defsystem},
+you also define the following method:
+
+@lisp
+(defmethod source-file-type ((f cl-source-file.lis) (s system))
+ (declare (ignorable f s))
+ "lis")
+@end lisp
+
+@node How do I mark a source file to be loaded only and not compiled?, How do I work with readtables?, How do I create a system definition where all the source files have a .cl extension?, Issues with using and extending ASDF to define systems
+@subsection How do I mark a source file to be loaded only and not compiled?
+
+There is no provision in ASDF for ensuring that
+some components are always loaded as source, while others are always
+compiled.
+There is @code{load-source-op} (@pxref{Predefined operations of
+ASDF,load-source-op}), but that is an operation to be applied to a
+system as a whole, not to one or another specific source files.
+While this idea often comes up in discussions,
+it doesn't play well with either the linking model of ECL
+or with various bundle operations.
+In addition, the dependency model of ASDF would have to be modified incompatibly
+to allow for such a trick.
+@c If your code doesn't compile cleanly, fix it.
+@c If compilation makes it slow, use @code{declaim} or @code{eval-when}
+@c to adjust your compiler settings,
+@c or eschew compilation by @code{eval}uating a quoted source form at load-time.
+
+@node How do I work with readtables?, , How do I mark a source file to be loaded only and not compiled?, Issues with using and extending ASDF to define systems
+@subsection How do I work with readtables?
+
+@cindex readtables
+
+It is possible to configure the lisp syntax by modifying the currently-active readtable.
+However, this same readtable is shared globally by all software being compiled by ASDF,
+especially since @code{load} and @code{compile-file} both bind @var{*readtable*},
+so that its value is the same across the build at the start of every file
+(unless overridden by some @code{perform :around} method),
+even if a file locally binds it to a different readtable during the build.
+
+Therefore, the following hygiene restrictions apply. If you don't abide by these restrictions,
+there will be situations where your output files will be corrupted during an incremental build.
+We are not trying to prescribe new restrictions for the sake of good style:
+these restrictions have always applied implicitly, and
+we are simply describing what they have always been.
+
+@itemize
+@item It is forbidden to modifying any standard character or standard macro dispatch defined in the CLHS.
+@item No two dependencies may assign different meanings to the same non-standard character.
+@item Using any non-standard character while expecting the implementation to treat some way
+ counts as such an assignment of meaning.
+@item libraries need to document these assignments of meaning to non-standard characters.
+@item free software libraries will register these changes on:
+ @url{http://www.cliki.net/Macro%20Characters}
+@end itemize
+
+If you want to use readtable modifications that cannot abide by those restrictions,
+you @emph{must} create a different readtable object and set @var{*readtable*}
+to temporarily bind it to your new readtable (which will be undone after processing the file).
+
+For that, we recommend you use system @code{named-readtables}
+to define or combine such readtables using @code{named-readtables:defreadtable}
+and use them using @code{named-readtables:in-readtable}.
+Equivalently, you can use system @code{cl-syntax},
+that itself uses @code{named-readtables},
+but may someday do more with, e.g. @var{*print-pprint-dispatch*}.
+
+For even more advanced syntax modification beyond what a readtable can express,
+you may consider either:
+@itemize
+@item a @code{perform} method that compiles a constant file that contains a single form
+ @code{#.*code-read-with-alternate-reader*} in an environment where this special variable
+ was bound to the code read by your alternate reader, or
+@item using the system @code{reader-interception}.
+@end itemize
+
+Beware that @c unless and until the @code{syntax-control} branch is merged,
+it is unsafe to use ASDF from the REPL to compile or load systems
+while the readtable isn't the shared readtable previously used to build software.
+You @emph{must} manually undo any binding of @var{*readtable*} at the REPL
+and restore its initial value whenever you call @code{operate}
+(via e.g. @code{load-system}, @code{test-system} or @code{require})
+from a REPL that is using a different readtable.
+
+@subsubsection How should my system use a readtable exported by another system?
+
+Use from the @code{named-readtables} system the macro @code{named-readtables:in-readtable}.
+
+If the other system fails to use @code{named-readtables}, fix it and send a patch upstream.
+In the day and age of Quicklisp and clbuild, there is little reason
+to eschew using such an important library anymore.
+
+@subsubsection How should my library make a readtable available to other systems?
+
+Use from the @code{named-readtables} system the macro @code{named-readtables:defreadtable}.
+
+@node ASDF development FAQs, , Issues with using and extending ASDF to define systems, FAQ
+@section ASDF development FAQs
+
+@menu
+* How do run the tests interactively in a REPL?::
+@end menu
+
+@node How do run the tests interactively in a REPL?, , ASDF development FAQs, ASDF development FAQs
+@subsection How do run the tests interactively in a REPL?
+
+This not-so-frequently asked question is primarily for ASDF developers,
+but those who encounter an unexpected error in some test may be
+interested, too.
+
+Here's the procedure for experimenting with tests in a REPL:
+@example
+;; BEWARE! Some tests expect you to be in the .../asdf/test directory
+;; If your REPL is not there yet, change your current directory:
+;; under SLIME, you may: ,change-directory ~/common-lisp/asdf/test/
+;; otherwise you may evaluate something like:
+(require "asdf") (asdf:upgrade-asdf) ;load UIOP & update asdf.lisp
+(uiop:chdir (asdf:system-relative-pathname :asdf "test/"))
+(setf *default-pathname-defaults* (uiop:getcwd))
+
+;; Load the test script support.
+(load "script-support.lisp")
+
+;; Initialize the script support.
+;; This will also change your *package* to asdf-test.
+;; NB: this function is also available from package cl-user,
+;; and also available with the shorter name da in both packages.
+(asdf-test::debug-asdf)
+
+;; In case you modified ASDF since you last tested it,
+;; you need to update asdf.lisp itself by evaluating 'make' in a shell,
+;; or (require "asdf") (asdf:load-system :asdf) in another CL REPL,
+;; if not done in this REPL above.
+;; *Then*, in this REPL, you need to evaluate:
+;(asdf-test::compile-load-asdf)
+
+;; Now, you may experiment with test code from a .script file.
+;; See the instructions given at the end of your failing test
+;; to identify which form is needed, e.g.
+(frob-packages)
+(asdf::with-asdf-cache () (load "test-utilities.script"))
+@end example
-@node Concept Index, Function and Class Index, Inspiration, Top
+@comment FIXME: Add a FAQ about how to use a new system class...
+
+@comment node-name, next, previous, up
+@node Ongoing Work, Bibliography, FAQ, Top
+@unnumbered Ongoing Work
+For an active list of things to be done,
+see the @file{TODO} file in the source repository.
+
+Also, bugs are now tracked on launchpad:
+@url{https://launchpad.net/asdf}.
+
+@node Bibliography, Concept Index, Ongoing Work, Top
+@unnumbered Bibliography
+
+@itemize
+@item Francois-Rene Rideau:
+ ``ASDF 3, or Why Lisp is Now an Acceptable Scripting Language'', 2014.
+ This article describes the innovations in ASDF 3 and 3.1,
+ as well as historical information on previous versions.
+ @url{http://github.com/fare/asdf3-2013}
+@item Alastair Bridgewater:
+ ``Quick-build'' (private communication), 2012.
+ @code{quick-build} is a simple and robust one file, one package build system,
+ similar to @code{faslpath}, in 182 lines of code
+ (117 of which are not blank, not comments, not docstrings).
+ Unhappily, it remains unpublished and its IP status is unclear as of April 2014.
+ @code{asdf/package-system} is mostly compatible with it,
+ modulo a different setup for toplevel hierarchies.
+@item Zach Beane:
+ ``Quicklisp'', 2011.
+ The Quicklisp blog and Xach's livejournal contain information on Quicklisp.
+ @url{http://blog.quicklisp.org/}
+ @url{http://xach.livejournal.com/}
+@item Francois-Rene Rideau and Robert Goldman:
+ ``Evolving ASDF: More Cooperation, Less Coordination'', 2010.
+ This article describes the main issues solved by ASDF 2.
+ @url{http://common-lisp.net/project/asdf/doc/ilc2010draft.pdf}
+ @url{http://www.common-lisp.org/gitweb?p=projects/asdf/ilc2010.git}
+@item Francois-Rene Rideau and Spencer Brody:
+ ``XCVB: an eXtensible Component Verifier and Builder for Common Lisp'', 2009.
+ This article describes XCVB, a proposed competitor for ASDF,
+ many ideas of which have been incorporated into ASDF 2 and 3,
+ though many other of which still haven't.
+ @url{http://common-lisp.net/projects/xcvb/}
+@item Peter von Etter:
+ ``faslpath'', 2009.
+ @code{faslpath} is similar to the latter @code{quick-build}
+ and our letter @code{asdf/package-system} extension,
+ except that it uses the dot @code{.} rather than the slash @code{/} as a separator.
+ @url{https://code.google.com/p/faslpath/}
+@item Drew McDermott:
+ ``A Framework for Maintaining the Coherence of a Running Lisp,''
+ International Lisp Conference, 2005, available in pre-print form at
+ @url{http://www.cs.yale.edu/homes/dvm/papers/lisp05.pdf}
+@item Dan Barlow: ``ASDF Manual'', 2004.
+ Older versions of this document from the days of ASDF 1;
+ they include ideas laid down by Dan Barlow,
+ and comparisons with older defsystems (@code{mk-defsystem})
+ and defsystem (@code{defsystem-4}, kmp's Memo 801).
+@item Marco Antoniotti and Peter Van Eynde:
+ ``@code{DEFSYSTEM}: A @code{make} for Common Lisp, A Thoughtful Re-Implementation of an Old Idea'', 2002.
+ The @file{defsystem-4} proposal available in the CLOCC repository.
+@item Mark Kantrovitz: ``Defsystem: A Portable Make Facility for Common Lisp'', 1990.
+ The classic @file{mk-defsystem}, later variants of which
+ are available in the CLOCC repository as @code{defsystem-3.x}.
+@item Richard Elliot Robbins:
+ ``BUILD: A Tool for Maintaining Consistency in Modular Systems'', MIT AI TR 874, 1985.
+ @url{ftp://publications.ai.mit.edu/ai-publications/pdf/AITR-874.pdf}
+@item Kent M. Pitman (kmp): ``The Description of Large Systems'', MIT AI Memo 801, 1984.
+ Available in updated-for-CL form on the web at
+ @url{http://nhplace.com/kent/Papers/Large-Systems.html}
+@item Dan Weinreb and David Moon:
+ ``Lisp Machine Manual'', MIT, 1981.
+ The famous CHINE NUAL describes one of the earliest variants of DEFSYSTEM.
+ @url{https://bitsavers.trailing-edge.com/pdf/mit/cadr/chinual_4thEd_Jul81.pdf}
+@end itemize
+
+
+@node Concept Index, Function and Class Index, Bibliography, Top
@unnumbered Concept Index
-
+
@printindex cp
@node Function and Class Index, Variable Index, Concept Index, Top
@unnumbered Function and Class Index
-
+
@printindex fn
@node Variable Index, , Function and Class Index, Top
@unnumbered Variable Index
-
-@printindex vr
-
-
+@printindex vr
@bye
-
Repositories / ecl.git / commitdiff