Description: TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. . cl-asdf (2:3.0.0-1) unstable; urgency=low . ASDF 3.0.0 is the first official release of ASDF 3; ASDF 2.27 to 2.33 were pre-releases. Since 2.33, the following changes were done: . * Portability: have *uninteresting-conditions* be empty by default. Move stuff to *usual-uninteresting-conditions*, unused by default. Will make the SBCL team happy. Also, fix tests on ABCL. Fix regression of program-op on ECL, by implicitly linking in UIOP or ASDF. . * UIOP: improvements to slurp-input-stream and thus run-program, notably accepting T as alias for *standard-output*, for better backward-compatibility of the deprecated run-shell-command. New macro with-output-file. . * POIU support enhanced with various tweaks. . * Build cleanup so make and concatenate-source-op create the same asdf.lisp Author: Francois-Rene Rideau --- The information above should follow the Patch Tagging Guidelines, please checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here are templates for supplementary fields that you might want to add: Origin: , Bug: Bug-Debian: http://bugs.debian.org/ Bug-Ubuntu: https://launchpad.net/bugs/ Forwarded: Reviewed-By: Last-Update: --- cl-asdf-3.0.0.orig/Makefile +++ cl-asdf-3.0.0/Makefile @@ -155,7 +155,7 @@ extract-all-tagged-asdf: build/asdf.lisp # Note that the debian git at git://git.debian.org/git/pkg-common-lisp/cl-asdf.git is stale, # as we currently build directly from upstream at git://common-lisp.net/projects/asdf/asdf.git debian-package: mrproper - : $${RELEASE:="$$(git tag -l '2.[0-9][0-9]' | tail -n 1)"} ; echo building package version $$RELEASE ; \ + : $${RELEASE:="$$(git tag -l '3.[0-9].[0-9]' | tail -n 1)"} ; echo building package version $$RELEASE ; \ git-buildpackage --git-debian-branch=release --git-upstream-branch=release --git-upstream-tag=$$RELEASE --git-tag --git-retag --git-ignore-branch # Replace SBCL's ASDF with the current one. -- NOT recommended now that SBCL has ASDF2. --- cl-asdf-3.0.0.orig/test/test-utilities.script +++ cl-asdf-3.0.0/test/test-utilities.script @@ -34,7 +34,11 @@ (assert (version-satisfies (asdf-version) (asdf-version))) (assert - (version-satisfies (asdf-version) "2.0")) + (version-satisfies (asdf-version) "3.0")) +(assert + (not (version-satisfies (asdf-version) "2.0"))) +(assert + (version<= "2.0" (asdf-version))) (assert (not (version-satisfies (asdf-version) "666"))) (assert-pathnames-equal --- cl-asdf-3.0.0.orig/uiop/run-program.lisp +++ cl-asdf-3.0.0/uiop/run-program.lisp @@ -137,7 +137,7 @@ by /bin/sh in POSIX" ;;;; 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) (funcall function input-stream)) --- /dev/null +++ cl-asdf-3.0.0/build/asdf.lisp @@ -0,0 +1,9725 @@ +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- +;;; This is ASDF 3.0.0: Another System Definition Facility. +;;; +;;; Feedback, bug reports, and patches are all welcome: +;;; please mail to . +;;; Note first that the canonical source for ASDF is presently +;;; . +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the git master +;;; branch is the latest development version, whereas the git release +;;; branch may be slightly older but is considered `stable' + +;;; -- LICENSE START +;;; (This is the MIT / X Consortium license as taken from +;;; http://www.opensource.org/licenses/mit-license.html on or about +;;; Monday; July 13, 2009) +;;; +;;; Copyright (c) 2001-2012 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 +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; -- LICENSE END + +;;; The problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file. + +#+xcvb (module ()) + +(in-package :cl-user) + +#+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) +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (member :asdf3 *features*) + (let* ((existing-version + (when (find-package :asdf) + (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) + (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) + (etypecase ver + (string ver) + (cons (format nil "~{~D~^.~}" ver)) + (null "1.0")))))) + (first-dot (when existing-version (position #\. existing-version))) + (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot)))) + (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))) + (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. +;; +;; See https://bugs.launchpad.net/asdf/+bug/485687 +;; + +(defpackage :uiop/package + ;; 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 + ;; 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) + (:export + #:find-package* #:find-symbol* #:symbol-call + #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* + #:symbol-shadowing-p #:home-package-p + #:symbol-package-name #:standard-common-lisp-symbol-p + #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol + #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol + #:ensure-package-unused #:delete-package* + #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away + #:package-definition-form #:parse-define-package-form + #:ensure-package #:define-package)) + +(in-package :uiop/package) + +;;;; General purpose package utilities + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun find-package* (package-designator &optional (error t)) + (let ((package (find-package package-designator))) + (cond + (package package) + (error (error "No package named ~S" (string package-designator))) + (t nil)))) + (defun find-symbol* (name package-designator &optional (error t)) + "Find a symbol in a package of given string'ified NAME; +unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax +by letting you supply a symbol or keyword for the name; +also works well when the package is not present. +If optional ERROR argument is NIL, return NIL instead of an error +when the symbol is not found." + (block nil + (let ((package (find-package* package-designator error))) + (when package ;; package error handled by find-package* already + (multiple-value-bind (symbol status) (find-symbol (string name) package) + (cond + (status (return (values symbol status))) + (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) + (values nil nil)))) + (defun symbol-call (package name &rest args) + "Call a function associated with symbol of given name in given package, +with given ARGS. Useful when the call is read before the package is loaded, +or when loading the package is optional." + (apply (find-symbol* name package) args)) + (defun intern* (name package-designator &optional (error t)) + (intern (string name) (find-package* package-designator error))) + (defun export* (name package-designator) + (let* ((package (find-package* package-designator)) + (symbol (intern* name package))) + (export (or symbol (list symbol)) package))) + (defun import* (symbol package-designator) + (import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadowing-import* (symbol package-designator) + (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadow* (name package-designator) + (shadow (string name) (find-package* package-designator))) + (defun make-symbol* (name) + (etypecase name + (string (make-symbol name)) + (symbol (copy-symbol name)))) + (defun unintern* (name package-designator &optional (error t)) + (block nil + (let ((package (find-package* package-designator error))) + (when package + (multiple-value-bind (symbol status) (find-symbol* name package error) + (cond + (status (unintern symbol package) + (return (values symbol status))) + (error (error "symbol ~A not present in package ~A" + (string symbol) (package-name package)))))) + (values nil nil)))) + (defun symbol-shadowing-p (symbol package) + (and (member symbol (package-shadowing-symbols package)) t)) + (defun home-package-p (symbol package) + (and package (let ((sp (symbol-package symbol))) + (and sp (let ((pp (find-package* package))) + (and pp (eq sp pp)))))))) + + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun symbol-package-name (symbol) + (let ((package (symbol-package symbol))) + (and package (package-name package)))) + (defun standard-common-lisp-symbol-p (symbol) + (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) + (and (eq sym symbol) (eq status :external)))) + (defun reify-package (package &optional package-context) + (if (eq package package-context) t + (etypecase package + (null nil) + ((eql (find-package :cl)) :cl) + (package (package-name package))))) + (defun unreify-package (package &optional package-context) + (etypecase package + (null nil) + ((eql t) package-context) + ((or symbol string) (find-package package)))) + (defun reify-symbol (symbol &optional package-context) + (etypecase symbol + ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) + (symbol (vector (symbol-name symbol) + (reify-package (symbol-package symbol) package-context))))) + (defun unreify-symbol (symbol &optional package-context) + (etypecase symbol + (symbol symbol) + ((simple-vector 2) + (let* ((symbol-name (svref symbol 0)) + (package-foo (svref symbol 1)) + (package (unreify-package package-foo package-context))) + (if package (intern* symbol-name package) + (make-symbol* symbol-name))))))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defvar *all-package-happiness* '()) + (defvar *all-package-fishiness* (list t)) + (defun record-fishy (info) + ;;(format t "~&FISHY: ~S~%" info) + (push info *all-package-fishiness*)) + (defmacro when-package-fishiness (&body body) + `(when *all-package-fishiness* ,@body)) + (defmacro note-package-fishiness (&rest info) + `(when-package-fishiness (record-fishy (list ,@info))))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + #+(or clisp clozure) + (defun get-setf-function-symbol (symbol) + #+clisp (let ((sym (get symbol 'system::setf-function))) + (if sym (values sym :setf-function) + (let ((sym (get symbol 'system::setf-expander))) + (if sym (values sym :setf-expander) + (values nil nil))))) + #+clozure (gethash symbol ccl::%setf-function-names%)) + #+(or clisp clozure) + (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) + #+clisp (assert (member kind '(:setf-function :setf-expander))) + #+clozure (assert (eq kind t)) + #+clisp + (cond + ((null new-setf-symbol) + (remprop symbol 'system::setf-function) + (remprop symbol 'system::setf-expander)) + ((eq kind :setf-function) + (setf (get symbol 'system::setf-function) new-setf-symbol)) + ((eq kind :setf-expander) + (setf (get symbol 'system::setf-expander) new-setf-symbol)) + (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" + kind symbol new-setf-symbol))) + #+clozure + (progn + (gethash symbol ccl::%setf-function-names%) new-setf-symbol + (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) + #+(or clisp clozure) + (defun create-setf-function-symbol (symbol) + #+clisp (system::setf-symbol symbol) + #+clozure (ccl::construct-setf-function-name symbol)) + (defun set-dummy-symbol (symbol reason other-symbol) + (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) + (defun make-dummy-symbol (symbol) + (let ((dummy (copy-symbol symbol))) + (set-dummy-symbol dummy 'replacing symbol) + (set-dummy-symbol symbol 'replaced-by dummy) + dummy)) + (defun dummy-symbol (symbol) + (get symbol 'dummy-symbol)) + (defun get-dummy-symbol (symbol) + (let ((existing (dummy-symbol symbol))) + (if existing (values (cdr existing) (car existing)) + (make-dummy-symbol symbol)))) + (defun nuke-symbol-in-package (symbol package-designator) + (let ((package (find-package* package-designator)) + (name (symbol-name symbol))) + (multiple-value-bind (sym stat) (find-symbol name package) + (when (and (member stat '(:internal :external)) (eq symbol sym)) + (if (symbol-shadowing-p symbol package) + (shadowing-import* (get-dummy-symbol symbol) package) + (unintern* symbol package)))))) + (defun nuke-symbol (symbol &optional (packages (list-all-packages))) + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind (nuke-symbol setf-symbol))) + (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) + (defun rehome-symbol (symbol package-designator) + "Changes the home package of a symbol, also leaving it present in its old home if any" + (let* ((name (symbol-name symbol)) + (package (find-package* package-designator)) + (old-package (symbol-package symbol)) + (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) + (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) + (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) + (unless (eq package old-package) + (let ((overwritten-symbol-shadowing-p + (and overwritten-symbol-status + (symbol-shadowing-p overwritten-symbol package)))) + (note-package-fishiness + :rehome-symbol name + (when old-package (package-name old-package)) old-status (and shadowing t) + (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) + (when old-package + (if shadowing + (shadowing-import* shadowing old-package)) + (unintern* symbol old-package)) + (cond + (overwritten-symbol-shadowing-p + (shadowing-import* symbol package)) + (t + (when overwritten-symbol-status + (unintern* overwritten-symbol package)) + (import* symbol package))) + (if shadowing + (shadowing-import* symbol old-package) + (import* symbol old-package)) + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind + (let* ((setf-function (fdefinition setf-symbol)) + (new-setf-symbol (create-setf-function-symbol symbol))) + (note-package-fishiness + :setf-function + name (package-name package) + (symbol-name setf-symbol) (symbol-package-name setf-symbol) + (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) + (when (symbol-package setf-symbol) + (unintern* setf-symbol (symbol-package setf-symbol))) + (setf (fdefinition new-setf-symbol) setf-function) + (set-setf-function-symbol new-setf-symbol symbol kind)))) + #+(or clisp clozure) + (multiple-value-bind (overwritten-setf foundp) + (get-setf-function-symbol overwritten-symbol) + (when foundp + (unintern overwritten-setf))) + (when (eq old-status :external) + (export* symbol old-package)) + (when (eq overwritten-symbol-status :external) + (export* symbol package)))) + (values overwritten-symbol overwritten-symbol-status)))) + (defun ensure-package-unused (package) + (loop :for p :in (package-used-by-list package) :do + (unuse-package package p))) + (defun delete-package* (package &key nuke) + (let ((p (find-package package))) + (when p + (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) + (ensure-package-unused p) + (delete-package package)))) + (defun package-names (package) + (cons (package-name package) (package-nicknames package))) + (defun packages-from-names (names) + (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) + (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) + separator + (index (random most-positive-fixnum))) + (loop :for i :from index + :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) + :thereis (and (not (find-package n)) n))) + (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) + (let ((new-name + (apply 'fresh-package-name + :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) + (record-fishy (list :rename-away (package-names p) new-name)) + (rename-package p new-name)))) + + +;;; Communicable representation of symbol and package information + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun package-definition-form (package-designator + &key (nicknamesp t) (usep t) + (shadowp t) (shadowing-import-p t) + (exportp t) (importp t) internp (error t)) + (let* ((package (or (find-package* package-designator error) + (return-from package-definition-form nil))) + (name (package-name package)) + (nicknames (package-nicknames package)) + (use (mapcar #'package-name (package-use-list package))) + (shadow ()) + (shadowing-import (make-hash-table :test 'equal)) + (import (make-hash-table :test 'equal)) + (export ()) + (intern ())) + (when package + (loop :for sym :being :the :symbols :in package + :for status = (nth-value 1 (find-symbol* sym package)) :do + (ecase status + ((nil :inherited)) + ((:internal :external) + (let* ((name (symbol-name sym)) + (external (eq status :external)) + (home (symbol-package sym)) + (home-name (package-name home)) + (imported (not (eq home package))) + (shadowing (symbol-shadowing-p sym package))) + (cond + ((and shadowing imported) + (push name (gethash home-name shadowing-import))) + (shadowing + (push name shadow)) + (imported + (push name (gethash home-name import)))) + (cond + (external + (push name export)) + (imported) + (t (push name intern))))))) + (labels ((sort-names (names) + (sort names #'string<)) + (table-keys (table) + (loop :for k :being :the :hash-keys :of table :collect k)) + (when-relevant (key value) + (when value (list (cons key value)))) + (import-options (key table) + (loop :for i :in (sort-names (table-keys table)) + :collect `(,key ,i ,@(sort-names (gethash i table)))))) + `(defpackage ,name + ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) + (:use ,@(and usep (sort-names use))) + ,@(when-relevant :shadow (and shadowp (sort-names shadow))) + ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) + ,@(import-options :import-from (and importp import)) + ,@(when-relevant :export (and exportp (sort-names export))) + ,@(when-relevant :intern (and internp (sort-names intern))))))))) + + +;;; ensure-package, define-package +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun ensure-shadowing-import (name to-package from-package shadowed imported) + (check-type name string) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (let ((import-me (find-symbol* name from-package))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (cond + ((gethash name shadowed) + (unless (eq import-me existing) + (error "Conflicting shadowings for ~A" name))) + (t + (setf (gethash name shadowed) t) + (setf (gethash name imported) t) + (unless (or (null status) + (and (member status '(:internal :external)) + (eq existing import-me) + (symbol-shadowing-p existing to-package))) + (note-package-fishiness + :shadowing-import name + (package-name from-package) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name to-package) status + (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) + (shadowing-import* import-me to-package)))))) + (defun ensure-imported (import-me into-package &optional from-package) + (check-type import-me symbol) + (check-type into-package package) + (check-type from-package (or null package)) + (let ((name (symbol-name import-me))) + (multiple-value-bind (existing status) (find-symbol name into-package) + (cond + ((not status) + (import* import-me into-package)) + ((eq import-me existing)) + (t + (let ((shadowing-p (symbol-shadowing-p existing into-package))) + (note-package-fishiness + :ensure-imported name + (and from-package (package-name from-package)) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name into-package) + status + (and status (or (home-package-p existing into-package) (symbol-package-name existing))) + shadowing-p) + (cond + ((or shadowing-p (eq status :inherited)) + (shadowing-import* import-me into-package)) + (t + (unintern* existing into-package) + (import* import-me into-package)))))))) + (values)) + (defun ensure-import (name to-package from-package shadowed imported) + (check-type name string) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (multiple-value-bind (import-me import-status) (find-symbol name from-package) + (when (null import-status) + (note-package-fishiness + :import-uninterned name (package-name from-package) (package-name to-package)) + (setf import-me (intern* name from-package))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (cond + ((and imported (gethash name imported)) + (unless (and status (eq import-me existing)) + (error "Can't import ~S from both ~S and ~S" + name (package-name (symbol-package existing)) (package-name from-package)))) + ((gethash name shadowed) + (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) + (t + (setf (gethash name imported) t)))) + (ensure-imported import-me to-package from-package))) + (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type from-package package) + (check-type mixp (member nil t)) ; no cl:boolean on Genera + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (multiple-value-bind (existing status) (find-symbol name to-package) + (let* ((sp (symbol-package symbol)) + (in (gethash name inherited)) + (xp (and status (symbol-package existing)))) + (when (null sp) + (note-package-fishiness + :import-uninterned name + (package-name from-package) (package-name to-package) mixp) + (import* symbol from-package) + (setf sp (package-name from-package))) + (cond + ((gethash name shadowed)) + (in + (unless (equal sp (first in)) + (if mixp + (ensure-shadowing-import name to-package (second in) shadowed imported) + (error "Can't inherit ~S from ~S, it is inherited from ~S" + name (package-name sp) (package-name (first in)))))) + ((gethash name imported) + (unless (eq symbol existing) + (error "Can't inherit ~S from ~S, it is imported from ~S" + name (package-name sp) (package-name xp)))) + (t + (setf (gethash name inherited) (list sp from-package)) + (when (and status (not (eq sp xp))) + (let ((shadowing (symbol-shadowing-p existing to-package))) + (note-package-fishiness + :inherited name + (package-name from-package) + (or (home-package-p symbol from-package) (symbol-package-name symbol)) + (package-name to-package) + (or (home-package-p existing to-package) (symbol-package-name existing))) + (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported) + (unintern* existing to-package))))))))) + (defun ensure-mix (name symbol to-package from-package shadowed imported inherited) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (unless (gethash name shadowed) + (multiple-value-bind (existing status) (find-symbol name to-package) + (let* ((sp (symbol-package symbol)) + (im (gethash name imported)) + (in (gethash name inherited))) + (cond + ((or (null status) + (and status (eq symbol existing)) + (and in (eq sp (first in)))) + (ensure-inherited name symbol to-package from-package t shadowed imported inherited)) + (in + (remhash name inherited) + (ensure-shadowing-import name to-package (second in) shadowed imported)) + (im + (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]" + name (package-name from-package) + (home-package-p symbol from-package) (symbol-package-name symbol) + (package-name to-package) + (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) + (check-type name string) + (check-type recycle list) + (check-type exported hash-table) + (when (gethash name exported) ;; don't bother recycling private symbols + (let (recycled foundp) + (dolist (r recycle (values recycled foundp)) + (multiple-value-bind (symbol status) (find-symbol name r) + (when (and status (home-package-p symbol r)) + (cond + (foundp + ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. + (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r))) + (t + (setf recycled symbol foundp r))))))))) + (defun symbol-recycled-p (sym recycle) + (check-type sym symbol) + (check-type recycle list) + (and (member (symbol-package sym) recycle) t)) + (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) + (check-type name string) + (check-type package package) + (check-type intern (member nil t)) ; no cl:boolean on Genera + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (unless (or (gethash name shadowed) + (gethash name imported) + (gethash name inherited)) + (multiple-value-bind (existing status) + (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) + (cond + ((and status (eq existing recycled) (eq previous package))) + (previous + (rehome-symbol recycled package)) + ((and status (eq package (symbol-package existing)))) + (t + (when status + (note-package-fishiness + :ensure-symbol name + (reify-package (symbol-package existing) package) + status intern) + (unintern existing)) + (when intern + (intern* name package)))))))) + (declaim (ftype function ensure-exported)) + (defun ensure-exported-to-user (name symbol to-package &optional recycle) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type recycle list) + (assert (equal name (symbol-name symbol))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (unless (and status (eq symbol existing)) + (let ((accessible + (or (null status) + (let ((shadowing (symbol-shadowing-p existing to-package)) + (recycled (symbol-recycled-p existing recycle))) + (unless (and shadowing (not recycled)) + (note-package-fishiness + :ensure-export name (symbol-package-name symbol) + (package-name to-package) + (or (home-package-p existing to-package) (symbol-package-name existing)) + status shadowing) + (if (or (eq status :inherited) shadowing) + (shadowing-import* symbol to-package) + (unintern existing to-package)) + t))))) + (when (and accessible (eq status :external)) + (ensure-exported name symbol to-package recycle)))))) + (defun ensure-exported (name symbol from-package &optional recycle) + (dolist (to-package (package-used-by-list from-package)) + (ensure-exported-to-user name symbol to-package recycle)) + (unless (eq from-package (symbol-package symbol)) + (ensure-imported symbol from-package)) + (export* name from-package)) + (defun ensure-export (name from-package &optional recycle) + (multiple-value-bind (symbol status) (find-symbol* name from-package) + (unless (eq status :external) + (ensure-exported name symbol from-package recycle)))) + (defun ensure-package (name &key + nicknames documentation use + shadow shadowing-import-from + import-from export intern + recycle mix reexport + unintern) + #+(or gcl2.6 genera) (declare (ignore documentation)) + (let* ((package-name (string name)) + (nicknames (mapcar #'string nicknames)) + (names (cons package-name nicknames)) + (previous (packages-from-names names)) + (discarded (cdr previous)) + (to-delete ()) + (package (or (first previous) (make-package package-name :nicknames nicknames))) + (recycle (packages-from-names recycle)) + (use (mapcar 'find-package* use)) + (mix (mapcar 'find-package* mix)) + (reexport (mapcar 'find-package* reexport)) + (shadow (mapcar 'string shadow)) + (export (mapcar 'string export)) + (intern (mapcar 'string intern)) + (unintern (mapcar 'string unintern)) + (shadowed (make-hash-table :test 'equal)) ; string to bool + (imported (make-hash-table :test 'equal)) ; string to bool + (exported (make-hash-table :test 'equal)) ; string to bool + ;; 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) + (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)) + (unuse-package p package)) + (loop :for p :in discarded + :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) + (package-names p)) + :do (note-package-fishiness :nickname name (package-names p)) + (cond (n (rename-package p (first n) (rest n))) + (t (rename-package-away p) + (push p to-delete)))) + (rename-package package package-name nicknames) + (dolist (name unintern) + (multiple-value-bind (existing status) (find-symbol name package) + (when status + (unless (eq status :inherited) + (note-package-fishiness + :unintern (package-name package) name (symbol-package-name existing) status) + (unintern* name package nil))))) + (dolist (name export) + (setf (gethash name exported) t)) + (dolist (p reexport) + (do-external-symbols (sym p) + (setf (gethash (string sym) exported) t))) + (do-external-symbols (sym package) + (let ((name (symbol-name sym))) + (unless (gethash name exported) + (note-package-fishiness + :over-export (package-name package) name + (or (home-package-p sym package) (symbol-package-name sym))) + (unexport sym package)))) + (dolist (name shadow) + (setf (gethash name shadowed) t) + (multiple-value-bind (existing status) (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) + (let ((shadowing (and status (symbol-shadowing-p existing package)))) + (cond + ((eq previous package)) + (previous + (rehome-symbol recycled package)) + ((or (member status '(nil :inherited)) + (home-package-p existing package))) + (t + (let ((dummy (make-symbol name))) + (note-package-fishiness + :shadow-imported (package-name package) name + (symbol-package-name existing) status shadowing) + (shadowing-import* dummy package) + (import* dummy package))))))) + (shadow* name package)) + (loop :for (p . syms) :in shadowing-import-from + :for pp = (find-package* p) :do + (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) + (loop :for p :in mix + :for pp = (find-package* p) :do + (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) + (loop :for (p . syms) :in import-from + :for pp = (find-package p) :do + (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) + (dolist (p (append use mix)) + (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) + (use-package p package)) + (loop :for name :being :the :hash-keys :of exported :do + (ensure-symbol name package t recycle shadowed imported inherited exported) + (ensure-export name package recycle)) + (dolist (name intern) + (ensure-symbol name package t recycle shadowed imported inherited exported)) + (do-symbols (sym package) + (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) + (map () 'delete-package* to-delete) + package))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun parse-define-package-form (package clauses) + (loop + :with use-p = nil :with recycle-p = nil + :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 :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) + :finally (return `(,package + :nicknames ,nicknames :documentation ,documentation + :use ,(if use-p use '(:common-lisp)) + :shadow ,shadow :shadowing-import-from ,shadowing-import-from + :import-from ,import-from :export ,export :intern ,intern + :recycle ,(if recycle-p recycle (cons package nicknames)) + :mix ,mix :reexport ,reexport :unintern ,unintern))))) + +(defmacro define-package (package &rest clauses) + (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)) + (eval-when (:compile-toplevel :load-toplevel :execute) + ,ensure-form)))) + +;;;; Final tricks to keep various implementations happy. +;; We want most such tricks in common-lisp.lisp, +;; but these need to be done before the define-package form there, +;; that we nevertheless want to be the very first form. +(eval-when (:load-toplevel :compile-toplevel :execute) + #+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*)))) + +;; Compatibility with whoever calls asdf/package +(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) +;;;; ------------------------------------------------------------------------- +;;;; Handle compatibility with multiple implementations. +;;; This file is for papering over the deficiencies and peculiarities +;;; of various Common Lisp implementations. +;;; For implementation-specific access to the system, see os.lisp instead. +;;; A few functions are defined here, but actually exported from utility; +;;; from this package only common-lisp symbols are exported. + +(uiop/package:define-package :uiop/common-lisp + (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) + (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package) + (:reexport :common-lisp) + (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) + #+allegro (:intern #:*acl-warn-save*) + #+cormanlisp (:shadow #:user-homedir-pathname) + #+cormanlisp + (: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)) +(in-package :uiop/common-lisp) + +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us port it.") + +;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. + + +;;;; Early meta-level tweaks + +#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) +(eval-when (:load-toplevel :compile-toplevel :execute) + (pushnew :asdf-unicode *features*)) + +#+allegro +(eval-when (:load-toplevel :compile-toplevel :execute) + (defparameter *acl-warn-save* + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + excl:*warn-on-nested-reader-conditionals*)) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* nil)) + (setf *print-readably* nil)) + +#+cormanlisp +(eval-when (:load-toplevel :compile-toplevel :execute) + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun translate-logical-pathname (x) x) + (defun user-homedir-pathname (&optional host) + (declare (ignore host)) + (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) + +#+ecl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf *load-verbose* 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 +(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)))))) + +#+genera +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path))))) + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick + (read-from-string + "(eval-when (:load-toplevel :compile-toplevel :execute) + (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) + (ccl:define-entry-point (_system \"system\") ((name :string)) :int) + ;; Note: ASDF may expect user-homedir-pathname to provide + ;; the pathname of the current user's home directory, whereas + ;; MCL by default provides the directory from which MCL was started. + ;; See http://code.google.com/p/mcl/wiki/Portability + (defun user-homedir-pathname () + (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) + (defun probe-posix (posix-namestring) + \"If a file exists for the posix namestring, return the pathname\" + (ccl::with-cstrs ((cpath posix-namestring)) + (ccl::rlet ((is-dir :boolean) + (fsref :fsref)) + (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) + (ccl::%path-from-fsref fsref is-dir))))))")) + +#+mkcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (require :cmp) + (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics + + +;;;; Looping +(eval-when (:load-toplevel :compile-toplevel :execute) + (defmacro loop* (&rest rest) + #-genera `(loop ,@rest) + #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh. + + +;;;; 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))) + (let ((length (length string)) (stream nil)) + (labels ((emit-string (x &optional (start 0) (end (length x))) + (when (< start end) + (unless stream (setf stream (make-string-output-stream))) + (write-string x stream :start start :end end))) + (emit-substring (start end) + (when (and (zerop start) (= end length)) + (return-from frob-substrings string)) + (emit-string string start end)) + (recurse (substrings start end) + (cond + ((>= start end)) + ((null substrings) (emit-substring start end)) + (t (let* ((sub-spec (first substrings)) + (sub (if (consp sub-spec) (car sub-spec) sub-spec)) + (fun (if (consp sub-spec) (cdr sub-spec) frob)) + (found (search sub string :start2 start :end2 end)) + (more (rest substrings))) + (cond + (found + (recurse more start found) + (etypecase fun + (null) + (string (emit-string fun)) + (function (funcall fun sub #'emit-string))) + (recurse substrings (+ found (length sub)) end)) + (t + (recurse more start end)))))))) + (recurse substrings 0 length)) + (if stream (get-output-stream-string stream) ""))) + + (defmacro compatfmt (format) + #+(or gcl genera) + (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) + #-(or gcl genera) format)) + + +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities for ASDF + +(uiop/package:define-package :uiop/utility + (: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-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings + #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt + #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + (: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 + #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists + #:remove-plist-keys #:remove-plist-key ;; plists + #:emptyp ;; sequences + #:+non-base-chars-exist-p+ ;; characters + #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings + #:first-char #:last-char #:split-string + #:string-prefix-p #:string-enclosed-p #:string-suffix-p + #:find-class* ;; CLOS + #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps + #:earlier-stamp #:stamps-earliest #:earliest-stamp + #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f + #:list-to-hash-set ;; hash-table + #:ensure-function #:access-at #:access-at-count ;; functions + #:call-function #:call-functions #:register-hook-function + #:match-condition-p #:match-any-condition-p ;; conditions + #:call-with-muffled-conditions #:with-muffled-conditions + #:lexicographic< #:lexicographic<= + #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version +(in-package :uiop/utility) + +;;;; Defining functions in a way compatible with hot-upgrade: +;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, +;; thus replacing the function without warning or error +;; even if the signature and/or generic-ness of the function has changed. +;; For a generic function, this invalidates any previous DEFMETHOD. +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun undefine-function (function-spec) + (cond + ((symbolp function-spec) + #+clisp + (let ((f (and (fboundp function-spec) (fdefinition function-spec)))) + (when (typep f 'clos:standard-generic-function) + (loop :for m :in (clos:generic-function-methods f) + :do (remove-method f m)))) + (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)) + (t (error "bad function spec ~S" function-spec)))) + (defun undefine-functions (function-spec-list) + (map () 'undefine-function function-spec-list)) + (macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + (destructuring-bind (name &key (supersede t)) + (if (or (atom name) (eq (car name) 'setf)) + (list name :supersede nil) + 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 + `((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) + `(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))) + (otherwise form))) + form))))) + +;;; Magic debugging help. See contrib/debug.lisp +(with-upgradability () + (defvar *uiop-debug-utility* + '(or (ignore-errors + (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) + (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp")) + "form that evaluates to the pathname to your favorite debugging utilities") + + (defmacro uiop-debug (&rest keys) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (load-uiop-debug-utility ,@keys))) + + (defun load-uiop-debug-utility (&key package utility-file) + (let* ((*package* (if package (find-package package) *package*)) + (keyword (read-from-string + (format nil ":DBG-~:@(~A~)" (package-name *package*))))) + (unless (member keyword *features*) + (let* ((utility-file (or utility-file *uiop-debug-utility*)) + (file (ignore-errors (probe-file (eval utility-file))))) + (if file (load file) + (error "Failed to locate debug utility file: ~S" utility-file))))))) + + +;;; Flow control +(with-upgradability () + (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))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (if (and ,@variables) + ,then-form + ,else-form))))) + +;;; List manipulation +(with-upgradability () + (defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." + (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) + ,@body + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) + + (define-modify-macro appendf (&rest args) + append "Append onto list") ;; only to be used on short lists. + + (defun length=n-p (x n) ;is it that (= (length x) n) ? + (check-type n (integer 0 *)) + (loop + :for l = x :then (cdr l) + :for i :downfrom n :do + (cond + ((zerop i) (return (null l))) + ((not (consp l)) (return nil))))) + + (defun ensure-list (x) + (if (listp x) x (list x)))) + + +;;; remove a key from a plist, i.e. for keyword argument cleanup +(with-upgradability () + (defun remove-plist-key (key plist) + "Remove a single key from a plist" + (loop* :for (k v) :on plist :by #'cddr + :unless (eq k key) + :append (list k v))) + + (defun remove-plist-keys (keys plist) + "Remove a list of keys from a plist" + (loop* :for (k v) :on plist :by #'cddr + :unless (member k keys) + :append (list k v)))) + + +;;; Sequences +(with-upgradability () + (defun emptyp (x) + "Predicate that is true for an empty sequence" + (or (null x) (and (vectorp x) (zerop (length x)))))) + + +;;; Characters +(with-upgradability () + (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) + + +;;; Strings +(with-upgradability () + (defun base-string-p (string) + (declare (ignorable string)) + (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) + + (defun strings-common-element-type (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)) + + (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))) + :element-type (strings-common-element-type strings)) + :with pos = 0 + :for input :in strings + :do (etypecase input + (null) + (character (setf (char output pos) input) (incf pos)) + (string (replace output input :start1 pos) (incf pos (length input)))) + :finally (return output))) + + (defun strcat (&rest strings) + (reduce/strcat strings)) + + (defun first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + + (defun last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + + (defun split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. +If MAX is specified, then no more than max(1,MAX) components will be returned, +starting the separation from the end, e.g. when called with arguments + \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." + (block () + (let ((list nil) (words 0) (end (length string))) + (flet ((separatorp (char) (find char separator)) + (done () (return (cons (subseq string 0 end) list)))) + (loop + :for start = (if (and max (>= words (1- max))) + (done) + (position-if #'separatorp string :end end :from-end t)) + :do (when (null start) (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) + + (defun string-prefix-p (prefix string) + "Does STRING begin with PREFIX?" + (let* ((x (string prefix)) + (y (string string)) + (lx (length x)) + (ly (length y))) + (and (<= lx ly) (string= x y :end2 lx)))) + + (defun string-suffix-p (string suffix) + "Does STRING end with SUFFIX?" + (let* ((x (string string)) + (y (string suffix)) + (lx (length x)) + (ly (length y))) + (and (<= ly lx) (string= x y :start1 (- lx ly))))) + + (defun string-enclosed-p (prefix string suffix) + "Does STRING begin with PREFIX and end with SUFFIX?" + (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))))) + + +;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype stamp () '(or real boolean))) +(with-upgradability () + (defun stamp< (x y) + (etypecase x + (null (and y t)) + ((eql t) nil) + (real (etypecase y + (null nil) + ((eql t) t) + (real (< x y)))))) + (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) + (defun stamp*< (&rest list) (stamps< list)) + (defun stamp<= (x y) (not (stamp< y x))) + (defun earlier-stamp (x y) (if (stamp< x y) x y)) + (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) + (defun earliest-stamp (&rest list) (stamps-earliest list)) + (defun later-stamp (x y) (if (stamp< x y) y x)) + (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) + (defun latest-stamp (&rest list) (stamps-latest list)) + (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)) + "Coerce the object FUN into a function. + +If FUN is a FUNCTION, return it. +If the FUN is a non-sequence literal constant, return constantly that, +i.e. for a boolean keyword character number or pathname. +Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. +If FUN is a CONS, return the function that applies its CAR +to the appended list of the rest of its CDR and the arguments. +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)))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + + (defun access-at (object at) + "Given an OBJECT and an AT specifier, list of successive accessors, +call each accessor on the result of the previous calls. +An accessor may be an integer, meaning a call to ELT, +a keyword, meaning a call to GETF, +NIL, meaning identity, +a function or other symbol, meaning itself, +or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. +As a degenerate case, the AT specifier may be an atom of a single such accessor +instead of a list." + (flet ((access (object accessor) + (etypecase accessor + (function (funcall accessor object)) + (integer (elt object accessor)) + (keyword (getf object accessor)) + (null object) + (symbol (funcall accessor object)) + (cons (funcall (ensure-function accessor) object))))) + (if (listp at) + (dolist (accessor at object) + (setf object (access object accessor))) + (access object at)))) + + (defun access-at-count (at) + "From an AT specification, extract a COUNT of maximum number + of sub-objects to read as per ACCESS-AT" + (cond + ((integerp at) + (1+ at)) + ((and (consp at) (integerp (first at))) + (1+ (first at))))) + + (defun call-function (function-spec &rest arguments) + (apply (ensure-function function-spec) arguments)) + + (defun call-functions (function-specs) + (map () 'call-function function-specs)) + + (defun register-hook-function (variable hook &optional call-now-p) + (pushnew hook (symbol-value variable)) + (when call-now-p (call-function hook)))) + + +;;; Version handling +(with-upgradability () + (defun unparse-version (version-list) + (format nil "~{~D~^.~}" version-list)) + + (defun parse-version (version-string &optional on-error) + "Parse a VERSION-STRING as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid; +otherwise return NIL. + +When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, +with format arguments explaining why the version is invalid. +ON-ERROR is also called if the version is not canonical +in that it doesn't print back to itself, but the list is returned anyway." + (block nil + (unless (stringp version-string) + (call-function on-error "~S: ~S is not a string" 'parse-version version-string) + (return)) + (unless (loop :for prev = nil :then c :for c :across version-string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version version-string) + (return)) + (let* ((version-list + (mapcar #'parse-integer (split-string version-string :separator "."))) + (normalized-version (unparse-version version-list))) + (unless (equal version-string normalized-version) + (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) + version-list))) + + (defun lexicographic< (< x y) + (cond ((null y) nil) + ((null x) t) + ((funcall < (car x) (car y)) t) + ((funcall < (car y) (car x)) nil) + (t (lexicographic< < (cdr x) (cdr y))))) + + (defun lexicographic<= (< x y) + (not (lexicographic< < y x))) + + (defun version< (version1 version2) + (let ((v1 (parse-version version1 nil)) + (v2 (parse-version version2 nil))) + (lexicographic< '< v1 v2))) + + (defun version<= (version1 version2) + (not (version< version2 version1))) + + (defun version-compatible-p (provided-version required-version) + "Is the provided version a compatible substitution for the required-version? +If major versions differ, it's not compatible. +If they are equal, then any later version is compatible, +with later being determined by a lexicographical comparison of minor numbers." + (let ((x (parse-version provided-version nil)) + (y (parse-version required-version nil))) + (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))) + + +;;; Condition control + +(with-upgradability () + (defparameter +simple-condition-format-control-slot+ + #+abcl 'system::format-control + #+allegro 'excl::format-control + #+clisp 'system::$format-control + #+clozure 'ccl::format-control + #+(or cmu scl) 'conditions::format-control + #+ecl '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 + "Name of the slot for FORMAT-CONTROL in simple-condition") + + (defun match-condition-p (x condition) + "Compare received CONDITION to some pattern X: +a symbol naming a condition class, +a simple vector of length 2, arguments to find-symbol* with result as above, +or a string describing the format-control of a simple-condition." + (etypecase x + (symbol (typep condition x)) + ((simple-vector 2) + (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))) + (function (funcall x condition)) + (string (and (typep condition 'simple-condition) + ;; On SBCL, it's always set and the check triggers a warning + #+(or allegro clozure cmu lispworks scl) + (slot-boundp condition +simple-condition-format-control-slot+) + (ignore-errors (equal (simple-condition-format-control condition) x)))))) + + (defun match-any-condition-p (condition conditions) + "match CONDITION against any of the patterns of CONDITIONS supplied" + (loop :for x :in conditions :thereis (match-condition-p x condition))) + + (defun call-with-muffled-conditions (thunk conditions) + (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) + (muffle-warning c))))) + (funcall thunk))) + + (defmacro with-muffled-conditions ((conditions) &body body) + `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) + + +;;;; --------------------------------------------------------------------------- +;;;; Access to the Operating System + +(uiop/package:define-package :uiop/os + (:nicknames :asdf/os) + (: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 + #:getenv #:getenvp ;; environment variables + #:implementation-identifier ;; implementation identifier + #:implementation-type #:*implementation-type* + #:operating-system #:architecture #:lisp-version-string + #:hostname #:getcwd #:chdir + ;; Windows shortcut support + #:read-null-terminated-string #:read-little-endian + #:parse-file-location-info #:parse-windows-shortcut)) +(in-package :uiop/os) + +;;; Features +(with-upgradability () + (defun featurep (x &optional (*features* *features*)) + (cond + ((atom x) (and (member x *features*) t)) + ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) + ((eq :or (car x)) (some #'featurep (cdr x))) + ((eq :and (car x)) (every #'featurep (cdr x))) + (t (error "Malformed feature specification ~S" x)))) + + (defun os-unix-p () + (or #+abcl (featurep :unix) + #+(and (not abcl) (or unix cygwin darwin)) t)) + + (defun os-windows-p () + (or #+abcl (featurep :windows) + #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) + + (defun os-genera-p () + (or #+genera 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."))))) + + (detect-os)) + +;;;; Environment variables: getting them, and parsing them. + +(with-upgradability () + (defun getenv (x) + (declare (ignorable x)) + #+(or abcl clisp ecl xcl) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) + #+gcl (system:getenv x) + #+genera nil + #+lispworks (lispworks:environment-variable x) + #+mcl (ccl:with-cstrs ((name x)) + (let ((value (_getenv name))) + (unless (ccl:%null-ptr-p value) + (ccl:%get-cstring value)))) + #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) + #+sbcl (sb-ext:posix-getenv x) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (error "~S is not supported on your implementation" 'getenv)) + + (defun getenvp (x) + "Predicate that is true if the named variable is present in the libc environment, +then returning the non-empty string value of the variable" + (let ((g (getenv x))) (and (not (emptyp g)) g)))) + + +;;;; implementation-identifier +;; +;; produce a string to identify current implementation. +;; Initially stolen from SLIME's SWANK, completely rewritten since. +;; We're back to runtime checking, for the sake of e.g. ABCL. + +(with-upgradability () + (defun first-feature (feature-sets) + (dolist (x feature-sets) + (multiple-value-bind (short long feature-expr) + (if (consp x) + (values (first x) (second x) (cons :or (rest x))) + (values x x x)) + (when (featurep feature-expr) + (return (values short long)))))) + + (defun implementation-type () + (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)) + + (defun operating-system () + (first-feature + '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd + (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd + (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + :genera))) + + (defun architecture () + (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) + (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) + :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) + :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach + ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, + ;; we may have to segregate the code still by architecture. + (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) + + #+clozure + (defun ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) + + (defun lisp-version-string () + (let ((s (lisp-implementation-version))) + (car ; as opposed to OR, this idiom prevents some unreachable code warning + (list + #+allegro + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" + excl::*common-lisp-version-number* + ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) + (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm + (excl:ics-target-case (:-ics "8")) + (and (member :smp *features*) "S")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp + (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure + (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand (ccl-fasl-version) #xFF)) + #+cmu (substitute #\- #\/ s) + #+scl (format nil "~A~A" s + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera + (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + #+mcl (subseq s 8) ; strip the leading "Version " + s)))) + + (defun implementation-identifier () + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or (implementation-type) (lisp-implementation-type)) + (or (lisp-version-string) (lisp-implementation-version)) + (or (operating-system) (software-type)) + (or (architecture) (machine-type)))))) + + +;;;; Other system information + +(with-upgradability () + (defun hostname () + ;; 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? + #+allegro (symbol-call :excl.osi :gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname))) + + +;;; Current directory +(with-upgradability () + + #+cmu + (defun parse-unix-namestring* (unix-namestring) + (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 + :directory directory :name name :type type :version version))) + + (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) + #+allegro (excl::current-directory) + #+clisp (ext:default-directory) + #+clozure (ccl:current-directory) + #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring + (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))) + #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! + #+lispworks (system:current-directory) + #+mkcl (mk-ext:getcwd) + #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) + #+xcl (extensions:current-directory) + (error "getcwd not supported on your implementation"))) + + (defun chdir (x) + "Change current directory, as per POSIX chdir(2), to a given pathname object" + (if-let (x (pathname x)) + (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x)) + #+allegro (excl:chdir x) + #+clisp (ext:cd x) + #+clozure (setf (ccl:current-directory) x) + #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) + #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) + (error "Could not set current directory to ~A" x)) + #+ecl (ext:chdir x) + #+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)) + (error "chdir not supported on your implementation"))))) + + +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; 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. +(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) + (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)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + + (defun parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + + (defun parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file (c) + (declare (ignore c)) + nil))))) + + +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp pathnames +;; This layer allows for portable manipulation of pathname objects themselves, +;; which all is necessary prior to any access the filesystem or environment. + +(uiop/package:define-package :uiop/pathname + (:nicknames :asdf/pathname) + (:recycle :uiop/pathname :asdf/pathname :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) + (:export + ;; Making and merging pathnames, portably + #:normalize-pathname-directory-component #:denormalize-pathname-directory-component + #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* + #:nil-pathname #:*nil-pathname* #:with-pathname-defaults + ;; Predicates + #:pathname-equal #:logical-pathname-p #:physical-pathname-p + #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p + ;; Directories + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + ;; Parsing filenames + #:component-name-to-pathname-components + #:split-name-type #:parse-unix-namestring #:unix-namestring + #:split-unix-namestring-directory-components + ;; Absolute and relative pathnames + #:subpathname #:subpathname* + #:ensure-absolute-pathname + #:pathname-root #:pathname-host-pathname + #:subpathp + ;; Checking constraints + #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints + ;; Wildcard pathnames + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden + ;; Translate a pathname + #:relativize-directory-component #:relativize-pathname-directory + #:directory-separator-for-host #:directorize-pathname-host-device + #:translate-pathname* + #:*output-translation-function*)) +(in-package :uiop/pathname) + +;;; Normalizing pathnames across implementations + +(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)) + (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 + ((consp directory) + `(:relative ,@directory)) + (t + (error (compatfmt "~@") 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)))) + + (defun merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. + (let ((directory (normalize-pathname-directory-component specified))) + (ecase (first directory) + ((nil) defaults) + (:absolute specified) + (:relative + (let ((defdir (normalize-pathname-directory-component defaults)) + (reldir (cdr directory))) + (cond + ((null defdir) + directory) + ((not (eq :back (first reldir))) + (append defdir reldir)) + (t + (loop :with defabs = (first defdir) + :with defrev = (reverse (rest defdir)) + :while (and (eq :back (car reldir)) + (or (and (eq :absolute defabs) (null defrev)) + (stringp (car defrev)))) + :do (pop reldir) (pop defrev) + :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) + + ;; Giving :unspecific as :type argument to make-pathname is not portable. + ;; 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) + + (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp) + 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" + (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) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + + (defun make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname* + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) + + (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE 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. +This is what users want on a modern Unix or Windows operating system, +unlike the MERGE-PATHNAME 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, +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)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl + (let* ((specified (pathname specified)) + (defaults (pathname defaults)) + (directory (normalize-pathname-directory-component (pathname-directory specified))) + (name (or (pathname-name specified) (pathname-name defaults))) + (type (or (pathname-type specified) (pathname-type defaults))) + (version (or (pathname-version specified) (pathname-version defaults)))) + (labels ((unspecific-handler (p) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) + (multiple-value-bind (host device directory unspecific-handler) + (ecase (first directory) + ((:absolute) + (values (pathname-host specified) + (pathname-device specified) + directory + (unspecific-handler specified))) + ((nil :relative) + (values (pathname-host defaults) + (pathname-device defaults) + (merge-pathname-directory-components directory (pathname-directory defaults)) + (unspecific-handler defaults)))) + (make-pathname* :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) + + (defun 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" + ;; 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*) + #+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)) + + (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) + + (defmacro with-pathname-defaults ((&optional defaults) &body body) + `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))) + + +;;; Some pathname predicates +(with-upgradability () + (defun pathname-equal (p1 p2) + (when (stringp p1) (setf p1 (pathname p1))) + (when (stringp p2) (setf p2 (pathname p2))) + (flet ((normalize-component (x) + (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) + x))) + (macrolet ((=? (&rest accessors) + (flet ((frob (x) + (reduce 'list (cons 'normalize-component accessors) + :initial-value x :from-end t))) + `(equal ,(frob 'p1) ,(frob 'p2))))) + (or (and (null p1) (null p2)) + (and (pathnamep p1) (pathnamep p2) + (and (=? pathname-host) + (=? 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)))) + + (defun absolute-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing an :ABSOLUTE directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let ((pathname (pathname pathspec))) + (and (eq :absolute (car (normalize-pathname-directory-component + (pathname-directory pathname)))) + pathname)))) + + (defun relative-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let* ((pathname (pathname pathspec)) + (directory (normalize-pathname-directory-component + (pathname-directory pathname)))) + (when (or (null directory) (eq :relative (car directory))) + pathname)))) + + (defun hidden-pathname-p (pathname) + "Return a boolean that is true if the pathname is hidden as per Unix style, +i.e. its name starts with a dot." + (and pathname (equal (first-char (pathname-name pathname)) #\.))) + + (defun file-pathname-p (pathname) + "Does PATHNAME represent a file, i.e. has a non-null NAME component? + +Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing file. + +Returns the (parsed) PATHNAME when true" + (when pathname + (let* ((pathname (pathname pathname)) + (name (pathname-name pathname))) + (when (not (member name '(nil :unspecific "") :test 'equal)) + pathname))))) + + +;;; Directory pathnames +(with-upgradability () + (defun pathname-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) + + (defun pathname-parent-directory-pathname (pathname) + "Returns a new pathname that corresponds to the parent of the current pathname's directory, +i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is +Unix pathname /foo/bar/baz/file.type then return /foo/bar/" + (when pathname + (make-pathname* :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) + + (defun directory-pathname-p (pathname) + "Does PATHNAME represent a directory? + +A directory-pathname is a pathname _without_ a filename. The three +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing directory." + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) + + (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) + "Converts the non-wild pathname designator PATHSPEC to directory form." + (cond + ((stringp pathspec) + (ensure-directory-pathname (pathname pathspec))) + ((not (pathnamep pathspec)) + (call-function on-error (compatfmt "~@") pathspec)) + ((wild-pathname-p pathspec) + (call-function on-error (compatfmt "~@") pathspec)) + ((directory-pathname-p pathspec) + pathspec) + (t + (make-pathname* :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil :defaults pathspec))))) + + +;;; Parsing filenames +(with-upgradability () + (defun split-unix-namestring-directory-components + (unix-namestring &key ensure-directory dot-dot) + "Splits the path string UNIX-NAMESTRING, returning four values: +A flag that is either :absolute or :relative, indicating + how the rest of the values are to be interpreted. +A directory path --- a list of strings and keywords, suitable for + use with MAKE-PATHNAME when prepended with the flag value. + Directory components with an empty name or the name . are removed. + Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). +A last-component, either a file-namestring including type extension, + or NIL in the case of a directory pathname. +A flag that is true iff the unix-style-pathname was just + a file-namestring without / path specification. +ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: +the third return value will be NIL, and final component of the namestring +will be treated as part of the directory path. + +An empty string is thus read as meaning a pathname object with all fields nil. + +Note that : characters will NOT be interpreted as host specification. +Absolute pathnames are only appropriate on Unix-style systems. + +The intention of this function is to support structured component names, +e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." + (check-type unix-namestring string) + (check-type dot-dot (member nil :back :up)) + (if (and (not (find #\/ unix-namestring)) (not ensure-directory) + (plusp (length unix-namestring))) + (values :relative () unix-namestring t) + (let* ((components (split-string unix-namestring :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char unix-namestring) #\/) + (values :absolute (cdr components)) + (values :relative nil)) + (values :relative components)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) + components)) + (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) + (cond + ((equal last-comp "") + (values relative components nil nil)) ; "" already removed from components + (ensure-directory + (values relative components nil nil)) + (t + (values relative (butlast components) last-comp nil))))))) + + (defun split-name-type (filename) + "Split a filename into two values NAME and TYPE that are returned. +We assume filename has no directory component. +The last . if any separates name and type from from type, +except that if there is only one . and it is in first position, +the whole filename is the NAME with an empty type. +NAME is always a string. +For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." + (check-type filename string) + (assert (plusp (length filename))) + (destructuring-bind (name &optional (type *unspecific-pathname-type*)) + (split-string filename :max 2 :separator ".") + (if (equal name "") + (values filename *unspecific-pathname-type*) + (values name type)))) + + (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory + &allow-other-keys) + "Coerce NAME into a PATHNAME using standard Unix syntax. + +Unix syntax is used whether or not the underlying system is Unix; +on such non-Unix systems it is only usable but for relative pathnames; +but especially to manipulate relative pathnames portably, it is of crucial +to possess a portable pathname syntax independent of the underlying OS. +This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. + +When given a PATHNAME object, just return it untouched. +When given NIL, just return NIL. +When given a non-null SYMBOL, first downcase its name and treat it as a string. +When given a STRING, portably decompose it into a pathname as below. + +#\\/ separates directory components. + +The last #\\/-separated substring is interpreted as follows: +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 + are separated by SPLIT-NAME-TYPE. +3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. + +Directory components with an empty name the name . are removed. +Any directory named .. is read as DOT-DOT, +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. +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 MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, +which is an important reason to always use MERGE-PATHNAMES*. + +Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME +with those keys, removing TYPE DEFAULTS and 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 :WANT-RELATIVE T +to throw an error if the pathname is absolute" + (block nil + (check-type type (or null string (eql :directory))) + (when ensure-directory + (setf type :directory)) + (etypecase name + ((or null pathname) (return name)) + (symbol + (setf name (string-downcase name))) + (string)) + (multiple-value-bind (relative path filename file-only) + (split-unix-namestring-directory-components + name :dot-dot dot-dot :ensure-directory (eq type :directory)) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'ensure-pathname + (make-pathname* + :directory (unless file-only (cons relative path)) + :name name :type type + :defaults (or defaults *nil-pathname*)) + (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) + + (defun unix-namestring (pathname) + "Given a non-wild PATHNAME, return a Unix-style namestring for it. +If the PATHNAME is NIL or a STRING, return it unchanged. + +This only considers the DIRECTORY, NAME and TYPE components of the pathname. +This is a portable solution for representing relative pathnames, +But unless you are running on a Unix system, it is not a general solution +to representing native pathnames. + +An error is signaled if the argument is not NULL, a STRING or a PATHNAME, +or if it is a PATHNAME but some of its components are not recognized." + (etypecase pathname + ((or null string) pathname) + (pathname + (with-output-to-string (s) + (flet ((err () (error "Not a valid unix-namestring ~S" pathname))) + (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) + (name (pathname-name pathname)) + (type (pathname-type pathname)) + (type (and (not (eq type :unspecific)) type))) + (cond + ((eq dir ())) + ((eq dir '(:relative)) (princ "./" s)) + ((consp dir) + (destructuring-bind (relabs &rest dirs) dir + (or (member relabs '(:relative :absolute)) (err)) + (when (eq relabs :absolute) (princ #\/ s)) + (loop :for x :in dirs :do + (cond + ((member x '(:back :up)) (princ "../" s)) + ((equal x "") (err)) + ;;((member x '("." "..") :test 'equal) (err)) + ((stringp x) (format s "~A/" x)) + (t (err)))))) + (t (err))) + (cond + (name + (or (and (stringp name) (or (null type) (stringp type))) (err)) + (format s "~A~@[.~A~]" name type)) + (t + (or (null type) (err))))))))))) + +;;; Absolute and relative pathnames +(with-upgradability () + (defun subpathname (pathname subpath &key type) + "This function takes a PATHNAME and a SUBPATH and a TYPE. +If SUBPATH is already a PATHNAME object (not namestring), +and is an absolute pathname at that, it is returned unchanged; +otherwise, SUBPATH is turned into a relative pathname with given TYPE +as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, +then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." + (or (and (pathnamep subpath) (absolute-pathname-p subpath)) + (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) + (pathname-directory-pathname pathname)))) + + (defun subpathname* (pathname subpath &key type) + "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + + (defun pathname-root (pathname) + (make-pathname* :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + + (defun pathname-host-pathname (pathname) + (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)) + (cond + ((absolute-pathname-p path)) + ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) + ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) + ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) + (or (if (absolute-pathname-p default-pathname) + (absolute-pathname-p (merge-pathnames* path default-pathname)) + (call-function on-error "Default pathname ~S is not an absolute pathname" + default-pathname)) + (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" + path default-pathname)))) + (t (call-function on-error + "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults))))) + + +;;; 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-file* + (make-pathname :directory nil :name *wild* :type *wild* + :version (or #-(or allegro abcl xcl) *wild*))) + (defparameter *wild-directory* + (make-pathname* :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil)) + (defparameter *wild-inferiors* + (make-pathname* :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil)) + (defparameter *wild-path* + (merge-pathnames* *wild-file* *wild-inferiors*)) + + (defun wilden (path) + (merge-pathnames* *wild-path* path))) + + +;;; Translate a pathname +(with-upgradability () + (defun relativize-directory-component (directory-component) + (let ((directory (normalize-pathname-directory-component directory-component))) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory)))) + + (defun relativize-pathname-directory (pathspec) + (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*)) + (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) + (last-char (namestring foo)))) + + #-scl + (defun directorize-pathname-host-device (pathname) + #+(or unix abcl) + (when (and #+abcl (os-unix-p) (physical-pathname-p pathname)) + (return-from directorize-pathname-host-device pathname)) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (separator (directory-separator-for-host root)) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + #'(lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (split-unix-namestring-directory-components root-string :ensure-directory t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname* :defaults root :directory `(:absolute ,@path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) + + #+scl + (defun directorize-pathname-host-device (pathname) + (let ((scheme (ext:pathname-scheme pathname)) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) + (flet ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) + (let ((prefix "")) + (when (specificp port) + (setf prefix (format nil ":~D" port))) + (when (and (specificp host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (specificp scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname))) + + (defun* (translate-pathname*) (path absolute-source destination &optional root source) + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (error "Invalid destination")) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) + + (defvar *output-translation-function* 'identity + "Hook for output translations. + +This function needs to be idempotent, so that actions can work +whether their inputs were translated or not, +which they will be if we are composing operations. e.g. if some +create-lisp-op creates a lisp file from some higher-level input, +you need to still be able to use compile-op on that lisp file.")) + +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp filesystem access + +(uiop/package:define-package :uiop/filesystem + (:nicknames :asdf/filesystem) + (:recycle :uiop/filesystem :asdf/pathname :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) + (:export + ;; Native namestrings + #:native-namestring #:parse-native-namestring + ;; Probing the filesystem + #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p + #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories + #:collect-sub*directories + ;; Resolving symlinks somewhat + #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks* + ;; merging with cwd + #:get-pathname-defaults #:call-with-current-directory #:with-current-directory + ;; Environment pathnames + #:inter-directory-separator #:split-native-pathnames-string + #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:lisp-implementation-directory #:lisp-implementation-pathname-p + ;; Simple filesystem operations + #:ensure-all-directories-exist + #:rename-file-overwriting-target + #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) +(in-package :uiop/filesystem) + +;;; Native namestrings, as seen by the operating system calls rather than Lisp +(with-upgradability () + (defun native-namestring (x) + "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system" + (when x + (let ((p (pathname x))) + #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 + #+(or cmu scl) (ext:unix-namestring p nil) + #+sbcl (sb-ext:native-namestring p) + #-(or clozure cmu sbcl scl) + (if (os-unix-p) (unix-namestring p) + (namestring p))))) + + (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) + "From a native namestring suitable for use by the operating system, return +a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" + (check-type string (or string null)) + (let* ((pathname + (when string + (with-pathname-defaults () + #+clozure (ccl:native-to-pathname string) + #+sbcl (sb-ext:parse-native-namestring string) + #-(or clozure sbcl) + (if (os-unix-p) + (parse-unix-namestring string :ensure-directory ensure-directory) + (parse-namestring string))))) + (pathname + (if ensure-directory + (and pathname (ensure-directory-pathname pathname)) + pathname))) + (apply 'ensure-pathname pathname constraints)))) + + +;;; Probing the filesystem +(with-upgradability () + (defun truename* (p) + ;; 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) + ;; 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 + ;; and calls compute-action-stamp which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (and pathname + (handler-case (file-write-date (translate-logical-pathname pathname)) + (file-error () nil)))) + + (defun probe-file* (p &key truename) + "when given a pathname P (designated by a string as per PARSE-NAMESTRING), +probes the filesystem for a file or directory with given pathname. +If it exists, return its truename is ENSURE-PATHNAME is true, +or the original (parsed) pathname if it is false (the default)." + (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p) :truename truename)) + (pathname + (and (not (wild-pathname-p p)) + (handler-case + (or + #+allegro + (probe-file p :follow-symlinks truename) + #-(or allegro clisp gcl2.6) + (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) + #.(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)) + (pp (find-symbol* '#:probe-pathname :ext nil)) + (resolve (if pp + `(ignore-errors (,pp p)) + '(or (truename* p) + (truename* (ignore-errors (ensure-directory-pathname p))))))) + (if fs + `(if truename + ,resolve + (and (ignore-errors (,fs p)) p)) + (probe resolve))))) + (file-error () nil))))))) + + (defun directory-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (directory-pathname-p p) p))) + + (defun file-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (file-pathname-p p) p))) + + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+(or clozure digitool) '(:follow-links nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl 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)) + + (defun directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (logical-pathname-p dir) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let* ((pat (merge-pathnames* pattern dir)) + (entries (append (ignore-errors (directory* pat)) + #+clisp + (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)))))))) + + (defun subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) + + (defun collect-sub*directories (directory collectp recursep collector) + (when (call-function collectp directory) + (call-function collector directory)) + (dolist (subdir (subdirectories directory)) + (when (call-function recursep subdir) + (collect-sub*directories subdir collectp recursep collector))))) + +;;; Resolving symlinks somewhat +(with-upgradability () + (defun truenamize (pathname) + "Resolve as much of a pathname as possible" + (block nil + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p pathname)) + (unless (absolute-pathname-p p) + (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil)) + (return p)))) + (when (logical-pathname-p p) (return p)) + (let ((found (probe-file* p :truename t))) + (when found (return found))) + (let* ((directory (normalize-pathname-directory-component (pathname-directory p))) + (up-components (reverse (rest 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)))))) + + (defun resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro + (if (physical-pathname-p path) + (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) + path)) + + (defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. +Defaults to T.") + + (defun resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path))) + + +;;; Check pathname constraints +(with-upgradability () + (defun ensure-pathname + (pathname &key + on-error + defaults type dot-dot + want-pathname + want-logical want-physical ensure-physical + want-relative want-absolute ensure-absolute ensure-subpath + want-non-wild want-wild wilden + want-file want-directory ensure-directory + want-existing ensure-directories-exist + truename resolve-symlinks truenamize + &aux (p pathname)) ;; mutable working copy, preserve original + "Coerces its argument into a PATHNAME, +optionally doing some transformations and checking specified constraints. + +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. + +Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. +The boolean T is an alias for ERROR. +ERROR means that an error will be raised if the constraint is not satisfied. +CERROR means that an continuable error will be raised if the constraint is not satisfied. +IGNORE means just return NIL instead of the pathname. + +The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) +that will be called with the the following arguments: +a generic format string for ensure pathname, the pathname, +the keyword argument corresponding to the failed check or transformation, +a format string for the reason ENSURE-PATHNAME failed, +and a list with arguments to that format string. +If ON-ERROR is NIL, ERROR is used instead, which does the right thing. +You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). + +The transformations and constraint checks are done in this order, +which is also the order in the lambda-list: + +WANT-PATHNAME checks that pathname (after parsing if needed) is not null. +Otherwise, if the pathname is NIL, ensure-pathname returns NIL. +WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME +WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME +ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME +WANT-RELATIVE checks that pathname has a relative directory component +WANT-ABSOLUTE checks that pathname does have an absolute directory component +ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again +that the result absolute is an absolute pathname indeed. +ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. +WANT-FILE checks that pathname has a non-nil FILE component +WANT-DIRECTORY checks that pathname has nil FILE and TYPE components +ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret +any file and type components as being actually a last directory component. +WANT-NON-WILD checks that pathname is not a wild pathname +WANT-WILD checks that pathname is a wild pathname +WILDEN merges the pathname with **/*.*.* if it is not wild +WANT-EXISTING checks that a file (or directory) exists with that pathname. +ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. +TRUENAME replaces the pathname by its truename, or errors if not possible. +RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. +TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." + (block nil + (flet ((report-error (keyword description &rest arguments) + (call-function (or on-error 'error) + "Invalid pathname ~S: ~*~?" + pathname keyword description arguments))) + (macrolet ((err (constraint &rest arguments) + `(report-error ',(intern* constraint :keyword) ,@arguments)) + (check (constraint condition &rest arguments) + `(when ,constraint + (unless ,condition (err ,constraint ,@arguments)))) + (transform (transform condition expr) + `(when ,transform + (,@(if condition `(when ,condition) '(progn)) + (setf p ,expr))))) + (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)) + (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)) + (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") + (transform ensure-absolute (not (absolute-pathname-p p)) + (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) + (check ensure-absolute (absolute-pathname-p p) + "Could not make into an absolute pathname even after merging with ~S" defaults) + (check ensure-subpath (absolute-pathname-p defaults) + "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) + (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) + (check want-file (file-pathname-p p) "Expected a file pathname") + (check want-directory (directory-pathname-p p) "Expected a directory pathname") + (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) + (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") + (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") + (transform wilden (not (wild-pathname-p p)) (wilden p)) + (when want-existing + (let ((existing (probe-file* p :truename truename))) + (if existing + (when truename + (return existing)) + (err want-existing "Expected an existing pathname")))) + (when ensure-directories-exist (ensure-directories-exist p)) + (when truename + (let ((truename (truename* p))) + (if truename + (return truename) + (err truename "Can't get a truename for pathname")))) + (transform resolve-symlinks () (resolve-symlinks p)) + (transform truenamize () (truenamize p)) + p))))) + + +;;; Pathname defaults +(with-upgradability () + (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) + (or (absolute-pathname-p defaults) + (merge-pathnames* defaults (getcwd)))) + + (defun call-with-current-directory (dir thunk) + (if dir + (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir)))) + (*default-pathname-defaults* dir) + (cwd (getcwd))) + (chdir dir) + (unwind-protect + (funcall thunk) + (chdir cwd))) + (funcall thunk))) + + (defmacro with-current-directory ((&optional dir) &body body) + "Call BODY while the POSIX current working directory is set to DIR" + `(call-with-current-directory ,dir #'(lambda () ,@body)))) + + +;;; Environment pathnames +(with-upgradability () + (defun inter-directory-separator () + (if (os-unix-p) #\: #\;)) + + (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) + (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) + ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory + (apply 'parse-native-namestring (getenvp x) + :ensure-directory (or ensure-directory want-directory) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) + constraints)) + (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) + (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) + (getenv-pathname x :want-absolute t :ensure-directory t)) + (defun getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :ensure-directory t)) + + (defun lisp-implementation-directory (&key truename) + (declare (ignorable truename)) + #+(or clozure ecl gcl mkcl sbcl) + (let ((dir + (ignore-errors + #+clozure #p"ccl:" + #+(or ecl mkcl) #p"SYS:" + #+gcl system::*system-directory* + #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :ensure-directory t))))) + (if (and dir truename) + (truename* dir) + dir))) + + (defun lisp-implementation-pathname-p (pathname) + ;; Other builtin systems are those under the implementation directory + (and (when pathname + (if-let (impdir (lisp-implementation-directory)) + (or (subpathp pathname impdir) + (when *resolve-symlinks* + (if-let (truename (truename* pathname)) + (if-let (trueimpdir (truename* impdir)) + (subpathp truename trueimpdir))))))) + t))) + + +;;; Simple filesystem operations +(with-upgradability () + (defun ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (when pathname + (ensure-directories-exist (translate-logical-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) + #-clisp + (rename-file source target + #+clozure :if-exists #+clozure :rename-and-delete)) + + (defun delete-file-if-exists (x) + (when x (handler-case (delete-file x) (file-error () nil)))) + + (defun delete-empty-directory (directory-pathname) + "Delete an empty directory" + #+(or abcl digitool gcl) (delete-file directory-pathname) + #+allegro (excl:delete-directory directory-pathname) + #+clisp (ext:delete-directory directory-pathname) + #+clozure (ccl::delete-empty-directory directory-pathname) + #+(or cmu scl) (multiple-value-bind (ok errno) + (unix:unix-rmdir (native-namestring directory-pathname)) + (unless ok + #+cmu (error "Error number ~A when trying to delete directory ~A" + errno directory-pathname) + #+scl (error "~@" + directory-pathname (unix:get-unix-error-msg errno)))) + #+cormanlisp (win32:delete-directory directory-pathname) + #+ecl (si:rmdir directory-pathname) + #+lispworks (lw:delete-directory directory-pathname) + #+mkcl (mkcl:rmdir 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 + + (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. + +To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be +a physical non-wildcard directory pathname (not namestring). + +If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: +if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. + +Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass +the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument +which in practice is thus compulsory, and validates by returning a non-NIL result. +If you're suicidal or extremely confident, just use :VALIDATE T." + (check-type if-does-not-exist (member :error :ignore)) + (cond + ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) + (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname)))) + (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname" + 'delete-filesystem-tree directory-pathname)) + ((not validatep) + (error "~S was asked to delete ~S but was not provided a validation predicate" + 'delete-filesystem-tree directory-pathname)) + ((not (call-function validate directory-pathname)) + (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" + 'delete-filesystem-tree directory-pathname validate)) + ((not (directory-exists-p directory-pathname)) + (ecase if-does-not-exist + (:error + (error "~S was asked to delete ~S but the directory does not exist" + 'delete-filesystem-tree directory-pathname)) + (:ignore nil))) + #-(or allegro cmu clozure sbcl scl) + ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, + ;; except on implementations where we can prevent DIRECTORY from following symlinks; + ;; instead spawn a standard external program to do the dirty work. + (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) + (t + ;; On supported implementation, call supported system functions + #+allegro (symbol-call :excl.osi :delete-directory-and-files + directory-pathname :if-does-not-exist if-does-not-exist) + #+clozure (ccl:delete-directory directory-pathname) + #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later + '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) + ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, + ;; do things the hard way. + #-(or allegro clozure genera sbcl) + (let ((sub*directories + (while-collecting (c) + (collect-sub*directories directory-pathname t t #'c)))) + (dolist (d (nreverse sub*directories)) + (map () 'delete-file (directory-files d)) + (delete-empty-directory d))))))) + +;;;; --------------------------------------------------------------------------- +;;;; Utilities related to streams + +(uiop/package:define-package :uiop/stream + (:nicknames :asdf/stream) + (: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 + #: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 + #: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 + #:eval-input #:eval-thunk #:standard-eval-thunk + ;; Temporary files + #:*temporary-directory* #:temporary-directory #:default-temporary-directory + #:setup-temporary-directory + #:call-with-temporary-file #:with-temporary-file + #:add-pathname-suffix #:tmpize-pathname + #:call-with-staging-pathname #:with-staging-pathname)) +(in-package :uiop/stream) + +(with-upgradability () + (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) + "default element-type for open (depends on the current CL implementation)") + + (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)) + + +;;; Encodings (mostly hooks only; full support requires asdf-encodings) +(with-upgradability () + (defparameter *default-encoding* + ;; preserve explicit user changes to something other than the legacy default :default + (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) + (unless (eq previous :default) previous)) + :utf-8) + "Default encoding for source files. +The default value :utf-8 is the portable thing. +The legacy behavior was :default. +If you (asdf:load-system :asdf-encodings) then +you will have autodetection via *encoding-detection-hook* below, +reading emacs-style -*- coding: utf-8 -*- specifications, +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 + "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. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") + + (defun always-default-encoding (pathname) + (declare (ignore pathname)) + *default-encoding*) + + (defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") + + (defun detect-encoding (pathname) + (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname)) + (funcall *encoding-detection-hook* pathname) + *default-encoding*)) + + (defun default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) + :default))) + + (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") + + (defun encoding-external-format (encoding) + (funcall *encoding-external-format-hook* encoding))) + + +;;; Safe syntax +(with-upgradability () + (defvar *standard-readtable* (copy-readtable nil)) + + (defmacro with-safe-io-syntax ((&key (package :cl)) &body body) + "Establish safe CL reader options around the evaluation of BODY" + `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) + + (defun call-with-safe-io-syntax (thunk &key (package :cl)) + (with-standard-io-syntax + (let ((*package* (find-package package)) + (*read-default-float-format* 'double-float) + (*print-readably* nil) + (*read-eval* nil)) + (funcall thunk)))) + + (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) + (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 +(with-upgradability () + (defun call-with-output (output function) + "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 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. +Otherwise, signal an error." + (etypecase output + (null + (with-output-to-string (stream) (funcall function stream))) + ((eql t) + (funcall function *standard-output*)) + (stream + (funcall function output)) + (string + (assert (fill-pointer output)) + (with-output-to-string (stream output) (funcall function stream))))) + + (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) +as per FORMAT, and evaluate BODY within the scope of this binding." + `(call-with-output ,value #'(lambda (,output-var) ,@body))) + + (defun output-string (string &optional output) + "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" + (if output + (with-output (output) (princ string output)) + string))) + + +;;; 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*) + (external-format *utf-8-external-format*) + (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 + :if-does-not-exist if-does-not-exist) + (funcall thunk s))) + + (defmacro with-input-file ((var pathname &rest keys + &key element-type external-format if-does-not-exist) + &body body) + (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))) + + (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))) + +;;; Ensure output buffers are flushed +(with-upgradability () + (defun finish-outputs (&rest streams) + "Finish output on the main output streams as well as any specified one. +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*))) + (ignore-errors (finish-output s))) + (values)) + + (defun format! (stream format &rest args) + "Just like format, but call finish-outputs before and after the output." + (finish-outputs stream) + (apply 'format stream format args) + (finish-output stream)) + + (defun safe-format! (stream format &rest args) + (with-safe-io-syntax () + (ignore-errors (apply 'format! stream format args)) + (finish-outputs stream)))) ; just in case format failed + + +;;; Simple Whole-Stream processing +(with-upgradability () + (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) + "Copy the contents of the INPUT stream into the OUTPUT stream. +If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. +Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." + (with-open-stream (input input) + (if linewise + (loop* :for (line eof) = (multiple-value-list (read-line input nil nil)) + :while line :do + (when prefix (princ prefix output)) + (princ line output) + (unless eof (terpri output)) + (finish-output output) + (when eof (return))) + (loop + :with buffer-size = (or buffer-size 8192) + :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return)))))) + + (defun concatenate-files (inputs output) + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + + (defun copy-file (input output) + ;; 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)) + "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)))) + + (defun slurp-stream-lines (input &key count) + "Read the contents of the INPUT stream as a list of lines, return those lines. + +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))) + + (defun slurp-stream-line (input &key (at 0)) + "Read the contents of the INPUT stream as a list of lines, +then return the ACCESS-AT of that list of lines using the AT specifier. +PATH defaults to 0, i.e. return the first line. +PATH is typically an integer, or a list of an integer and a function. +If PATH is NIL, it will return all the lines in the file. + +The stream will not be read beyond the Nth lines, +where N is the index specified by path +if path is either an integer or a list that starts with an integer." + (access-at (slurp-stream-lines input :count (access-at-count at)) at)) + + (defun slurp-stream-forms (input &key count) + "Read the contents of the INPUT stream as a list of forms, +and return those forms. + +If COUNT is null, read to the end of the stream; +if COUNT is an integer, stop after COUNT forms were read. + +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (check-type count (or null integer)) + (loop :with eof = '#:eof + :for n :from 0 + :for form = (if (and count (>= n count)) + eof + (read-preserving-whitespace input nil eof)) + :until (eq form eof) :collect form)) + + (defun slurp-stream-form (input &key (at 0)) + "Read the contents of the INPUT stream as a list of forms, +then return the ACCESS-AT of these forms following the AT. +AT defaults to 0, i.e. return the first form. +AT is typically a list of integers. +If AT is NIL, it will return all the forms in the file. + +The stream will not be read beyond the Nth form, +where N is the index specified by path, +if path is either an integer or a list that starts with an integer. + +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (access-at (slurp-stream-forms input :count (access-at-count at)) at)) + + (defun read-file-string (file &rest keys) + "Open FILE with option KEYS, read its contents as a string" + (apply 'call-with-input-file file 'slurp-stream-string keys)) + + (defun read-file-lines (file &rest keys) + "Open FILE with option KEYS, read its contents 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-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. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-forms input :count count)) + (remove-plist-key :count keys))) + + (defun read-file-form (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-FORM 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-form input :at at)) + (remove-plist-key :at 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, +within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." + (with-safe-io-syntax (:package package) + (apply 'read-file-form pathname (remove-plist-key :package keys)))) + + (defun eval-input (input) + "Portably read and evaluate forms from INPUT, return the last values." + (with-input (input) + (loop :with results :with eof ='#:eof + :for form = (read input nil eof) + :until (eq form eof) + :do (setf results (multiple-value-list (eval form))) + :finally (return (apply 'values results))))) + + (defun eval-thunk (thunk) + "Evaluate a THUNK of code: +If a function, FUNCALL it without arguments. +If a constant literal and not a sequence, return it. +If a cons or a symbol, EVAL it. +If a string, repeatedly read and evaluate from it, returning the last values." + (etypecase thunk + ((or boolean keyword number character pathname) thunk) + ((or cons symbol) (eval thunk)) + (function (funcall thunk)) + (string (eval-input thunk)))) + + (defun standard-eval-thunk (thunk &key (package :cl)) + "Like EVAL-THUNK, but in a more standardized evaluation context." + ;; Note: it's "standard-" not "safe-", because evaluation is never safe. + (when thunk + (with-safe-io-syntax (:package package) + (let ((*read-eval* t)) + (eval-thunk thunk)))))) + + +;;; Using temporary files +(with-upgradability () + (defun default-temporary-directory () + (or + (when (os-unix-p) + (or (getenv-pathname "TMPDIR" :ensure-directory t) + (parse-native-namestring "/tmp/"))) + (when (os-windows-p) + (getenv-pathname "TEMP" :ensure-directory t)) + (subpathname (user-homedir-pathname) "tmp/"))) + + (defvar *temporary-directory* nil) + + (defun temporary-directory () + (or *temporary-directory* (default-temporary-directory))) + + (defun setup-temporary-directory () + (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*)) + + (defun call-with-temporary-file + (thunk &key + prefix keep (direction :io) + (element-type *default-stream-element-type*) + (external-format :default)) + #+gcl2.6 (declare (ignorable external-format)) + (check-type direction (member :output :io)) + (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 + ;; 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))))))))) + + (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) + (pathname (gensym "PATHNAME") pathnamep) + prefix 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." + (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))))) + + ;; 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 tmpize-pathname (x) + (add-pathname-suffix x "-ASDF-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." + (let* ((pathname (pathname pathname)) + (staging (tmpize-pathname pathname))) + (unwind-protect + (multiple-value-prog1 + (funcall fun staging) + (rename-file-overwriting-target staging pathname)) + (delete-file-if-exists staging)))) + + (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) + +;;;; ------------------------------------------------------------------------- +;;;; Starting, Stopping, Dumping a Lisp image + +(uiop/package:define-package :uiop/image + (:nicknames :asdf/image) + (:recycle :uiop/image :asdf/image :xcvb-driver) + (: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 + #:*lisp-interaction* + #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition + #:call-with-fatal-condition-handler #:with-fatal-condition-handler + #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* + #:*image-postlude* #:*image-dump-hook* + #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace + #:shell-boolean-exit + #:register-image-restore-hook #:register-image-dump-hook + #:call-image-restore-hook #:call-image-dump-hook + #:restore-image #:dump-image #:create-image +)) +(in-package :uiop/image) + +(with-upgradability () + (defvar *lisp-interaction* t + "Is this an interactive Lisp environment, or is it batch processing?") + + (defvar *command-line-arguments* nil + "Command-line arguments") + + (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments + "Is this a dumped image? As a standalone executable?") + + (defvar *image-restore-hook* nil + "Functions to call (in reverse order) when the image is restored") + + (defvar *image-restored-p* nil + "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") + + (defvar *image-prelude* nil + "a form to evaluate, or string containing forms to read and evaluate +when the image is restarted, but before the entry point is called.") + + (defvar *image-entry-point* nil + "a function with which to restart the dumped image when execution is restored from it.") + + (defvar *image-postlude* nil + "a form to evaluate, or string containing forms to read and evaluate +before the image dump hooks are called and before the image is dumped.") + + (defvar *image-dump-hook* nil + "Functions to call (in order) when before an image is dumped") + + (defvar *fatal-conditions* '(error) + "conditions that cause the Lisp image to enter the debugger if interactive, +or to die if not interactive")) + + +;;; Exiting properly or im- +(with-upgradability () + (defun quit (&optional (code 0) (finish-output t)) + "Quits from the Lisp world, with the given exit status if provided. +This is designed to abstract away the implementation specific quit forms." + (when finish-output ;; essential, for ClozureCL, and for standard compliance. + (finish-outputs)) + #+(or abcl xcl) (ext:quit :status code) + #+allegro (excl:exit code :quiet t) + #+clisp (ext:quit code) + #+clozure (ccl:quit code) + #+cormanlisp (win32:exitprocess code) + #+(or cmu scl) (unix:unix-exit code) + #+ecl (si:quit code) + #+gcl (lisp: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) ? + #+mkcl (mk-ext:quit :exit-code code) + #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) + (quit (find-symbol* :quit :sb-ext nil))) + (cond + (exit `(,exit :code code :abort (not finish-output))) + (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) + + (defun die (code format &rest arguments) + "Die in error with some error message" + (with-safe-io-syntax () + (ignore-errors + (fresh-line *stderr*) + (apply #'format *stderr* format arguments) + (format! *stderr* "~&"))) + (quit code)) + + (defun raw-print-backtrace (&key (stream *debug-io*) count) + "Print a backtrace, directly accessing the implementation" + (declare (ignorable stream count)) + #+abcl + (let ((*debug-io* stream)) (top-level::backtrace-command count)) + #+allegro + (let ((*terminal-io* stream) + (*standard-output* stream) + (tpl:*zoom-print-circle* *print-circle*) + (tpl:*zoom-print-level* *print-level*) + (tpl:*zoom-print-length* *print-length*)) + (tpl:do-command "zoom" + :from-read-eval-print-loop nil + :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) + (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) + #+lispworks + (let ((dbg::*debugger-stack* + (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) + (*debug-io* stream) + (dbg:*debug-print-level* *print-level*) + (dbg:*debug-print-length* *print-length*)) + (dbg:bug-backtrace nil)) + #+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)) + (with-safe-io-syntax (:package :cl) + (let ((*print-readably* nil) + (*print-circle* t) + (*print-miser-width* 75) + (*print-length* nil) + (*print-level* nil) + (*print-pretty* t)) + (ignore-errors (apply 'raw-print-backtrace keys))))) + + (defun print-condition-backtrace (condition &key (stream *stderr*) count) + ;; 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) + (when condition + (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" + condition))) + + (defun fatal-condition-p (condition) + (match-any-condition-p condition *fatal-conditions*)) + + (defun handle-fatal-condition (condition) + "Depending on whether *LISP-INTERACTION* is set, enter debugger or die" + (cond + (*lisp-interaction* + (invoke-debugger condition)) + (t + (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) + (print-condition-backtrace condition :stream *stderr*) + (die 99 "~A" condition)))) + + (defun call-with-fatal-condition-handler (thunk) + (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition)) + (funcall thunk))) + + (defmacro with-fatal-condition-handler ((&optional) &body body) + `(call-with-fatal-condition-handler #'(lambda () ,@body))) + + (defun shell-boolean-exit (x) + "Quit with a return code that is 0 iff argument X is true" + (quit (if x 0 1)))) + + +;;; Using image hooks +(with-upgradability () + (defun register-image-restore-hook (hook &optional (call-now-p t)) + (register-hook-function '*image-restore-hook* hook call-now-p)) + + (defun register-image-dump-hook (hook &optional (call-now-p nil)) + (register-hook-function '*image-dump-hook* hook call-now-p)) + + (defun call-image-restore-hook () + (call-functions (reverse *image-restore-hook*))) + + (defun call-image-dump-hook () + (call-functions *image-dump-hook*))) + + +;;; Proper command-line arguments +(with-upgradability () + (defun raw-command-line-arguments () + "Find what the actual command line for this process was." + #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! + #+allegro (sys:command-line-arguments) ; default: :application t + #+clisp (coerce (ext:argv) 'list) + #+clozure (ccl::command-line-arguments) + #+(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 + #+lispworks sys:*line-arguments-list* + #+sbcl sb-ext:*posix-argv* + #+xcl system:*argv* + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks 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)))) + (rest arguments))) + + (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*) + (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) + (when *image-restored-p* + (if if-already-restored + (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) + (return-from restore-image))) + (with-fatal-condition-handler () + (setf *image-restored-p* :in-progress) + (call-image-restore-hook) + (standard-eval-thunk *image-prelude*) + (setf *image-restored-p* t) + (let ((results (multiple-value-list + (if *image-entry-point* + (call-function *image-entry-point*) + t)))) + (if *lisp-interaction* + (apply 'values results) + (shell-boolean-exit (first results))))))) + + +;;; Dumping an image + +(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)) + (declare (ignorable filename output-name executable)) + (setf *image-dumped-p* (if executable :executable t)) + (setf *image-restored-p* :in-regress) + (standard-eval-thunk *image-postlude*) + (call-image-dump-hook) + (setf *image-restored-p* nil) + #-(or clisp clozure cmu lispworks sbcl scl) + (when executable + (error "Dumping an executable is not supported on this implementation! Aborting.")) + #+allegro + (progn + (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 + (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) + #+clisp + (apply #'ext:saveinitmem filename + :quiet t + :start-package *package* + :keep-global-handlers nil + :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x + (when executable + (list + ;; :parse-options nil ;--- requires a non-standard patch to clisp. + :norc t :script nil :init-function #'restore-image))) + #+clozure + (flet ((dump (prepend-kernel) + (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify + :toplevel-function (when executable #'restore-image)))) + ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) + (if prepend-symbols + (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) + (require 'elf) + (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) + (dump path)) + (dump t))) + #+(or cmu scl) + (progn + (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)))) + #+gcl + (progn + (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) + (si::save-system filename)) + #+lispworks + (if executable + (lispworks:deliver 'restore-image filename 0 :interface nil) + (hcl:save-image filename :environment nil)) + #+sbcl + (progn + ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself + (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 + #-(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 + (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)) + ;; 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)))) + + +;;; Some universal image restore hooks +(with-upgradability () + (map () 'register-image-restore-hook + '(setup-temporary-directory setup-stderr setup-command-line-arguments + #+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) + (:export + ;;; Escaping the command invocation madness + #:easy-sh-character-p #:escape-sh-token #:escape-sh-command + #:escape-windows-token #:escape-windows-command + #:escape-token #:escape-command + + ;;; run-program + #:slurp-input-stream + #:run-program + #:subprocess-error + #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process + )) +(in-package :uiop/run-program) + +;;;; ----- Escaping strings for the shell ----- + +(with-upgradability () + (defun requires-escaping-p (token &key good-chars bad-chars) + "Does this token require escaping, given the specification of +either good chars that don't need escaping or bad chars that do need escaping, +as either a recognizing function or a sequence of characters." + (some + (cond + ((and good-chars bad-chars) + (error "only one of good-chars and bad-chars can be provided")) + ((functionp good-chars) + (complement good-chars)) + ((functionp bad-chars) + bad-chars) + ((and good-chars (typep good-chars 'sequence)) + #'(lambda (c) (not (find c good-chars)))) + ((and bad-chars (typep bad-chars 'sequence)) + #'(lambda (c) (find c bad-chars))) + (t (error "requires-escaping-p: no good-char criterion"))) + token)) + + (defun escape-token (token &key stream quote good-chars bad-chars escaper) + "Call the ESCAPER function on TOKEN string if it needs escaping as per +REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, +using STREAM as output (or returning result as a string if NIL)" + (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars) + (with-output (stream) + (apply escaper token stream (when quote `(:quote ,quote)))) + (output-string token stream))) + + (defun escape-windows-token-within-double-quotes (x &optional s) + "Escape a string token X within double-quotes +for use within a MS Windows command-line, outputing to S." + (labels ((issue (c) (princ c s)) + (issue-backslash (n) (loop :repeat n :do (issue #\\)))) + (loop + :initially (issue #\") :finally (issue #\") + :with l = (length x) :with i = 0 + :for i+1 = (1+ i) :while (< i l) :do + (case (char x i) + ((#\") (issue-backslash 1) (issue #\") (setf i i+1)) + ((#\\) + (let* ((j (and (< i+1 l) (position-if-not + #'(lambda (c) (eql c #\\)) x :start i+1))) + (n (- (or j l) i))) + (cond + ((null j) + (issue-backslash (* 2 n)) (setf i l)) + ((and (< j l) (eql (char x j) #\")) + (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j))) + (t + (issue-backslash n) (setf i j))))) + (otherwise + (issue (char x i)) (setf i i+1)))))) + + (defun escape-windows-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a MS Windows command-line, outputing to S." + (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil + :escaper 'escape-windows-token-within-double-quotes)) + + (defun escape-sh-token-within-double-quotes (x s &key (quote t)) + "Escape a string TOKEN within double-quotes +for use within a POSIX Bourne shell, outputing to S; +omit the outer double-quotes if key argument :QUOTE is NIL" + (when quote (princ #\" s)) + (loop :for c :across x :do + (when (find c "$`\\\"") (princ #\\ s)) + (princ c s)) + (when quote (princ #\" s))) + + (defun easy-sh-character-p (x) + (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 + :escaper 'escape-sh-token-within-double-quotes)) + + (defun escape-shell-token (token &optional s) + (cond + ((os-unix-p) (escape-sh-token token s)) + ((os-windows-p) (escape-windows-token token s)))) + + (defun escape-command (command &optional s + (escaper 'escape-shell-token)) + "Given a COMMAND as a list of tokens, return a string of the +spaced, escaped tokens, using ESCAPER to escape." + (etypecase command + (string (output-string command s)) + (list (with-output (s) + (loop :for first = t :then nil :for token :in command :do + (unless first (princ #\space s)) + (funcall escaper token s)))))) + + (defun escape-windows-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by CommandLineToArgv in MS Windows" + ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx + ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx + (escape-command command s 'escape-windows-token)) + + (defun escape-sh-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by /bin/sh in POSIX" + (escape-command command s 'escape-sh-token)) + + (defun escape-shell-command (command &optional stream) + "Escape a command for the current operating system's shell" + (escape-command command stream 'escape-shell-token))) + + +;;;; 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) + (funcall function input-stream)) + + (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys) + (apply (first list) (cons input-stream (rest list)))) + + #-(or gcl2.6 genera) + (defmethod slurp-input-stream ((output-stream stream) input-stream + &key linewise prefix (element-type 'character) buffer-size &allow-other-keys) + (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 &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-string stream)) + + (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-lines stream :count count)) + + (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-line stream :at at)) + + (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys) + (declare (ignorable x)) + (slurp-stream-forms stream :count count)) + + (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys) + (declare (ignorable x)) + (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 ((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 slurp-input-stream (x stream + &key linewise prefix (element-type 'character) buffer-size + &allow-other-keys) + (declare (ignorable stream linewise prefix element-type buffer-size)) + (cond + #+(or gcl2.6 genera) + ((functionp x) (funcall x stream)) + #+(or gcl2.6 genera) + ((output-stream-p x) + (copy-stream-to-stream + input-stream output-stream + :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). + +Always call a shell (rather than directly execute the command) +if FORCE-SHELL is specified. + +Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), +unless IGNORE-ERROR-STATUS is specified. + +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))))) + +;;;; ------------------------------------------------------------------------- +;;;; Support to build (compile and load) Lisp files + +(uiop/package:define-package :uiop/lisp-build + (:nicknames :asdf/lisp-build) + (:recycle :uiop/lisp-build :asdf/lisp-build :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) + (:export + ;; Variables + #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* + #:*output-translation-function* + #:*optimization-settings* #:*previous-optimization-settings* + #: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* + ;; Types + #+sbcl #:sb-grovel-unknown-constant-condition + ;; Functions & Macros + #:get-optimization-settings #:proclaim-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 + #:reify-deferred-warnings #:unreify-deferred-warnings + #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings + #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* + #: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* + #:load* #:load-from-string #:combine-fasls) + (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) +(in-package :uiop/lisp-build) + +(with-upgradability () + (defvar *compile-file-warnings-behaviour* + (or #+clisp :ignore :warn) + "How should ASDF react if it encounters a warning when compiling a file? +Valid values are :error, :warn, and :ignore.") + + (defvar *compile-file-failure-behaviour* + (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) + "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.")) + + +;;; Optimization settings +(with-upgradability () + (defvar *optimization-settings* nil) + (defvar *previous-optimization-settings* nil) + (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) + (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*) + #+sbcl (cdr (assoc x sb-c::*policy*))) + :when y :collect (list x y)))) + (defun proclaim-optimization-settings () + "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" + (proclaim `(optimize ,@*optimization-settings*)) + (let ((settings (get-optimization-settings))) + (unless (equal *previous-optimization-settings* settings) + (setf *previous-optimization-settings* settings))))) + + +;;; Condition control +(with-upgradability () + #+sbcl + (progn + (defun sb-grovel-unknown-constant-condition-p (c) + (and (typep c 'sb-int:simple-style-warning) + (string-enclosed-p + "Couldn't grovel for " + (simple-condition-format-control c) + " (unknown to the C compiler)."))) + (deftype sb-grovel-unknown-constant-condition () + '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) + + (defvar *usual-uninteresting-conditions* + (append + ;;#+clozure '(ccl:compiler-warning) + #+cmu '("Deleting unreachable code.") + #+lispworks '("~S being redefined in ~A (previously in ~A)." + "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. + #+sbcl + '(sb-c::simple-compiler-note + "&OPTIONAL and &KEY found in the same lambda list: ~S" + #+sb-eval sb-kernel:lexical-environment-too-complex + sb-kernel:undefined-alien-style-warning + sb-grovel-unknown-constant-condition ; defined above. + sb-ext:implicit-generic-function-warning ;; Controversial. + sb-int:package-at-variance + sb-kernel:uninteresting-redefinition + ;; BEWARE: the below four are controversial to include here. + sb-kernel:redefinition-with-defun + sb-kernel:redefinition-with-defgeneric + sb-kernel:redefinition-with-defmethod + sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs + '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop + "A suggested value to which to set or bind *uninteresting-conditions*.") + + (defvar *uninteresting-conditions* '() + "Conditions that may be skipped while compiling or loading Lisp code.") + (defvar *uninteresting-compiler-conditions* '() + "Additional conditions that may be skipped while compiling Lisp code.") + (defvar *uninteresting-loader-conditions* + (append + '("Overwriting already existing readtable ~S." ;; from named-readtables + #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers + #+clisp '(clos::simple-gf-replacing-method-warning)) + "Additional conditions that may be skipped while loading Lisp code.")) + +;;;; ----- Filtering conditions while building ----- +(with-upgradability () + (defun call-with-muffled-compiler-conditions (thunk) + (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" + `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) + (defun call-with-muffled-loader-conditions (thunk) + (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" + `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) + + +;;;; Handle warnings and failures +(with-upgradability () + (define-condition compile-condition (condition) + ((context-format + :initform nil :reader compile-condition-context-format :initarg :context-format) + (context-arguments + :initform nil :reader compile-condition-context-arguments :initarg :context-arguments) + (description + :initform nil :reader compile-condition-description :initarg :description)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A~@[ while ~?~]~@:>") + (or (compile-condition-description c) (type-of c)) + (compile-condition-context-format c) + (compile-condition-context-arguments c))))) + (define-condition compile-file-error (compile-condition error) ()) + (define-condition compile-warned-warning (compile-condition warning) ()) + (define-condition compile-warned-error (compile-condition error) ()) + (define-condition compile-failed-warning (compile-condition warning) ()) + (define-condition compile-failed-error (compile-condition error) ()) + + (defun check-lisp-compile-warnings (warnings-p failure-p + &optional context-format context-arguments) + (when failure-p + (case *compile-file-failure-behaviour* + (:warn (warn 'compile-failed-warning + :description "Lisp compilation failed" + :context-format context-format + :context-arguments context-arguments)) + (:error (error 'compile-failed-error + :description "Lisp compilation failed" + :context-format context-format + :context-arguments context-arguments)) + (:ignore nil))) + (when warnings-p + (case *compile-file-warnings-behaviour* + (:warn (warn 'compile-warned-warning + :description "Lisp compilation had style-warnings" + :context-format context-format + :context-arguments context-arguments)) + (:error (error 'compile-warned-error + :description "Lisp compilation had style-warnings" + :context-format context-format + :context-arguments context-arguments)) + (:ignore nil)))) + + (defun check-lisp-compile-results (output warnings-p failure-p + &optional context-format context-arguments) + (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))) + + +;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. +;;; +;;; To support an implementation, three functions must be implemented: +;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings +;;; See their respective docstrings. +(with-upgradability () + (defun reify-simple-sexp (sexp) + (etypecase sexp + (symbol (reify-symbol sexp)) + ((or number character simple-string pathname) sexp) + (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) + (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) + + (defun unreify-simple-sexp (sexp) + (etypecase sexp + ((or symbol number character simple-string pathname) sexp) + (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) + ((simple-vector 2) (unreify-symbol sexp)) + ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) + + #+clozure + (progn + (defun reify-source-note (source-note) + (when source-note + (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) + (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note + (declare (ignorable source)) + (list :filename filename :start-pos start-pos :end-pos end-pos + #|:source (reify-source-note source)|#)))) + (defun unreify-source-note (source-note) + (when source-note + (destructuring-bind (&key filename start-pos end-pos source) source-note + (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos + :source (unreify-source-note source))))) + (defun unsymbolify-function-name (name) + (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) + `(setf ,setfed) + name)) + (defun symbolify-function-name (name) + (if (and (consp name) (eq (first name) 'setf)) + (let ((setfed (second name))) + (gethash setfed ccl::%setf-function-names%)) + name)) + (defun reify-function-name (function-name) + (let ((name (or (first function-name) ;; defun: extract the name + (let ((sec (second function-name))) + (or (and (atom sec) sec) ; scoped method: drop scope + (first sec)))))) ; method: keep gf name, drop method specializers + (list name))) + (defun unreify-function-name (function-name) + function-name) + (defun nullify-non-literals (sexp) + (typecase sexp + ((or number character simple-string symbol pathname) sexp) + (cons (cons (nullify-non-literals (car sexp)) + (nullify-non-literals (cdr sexp)))) + (t nil))) + (defun reify-deferred-warning (deferred-warning) + (with-accessors ((warning-type ccl::compiler-warning-warning-type) + (args ccl::compiler-warning-args) + (source-note ccl:compiler-warning-source-note) + (function-name ccl:compiler-warning-function-name)) deferred-warning + (list :warning-type warning-type :function-name (reify-function-name function-name) + :source-note (reify-source-note source-note) + :args (destructuring-bind (fun &rest more) + args + (cons (unsymbolify-function-name fun) + (nullify-non-literals more)))))) + (defun unreify-deferred-warning (reified-deferred-warning) + (destructuring-bind (&key warning-type function-name source-note args) + reified-deferred-warning + (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) + 'ccl::compiler-warning) + :function-name (unreify-function-name function-name) + :source-note (unreify-source-note source-note) + :warning-type warning-type + :args (destructuring-bind (fun . more) args + (cons (symbolify-function-name fun) more)))))) + #+(or cmu scl) + (defun reify-undefined-warning (warning) + ;; Extracting undefined-warnings from the compilation-unit + ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" + (list* + (c::undefined-warning-kind warning) + (c::undefined-warning-name warning) + (c::undefined-warning-count warning) + (mapcar + #'(lambda (frob) + ;; the lexenv slot can be ignored for reporting purposes + `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob) + :source ,(c::compiler-error-context-source frob) + :original-source ,(c::compiler-error-context-original-source frob) + :context ,(c::compiler-error-context-context frob) + :file-name ,(c::compiler-error-context-file-name frob) ; a pathname + :file-position ,(c::compiler-error-context-file-position frob) ; an integer + :original-source-path ,(c::compiler-error-context-original-source-path frob))) + (c::undefined-warning-warnings warning)))) + + #+sbcl + (defun reify-undefined-warning (warning) + ;; Extracting undefined-warnings from the compilation-unit + ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" + (list* + (sb-c::undefined-warning-kind warning) + (sb-c::undefined-warning-name warning) + (sb-c::undefined-warning-count warning) + (mapcar + #'(lambda (frob) + ;; the lexenv slot can be ignored for reporting purposes + `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) + :source ,(sb-c::compiler-error-context-source frob) + :original-source ,(sb-c::compiler-error-context-original-source frob) + :context ,(sb-c::compiler-error-context-context frob) + :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname + :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer + :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) + (sb-c::undefined-warning-warnings warning)))) + + (defun reify-deferred-warnings () + "return a portable S-expression, portably readable and writeable in any Common Lisp implementation +using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by +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.) + #+clozure + (mapcar 'reify-deferred-warning + (if-let (dw ccl::*outstanding-deferred-warnings*) + (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) + (ccl::deferred-warnings.warnings mdw)))) + #+(or cmu scl) + (when lisp::*in-compilation-unit* + ;; Try to send nothing through the pipe if nothing needs to be accumulated + `(,@(when c::*undefined-warnings* + `((c::*undefined-warnings* + ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*)))) + ,@(loop :for what :in '(c::*compiler-error-count* + c::*compiler-warning-count* + c::*compiler-note-count*) + :for value = (symbol-value what) + :when (plusp value) + :collect `(,what . ,value)))) + #+sbcl + (when sb-c::*in-compilation-unit* + ;; Try to send nothing through the pipe if nothing needs to be accumulated + `(,@(when sb-c::*undefined-warnings* + `((sb-c::*undefined-warnings* + ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) + ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* + sb-c::*compiler-error-count* + sb-c::*compiler-warning-count* + sb-c::*compiler-style-warning-count* + sb-c::*compiler-note-count*) + :for value = (symbol-value what) + :when (plusp value) + :collect `(,what . ,value))))) + + (defun unreify-deferred-warnings (reified-deferred-warnings) + "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding +deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT. +Handle any warning that has been resolved already, +such as an undefined function that has been defined since. +One of three functions required for deferred-warnings support in ASDF." + (declare (ignorable reified-deferred-warnings)) + #+allegro + (destructuring-bind (&key functions-defined functions-called) + reified-deferred-warnings + (setf excl::.functions-defined. + (append functions-defined excl::.functions-defined.) + excl::.functions-called. + (append functions-called excl::.functions-called.))) + #+clozure + (let ((dw (or ccl::*outstanding-deferred-warnings* + (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) + (appendf (ccl::deferred-warnings.warnings dw) + (mapcar 'unreify-deferred-warning reified-deferred-warnings))) + #+(or cmu scl) + (dolist (item reified-deferred-warnings) + ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. + ;; For *undefined-warnings*, the adjustment is a list of initargs. + ;; For everything else, it's an integer. + (destructuring-bind (symbol . adjustment) item + (case symbol + ((c::*undefined-warnings*) + (setf c::*undefined-warnings* + (nconc (mapcan + #'(lambda (stuff) + (destructuring-bind (kind name count . rest) stuff + (unless (case kind (:function (fboundp name))) + (list + (c::make-undefined-warning + :name name + :kind kind + :count count + :warnings + (mapcar #'(lambda (x) + (apply #'c::make-compiler-error-context x)) + rest)))))) + adjustment) + c::*undefined-warnings*))) + (otherwise + (set symbol (+ (symbol-value symbol) adjustment)))))) + #+sbcl + (dolist (item reified-deferred-warnings) + ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. + ;; For *undefined-warnings*, the adjustment is a list of initargs. + ;; For everything else, it's an integer. + (destructuring-bind (symbol . adjustment) item + (case symbol + ((sb-c::*undefined-warnings*) + (setf sb-c::*undefined-warnings* + (nconc (mapcan + #'(lambda (stuff) + (destructuring-bind (kind name count . rest) stuff + (unless (case kind (:function (fboundp name))) + (list + (sb-c::make-undefined-warning + :name name + :kind kind + :count count + :warnings + (mapcar #'(lambda (x) + (apply #'sb-c::make-compiler-error-context x)) + rest)))))) + adjustment) + sb-c::*undefined-warnings*))) + (otherwise + (set symbol (+ (symbol-value symbol) adjustment))))))) + + (defun reset-deferred-warnings () + "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. +One of three functions required for deferred-warnings support in ASDF." + #+allegro + (setf excl::.functions-defined. nil + excl::.functions-called. nil) + #+clozure + (if-let (dw ccl::*outstanding-deferred-warnings*) + (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) + (setf (ccl::deferred-warnings.warnings mdw) nil))) + #+(or cmu scl) + (when lisp::*in-compilation-unit* + (setf c::*undefined-warnings* nil + c::*compiler-error-count* 0 + c::*compiler-warning-count* 0 + c::*compiler-note-count* 0)) + #+sbcl + (when sb-c::*in-compilation-unit* + (setf sb-c::*undefined-warnings* nil + sb-c::*aborted-compilation-unit-count* 0 + sb-c::*compiler-error-count* 0 + sb-c::*compiler-warning-count* 0 + sb-c::*compiler-style-warning-count* 0 + sb-c::*compiler-note-count* 0))) + + (defun save-deferred-warnings (warnings-file) + "Save forward reference conditions so they may be issued at a latter time, +possibly in a different process." + (with-open-file (s warnings-file :direction :output :if-exists :supersede + :element-type *default-stream-element-type* + :external-format *utf-8-external-format*) + (with-safe-io-syntax () + (write (reify-deferred-warnings) :stream s :pretty t :readably t) + (terpri s)))) + + (defun warnings-file-type (&optional implementation-type) + (case (or implementation-type *implementation-type*) + ((:acl :allegro) "allegro-warnings") + ;;((:clisp) "clisp-warnings") + ((:cmu :cmucl) "cmucl-warnings") + ((:sbcl) "sbcl-warnings") + ((:clozure :ccl) "ccl-warnings") + ((:scl) "scl-warnings"))) + + (defvar *warnings-file-type* nil + "Type for warnings files") + + (defun enable-deferred-warnings-check () + (setf *warnings-file-type* (warnings-file-type))) + + (defun disable-deferred-warnings-check () + (setf *warnings-file-type* nil)) + + (defun warnings-file-p (file &optional implementation-type) + (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) + (let ((file-errors nil) + (failure-p nil) + (warnings-p nil)) + (handler-bind + ((warning #'(lambda (c) + (setf warnings-p t) + (unless (typep c 'style-warning) + (setf failure-p t))))) + (with-compilation-unit (:override t) + (reset-deferred-warnings) + (dolist (file files) + (unreify-deferred-warnings + (handler-case (safe-read-file-form file) + (error (c) + ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging + (push c file-errors) + nil)))))) + (dolist (error file-errors) (error error)) + (check-lisp-compile-warnings + (or failure-p warnings-p) failure-p context-format context-arguments))) + + #| + Mini-guide to adding support for deferred warnings on an implementation. + + First, look at what such a warning looks like: + + (describe + (handler-case + (and (eval '(lambda () (some-undefined-function))) nil) + (t (c) c))) + + Then you can grep for the condition type in your compiler sources + and see how to catch those that have been deferred, + and/or read, clear and restore the deferred list. + + Also look at + (macroexpand-1 '(with-compilation-unit () foo)) + |# + + (defun call-with-saved-deferred-warnings (thunk warnings-file) + (if warnings-file + (with-compilation-unit (:override t) + (unwind-protect + (let (#+sbcl (sb-c::*undefined-warnings* nil)) + (multiple-value-prog1 + (funcall thunk) + (save-deferred-warnings warnings-file))) + (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))) + + +;;; from ASDF +(with-upgradability () + (defun current-lisp-file-pathname () + (or *compile-file-pathname* *load-pathname*)) + + (defun load-pathname () + *load-pathname*) + + (defun lispize-pathname (input-file) + (make-pathname :type "lisp" :defaults input-file)) + + (defun compile-file-type (&rest keys) + "pathname TYPE for lisp FASt Loading files" + (declare (ignorable keys)) + #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) + + (defun call-around-hook (hook function) + (call-function (or hook 'funcall) function)) + + (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (let* ((keys + (remove-plist-keys `(#+(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 + (let* ((type (pathname-type (apply 'compile-file-type keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) + (funcall *output-translation-function* + (apply 'compile-file-pathname input-file keys))))) + + (defun* (compile-file*) (input-file &rest keys + &key compile-check output-file warnings-file + #+clisp lib-file #+(or ecl mkcl) object-file + &allow-other-keys) + "This function provides a portable wrapper around COMPILE-FILE. +It ensures that the OUTPUT-FILE value is only returned and +the file only actually created if the compilation was successful, +even though your implementation may not do that, and including +an optional call to an user-provided consistency check function COMPILE-CHECK; +it will call this function if not NIL at the end of the compilation +with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE +where TMP-FILE is the name of a temporary output-file. +It also checks two flags (with legacy british spelling from ASDF1), +*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* +with appropriate implementation-dependent defaults, +and if a failure (respectively warnings) are reported by COMPILE-FILE +with consider it an error unless the respective behaviour flag +is one of :SUCCESS :WARN :IGNORE. +If WARNINGS-FILE is defined, deferred warnings are saved to that file. +On ECL or MKCL, it creates both the linkable object and loadable fasl files. +On implementations that erroneously do not recognize standard keyword arguments, +it will filter them appropriately." + #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file))) + (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" + 'compile-file* output-file object-file) + (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)) + (output-file + (or output-file + (apply 'compile-file-pathname* input-file :output-file output-file keywords))) + #+ecl + (object-file + (unless (use-ecl-byte-compiler-p) + (or object-file + (compile-file-pathname output-file :type :object)))) + #+mkcl + (object-file + (or object-file + (compile-file-pathname output-file :fasl-p nil))) + (tmp-file (tmpize-pathname output-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)))) + (cond + ((and output-truename + (flet ((check-flag (flag behaviour) + (or (not flag) (member behaviour '(:success :warn :ignore))))) + (and (check-flag failure-p *compile-file-failure-behaviour*) + (check-flag warnings-p *compile-file-warnings-behaviour*))) + (progn + #+(or ecl mkcl) + (when (and #+ecl object-file) + (setf output-truename + (compiler::build-fasl + tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files + (list object-file)))) + (or (not compile-check) + (apply compile-check input-file :output-file tmp-file keywords)))) + (delete-file-if-exists output-file) + (when output-truename + #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-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) + (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))))) + + (defun load-from-string (string) + "Portably read and evaluate forms from a STRING." + (with-input-from-string (s string) (load* s)))) + +;;; Links FASLs together +(with-upgradability () + (defun combine-fasls (inputs 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) + #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 + #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+lispworks + (let (fasls) + (unwind-protect + (progn + (loop :for i :in inputs + :for n :from 1 + :for f = (add-pathname-suffix + output (format nil "-FASL~D" n)) + :do (copy-file i f) + (push f fasls)) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) + (eval `(scm:defsystem :fasls-to-concatenate + (:default-pathname ,(pathname-directory-pathname output)) + :members + ,(loop :for f :in (reverse fasls) + :collect `(,(namestring f) :load-only t)))) + (scm:concatenate-system output :fasls-to-concatenate)) + (loop :for f :in fasls :do (ignore-errors (delete-file f))) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) + +;;;; --------------------------------------------------------------------------- +;;;; Generic support for configuration files + +(uiop/package:define-package :uiop/configuration + (:nicknames :asdf/configuration) + (:recycle :uiop/configuration :asdf/configuration :asdf) + (:use :uiop/common-lisp :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) + (:export + #:get-folder-path + #:user-configuration-directories #:system-configuration-directories + #:in-first-directory + #:in-user-configuration-directory #:in-system-configuration-directory + #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory + #:configuration-inheritance-directive-p + #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* + #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook + #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* + #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) +(in-package :uiop/configuration) + +(with-upgradability () + (define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s (compatfmt "~@<~? (will be skipped)~@:>") + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) + + (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) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + (ecase folder + (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) + (:appdata (getenv-absolute-directory "APPDATA")) + (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) + + (defun user-configuration-directories () + (let ((dirs + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") + :collect (subpathname* dir "common-lisp/")))) + ,@(when (os-windows-p) + `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") + ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) + ,(subpathname (user-homedir-pathname) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) + + (defun system-configuration-directories () + (cond + ((os-unix-p) '(#p"/etc/common-lisp/")) + ((os-windows-p) + (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")) + (list it))))) + + (defun in-first-directory (dirs x &key (direction :input)) + (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)))))) + + (defun in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) + (defun in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) + + (defun configuration-inheritance-directive-p (x) + (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) + (etypecase reporter + (null + (apply 'error 'invalid-configuration args)) + (function + (apply reporter args)) + ((or symbol string) + (apply 'error reporter args)) + (cons + (apply 'apply (append reporter args))))) + + (defvar *ignored-configuration-form* nil) + + (defun validate-configuration-form (form tag directive-validator + &key location invalid-form-reporter) + (unless (and (consp form) (eq (car form) tag)) + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form form :location location) + (return-from validate-configuration-form nil)) + (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) + :for directive :in (cdr form) + :when (cond + ((configuration-inheritance-directive-p directive) + (incf inherit) t) + ((eq directive :ignore-invalid-entries) + (setf ignore-invalid-p t) t) + ((funcall directive-validator directive) + t) + (ignore-invalid-p + nil) + (t + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form directive :location location) + nil)) + :do (push directive x) + :finally + (unless (= inherit 1) + (report-invalid-form invalid-form-reporter + :arguments (list (compatfmt "~@") + :inherit-configuration :ignore-inherited-configuration))) + (return (nreverse x)))) + + (defun validate-configuration-file (file validator &key description) + (let ((forms (read-file-forms file))) + (unless (length=n-p forms 1) + (error (compatfmt "~@~%") + description forms)) + (funcall validator (car forms) :location file))) + + (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." + (let ((files (sort (ignore-errors + (remove-if + 'hidden-pathname-p + (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) + #'string< :key #'namestring))) + `(,tag + ,@(loop :for file :in files :append + (loop :with ignore-invalid-p = nil + :for form :in (read-file-forms file) + :when (eq form :ignore-invalid-entries) + :do (setf ignore-invalid-p t) + :else + :when (funcall validator form) + :collect form + :else + :when ignore-invalid-p + :do (setf *ignored-configuration-form* t) + :else + :do (report-invalid-form invalid-form-reporter :form form :location file))) + :inherit-configuration))) + + (defun resolve-relative-location (x &key ensure-directory wilden) + (ensure-pathname + (etypecase x + (pathname x) + (string (parse-unix-namestring + x :ensure-directory ensure-directory)) + (cons + (if (null (cdr x)) + (resolve-relative-location + (car x) :ensure-directory ensure-directory :wilden wilden) + (let* ((car (resolve-relative-location + (car x) :ensure-directory t :wilden nil))) + (merge-pathnames* + (resolve-relative-location + (cdr x) :ensure-directory ensure-directory :wilden wilden) + car)))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (parse-unix-namestring + (implementation-identifier) :ensure-directory t)) + ((eql :implementation-type) + (parse-unix-namestring + (string-downcase (implementation-type)) :ensure-directory t)) + ((eql :hostname) + (parse-unix-namestring (hostname) :ensure-directory t))) + :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) + :want-relative t)) + + (defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + + (defvar *user-cache* nil + "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") + + (defun compute-user-cache () + (setf *user-cache* + (flet ((try (x &rest sub) (and x `(,x ,@sub)))) + (or + (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) + (when (os-windows-p) + (try (or (get-folder-path :local-appdata) + (get-folder-path :appdata)) + "common-lisp" "cache" :implementation)) + '(:home ".cache" "common-lisp" :implementation))))) + (register-image-restore-hook 'compute-user-cache) + + (defun resolve-absolute-location (x &key ensure-directory wilden) + (ensure-pathname + (etypecase x + (pathname x) + (string + (let ((p #-mcl (parse-namestring x) + #+mcl (probe-posix x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if ensure-directory (ensure-directory-pathname p) p))) + (cons + (return-from resolve-absolute-location + (if (null (cdr x)) + (resolve-absolute-location + (car x) :ensure-directory ensure-directory :wilden wilden) + (merge-pathnames* + (resolve-relative-location + (cdr x) :ensure-directory ensure-directory :wilden wilden) + (resolve-absolute-location + (car x) :ensure-directory t :wilden nil))))) + ((eql :root) + ;; special magic! we return a relative pathname, + ;; but what it means to the output-translations is + ;; "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location + (let ((p (make-pathname* :directory '(:relative)))) + (if wilden (wilden p) p)))) + ((eql :home) (user-homedir-pathname)) + ((eql :here) (resolve-absolute-location + (or *here-directory* (pathname-directory-pathname (load-pathname))) + :ensure-directory t :wilden nil)) + ((eql :user-cache) (resolve-absolute-location + *user-cache* :ensure-directory t :wilden nil))) + :wilden (and wilden (not (pathnamep x))) + :resolve-symlinks *resolve-symlinks* + :want-absolute t)) + + ;; Try to override declaration in previous versions of ASDF. + (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) + (:ensure-directory boolean)) t) resolve-location)) + + (defun* (resolve-location) (x &key ensure-directory wilden directory) + ;; :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) + :with path = (resolve-absolute-location + first :ensure-directory (and (or dirp rest) t) + :wilden (and wilden (null rest))) + :for (element . morep) :on rest + :for dir = (and (or morep dirp) t) + :for wild = (and wilden (not morep)) + :for sub = (merge-pathnames* + (resolve-relative-location + element :ensure-directory dir :wilden wild) + path) + :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub)) + :finally (return path))) + + (defun location-designator-p (x) + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :*/ :**/ :*.*.* :implementation :implementation-type))))) + (or (typep x 'boolean) + (absolute-component-p x) + (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) + + (defun location-function-p (x) + (and + (length=n-p x 2) + (eq (car x) :function) + (or (symbolp (cadr x)) + (and (consp (cadr x)) + (eq (caadr x) 'lambda) + (length=n-p (cadadr x) 2))))) + + (defvar *clear-configuration-hook* '()) + + (defun register-clear-configuration-hook (hook-function &optional call-now-p) + (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) + + (defun clear-configuration () + (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 () + (when *ignored-configuration-form* + (clear-configuration) + (setf *ignored-configuration-form* nil)))) + + +;;;; ------------------------------------------------------------------------- +;;; Hacks for backward-compatibility of the driver + +(uiop/package:define-package :uiop/backward-driver + (:nicknames :asdf/backward-driver) + (:recycle :uiop/backward-driver :asdf/backward-driver :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/pathname :uiop/stream :uiop/os :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration) + (:export + #:coerce-pathname #:component-name-to-pathname-components + #+(or ecl mkcl) #:compile-file-keeping-object + )) +(in-package :uiop/backward-driver) + +;;;; Backward compatibility with various pathname functions. + +(with-upgradability () + (defun coerce-pathname (name &key type defaults) + ;; For backward-compatibility only, for people using internals + ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb + ;; Will be removed after 2014-01-16. + ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") + (parse-unix-namestring name :type type :defaults defaults)) + + (defun component-name-to-pathname-components (unix-style-namestring + &key force-directory force-relative) + ;; Will be removed after 2014-01-16. + ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") + (multiple-value-bind (relabs path filename file-only) + (split-unix-namestring-directory-components + unix-style-namestring :ensure-directory force-directory) + (declare (ignore file-only)) + (when (and force-relative (not (eq relabs :relative))) + (error (compatfmt "~@") + unix-style-namestring)) + (values relabs path filename))) + + #+(or ecl mkcl) + (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))) +;;;; --------------------------------------------------------------------------- +;;;; Re-export all the functionality in asdf/driver + +(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. + :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)) +;;;; ------------------------------------------------------------------------- +;;;; Handle upgrade as forward- and backward-compatibly as possible +;; See https://bugs.launchpad.net/asdf/+bug/485687 + +(asdf/package:define-package :asdf/upgrade + (:recycle :asdf/upgrade :asdf) + (:use :asdf/common-lisp :asdf/driver) + (:export + #:asdf-version #:*previous-asdf-versions* #:*asdf-version* + #:asdf-message #:*verbose-out* + #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error + #:*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*)) +(in-package :asdf/upgrade) + +;;; Special magic to detect if this is an upgrade + +(with-upgradability () + (defun asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")." + (when (find-package :asdf) + (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) + (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf)) + (rev (and revsym (boundp revsym) (symbol-value revsym)))) + (etypecase rev + (string rev) + (cons (format nil "~{~D~^.~}" rev)) + (null "1.0")))))) + (defvar *asdf-version* nil) + (defvar *previous-asdf-versions* nil) + (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) + `(with-upgradability () + (when (and ,upgrading-p ,@(when when `(,when))) + (handler-bind ((style-warning #'muffle-warning)) + (eval '(progn ,@body)))))) + (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. + ;; "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.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 "3.0.0") + (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* + (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. + '(#: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) + :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)))))))) + + +;;; Self-upgrade functions + +(with-upgradability () + (defun asdf-upgrade-error () + ;; Important notice for whom it concerns. The crux of the matter is that + ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. + (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ + Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%")) + + (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) + (let ((new-version (asdf-version))) + (unless (equal old-version new-version) + (push new-version *previous-asdf-versions*) + (when old-version + (if (version<= new-version old-version) + (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + 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*)) + t)))) + + (defun upgrade-asdf () + "Try to upgrade of ASDF. If a different version was used, return T. + We need do that before we operate on anything that may possibly depend on ASDF." + (let ((*load-print* nil) + (*compile-print* nil)) + (handler-bind (((or style-warning) #'muffle-warning)) + (symbol-call :asdf :load-system :asdf :verbose nil)))) + + (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) + +;;;; ------------------------------------------------------------------------- +;;;; Components + +(asdf/package:define-package :asdf/component + (:recycle :asdf/component :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export + #:component #:component-find-path + #:component-name #:component-pathname #:component-relative-pathname + #:component-parent #:component-system #:component-parent-pathname + #:child-component #:parent-component #:module + #:file-component + #:source-file #:c-source-file #:java-source-file + #:static-file #:doc-file #:html-file + #:file-type + #:source-file-type #:source-file-explicit-type ;; backward-compatibility + #:component-in-order-to #:component-sideway-dependencies + #:component-if-feature #:around-compile-hook + #:component-description #:component-long-description + #:component-version #:version-satisfies + #:component-inline-methods ;; backward-compatibility only. DO NOT USE! + #:component-operation-times ;; For internal use only. + ;; portable ASDF encoding and implementation-specific external-format + #:component-external-format #:component-encoding + #:component-children-by-name #:component-children #:compute-children-by-name + #:component-build-operation + #:module-default-component-class + #:module-components ;; backward-compatibility. DO NOT USE. + #:sub-components + + ;; 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 + #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods + #:relative-pathname #:absolute-pathname #:operation-times #:around-compile + #:%encoding #:properties #:component-properties #:parent)) +(in-package :asdf/component) + +(with-upgradability () + (defgeneric component-name (component) + (:documentation "Name of the COMPONENT, unique relative to its parent")) + (defgeneric component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + (defgeneric component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + (defgeneric (component-relative-pathname) (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) + (defgeneric component-external-format (component)) + (defgeneric component-encoding (component)) + (defgeneric version-satisfies (component version)) + (defgeneric component-version (component)) + (defgeneric (setf component-version) (new-version component)) + (defgeneric component-parent (component)) + (defmethod component-parent ((component null)) (declare (ignorable component)) 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))) + +(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 () + ((name :accessor component-name :initarg :name :type string :documentation + "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! + (version :accessor component-version :initarg :version :initform nil) + (description :accessor component-description :initarg :description :initform nil) + (long-description :accessor component-long-description :initarg :long-description :initform nil) + (sideway-dependencies :accessor component-sideway-dependencies :initform nil) + (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) + ;; In the ASDF object model, dependencies exist between *actions*, + ;; where an action is a pair of an operation and a component. + ;; Dependencies are represented as alists of operations + ;; to a list where each entry is a pair of an operation and a list of component specifiers. + ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: + ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. + ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) + ;; and do-first things that modify the current image (such as loading a fasl). + ;; These are now unified because we now correctly propagate timestamps between dependencies. + ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017, + ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains. + ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. + ;; See our ASDF 2 paper for more complete explanations. + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated. + (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES. + ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. + ;; There is no initform and no direct accessor for this specified pathname, + ;; so we only access the information through appropriate methods, after it has been processed. + ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4. + (relative-pathname :initarg :pathname) + ;; The absolute-pathname is computed based on relative-pathname and parent pathname. + ;; The slot is but a cache used by component-pathname. + (absolute-pathname) + (operation-times :initform (make-hash-table) + :accessor component-operation-times) + (around-compile :initarg :around-compile) + ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE! + (properties :accessor component-properties :initarg :properties + :initform nil) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) + ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. + (parent :initarg :parent :initform nil :reader component-parent) + (build-operation + :initarg :build-operation :initform nil :reader component-build-operation))) + + (defun component-find-path (component) + (check-type component (or null component)) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + + (defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~{~S~^ ~}" (component-find-path c)))) + + (defmethod component-system ((component component)) + (if-let (system (component-parent component)) + (component-system system) + component))) + + +;;;; Component hierarchy within a system +;; The tree typically but not necessarily follows the filesystem hierarchy. +(with-upgradability () + (defclass child-component (component) ()) + + (defclass file-component (child-component) + ((type :accessor file-type :initarg :type))) ; no default + (defclass source-file (file-component) + ((type :accessor source-file-explicit-type ;; backward-compatibility + :initform nil))) ;; NB: many systems have come to rely on this default. + (defclass c-source-file (source-file) + ((type :initform "c"))) + (defclass java-source-file (source-file) + ((type :initform "java"))) + (defclass static-file (source-file) + ((type :initform nil))) + (defclass doc-file (static-file) ()) + (defclass html-file (doc-file) + ((type :initform "html"))) + + (defclass parent-component (component) + ((children + :initform nil + :initarg :components + :reader module-components ; backward-compatibility + :accessor component-children) + (children-by-name + :reader module-components-by-name ; backward-compatibility + :accessor component-children-by-name) + (default-component-class + :initform nil + :initarg :default-component-class + :accessor module-default-component-class)))) + +(with-upgradability () + (defun compute-children-by-name (parent &key only-if-needed-p) + (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) + (let ((hash (make-hash-table :test 'equal))) + (setf (component-children-by-name parent) hash) + (loop :for c :in (component-children parent) + :for name = (component-name c) + :for previous = (gethash name hash) + :do (when previous (error 'duplicate-names :name name)) + (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 + + +;;;; component pathnames +(with-upgradability () + (defgeneric* (component-parent-pathname) (component)) + (defmethod component-parent-pathname (component) + (component-pathname (component-parent component))) + + (defmethod component-pathname ((component component)) + (if (slot-boundp component 'absolute-pathname) + (slot-value component 'absolute-pathname) + (let ((pathname + (merge-pathnames* + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) + (unless (or (null pathname) (absolute-pathname-p pathname)) + (error (compatfmt "~@") + pathname (component-find-path component))) + (setf (slot-value component 'absolute-pathname) pathname) + 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. + (parse-unix-namestring + (or (and (slot-boundp component 'relative-pathname) + (slot-value component 'relative-pathname)) + (component-name component)) + :want-relative t + :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)) + :directory) + + (defmethod source-file-type ((component file-component) system) + (declare (ignorable system)) + (file-type component))) + + +;;;; Encodings +(with-upgradability () + (defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) + + (defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c)))) + + +;;;; around-compile-hook +(with-upgradability () + (defgeneric around-compile-hook (component)) + (defmethod around-compile-hook ((c component)) + (cond + ((slot-boundp c 'around-compile) + (slot-value c 'around-compile)) + ((component-parent c) + (around-compile-hook (component-parent c)))))) + + +;;;; version-satisfies +(with-upgradability () + (defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) + (return-from version-satisfies t)) + (version-satisfies (component-version c) version)) + + (defmethod version-satisfies ((cver string) version) + (version-compatible-p cver version))) + + +;;; all sub-components (of a given type) +(with-upgradability () + (defun sub-components (component &key (type t)) + (while-collecting (c) + (labels ((recurse (x) + (when (if-let (it (component-if-feature x)) (featurep it) t) + (when (typep x type) + (c x)) + (when (typep x 'parent-component) + (map () #'recurse (component-children x)))))) + (recurse component))))) + +;;;; ------------------------------------------------------------------------- +;;;; Systems + +(asdf/package:define-package :asdf/system + (:recycle :asdf :asdf/system) + (:use :asdf/common-lisp :asdf/driver :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 + #:component-build-pathname #:build-pathname + #:component-entry-point #:entry-point + #:homepage #:system-homepage + #:bug-tracker #:system-bug-tracker + #:mailto #:system-mailto + #:long-name #:system-long-name + #:source-control #:system-source-control + #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system +(in-package :asdf/system) + +(with-upgradability () + (defgeneric* (find-system) (system &optional error-p)) + (defgeneric* (system-source-file) (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)) + + +;;;; The system class + +(with-upgradability () + (defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) (source-file) #|(children) (children-by-names)|#)) + + (defclass system (module proto-system) + ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. + (;; {,long-}description is now inherited from component, but we add the legacy accessors + (description :accessor system-description) + (long-description :accessor system-long-description) + (author :accessor system-author :initarg :author :initform nil) + (maintainer :accessor system-maintainer :initarg :maintainer :initform nil) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license :initform nil) + (homepage :accessor system-homepage :initarg :homepage :initform nil) + (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil) + (mailto :accessor system-mailto :initarg :mailto :initform nil) + (long-name :accessor system-long-name :initarg :long-name :initform nil) + ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced. + ;; I'm introducing the slot before the conventions are set for maximum compatibility. + (source-control :accessor system-source-control :initarg :source-control :initform nil) + (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) + (build-pathname + :initform nil :initarg :build-pathname :accessor component-build-pathname) + (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))) + + (defun reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys))) + + +;;;; Pathnames + +(with-upgradability () + (defmethod system-source-file ((system-name string)) + (system-source-file (find-system system-name))) + (defmethod system-source-file ((system-name symbol)) + (system-source-file (find-system system-name))) + + (defun system-source-directory (system-designator) + "Return a pathname object corresponding to the directory +in which the system specification (.asd file) is located." + (pathname-directory-pathname (system-source-file system-designator))) + + (defun (system-relative-pathname) (system name &key type) + (subpathname (system-source-directory system) name :type type)) + + (defmethod component-pathname ((system system)) + (let ((pathname (or (call-next-method) (system-source-directory system)))) + (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age + (slot-value system 'relative-pathname)) ;; systems that directly access this slot. + (setf (slot-value system 'relative-pathname) pathname)) + pathname)) + + (defmethod component-relative-pathname ((system system)) + (parse-unix-namestring + (and (slot-boundp system 'relative-pathname) + (slot-value system 'relative-pathname)) + :want-relative t + :type :directory + :ensure-absolute t + :defaults (system-source-directory system))) + + (defmethod component-parent-pathname ((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) + (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp + #:consult-asdf-cache #:do-asdf-cache + #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) +(in-package :asdf/cache) + +;;; This stamp cache is useful for: +;; * consistency of stamps used within a single run +;; * fewer accesses to the filesystem +;; * the ability to test with fake timestamps, without touching files + +(with-upgradability () + (defvar *asdf-cache* nil) + + (defun set-asdf-cache-entry (key value-list) + (apply 'values + (if *asdf-cache* + (setf (gethash key *asdf-cache*) value-list) + value-list))) + + (defun consult-asdf-cache (key &optional thunk) + (if *asdf-cache* + (multiple-value-bind (results foundp) (gethash key *asdf-cache*) + (if foundp + (apply 'values results) + (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) + (call-function thunk))) + + (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)))) + + (defmacro with-asdf-cache ((&key override) &body body) + `(call-with-asdf-cache #'(lambda () ,@body) :override ,override)) + + (defun compute-file-stamp (file) + (safe-file-write-date file)) + + (defun register-file-stamp (file &optional (stamp (compute-file-stamp file))) + (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp))) + + (defun get-file-stamp (file) + (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))) + + +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(asdf/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) + (: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 + #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems + #:system-definition-error #: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* + #: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* + ;; 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))) + + (define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply 'format s (format-control c) (format-arguments c))))) + + (define-condition load-system-definition-error (system-definition-error) + ((name :initarg :name :reader error-name) + (pathname :initarg :pathname :reader error-pathname) + (condition :initarg :condition :reader error-condition)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (error-name c) (error-pathname c) (error-condition c))))) + + (defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments)) + + (defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error (compatfmt "~@") name)))) + + (defun primary-system-name (name) + ;; When a system name has slashes, the file with defsystem is named by + ;; the first of the slash-separated components. + (first (split-string (coerce-name name) :separator "/"))) + + (defun coerce-filename (name) + (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) + + (defvar *defined-systems* (make-hash-table :test 'equal) + "This is a hash table whose keys are strings, being the +names of the systems, and whose values are pairs, the first +element of which is a universal-time indicating when the +system definition was last updated, and the second element +of which is a system object.") + + (defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + + (defun registered-systems () + (loop :for registered :being :the :hash-values :of *defined-systems* + :collect (coerce-name (cdr registered)))) + + (defun register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (if-let (file (ignore-errors (system-source-file system))) + (get-file-stamp file)) + system))))) + + (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)) + + (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) + + (defun clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. + (remhash (coerce-name name) *defined-systems*)) + + (defun map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (loop :for registered :being :the :hash-values :of *defined-systems* + :do (funcall fn (cdr registered))))) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- +(with-upgradability () + (defvar *system-definition-search-functions* '()) + + (defun cleanup-system-definition-search-functions () + (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))) + *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, + ;; but then it will be the responsibility of whoever does that + ;; 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))))) + (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*))) + + (defvar *central-registry* nil + "A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This is for backward compatibility. +Going forward, we recommend new users should be using the source-registry. +") + + (defun probe-asd (name defaults &key truename) + (block nil + (when (directory-pathname-p defaults) + (if-let (file (probe-file* + (ensure-absolute-pathname + (parse-unix-namestring name :type "asd") + #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) + nil) + :truename truename)) + (return file)) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (when (os-windows-p) + (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)))))))))) + + (defun sysdef-central-registry-search (system) + (let ((name (primary-system-name system)) + (to-remove nil) + (to-replace nil)) + (block nil + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir)) + directorized) + (when defaults + (cond ((directory-pathname-p defaults) + (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + (compatfmt "~@") + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :test (lambda (c) (declare (ignore c)) + (and (not (directory-pathname-p defaults)) + (directory-pathname-p + (setf directorized + (ensure-directory-pathname defaults))))) + :report (lambda (s) + (format s (compatfmt "~@") + directorized dir)) + (push (cons dir directorized) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position)))))))))) + + (defvar *preloaded-systems* (make-hash-table :test 'equal)) + + (defun make-preloaded-system (name keys) + (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys))) + + (defun sysdef-preloaded-system-search (requested) + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (make-preloaded-system name keys))))) + + (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*) + + (defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) + (when error-p + (sysdef-error (compatfmt "~@")))) + + (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))) + + (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-standard-io-syntax + (let ((*package* (find-package :asdf-user)) + ;; Note that our backward-compatible *readtable* is + ;; a global readtable that gets globally side-effected. Ouch. + ;; Same for the *print-pprint-dispatch* table. + ;; We should do something about that for ASDF3 if possible, or else ASDF4. + (*readtable* readtable) + (*print-pprint-dispatch* print-pprint-dispatch) + (*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)))) + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") + name pathname) + (with-muffled-loader-conditions () + (load* pathname :external-format external-format))))))) + + (defvar *old-asdf-systems* (make-hash-table :test 'equal)) + + (defun check-not-old-asdf-system (name pathname) + (or (not (equal name "asdf")) + (null pathname) + (let* ((version-pathname (subpathname pathname "version.lisp-expr")) + (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 "~@<~ + 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. ~ + Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ + and having an old version registered is a configuration error. ~ + ASDF will ignore this configured system rather than downgrade itself. ~ + In the future, you may want to either: ~ + (a) upgrade this configured ASDF to a newer version, ~ + (b) install a newer ASDF and register it in front of the former in your configuration, or ~ + (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ + Note that the older ASDF might be registered implicitly through configuration inherited ~ + from your system installation, in which case you might have to specify ~ + :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ + or other source-registry configuration file, environment variable or lisp parameter. ~ + Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ + that you might want to upgrade (if a recent enough version is available) ~ + or else remove altogether (since most implementations ship with a recent asdf); ~ + if you lack the system administration rights to upgrade or remove this package, ~ + 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))))))) + + (defun locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a system was found, +either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, +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))) + + (defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (assert (eq foundp (and (or found-system pathname previous) t))) + (let ((previous-pathname (and previous (system-source-file previous))) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (when (and pathname + (let ((stamp (get-file-stamp pathname))) + (and stamp + (not (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (translate-logical-pathname pathname) + (translate-logical-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))) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (get-file-stamp pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + (initialize-source-registry))))))) + +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(asdf/package:define-package :asdf/find-component + (:recycle :asdf/find-component :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system) + (:export + #:find-component + #:resolve-dependency-name #:resolve-dependency-spec + #:resolve-dependency-combination + ;; Conditions + #:missing-component #:missing-component-of-version #:retry + #:missing-dependency #:missing-dependency-of-version + #:missing-requires #:missing-parent + #:missing-required-by #:missing-version)) +(in-package :asdf/find-component) + +;;;; Missing component conditions + +(with-upgradability () + (define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + + (define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + + (defmethod print-object ((c missing-dependency) s) + (format s (compatfmt "~@<~A, required by ~A~@:>") + (call-next-method c nil) (missing-required-by c))) + + (define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + + (defmethod print-object ((c missing-component) s) + (format s (compatfmt "~@") + (missing-requires c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + + (defmethod print-object ((c missing-component-of-version) s) + (format s (compatfmt "~@") + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (coerce-name (missing-parent c)))))) + + +;;;; Finding components + +(with-upgradability () + (defgeneric* (find-component) (base path) + (:documentation "Find a component by resolving the PATH starting from BASE parent")) + (defgeneric resolve-dependency-combination (component combinator arguments)) + + (defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) + + (defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + + (defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + + (defmethod find-component ((parent parent-component) (name string)) + (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! + (values (gethash name (component-children-by-name parent)))) + + (defmethod find-component (base (name symbol)) + (if name + (find-component base (coerce-name name)) + base)) + + (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)) + actual) + + (defun resolve-dependency-name (component name &optional version) + (loop + (restart-case + (return + (let ((comp (find-component (component-parent component) name))) + (unless comp + (error 'missing-dependency + :required-by component + :requires name)) + (when version + (unless (version-satisfies comp version) + (error 'missing-dependency-of-version + :required-by component + :version version + :requires name))) + comp)) + (retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + :test + (lambda (c) + (or (null c) + (and (typep c 'missing-dependency) + (eq (missing-required-by c) component) + (equal (missing-requires c) name)))))))) + + (defun resolve-dependency-spec (component dep-spec) + (let ((component (find-component () component))) + (if (atom dep-spec) + (resolve-dependency-name component dep-spec) + (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) + + (defmethod resolve-dependency-combination (component combinator arguments) + (error (compatfmt "~@") + (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)))) + +;;;; ------------------------------------------------------------------------- +;;;; Operations + +(asdf/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) + (:export + #:operation + #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. + #:build-op ;; THE generic operation + #:*operations* #:make-operation #:find-operation #: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))) + +(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))) + + (defmethod initialize-instance :after ((o operation) &rest initargs + &key force force-not system verbose &allow-other-keys) + (declare (ignorable force force-not system verbose)) + (unless (slot-boundp o 'original-initargs) + (setf (operation-original-initargs o) initargs))) + + (defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity nil) + (ignore-errors + (format stream "~{~S~^ ~}" (operation-original-initargs o)))))) + +;;; make-operation, find-operation + +(with-upgradability () + (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)))))) + + (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)) + 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 + (apply 'make-operation spec (operation-original-initargs context)))) + (defmethod operation-original-initargs ((context symbol)) + (declare (ignorable context)) + nil) + + (defclass build-op (operation) ())) + + +;;;; ------------------------------------------------------------------------- +;;;; Actions + +(asdf/package:define-package :asdf/action + (:nicknames :asdf-action) + (:recycle :asdf/action :asdf) + (:use :asdf/common-lisp :asdf/driver :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 + #: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)) +(in-package :asdf/action) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype action () '(cons operation component))) ;; a step to be performed while building + +(with-upgradability () + (defgeneric traverse-actions (actions &key &allow-other-keys)) + (defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) + (defgeneric required-components (component &key &allow-other-keys))) + +;;;; Reified representation for storage or debugging. Note: dropping original-initargs +(with-upgradability () + (defun action-path (action) + (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c)))) + (defun find-action (path) + (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c))))) + + +;;;; Convenience methods +(with-upgradability () + (defmacro define-convenience-action-methods + (function (operation component &optional keyp) + &key if-no-operation if-no-component operation-initargs) + (let* ((rest (gensym "REST")) + (found (gensym "FOUND")) + (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) + (flet ((next-method (o c) + (if keyp + `(apply ',function ,o ,c ,rest) + `(,function ,o ,c)))) + `(progn + (defmethod ,function ((,operation symbol) ,component ,@more-args) + (if ,operation + ,(next-method + (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. + `(apply 'make-operation ,operation :original-initargs ,rest ,rest) + `(make-operation ,operation)) + `(or (find-component () ,component) ,if-no-component)) + ,if-no-operation)) + (defmethod ,function ((,operation operation) ,component ,@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))))))))) + + +;;;; self-description +(with-upgradability () + (defgeneric action-description (operation component) + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) + (defmethod action-description (operation component) + (format nil (compatfmt "~@<~A on ~A~@:>") + (type-of operation) component)) + (defgeneric* (explain) (operation component)) + (defmethod explain ((o operation) (c component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) + (define-convenience-action-methods explain (operation component)) + + (defun format-action (stream action &optional colon-p at-sign-p) + (assert (null colon-p)) (assert (null at-sign-p)) + (destructuring-bind (operation . component) action + (princ (action-description operation component) stream)))) + + +;;;; Dependencies +(with-upgradability () + (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is an operation designator + with respect to FIND-OPERATION in the context of the OPERATION argument, + and each is a component designator with respect to + FIND-COMPONENT in the context of the COMPONENT argument, + and means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on the expression satisfying FEATUREP. + (This is DEPRECATED -- use :IF-FEATURE instead.) + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the list.")) + (define-convenience-action-methods component-depends-on (operation component)) + + (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 + + +;;;; 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. +(with-upgradability () + (defclass downward-operation (operation) + ((downward-operation + :initform nil :initarg :downward-operation :reader downward-operation :allocation :class))) + (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. + (defclass upward-operation (operation) + ((upward-operation + :initform nil :initarg :downward-operation :reader upward-operation :allocation :class))) + ;; For backward-compatibility reasons, a system inherits from module and is a child-component + ;; so we must guard against this case. ASDF4: remove that. + (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. + (defclass sideway-operation (operation) + ((sideway-operation + :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class))) + (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. + (defclass selfward-operation (operation) + ((selfward-operation + :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class))) + (defmethod component-depends-on ((o selfward-operation) (c component)) + `(,@(loop :for op :in (ensure-list (selfward-operation o)) + :collect `(,op ,c)) + ,@(call-next-method)))) + + +;;;; Inputs, Outputs, and invisible dependencies +(with-upgradability () + (defgeneric* (output-files) (operation component)) + (defgeneric* (input-files) (operation component)) + (defgeneric* (operation-done-p) (operation component) + (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) + (define-convenience-action-methods output-files (operation component)) + (define-convenience-action-methods input-files (operation component)) + (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) + "Translate output files, unless asked not to. Memoize the result." + operation component ;; hush genera, not convinced by declare ignorable(!) + (do-asdf-cache `(output-files ,operation ,component) + (values + (multiple-value-bind (pathnames fixedp) (call-next-method) + ;; 1- Make sure we have absolute pathnames + (let* ((directory (pathname-directory-pathname + (component-pathname (find-component () component)))) + (absolute-pathnames + (loop + :for pathname :in pathnames + :collect (ensure-absolute-pathname pathname directory)))) + ;; 2- Translate those pathnames as required + (if fixedp + absolute-pathnames + (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" + (let ((files (output-files operation component))) + (assert (length=n-p files 1)) + (first files))) + + (defmethod input-files :around (operation component) + "memoize input files." + (do-asdf-cache `(input-files ,operation ,component) + (call-next-method))) + + (defmethod input-files ((o operation) (c component)) + (declare (ignorable o c)) + nil) + + (defmethod input-files ((o selfward-operation) (c component)) + `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) + :append (or (output-files dep-o c) (input-files dep-o c))) + (if-let ((pathname (component-pathname c))) + (and (file-pathname-p pathname) (list pathname)))) + ,@(call-next-method)))) + + +;;;; Done performing +(with-upgradability () + (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp + (define-convenience-action-methods component-operation-time (operation component)) + + (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp) + (defgeneric compute-action-stamp (plan operation component &key just-done) + (:documentation "Has this action been successfully done already, +and at what known timestamp has it been done at or will it be done at? +Takes two keywords JUST-DONE and PLAN: +JUST-DONE is a boolean that is true if the action was just successfully performed, +at which point we want compute the actual stamp and warn if files are missing; +otherwise we are making plans, anticipating the effects of the action. +PLAN is a plan object modelling future effects of actions, +or NIL to denote what actually happened. +Returns two values: +* a STAMP saying when it was done or will be done, + or T if the action has involves files that need to be recomputed. +* a boolean DONE-P that indicates whether the action has actually been done, + and both its output-files and its in-image side-effects are up to date.")) + + (defclass action-status () + ((stamp + :initarg :stamp :reader action-stamp + :documentation "STAMP associated with the ACTION if it has been completed already +in some previous image, or T if it needs to be done.") + (done-p + :initarg :done-p :reader action-done-p + :documentation "a boolean, true iff the action was already done (before any planned action).")) + (:documentation "Status of an action")) + + (defmethod print-object ((status action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) + + (defmethod component-operation-time ((o operation) (c component)) + (gethash (type-of o) (component-operation-times c))) + + (defmethod mark-operation-done ((o operation) (c component)) + (setf (gethash (type-of o) (component-operation-times c)) + (compute-action-stamp nil o c :just-done t)))) + + +;;;; Perform +(with-upgradability () + (defgeneric* (perform-with-restarts) (operation component)) + (defgeneric* (perform) (operation component)) + (define-convenience-action-methods perform (operation component)) + + (defmethod perform :before ((o operation) (c component)) + (ensure-all-directories-exist (output-files o c))) + (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 "~@") + (class-of o) (class-of c))) + + (defmethod perform-with-restarts (operation component) + ;; TOO verbose, especially as the default. Add your own :before method + ;; to perform-with-restart or perform if you want that: + #|(explain operation component)|# + (perform operation component)) + (defmethod perform-with-restarts :around (operation component) + (loop + (restart-case + (return (call-next-method)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@") + (action-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (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 + (: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 + :asdf/operation :asdf/action) + (:export + #:try-recompiling + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations + #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op + #:call-with-around-compile-hook + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source + #:lisp-compilation-output-files #:flags)) +(in-package :asdf/lisp-action) + + +;;;; Component classes +(with-upgradability () + (defclass cl-source-file (source-file) + ((type :initform "lisp"))) + (defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) + (defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp")))) + + +;;;; Operation classes +(with-upgradability () + (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)))) + +;;; 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, + ;; so we need to directly depend on prepare-op for its side-effects in the current image. + ((selfward-operation :initform '(prepare-op compile-op)))) + (defclass compile-op (basic-compile-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-op) + (downward-operation :initform 'load-op))) + + (defclass prepare-source-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-source-op))) + (defclass load-source-op (basic-load-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-source-op))) + + (defclass test-op (selfward-operation) + ((selfward-operation :initform 'load-op)))) + + +;;;; 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 "~@") 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 "~@") c)) + (defmethod action-description ((o compile-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) + (defgeneric call-with-around-compile-hook (component thunk)) + (defmethod call-with-around-compile-hook ((c component) function) + (call-around-hook (around-compile-hook c) function)) + (defun perform-lisp-compilation (o c) + (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, + ;; we consult input-files, the first of which should be the one to compile-file + (input-file (first (input-files o c))) + ;; on some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (outputs (output-files o c))) + (multiple-value-bind (output warnings-p failure-p) + (destructuring-bind + (output-file + &optional + #+clisp lib-file + #+(or ecl mkcl) object-file + 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))))))) + (check-lisp-compile-results output warnings-p failure-p + "~/asdf-action::format-action/" (list (cons o c)))))) + + (defun report-file-p (f) + (equalp (pathname-type f) "build-report")) + (defun perform-lisp-warnings-check (o c) + (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) + (actual-warnings-files (loop :for w :in expected-warnings-files + :when (get-file-stamp w) + :collect w + :else :do (warn "Missing warnings file ~S while ~A" + w (action-description o c))))) + (check-deferred-warnings actual-warnings-files) + (let* ((output (output-files o c)) + (report (find-if #'report-file-p output))) + (when report + (with-open-file (s report :direction :output :if-exists :supersede) + (format s ":success~%")))))) + (defmethod perform ((o compile-op) (c cl-source-file)) + (perform-lisp-compilation o c)) + (defun lisp-compilation-output-files (o c) + (let* ((i (first (input-files o c))) + (f (compile-file-pathname + i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) + `(,f ;; the fasl is the primary output, in first position + #+clisp + ,@`(,(make-pathname :type "lib" :defaults f)) + #+ecl + ,@(unless (use-ecl-byte-compiler-p) + `(,(compile-file-pathname i :type :object))) + #+mkcl + ,(compile-file-pathname i :fasl-p nil) ;; object file + ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) + `(,(make-pathname :type *warnings-file-type* :defaults f)))))) + (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))) + (perform-lisp-warnings-check o c))) + (defmethod input-files ((o compile-op) (c system)) + (when (and *warnings-file-type* (not (builtin-system-p c))) + ;; The most correct way to do it would be to use: + ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) + ;; but it's expensive and we don't care too much about file order or ASDF extensions. + (loop :for sub :in (sub-components c :type 'cl-source-file) + :nconc (remove-if-not 'warnings-file-p (output-files o sub))))) + (defmethod output-files ((o compile-op) (c system)) + (when (and *warnings-file-type* (not (builtin-system-p c))) + (if-let ((pathname (component-pathname c))) + (list (subpathname pathname (coerce-filename c) :type "build-report")))))) + +;;; load-op +(with-upgradability () + (defmethod action-description ((o load-op) (c cl-source-file)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o load-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o load-op) component) + (declare (ignorable o)) + (format nil (compatfmt "~@") + component)) + (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) + (loop + (restart-case + (return (call-next-method)) + (try-recompiling () + :report (lambda (s) + (format s "Recompile ~a and try loading it again" + (component-name c))) + (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)))) + (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, load-source-op + +;;; prepare-source-op +(with-upgradability () + (defmethod action-description ((o prepare-source-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") 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)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o load-source-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@") 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)))))) + + (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 + (:recycle :asdf/plan :asdf) + (:use :asdf/common-lisp :asdf/driver :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* + #:planned-action-status #:plan-action-status #:action-already-done-p + #:circular-dependency #:circular-dependency-actions + #:node-for #:needed-in-image-p + #:action-index #:action-planned-p #:action-valid-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 + #:circular-dependency #:circular-dependency-actions + #:call-while-visiting-action #:while-visiting-action + #:traverse #: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 + #:required-components #:filtered-sequential-plan + #:plan-system + #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component + #:traverse-actions #:traverse-sub-actions)) +(in-package :asdf/plan) + +;;;; Generic plan traversal class +(with-upgradability () + (defclass plan-traversal () + ((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) + (total-action-count :initform 0 :accessor plan-total-action-count) + (planned-action-count :initform 0 :accessor plan-planned-action-count) + (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) + (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) + (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) + (visiting-action-list :initform () :accessor plan-visiting-action-list)))) + + +;;;; Planned action status +(with-upgradability () + (defgeneric plan-action-status (plan operation component) + (:documentation "Returns the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + + (defgeneric (setf plan-action-status) (new-status plan operation component) + (:documentation "Sets the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + + (defclass planned-action-status (action-status) + ((planned-p + :initarg :planned-p :reader action-planned-p + :documentation "a boolean, true iff the action was included in the plan.") + (index + :initarg :index :reader action-index + :documentation "an integer, counting all traversed actions in traversal order.")) + (:documentation "Status of an action in a plan")) + + (defmethod print-object ((status planned-action-status) stream) + (print-unreadable-object (status stream :type t :identity nil) + (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) + + ;; TODO: eliminate NODE-FOR, use CONS. + ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. + ;; However, see also component-operation-time and mark-operation-done + (defun node-for (o c) (cons (type-of o) c)) + + (defun action-already-done-p (plan operation component) + (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) + (remhash to times) + (setf (gethash to times) (action-stamp new-status)))) + new-status)) + + +;;;; forcing +(with-upgradability () + (defgeneric action-forced-p (plan operation component)) + (defgeneric action-forced-not-p (plan operation component)) + + (defun normalize-forced-systems (x system) + (etypecase x + ((member nil :all) x) + (cons (list-to-hash-set (mapcar #'coerce-name x))) + ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) + + (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)))) + + (defmethod action-forced-p (plan operation component) + (and + ;; Did the user ask us to re-perform the action? + (action-override-p plan operation component 'plan-forced) + ;; You really can't force a builtin system and :all doesn't apply to it, + ;; except it it's the specifically the system currently being built. + (not (let ((system (component-system component))) + (and (builtin-system-p system) + (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)))) + + (defmethod action-forced-p ((plan null) operation component) + (declare (ignorable plan operation component)) + nil) + + (defmethod action-forced-not-p ((plan null) operation component) + (declare (ignorable plan operation component)) + nil)) + + +;;;; action-valid-p +(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)) + (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))) + + +;;;; Is the action needed in this image? +(with-upgradability () + (defgeneric needed-in-image-p (operation component) + (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful, + or could it just as well have been done in another Lisp image?")) + + (defmethod needed-in-image-p ((o operation) (c component)) + ;; We presume that actions that modify the filesystem don't need be run + ;; in the current image if they have already been done in another, + ;; and can be run in another process (e.g. a fork), + ;; whereas those that don't are meant to side-effect the current image and can't. + (not (output-files o c)))) + + +;;;; Visiting dependencies of an action and computing action stamps +(with-upgradability () + (defun map-direct-dependencies (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 + :do (funcall fun dep-o dep-c)))) + + (defun reduce-direct-dependencies (operation component combinator seed) + (map-direct-dependencies + 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 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) + + (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))))) + + +;;;; Generic support for plan-traversal +(with-upgradability () + (defgeneric plan-record-dependency (plan operation component)) + + (defgeneric call-while-visiting-action (plan operation component function) + (:documentation "Detect circular dependencies")) + + (defmethod initialize-instance :after ((plan plan-traversal) + &key (force () fp) (force-not () fnp) 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))))) + + (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)) + + (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) + (or (and (action-forced-not-p plan o c) (plan-action-status nil o c)) + (values (gethash (node-for o c) (plan-visited-actions plan))))) + + (defmethod action-valid-p ((plan plan-traversal) (o operation) (s system)) + (and (not (action-forced-not-p plan o s)) (call-next-method))) + + (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) + (with-accessors ((action-set plan-visiting-action-set) + (action-list plan-visiting-action-list)) plan + (let ((action (cons operation component))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil)))))) + + +;;;; Actual traversal: traverse-action +(with-upgradability () + (define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (circular-dependency-actions c))))) + + (defmacro while-visiting-action ((p o c) &body body) + `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))) + + (defgeneric traverse-action (plan operation component needed-in-image-p)) + + (defmethod traverse-action (plan operation component needed-in-image-p) + (block nil + (unless (action-valid-p plan operation component) (return nil)) + (plan-record-dependency plan operation component) + (let* ((aniip (needed-in-image-p operation component)) + (eniip (and aniip needed-in-image-p)) + (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) + (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! + (t + (setf (plan-action-status plan operation component) + (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)))))) + (while-visiting-action (plan operation component) ; maintain context, handle circularity. + (visit-action eniip))))))) + + +;;;; Sequential plans (the default) +(with-upgradability () + (defclass sequential-plan (plan-traversal) + ((actions-r :initform nil :accessor plan-actions-r))) + + (defgeneric plan-actions (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)) + (values)) + + (defmethod (setf plan-action-status) :after + (new-status (p sequential-plan) (o operation) (c component)) + (when (action-planned-p new-status) + (push (cons o c) (plan-actions-r p))))) + + +;;;; high-level interface: traverse, perform-plan, plan-operates-on-p +(with-upgradability () + (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)) + + (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)))) + (traverse-action plan o c t) + (plan-actions plan))) + + (defmethod perform-plan :around (plan &key) + (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 ((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 list) (component-path list)) + (find component-path (mapcar 'cdr plan) + :test 'equal :key 'component-find-path))) + + +;;;; Incidental traversals +(with-upgradability () + (defclass filtered-sequential-plan (sequential-plan) + ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) + (component-type :initform t :initarg :component-type :reader plan-component-type) + (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) + (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) + 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 action-filter (ensure-function action-filter)))) + + (defmethod action-valid-p ((plan filtered-sequential-plan) o c) + (and (funcall (plan-action-filter plan) o c) + (typep c (plan-component-type plan)) + (call-next-method))) + + (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))) + + (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) + :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)) + :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))) + :from-end t))) + +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations + +(asdf/package:define-package :asdf/operate + (:recycle :asdf/operate :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :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 + #:*load-system-operation* #:module-provide-asdf + #:component-loaded-p #:already-loaded-systems)) +(in-package :asdf/operate) + +(with-upgradability () + (defgeneric* (operate) (operation component &key &allow-other-keys) + (:documentation + "Operate does three things: + +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 + +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. + +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. + +The :FORCE or :FORCE-NOT argument to OPERATE can be: + T to force the inside of the specified system to be rebuilt (resp. not), + without recursively forcing the other systems we depend on. + :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). + (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list +:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced.")) + + (define-convenience-action-methods + operate (operation component &key) + ;; I'd like to at least remove-plist-keys :force :force-not :verbose, + ;; but swank.asd relies on :force (!). + :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. + :if-no-component (error 'missing-component :requires component)) + + (defvar *systems-being-operated* nil + "A boolean indicating that some systems are being operated on") + + (defmethod operate :around (operation component &rest keys + &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 + (component (component-find-path component)) + (t component)))) + ;; Before we operate on any system, make sure ASDF is up-to-date, + ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. + (unless systems-being-operated + (when (upgrade-asdf) + ;; 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)))) + ;; Setup proper bindings around any operate call. + (with-system-definitions () + (let* ((*verbose-out* (and verbose *standard-output*)) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure)) + (call-next-method))))) + + (defmethod operate :before ((operation operation) (component component) + &key version &allow-other-keys) + (let ((system (component-system component))) + (setf (gethash (coerce-name system) *systems-being-operated*) system)) + (unless (version-satisfies component version) + (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))) + (apply 'perform-plan plan keys) + (values operation plan))) + + (defun oos (operation component &rest args &key &allow-other-keys) + (apply 'operate operation component args)) + + (setf (documentation 'oos 'function) + (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" + (documentation 'operate 'function)))) + + +;;;; Common operations +(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, +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") + + (defun build-system (system &rest keys) + "Shorthand for `(operate 'asdf:build-op system)`." + (apply 'operate 'build-op system keys) + t) + + (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate *load-system-operation* system keys) + t) + + (defun load-systems (&rest systems) + "Loading multiple systems at once." + (map () 'load-system 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." + (declare (ignore force force-not verbose version)) + (apply 'operate 'compile-op system args) + t) + + (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'test-op system args) + t)) + + +;;;; Define require-system, to be hooked into CL:REQUIRE when possible, +;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL +(with-upgradability () + (defun component-loaded-p (c) + (action-already-done-p nil (make-instance 'load-op) (find-component c ()))) + + (defun already-loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + + (defun require-system (s &rest keys &key &allow-other-keys) + (apply 'load-system s :force-not (already-loaded-systems) keys)) + + (defvar *modules-being-required* nil) + + (defclass require-system (system) + ((module :initarg :module :initform nil :accessor required-module))) + + (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 "~@") + (cons combinator arguments) component combinator)) + (let* ((module (car arguments)) + (name (string-downcase module)) + (system (find-system name nil))) + (assert module) + ;;(unless (typep system '(or null require-system)) + ;; (warn "~S depends on ~S but ~S is registered as a ~S" + ;; component (cons combinator arguments) module (type-of system))) + (or system (let ((system (make-instance 'require-system :name name))) + (register-system system) + system)))) + + (defun module-provide-asdf (name) + (let ((module (string-downcase name))) + (unless (member module *modules-being-required* :test 'equal) + (let ((*modules-being-required* (cons module *modules-being-required*)) + #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal))) + (handler-bind + ((style-warning #'muffle-warning) + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream))) + (let ((system (find-system module nil))) + (when system + (require-system system :verbose nil) + t))))))))) + + +;;;; Some upgrade magic +(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*) + (dolist (s l) (find-system s nil))))) + + (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) + + +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility + +(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) + +;;;; 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))) + +;;;; 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)))))) + +(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 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)))) + + +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(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) + +;;; 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 (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)))) + + +;;; 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 "~@") + (duplicate-names-name c))))) + + (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 "~@") + (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 "~@") + (non-toplevel-system-parent c) (non-toplevel-system-name c))))) + + (defun sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@")) + 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." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components))) + + (defun* (normalize-version) (form &key pathname component parent) + (labels ((invalid (&optional (continuation "using NIL instead")) + (warn (compatfmt "~@") + form component parent pathname continuation)) + (invalid-parse (control &rest args) + (unless (builtin-system-p (find-component parent component)) + (apply 'warn control args) + (invalid)))) + (if-let (v (typecase form + ((or string null) form) + (real + (invalid "Substituting a string") + (format nil "~D" form)) ;; 1.0 becomes "1.0" + (cons + (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))) + ((:read-file-line) + (destructuring-bind (subpath &key (at 0)) (rest form) + (read-file-lines (subpathname pathname subpath) :at at))) + (otherwise + (invalid)))) + (t + (invalid)))) + (if-let (pv (parse-version v #'invalid-parse)) + (unparse-version pv) + (invalid)))))) + + +;;; Main parsing function +(with-upgradability () + (defun* (parse-component-form) (parent options &key previous-serial-component) + (destructuring-bind + (type name &rest rest &key + (builtin-system-p () bspp) + ;; the following list of keywords is reproduced below in the + ;; remove-plist-keys form. important to keep them in sync + components pathname perform explain output-files operation-done-p + weakly-depends-on depends-on serial + 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)) + (check-component-input type name weakly-depends-on depends-on components) + (when (and parent + (find-component parent name) + (not ;; ignore the same object when rereading the defsystem + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) + (let* ((name (coerce-name name)) + (args `(:name ,name + :pathname ,pathname + ,@(when parent `(:parent ,parent)) + ,@(remove-plist-keys + '(:components :pathname :if-component-dep-fails :version + :perform :explain :output-files :operation-done-p + :weakly-depends-on :depends-on :serial) + rest))) + (component (find-component parent name)) + (class (class-for-type parent type))) + (when (and parent (subtypep class 'system)) + (error 'non-toplevel-system :parent parent :name name)) + (if component ; preserve identity + (apply 'reinitialize-instance component args) + (setf component (apply 'make-instance class args))) + (component-pathname component) ; eagerly compute the absolute pathname + (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 version (normalize-version version :component name :parent parent :pathname sysfile))) + ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. + ;; A better fix is required. + (setf (slot-value component 'version) version) + (when (typep component 'parent-component) + (setf (component-children component) + (loop + :with previous-component = nil + :for c-form :in components + :for c = (parse-component-form component c-form + :previous-serial-component previous-component) + :for name = (component-name c) + :collect c + :when serial :do (setf previous-component name))) + (compute-children-by-name component)) + (when previous-serial-component + (push previous-serial-component depends-on)) + (when weakly-depends-on + ;; ASDF4: deprecate this feature and remove it. + (appendf depends-on + (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + ;; Used by POIU. ASDF4: rename to component-depends-on? + (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)) + component))) + + (defun register-system-definition + (name &rest options &key pathname (class 'system) (source-file () sfp) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (get-file-stamp source-file)) + (register-system + (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)) + (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) + ;; 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))) + (unless (subtypep class 'system) + (error 'non-system-system :name name :class-name (class-name class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-directory pathname) + component-options))))) + + (defmacro defsystem (name &body options) + `(apply 'register-system-definition ',name ',options))) +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle + +(asdf/package:define-package :asdf/bundle + (:recycle :asdf/bundle :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + (:export + #:bundle-op #:bundle-op-build-args #:bundle-type + #: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 + #:lib-op #:monolithic-lib-op + #:dll-op #:monolithic-dll-op + #:binary-op #:monolithic-binary-op + #:program-op #:compiled-file #:precompiled-system #:prebuilt-system + #:user-system-p #:user-system #:trivial-system-p + #+ecl #:make-build + #:register-pre-built-system + #: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) + (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))) + + (defclass bundle-compile-op (bundle-op basic-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) + + ;; create a single fasl for the entire library + (defclass basic-fasl-op (bundle-compile-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 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 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 binary-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(fasl-op lib-op))) + (:documentation "produce fasl and asd files for the system")) + + (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies + + (defclass monolithic-bundle-op (monolithic-op bundle-op) + ((prologue-code :accessor monolithic-op-prologue-code) + (epilogue-code :accessor monolithic-op-epilogue-code))) + + (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))) + (:documentation "produce fasl and asd files for combined system and dependencies.")) + + (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () + (: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-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 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)) + (:documentation "create an executable file from the system and its dependencies")) + + (defun bundle-pathname-type (bundle-type) + (etypecase bundle-type + ((eql :no-output-file) nil) ;; should we error out instead? + ((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) + (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"))) + ((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)))))))) + + (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))) + + (defclass compiled-file (file-component) + ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + + (defclass precompiled-system (system) + ((build-pathname :initarg :fasl))) + + (defclass prebuilt-system (system) + ((build-pathname :initarg :static-library :initarg :lib + :accessor prebuilt-system-static-library)))) + + +;;; +;;; BUNDLE-OP +;;; +;;; This operation takes all components from one or more systems and +;;; creates a single output file, which may be +;;; a FASL, a statically linked library, a shared library, etc. +;;; 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)) + (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 + (when (typep instance 'monolithic-bundle-op) + (destructuring-bind (&rest original-initargs + &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)) + + (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)) + #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) + + (defgeneric* (trivial-system-p) (component)) + + (defun user-system-p (s) + (and (typep s 'system) + (not (builtin-system-p s)) + (not (trivial-system-p s))))) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype user-system () '(and system (satisfies user-system-p)))) + +;;; +;;; First we handle monolithic bundles. +;;; These are standalone systems which contain everything, +;;; including other ASDF systems required by the current one. +;;; A PROGRAM is always monolithic. +;;; +;;; 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)))))) + + (defmethod input-files ((o bundle-compile-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)) + ((:program) + 'program-op))) + + (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) + (system-relative-pathname system "asdf-output/"))) + (operation (apply #'operate operation-name + system + (remove-plist-keys '(:monolithic :type :move-here) args))) + (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)))) + (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) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files)))) + +;;; +;;; LOAD-FASL-OP +;;; +;;; This is like ASDF's LOAD-OP, but using monolithic 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) + ,@(call-next-method))) + + (defmethod input-files ((o load-fasl-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) + + (defmethod perform ((o load-fasl-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)) + (mark-operation-done (find-operation o 'load-op) c))) + +;;; +;;; PRECOMPILED FILES +;;; +;;; This component can be used to distribute ASDF systems in precompiled form. +;;; Only useful when the dependencies have also been precompiled. +;;; +(with-upgradability () + (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 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)) + + +;;; +;;; 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 "~@")))) + + (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)) + + (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)) + + (defun parse-output-translations-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:output-translations :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") 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 "~@") + string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error (compatfmt "~@") + string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) + + (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)) + + (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/")) + + (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")) + + (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)))) + + (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 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))) + + (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)) + + (defvar *output-translations-parameter* nil) + + (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf *output-translations-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 asdf/driver'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)))))) + +;;;; ------------------------------------------------------------------------- +;;; Backward-compatible interfaces + +(asdf/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) + (:export + #:*asdf-verbose* + #:operation-error #:compile-error #:compile-failed #:compile-warned + #:error-component #:error-operation + #:component-load-dependencies + #:enable-asdf-binary-locations-compatibility + #:operation-forced + #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings + #:component-property + #:run-shell-command + #:system-definition-pathname)) +(in-package :asdf/backward-interface) + +(with-upgradability () + (define-condition operation-error (error) ;; Bad, backward-compatible name + ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) + (define-condition compile-error (operation-error) ()) + (define-condition compile-failed (compile-error) ()) + (define-condition compile-warned (compile-error) ()) + + (defun component-load-dependencies (component) + ;; Old deprecated name for the same thing. Please update your software. + (component-sideway-dependencies component)) + + (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. + (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) + + (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)) + (defmethod operation-on-warnings ((o operation)) + (declare (ignorable o)) *compile-file-warnings-behaviour*) + (defmethod operation-on-failure ((o operation)) + (declare (ignorable o)) *compile-file-failure-behaviour*) + (defmethod (setf operation-on-warnings) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) + (defmethod (setf operation-on-failure) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) + + (defun system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x))) + + +;;;; ASDF-Binary-Locations compatibility +;; This remains supported for legacy user, but not recommended for new users. +(with-upgradability () + (defun enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? + (include-per-user-information nil) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) + (source-to-target-mappings nil) + (file-types `(,(compile-file-type) + "build-report" + #+ecl (compile-file-type :type :object) + #+mkcl (compile-file-type :fasl-p nil) + #+clisp "lib" #+sbcl "cfasl" + #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) + #+(or clisp ecl mkcl) + (when (null map-all-source-files) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) + (let* ((patterns (if map-all-source-files (list *wild-file*) + (loop :for type :in file-types + :collect (make-pathname :type type :defaults *wild-file*)))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir-pathname)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(: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 "~@")))) + + ;; 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 "~@") 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 "~@") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@") + 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 + system-source-registry + system-source-registry-directory + default-source-registry)) + + (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))) + #+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")) + + (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 #-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)))) + + (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 "~@") + 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*)))) + + +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. + +(asdf/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 + :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? + (:export + #:defsystem #:find-system #:locate-system #:coerce-name + #:oos #:operate #:traverse #:perform-plan #:sequential-plan + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #: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 + #: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 + #: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 + #: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 + #:operation-monolithic-p + #:required-components + #:component-loaded-p + + #:component #:parent-component #:child-component #:system #:module + #: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 + + #:component-children ; component accessors + #:component-children-by-name + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-system + #:component-encoding + #:component-external-format + + #:component-depends-on ; backward-compatible name rather than action-depends-on + #:module-components ; backward-compatibility + #:operation-on-warnings #:operation-on-failure ; backward-compatibility + #:component-property ; backward-compatibility + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:system-homepage + #:system-mailto + #:system-bug-tracker + #:system-long-name + #:system-source-control + #:map-systems + + #:*system-definition-search-functions* ; variables + #:*central-registry* + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*load-system-operation* + #:*asdf-verbose* ;; unused. For backward-compatibility only. + #:*verbose-out* + + #:asdf-version + + #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error + #:compile-warned-warning #:compile-failed-warning + #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names #:non-toplevel-system #:non-system-system + + #:try-recompiling + #:retry + #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry + + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + + #:clear-configuration + #:*output-translations-parameter* + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file* + #:compile-file-pathname* + #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check + #:enable-asdf-binary-locations-compatibility + #:*default-source-registries* + #:*source-registry-parameter* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry + #:system-registered-p #:registered-systems #:already-loaded-systems + #:resolve-location + #:asdf-message + #:*user-cache* + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory)) + +;;;; --------------------------------------------------------------------------- +;;;; ASDF-USER, where the action happens. + +(asdf/package:define-package :asdf/user + (:nicknames :asdf-user) + (:use :asdf/common-lisp :asdf/package :asdf/interface)) +;;;; ----------------------------------------------------------------------- +;;;; ASDF Footer: last words and cleanup + +(asdf/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)) +(in-package :asdf/footer) + +;;;; Hook ASDF into the implementation's REQUIRE and other entry points. + +(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* + #+clisp ,x + #+clozure ccl:*module-provider-functions* + #+(or cmu ecl) ext:*module-provider-functions* + #+mkcl mk-ext:*module-provider-functions* + #+sbcl sb-ext:*module-provider-functions*))) + + #+(or ecl mkcl) + (progn + (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) + (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) + + (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* + (loop :for f :in #+ecl ext:*module-provider-functions* + #+mkcl mk-ext::*module-provider-functions* + :collect + (if (eq f 'module-provide-asdf) f + #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l)))))))) + + +;;;; Done! +(with-upgradability () + #+allegro + (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*)) + + (provide :asdf) + + (cleanup-upgraded-asdf)) + +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) + + --- cl-asdf-3.0.0.orig/doc/index.html +++ cl-asdf-3.0.0/doc/index.html @@ -32,7 +32,8 @@

ASDF 3

-

ASDF 3, pre-released as 2.28 on February 1st 2013, +

ASDF 3, pre-released as 2.28 on February 1st 2013, and + released as 3.0.0 on May 15th 2013, is the current successor to Daniel Barlow's ASDF. It was rewritten for improved portability, robustness, usability, extensibility, configurability, internal consistency, --- /dev/null +++ cl-asdf-3.0.0/doc/asdf.log @@ -0,0 +1,190 @@ +This is pdfTeX, Version 3.1415926-1.40.10 (TeX Live 2009/Debian) (format=pdfetex 2013.4.24) 16 MAY 2013 00:33 +entering extended mode + file:line:error style messages enabled. + %&-line parsing enabled. +**\catcode126=12 \def\normaltilde{~}\catcode126=13 \let~\normaltilde \input ./ +asdf.texinfo +(./asdf.texinfo (/usr/share/texmf/tex/texinfo/texinfo.tex +Loading texinfo [version 2008-04-18.10]: +\bindingoffset=\dimen16 +\normaloffset=\dimen17 +\pagewidth=\dimen18 +\pageheight=\dimen19 +\outerhsize=\dimen20 +\outervsize=\dimen21 +\cornerlong=\dimen22 +\cornerthick=\dimen23 +\topandbottommargin=\dimen24 +\headlinebox=\box16 +\footlinebox=\box17 +\margin=\insert252 +\EMsimple=\toks13 +\groupbox=\box18 +\groupinvalidhelp=\toks14 +\mil=\dimen25 +\exdentamount=\skip18 +\inmarginspacing=\skip19 + pdf, +\tempnum=\count27 +\lnkcount=\count28 +\filename=\toks15 +\filenamelength=\count29 +\pgn=\count30 +\toksA=\toks16 +\toksB=\toks17 +\toksC=\toks18 +\toksD=\toks19 +\boxA=\box19 +\countA=\count31 +\nopdfimagehelp=\toks20 + fonts, +\sffam=\fam8 +\textleading=\dimen26 +\fontdepth=\count32 + page headings, +\titlepagetopglue=\skip20 +\titlepagebottomglue=\skip21 +\evenheadline=\toks21 +\oddheadline=\toks22 +\evenfootline=\toks23 +\oddfootline=\toks24 + tables, +\tableindent=\dimen27 +\itemindent=\dimen28 +\itemmargin=\dimen29 +\itemmax=\dimen30 +\itemno=\count33 +\multitableparskip=\skip22 +\multitableparindent=\skip23 +\multitablecolspace=\dimen31 +\multitablelinespace=\skip24 +\colcount=\count34 +\everytab=\toks25 + +conditionals, +\doignorecount=\count35 + indexing, +\whatsitskip=\skip25 +\whatsitpenalty=\count36 +\secondaryindent=\skip26 +\partialpage=\box20 +\doublecolumnhsize=\dimen32 + sectioning, +\unnumberedno=\count37 +\chapno=\count38 +\secno=\count39 +\subsecno=\count40 +\subsubsecno=\count41 +\appendixno=\count42 +\absseclevel=\count43 +\secbase=\count44 +\chapheadingskip=\skip27 +\secheadingskip=\skip28 +\subsecheadingskip=\skip29 + toc, +\tocfile=\write0 +\contentsrightmargin=\skip30 +\savepageno=\count45 +\lastnegativepageno=\count46 +\tocindent=\dimen33 + environments, +\errorbox=\box21 +\lispnarrowing=\skip31 +\envskipamount=\skip32 +\circthick=\dimen34 +\cartouter=\dimen35 +\cartinner=\dimen36 +\normbskip=\skip33 +\normpskip=\skip34 +\normlskip=\skip35 +\lskip=\skip36 +\rskip=\skip37 +\tabw=\dimen37 + defuns, +\defbodyindent=\skip38 +\defargsindent=\skip39 +\deflastargmargin=\skip40 +\defunpenalty=\count47 +\parencount=\count48 +\brackcount=\count49 + macros, +\paramno=\count50 +\macname=\toks26 + +cross references, +\auxfile=\write1 +\savesfregister=\count51 + insertions, +\footnoteno=\count52 +\SAVEfootins=\box22 +\SAVEmargin=\box23 + +(/usr/share/texmf-texlive/tex/generic/epsf/epsf.tex +This is `epsf.tex' v2.7.3 <23 July 2005> +\epsffilein=\read1 +\epsfframemargin=\dimen38 +\epsfframethickness=\dimen39 +\epsfrsize=\dimen40 +\epsftmp=\dimen41 +\epsftsize=\dimen42 +\epsfxsize=\dimen43 +\epsfysize=\dimen44 +\pspoints=\dimen45 +) +\noepsfhelp=\toks27 + localization, +\nolanghelp=\toks28 +\countUTFx=\count53 +\countUTFy=\count54 +\countUTFz=\count55 + formatting, +\defaultparindent=\dimen46 + and turning on texinfo input format.) +\openout1 = `asdf.aux'. + +@cpindfile=@write2 +@fnindfile=@write3 +@vrindfile=@write4 +@tpindfile=@write5 +@kyindfile=@write6 +@pgindfile=@write7 + [1 +\openout2 = `asdf.cp'. + +\openout3 = `asdf.fn'. + +\openout4 = `asdf.vr'. + +\openout5 = `asdf.tp'. + +\openout6 = `asdf.ky'. + +\openout7 = `asdf.pg'. + +{/var/lib/texmf/fonts/map/pdftex/updmap/pdftex.map}] +Overfull \hbox (52.19247pt too wide) in paragraph at lines 5--7 +[]@textrm You can find the lat-est ver-sion of this man-ual at [][]@texttt http +://common-lisp.net/project/asdf/asdf.html[][][]@textrm . | + +@hbox(7.60416+2.43333)x433.62, glue set - 1.0 +.@hbox(0.0+0.0)x0.0 +.@textrm Y +.@kern-0.91252 +.@textrm o +.@textrm u +.etc. + +[2] [-1] Chapter 1 +\openout0 = `asdf.toc'. + + Cross reference values unknown; you must run TeX again. +Chapter 2 [1] +Overfull \hbox (26.43913pt too wide) in paragraph at lines 268--268 + [] @texttt (let ((ver (symbol-value (or (find-symbol (string :*asdf-version*) + :asdf)[] | + +@hbox(7.60416+2.43333)x433.62 +.@glue(@leftskip) 28.90755 +.@hbox(0.0+0.0)x0.0 +.@penalty 10000 +.@glue 5.7 \ No newline at end of file --- /dev/null +++ cl-asdf-3.0.0/doc/asdf.html @@ -0,0 +1,4384 @@ + + +ASDF Manual + + + + + + + + + + +

ASDF Manual

+
+

Table of Contents

+ +
+ + + + +

+ +

asdf: another system definition facility

+ +

This manual describes ASDF, a system definition facility +for Common Lisp programs and libraries. + +

You can find the latest version of this manual at +http://common-lisp.net/project/asdf/asdf.html. + +

ASDF Copyright © 2001-2013 Daniel Barlow and contributors. + +

This manual Copyright © 2001-2013 Daniel Barlow and contributors. + +

This manual revised © 2009-2013 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 +“Software”), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +

The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +

THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +

+ + +

1 Introduction

+ +

+ASDF is Another System Definition Facility: +a tool for specifying how systems of Common Lisp software +are comprised 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. + +

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, +one for implementers of Common Lisp extensions who want to extend the build system. +See Loading a system, +to learn how to use ASDF to load a system. +See Defining systems with defsystem, +to learn how to define a system of your own. +See The object model of ASDF, for a description of +the ASDF internals and how to extend ASDF. + +

Nota Bene: +We have released ASDF 2.000 on May 31st 2010, +and ASDF 3.0 on January 31st 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 didn't use to, +and has been made to work with all actively used CL implementations and a few more. +See “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. +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. See Loading ASDF. + +

Also note that ASDF is not to be confused with ASDF-Install. +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 instead, +which works great 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. + +

+ + +

2 Loading ASDF

+ +

+ + + + +

2.1 Loading a pre-installed ASDF

+ +

Most recent Lisp implementations include a copy of ASDF 2, and soon ASDF 3. +You can usually load this copy using Common Lisp's require function: + +

     (require "asdf")
+
+

As of the writing of this manual, +the following implementations provide ASDF 2 this way: +abcl allegro ccl clisp cmucl ecl lispworks mkcl sbcl xcl. +The following implementation doesn't provide it yet but will in an upcoming release: +scl. +The following implementations are obsolete, not actively maintained, +and most probably will never bundle it: +cormanlisp gcl genera mcl. + +

If the implementation you are using doesn't provide ASDF 2 or ASDF 3, +see see Loading an otherwise installed ASDF below. +If that implementation is still actively maintained, +you may also send a bug report to your Lisp vendor and complain +about their failing to provide ASDF. + +

NB: all implementations except clisp also accept +(require "ASDF"), (require 'asdf) and (require :asdf). +For portability's sake, you probably want to use (require "asdf"). + +

2.2 Checking whether ASDF is loaded

+ +

To check whether ASDF is properly loaded in your current Lisp image, +you can run this form: + +

     (asdf:asdf-version)
+
+

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 an old version of ASDF. + +

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: + +

     (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"))))
+
+

If it returns NIL then ASDF is not installed. +Otherwise it should return a string. +If it returns "1.0", then it can actually be +any version before 1.77 or so, or some buggy variant of 1.x. + +

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. + +

2.3 Upgrading ASDF

+ +

If your implementation provides ASDF 3 or later, +you only need to (require "asdf"): +ASDF will automatically look whether an updated version of itself is available +amongst the regularly configured systems, before it compiles anything else. +See see Configuring ASDF below. + +

If your implementation does provide ASDF 2 or later, +but not ASDF 3 or later, +and you want to upgrade to a more recent version, +you need to install and configure your ASDF as above, +and additionally, you need to explicitly tell ASDF to load itself, +right after you require your implementation's old ASDF 2: + +

     (require "asdf")
+     (asdf:load-system :asdf)
+
+

If on the other hand, your implementation only provides an old ASDF, +you will require a special configuration step and an old-style loading. +Take special attention to not omit the trailing directory separator +/ at the end of your pathname: + +

     (require "asdf")
+     (push #p"/path/to/new/asdf/" asdf:*central-registry*)
+     (asdf:oos 'asdf:load-op :asdf)
+
+

Note that ASDF 1 won't redirect its output files, +or at least won't do it according to your usual ASDF 2 configuration. +You therefore need write access on the directory +where you install the new ASDF, +and make sure you're not using it +for multiple mutually incompatible implementations. +At worst, you may have to have multiple copies of the new ASDF, +e.g. one per implementation installation, to avoid clashes. +Note that to our knowledge all implementations that provide ASDF +provide ASDF 2 in their latest release, so +you may want to upgrade your implementation rather than go through that hoop. + +

Finally, if you are using an unmaintained implementation +that does not provide ASDF at all, +see see Loading an otherwise installed ASDF below. + +

Note that there are some limitations to upgrading ASDF: +

    +
  • Previously loaded ASDF extension becomes invalid, and will need to be reloaded. +This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc. +Since it isn't possible to automatically detect what extensions are present +that need to be invalidated, +ASDF will actually invalidate all previously loaded systems +when it is loaded on top of a different ASDF version, +starting with ASDF 2.014.8 (as far as releases go, 2.015); +and it will automatically attempt this self-upgrade as its very first step +starting with ASDF 3. + +
  • For this an many other reasons, +it important reason to load, configure and upgrade ASDF (if needed) +as one of the very first things done by your build and startup scripts. +Until all implementations provide ASDF 3 or later, +it is safer if you upgrade ASDF and its extensions as a special step +at the very beginning of whatever script you are running, +before you start using ASDF to load anything else; +even afterwards, it is still a good idea, to avoid having to +load and reload code twice as it gets invalidated. + +
  • 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 not specify +:depends-on (:asdf), or :depends-on ((:version :asdf "2.010")), +but instead that they check that a recent enough ASDF is installed, +with such code as: +
              (unless (or #+asdf2 (asdf:version-satisfies
    +                               (asdf:asdf-version) *required-asdf-version*))
    +            (error "FOO requires ASDF ~A or later." *required-asdf-version*))
    +
    +
  • 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. +
+ +

2.4 Loading an otherwise installed ASDF

+ +

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 asdf.lisp +somewhere and load it with: + +

     (load "/path/to/your/installed/asdf.lisp")
+
+

The single file asdf.lisp is all you normally need to use ASDF. + +

You can extract this file from latest release tarball on the +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. +See 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. + +

+ + +

3 Configuring ASDF

+ +

3.1 Configuring ASDF to find your systems

+ +

So it may compile and load your systems, ASDF must be configured to find +the .asd files that contain system definitions. + +

Since ASDF 2, the preferred way to configure where ASDF finds your systems is +the source-registry facility, +fully described in its own chapter of this manual. +See Controlling where ASDF searches for systems. + +

The default location for a user to install Common Lisp software is under +~/.local/share/common-lisp/source/. +If you install software there (it can be a symlink), +you don't need further configuration. +If you're installing software yourself at a location that isn't standard, +you have to tell ASDF where you installed it. See below. +If you're using some tool to install software (e.g. Quicklisp), +the authors of that tool should already have configured ASDF. + +

The simplest way to add a path to your search path, +say /home/luser/.asd-link-farm/ +is to create the directory +~/.config/common-lisp/source-registry.conf.d/ +and there create a file with any name of your choice, +and with the type conf, +for instance 42-asd-link-farm.conf +containing the line: + +

(:directory "/home/luser/.asd-link-farm/") + +

If you want all the subdirectories under /home/luser/lisp/ +to be recursively scanned for .asd files, instead use: + +

(:tree "/home/luser/lisp/") + +

Note that your Operating System distribution or your system administrator +may already have configured system-managed libraries for you. + +

The required .conf extension allows you to have disabled files +or editor backups (ending in ~), and works portably +(for instance, it is a pain to allow both empty and non-empty extension on CLISP). +Excluded are files the name of which start with a . character. +It is customary to start the filename with two digits +that specify the order in which the directories will be scanned. + +

ASDF will automatically read your configuration +the first time you try to find a system. +You can reset the source-registry configuration with: + +

     (asdf:clear-source-registry)
+
+

And you probably should do so before you dump your Lisp image, +if the configuration may change +between the machine where you save it at the time you save it +and the machine you resume it at the time you resume it. +Actually, you should use (asdf:clear-configuration) +before you dump your Lisp image, which includes the above. + +

3.2 Configuring ASDF to find your systems — old style

+ +

The old way to configure ASDF to find your systems is by +pushing directory pathnames onto the variable +asdf:*central-registry*. + +

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 ~/.sbclrc.) + +

The 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-registry1. + +

For instance, if you wanted ASDF to find the .asd file +/home/me/src/foo/foo.asd your initialization script +could after it loads ASDF with (require "asdf") +configure it with: + +

     (push "/home/me/src/foo/" asdf:*central-registry*)
+
+

Note the trailing slash: when searching for a system, +ASDF will evaluate each entry of the central registry +and coerce the result to a pathname2 +at which point the presence of the trailing directory name separator +is necessary to tell Lisp that you're discussing a directory +rather than a file. + +

Typically, however, there are a lot of .asd files, and +a common idiom was to have to put +a bunch of symbolic links to .asd files +in a common directory +and push that directory (the “link farm”) +to the +asdf:*central-registry* +instead of pushing each of the many involved directories +to the asdf:*central-registry*. +ASDF knows how to follow such symlinks +to the actual file location when resolving the paths of system components +(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 #p"/home/me/cl/systems/" (note the trailing slash) +is a member of *central-registry*, you could set up the +system foo for loading with asdf with the following +commands at the shell: + +

     $ cd /home/me/cl/systems/
+     $ ln -s ~/src/foo/foo.asd .
+
+

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. + +

3.3 Configuring where ASDF stores object files

+ +

+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 may be shared +between several versions of several Common Lisp implementations, +between several users using different compilation options +and without write privileges on shared source directories, etc. +This also allows to keep source directories uncluttered +by plenty of object files. + +

Starting with ASDF 2, the asdf-output-translations facility +was added to ASDF itself, that controls where object files will be stored. +This facility is fully described in a chapter of this manual, +Controlling where ASDF saves compiled files. + +

The simplest way to add a translation to your search path, +say from /foo/bar/baz/quux/ +to /where/i/want/my/fasls/ +is to create the directory +~/.config/common-lisp/asdf-output-translations.conf.d/ +and there create a file with any name of your choice and the type conf, +for instance 42-bazquux.conf +containing the line: + +

("/foo/bar/baz/quux/" "/where/i/want/my/fasls/") + +

To disable output translations for source under a given directory, +say /toto/tata/ +you can create a file 40-disable-toto.conf +with the line: + +

("/toto/tata/") + +

To wholly disable output translations for all directories, +you can create a file 00-disable.conf +with the line: + +

(t t) + +

Note that your Operating System distribution or your system administrator +may already have configured translations for you. +In absence of any configuration, the default is to redirect everything +under an implementation-dependent subdirectory of ~/.cache/common-lisp/. +See Controlling where ASDF searches for systems, for full details. + +

The required .conf extension allows you to have disabled files +or editor backups (ending in ~), and works portably +(for instance, it is a pain to allow both empty and non-empty extension on CLISP). +Excluded are files the name of which start with a . character. +It is customary to start the filename with two digits +that specify the order in which the directories will be scanned. + +

ASDF will automatically read your configuration +the first time you try to find a system. +You can reset the source-registry configuration with: + +

     (asdf:clear-output-translations)
+
+

And you probably should do so before you dump your Lisp image, +if the configuration may change +between the machine where you save it at the time you save it +and the machine you resume it at the time you resume it. +(Once again, you should use (asdf:clear-configuration) +before you dump your Lisp image, which includes the above.) + +

Finally 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 just delegate this functionality to ASDF. + +

+ + +

3.4 Resetting Configuration

+ +

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: + +

+— Function: clear-configuration
+

undoes any ASDF configuration, + regarding source-registry or output-translations. +

+ +

If you use SBCL, CMUCL or SCL, you may use this snippet +so that the ASDF configuration be cleared automatically as you dump an image: + +

     #+(or cmu sbcl scl)
+     (pushnew 'clear-configuration
+              #+(or cmu scl) ext:*before-save-initializations*
+              #+sbcl sb-ext:*save-hooks*)
+
+

For compatibility with all Lisp implementations, however, +you might want instead your build script to explicitly call +(asdf:clear-configuration) at an appropriate moment before dumping. + +

4 Using ASDF

+ +

4.1 Loading a system

+ +

The system foo is loaded (and compiled, if necessary) +by evaluating the following Lisp form: + +

     (asdf:load-system :foo)
+
+

On some implementations (namely recent versions of +ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, +LispWorks, MKCL, SBCL and XCL), +ASDF hooks into the CL:REQUIRE facility +and you can just use: + +

     (require :foo)
+
+

In older versions of ASDF, you needed to use +(asdf:oos 'asdf:load-op :foo). +If your ASDF is too old to provide asdf:load-system though +we recommend that you upgrade to ASDF 3. +See Loading an otherwise installed ASDF. + +

Note the name of a system is specified as a string or a symbol, +typically a keyword. +If a symbol (including a keyword), its name is taken and lowercased. +The name must be a suitable value for the :name initarg +to make-pathname in whatever filesystem the system is to be found. +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 :case :common, +which is reported not to work on some implementations + +

4.2 Other Operations

+ +

ASDF provides three commands for the most common system operations: +load-system, compile-system or test-system. +It also provides require-system, a version of load-system +that skips trying to update systems that are already loaded. + +

Because ASDF is an extensible system +for defining operations on components, +it also provides a generic function operate +(which is usually abbreviated by oos). +You'll use oos whenever you want to do something beyond +compiling, loading and testing. + +

Output from ASDF and ASDF extensions are supposed to be sent +to the CL stream *standard-output*, +and so rebinding that stream around calls to asdf:operate +should redirect all output from ASDF operations. + +

Reminder: before ASDF can operate on a system, however, +it must be able to find and load that system's definition. +See Configuring ASDF to find your systems. + +

For the advanced users, note that +require-system calls load-system +with keyword arguments :force-not (loaded-systems). +loaded-systems returns a list of the names of loaded systems. +load-system applies operate with the operation from +*load-system-operation*, which by default is load-op, +the system, and any provided keyword arguments. + +

4.3 Summary

+ +

To use ASDF: + +

    +
  • Load ASDF itself into your Lisp image, either through +(require "asdf") or else through +(load "/path/to/asdf.lisp"). + +
  • Make sure ASDF can find system definitions +thanks to proper source-registry configuration. + +
  • Load a system with (asdf:load-system :my-system) +or use some other operation on some system of your choice. + +
+ +

4.4 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. + +

+ + +

5 Defining systems with defsystem

+ +

This chapter describes how to use asdf to define systems and develop +software. + +

+ + +

5.1 The defsystem form

+ +

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 defsystem form. +This section begins with an example of a system definition, +then gives the full grammar of defsystem. + +

Let's look at a simple system. +This is a complete file that would +usually be saved as hello-lisp.asd: + +

     (in-package :asdf)
+     
+     (defsystem "hello-lisp"
+       :description "hello-lisp: a sample Lisp system."
+       :version "0.2.1"
+       :author "Joe User <joe@example.com>"
+       :licence "Public Domain"
+       :components ((:file "packages")
+                    (:file "macros" :depends-on ("packages"))
+                    (:file "hello" :depends-on ("macros"))))
+
+

Some notes about this example: + +

    +
  • The file starts with an in-package form +to use package asdf. +You could instead start your definition by using +a qualified name asdf:defsystem. + +
  • If in addition to simply using defsystem, +you are going to define functions, +create ASDF extension, globally bind symbols, etc., +it is recommended that to avoid namespace pollution between systems, +you should create your own package for that purpose, +for instance replacing the above (in-package :asdf) with: + +
              (defpackage :foo-system
    +            (:use :cl :asdf))
    +          
    +          (in-package :foo-system)
    +
    +
  • The defsystem form defines a system named hello-lisp +that contains three source files: +packages, macros and hello. + +
  • The file macros depends on packages +(presumably because the package it's in is defined in packages), +and the file hello depends on macros +(and hence, transitively on packages). +This means that ASDF will compile and load packages and macros +before starting the compilation of file hello. + +
  • The files are located in the same directory +as the file with the system definition. +ASDF resolves symbolic links (or Windows shortcuts) +before loading the system definition file and +stores its location in the resulting system3. +This is a good thing because the user can move the system sources +without having to edit the system definition. + + + + +
  • Make sure you know how the :version numbers will be parsed! They +are parsed as period-separated lists of integers. I.e., in the example, +0.2.1 is to be interpreted, roughly speaking, as (0 2 1). +In particular, version 0.2.1 is interpreted the same as +0.0002.1 and is strictly version-less-than version 0.20.1, +even though the two are the same when interpreted as decimal fractions. +Instead of a string representing the version, +the :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 +(: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 an access-at specifier with the (optional) :at keyword, +by default the specifier is 0, meaning the first form is returned. + +

    +

+ +

+ + +

5.2 A more involved example

+ +

Let's illustrate some more involved uses of defsystem via a +slightly convoluted example: + +

     (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")))
+
+

The :module component named "mod" is a collection of three files, +which will be located in a subdirectory of the main code directory named +mod (this location can be overridden; see the discussion of the +:pathname option in The defsystem grammar). + +

The method-form tokens provide a shorthand for defining methods on +particular components. This part + +

                     :perform (compile-op :after (op c)
+                               (do-something c))
+                     :explain (compile-op :after (op c)
+                               (explain-something c))
+
+

has the effect of + +

     (defmethod perform :after ((op compile-op) (c (eql ...)))
+                (do-something c))
+     (defmethod explain :after ((op compile-op) (c (eql ...)))
+                (explain-something c))
+
+

where ... is the component in question. +In this case ... would expand to something like + +

     (find-component (find-system "foo") "mod")
+
+

For more details on the syntax of such forms, see The defsystem grammar. +For more details on what these methods do, see Operations in +The object model of ASDF. + + + + + + + + +

+ + +

5.3 The defsystem grammar

+ + + +
     system-definition := ( defsystem system-designator system-option* )
+     
+     system-option := :defsystem-depends-on system-list
+                      | :weakly-depends-on system-list
+                      | :class class-name (see discussion below)
+                      | module-option
+                      | option
+     
+     module-option := :components component-list
+                      | :serial [ t | nil ]
+     
+     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 ( dependency-def* )
+             | :in-order-to ( dependency+ )
+     
+     
+     system-list := ( simple-component-name* )
+     
+     component-list := ( component-def* )
+     
+     component-def  := ( component-type simple-component-name option* )
+     
+     component-type := :module | :file | :static-file | other-component-type
+     
+     other-component-type := symbol-by-name (see Component types)
+     
+     dependency-def := simple-component-name
+                    | ( :feature name )
+                    | ( :version simple-component-name version-specifier)
+     
+     dependency := (dependent-op requirement+)
+     requirement := (required-op required-component+)
+                  | (feature feature-name)
+     dependent-op := operation-name
+     required-op := operation-name | feature
+     
+     simple-component-name := string
+                           |  symbol
+     
+     pathname-specifier := pathname | string | symbol
+     
+     method-form := (operation-name qual lambda-list &rest body)
+     qual := method qualifier
+     
+     component-dep-fail-option := :fail | :try-next | :ignore
+     
+     feature-expression := keyword | (:and feature-expression*)
+                           | (:or feature-expression*) | (:not feature-expression)
+
+

5.3.1 Component names

+ +

Component names (simple-component-name) +may be either strings or symbols. + +

5.3.2 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 my-component-type, in +the current package my-system-asd can be specified as +:my-component-type, or my-component-type. + +

system and its subclasses are not +allowed as component types for such children components. + +

5.3.3 System class names

+ +

A system class name will be looked up +in the same way as a Component type (see above), +except that only 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 DEFSYSTEM-DEPENDS-ON, +see below. For such class names in the ASDF package, we recommend that +the :class option be specified using a keyword symbol, such as + +

     :class :MY-NEW-SYSTEM-SUBCLASS
+
+

This practice will ensure that package name conflicts are avoided. +Otherwise, the symbol MY-NEW-SYSTEM-SUBCLASS will be read into +the current package before it has been exported from the ASDF +extension loaded by :defsystem-depends-on, causing a name +conflict in the current package. + +

5.3.4 Defsystem depends on

+ +

+The :defsystem-depends-on option to defsystem allows the +programmer to specify another ASDF-defined system or set of systems that +must be loaded before the system definition is processed. +Typically this is used to load an ASDF extension that is used in the +system definition. + +

5.3.5 Weakly depends on

+ +

+We do NOT recommend you use this feature. +If you are tempted to write a system foo +that weakly-depends-on a system bar, +we recommend that you should instead +write system foo in a parametric way, +and offer some special variable and/or some hook to specialize its behavior; +then you should write a system foo+bar +that does the hooking of things together. + +

The (deprecated) :weakly-depends-on option to defsystem +allows the programmer to specify another ASDF-defined system or set of systems +that ASDF should 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 defsystem, +this option is accepted at any component, but it probably +only makes sense at the defsystem level. +Programmers are cautioned not +to use this component option except at the defsystem level, as +this anomalous behavior may be removed without warning. + +

Finally, you might look into the asdf-system-connections extension, +that will let you define additional code to be loaded +when two systems are simultaneously loaded. +It may or may not be considered good style, but at least it can be used +in a way that has deterministic behavior independent of load order, +unlike weakly-depends-on. + +

5.3.6 Pathname specifiers

+ +

+A pathname specifier (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 / characters will be interpreted as directory separators. +Usually, Unix-style relative pathnames are used +(i.e. not starting with /, as opposed to absolute pathnames); +they are relative to the path of the parent component. +Finally, depending on the 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 component-type, +or else it will be extracted from the string itself (if applicable). + +

For instance, the component-type :module +wants a directory pathname, and so a string "foo/bar" +will be interpreted as the pathname #p"foo/bar/". +On the other hand, the component-type :file +wants a file of type lisp, and so a string "foo/bar" +will be interpreted as the pathname #p"foo/bar.lisp", +and a string "foo/bar.quux" +will be interpreted as the pathname #p"foo/bar.quux.lisp". +Finally, the component-type :static-file +wants a file without specifying a type, and so a string "foo/bar" +will be interpreted as the pathname #p"foo/bar", +and a string "foo/bar.quux" +will be interpreted as the pathname #p"foo/bar.quux". + +

ASDF does not interpret the string ".." to designate the parent +directory. This string will be passed through to the underlying +operating system for interpretation. We believe that this will +work on all platforms where ASDF is deployed, but do not guarantee this +behavior. A pathname object with a relative directory component of +:up or :back is the only guaranteed way to specify a +parent directory. + +

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 :case :common +as argument to 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 #p +or #.(make-pathname ...). +Note however, that #p... is a shorthand for #.(parse-namestring ...) +and that the behavior of parse-namestring is completely non-portable, +unless you are using Common Lisp logical-pathnames +(see Using logical pathnames, below). +Pathnames made with #.(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 didn't properly support +parsing component names as strings specifying paths with directories, +and the cumbersome #.(make-pathname ...) syntax had to be used. +An alternative to #. read-time evaluation is to use +(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. + +

5.3.7 Version specifiers

+ +

+Version specifiers are parsed as period-separated lists of integers. I.e., in the example, +0.2.1 is to be interpreted, roughly speaking, as (0 2 1). +In particular, version 0.2.1 is interpreted the same as +0.0002.1 and is strictly version-less-than version 0.20.1, +even though the two are the same when interpreted as decimal fractions. + +

System definers are encouraged to use version identifiers of the form +x.y.z for major version, minor version (compatible +API) and patch level. + +

See Common attributes of components. + +

5.3.8 Using 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 :pathname specifier +to components that use it, using such syntax as +#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 not +otherwise directly supported in the ASDF syntax +for pathname specifiers as strings. + +

The 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. + +

5.3.9 Serial dependencies

+ +

+If the :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 :depends-on. + +

     :serial t
+     :components ((:file "a") (:file "b") (:file "c"))
+
+

is equivalent to + +

     :components ((:file "a")
+                  (:file "b" :depends-on ("a"))
+                  (:file "c" :depends-on ("a" "b")))
+
+

5.3.10 Source location

+ +

The :pathname option is optional in all cases for systems +defined via defsystem, +and in the usual case the user is recommended not to supply it. + +

Instead, ASDF follows a hairy set of rules that are designed so that +

    +
  1. find-system +will load a system from disk +and have its pathname default to the right place. + +
  2. This pathname information will not be overwritten with +*default-pathname-defaults* +(which could be somewhere else altogether) +if the user loads up the .asd file into his editor +and interactively re-evaluates that form. +
+ +

If a system is being loaded for the first time, +its top-level pathname will be set to: + +

    +
  • The host/device/directory parts of *load-truename*, +if it is bound. +
  • *default-pathname-defaults*, otherwise. +
+ +

If a system is being redefined, the top-level pathname will be + +

    +
  • changed, if explicitly supplied or obtained from *load-truename* +(so that an updated source location is reflected in the system definition) + +
  • changed if it had previously been set from *default-pathname-defaults* + +
  • left as before, if it had previously been set from *load-truename* +and *load-truename* is currently unbound +(so that a developer can evaluate a defsystem form +from within an editor without clobbering its source location) +
+ +

5.3.11 if-feature option

+ +

This option allows you to specify a feature expression to be evaluated +as if by #+ 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 #+ 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. +This option was added in ASDF 3. + +

5.3.12 if-component-dep-fails 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 if-feature option instead. + +

+ + +

5.4 Other code in .asd files

+ +

Files containing defsystem forms +are regular Lisp files that are executed by load. +Consequently, you can put whatever Lisp code you like into these files +(e.g., code that examines the compile-time environment +and adds appropriate features to *features*). +However, some conventions should be followed, +so that users can control certain details of execution +of the Lisp in .asd files: + +

    +
  • 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 *standard-output*, +so that users can easily control the disposition +of output from ASDF operations. +
+ +

+ + +

6 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 extensible protocol. + +

This allows the addition of behaviours: +for example, cffi adds support of special FFI description files +to interface with C libraries and of wrapper files to embed C code in Lisp; +abcl-jar supports creating Java JAR archives in ABCL; +and poiu supports for compiling code in parallel using background processes. + +

This chapter deals with components and operations. + +

A component represents an individual source file or a group of source files, +and the things that get transformed into. +A system is a component at the top level of the component hierarchy. +A source-file is a component representing a single source-file +and the successive output files into which it is transformed. +A module is an intermediate component itself grouping several other components, +themselves source-files or further modules. + +

An Operation represents a transformation that can be performed on a component, +turning them from source files to intermediate results to final outputs. + +

A pair of an operation and a component is called an action. +An action represents a particular build step to be performed, +after all its dependencies have been fulfilled. +In the ASDF model, actions depend on other actions. +The term action itself was used by Kent Pitman in his old article, +but was only used by ASDF hackers starting with the ASDF 2; +but the concept is ubiquitous since the very beginning of ASDF 1, +though previously implicit. + +

Then, there are many functions available +to users, extenders and implementers of ASDF +to use, define or implement the activities +that are part of building your software. +Though they manipulate actions, +most of these functions do not take as an argument +a reified pair (a CONS cell) of an operation and a component; +instead, they usually take two separate arguments, +which allows to take advantage of the power CLOS-style multiple dispatch +for fun and profit. + +

There are many hooks in which to add functionality, +by customizing the behavior of existing functions. + +

Last but not least is the notion of dependency between two actions. +The structure of dependencies between actions is +a directed dependency graph. +ASDF is invoked by being told to operate +with some operation on some toplevel system; +it will then traverse the graph and build a plan +that follows its structure. +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 requiring and required +as applied to an action depending on the other: +the requiring action depends-on the completion of all required actions +before it may itself be performed. + +

Using the 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 load-op, compile-op or 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 prepare-op and 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 test-op or load-fasl-op +remain at the system level, and are not propagated along the hierarchy, +but instead do something global on the system. + +

+ + +

6.1 Operations

+ +

+An operation object of the appropriate type is instantiated +whenever the user wants to do something with a system like + +

    +
  • compile all its files +
  • load the files into a running lisp environment +
  • copy its source files somewhere else +
+ +

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. + +

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 operate. + + +

+— Generic function: operate operation system &rest initargs &key force force-not verbose &allow-other-keys
+— Generic function: oos operation system &rest initargs &key &allow-other-keys
+

operate invokes operation on system. +oos is a synonym for operate. + +

operation is a symbol that is passed, along with the supplied +initargs, to make-instance to create the operation object. +system is a system designator. + +

The initargs are passed to the 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. + +

If force is :all, then all systems +are forced to be recompiled even if not modified since last compilation. +If force is 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 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 force-not is :all, then all systems +are forced not to be recompiled even if modified since last compilation. +If force-not is t, then only the system being loaded +is forced not to be recompiled even if modified since last compilation, +but other systems are not affected. +If 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. +force takes precedences over force-not; +both of them apply to systems that are dependencies and were already compiled. + +

To see what operate would do, you can use: +

          (asdf::traverse (make-instance operation-class initargs ...) (find-system system-name))
+
+
+ +

+ + +

6.1.1 Predefined operations of ASDF

+ +

All the operations described in this section are in the asdf package. +They are invoked via the operate generic function. + +

     (asdf:operate 'asdf:operation-name :system-name {operation-options ...})
+
+
+— Operation: compile-op &key proclamations
+
+

This operation compiles the specified component. +If proclamations are supplied, they will be proclaimed. +This is a good place to specify optimization settings. + +

When creating a new component type, +you should provide methods for compile-op. + +

When compile-op is invoked, +component dependencies often cause some parts of the system +to be loaded as well as compiled. +Invoking compile-op +does not necessarily load all the parts of the system, though; +use load-op to load a system. +

+ +
+— Operation: load-op &key proclamations
+
+

This operation loads a system. + +

The default methods for load-op compile files before loading them. +For parity, your own methods on new component types should probably do so too. +

+ +
+— Operation: parent-load-op &key proclamations
+
+

This operation ensures that the dependencies +of a module, and its parent, and so on, are loaded (as per load-op) +before the components within that module may be operated upon. + +

By default, all operations depend on this parent-operation +for actions on components to depend on this “parent operation” being acted on the parent. + +

The default methods for load-op compile files before loading them. +For parity, your own methods on new component types should probably do so too. +

+ +
+— Operation: load-source-op
+
+

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. +

+ +

+ +

+— Operation: test-op
+
+

This operation will perform some tests on the module. +The default method will do nothing. +The default dependency is to require +load-op to be performed on the module first. +The default operation-done-p is that the operation is never done +— +we assume that if you invoke the 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. + +

People typically define test-op methods like thus: +

          (defmethod perform ((o asdf:test-op) (s (eql (asdf:find-system :mysystem))))
+            (asdf:load-system :mysystem)
+            (eval (read-from-string "(some expression that runs the tests)"))
+            t)
+
+
+ +
+— Operation: load-fasl-op
+
+

This operation will load and create if need be +a single fasl file for all the files in each loaded system. +(Its compilation-only equivalent is asdf::fasl-op.) + +

Once you have created such a fasl, +you can use precompiled-system to deliver it in a way +that is compatible with clients having asdf dependencies +on your system whether it is distributed as source of as a single binary. + +

On your build platform, you run something like that: +

          (asdf:operate 'load-fasl-op :mysystem)
+
+

And on your delivery platform, a form like this is evaluated +in a prologue or at some point before you save your image: +

          (defsystem :mysystem :class :precompiled-system
+              :fasl (some expression that will evaluate to a pathname))
+
+

Of course, before you define such systems, +you should not forget to (asdf:clear-configuration). + +

load-fasl-op is available on all actively supported Lisp implementations, +and on those implementations only, and only since ASDF 3. +This functionality was previously available for select implementations, +as part of a separate system asdf-bundle, +itself descended from asdf-ecl. +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

+ + +

6.1.2 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 operation. + +

ASDF's pre-defined operations are in no way “privileged”, +but it is requested that developers never use the 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. + +

An operation must provide methods for the following generic functions +when invoked with an object of type source-file: +FIXME describe this better + +

    +
  • input-files +ASDF has a pretty clever default 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 component-pathname of the component. + +
  • output-files +The output-files method determines where the method will put its files. +It returns two values, a list of pathnames, and a boolean. +If the boolean is T then the pathnames are marked +not be translated by enclosing :around methods. +If the boolean is NIL then enclosing :around methods +may translate these pathnames, e.g. to ensure object files +are somehow stored in some implementation-dependent cache. + +
  • perform +The perform method must call output-files +to find out where to put its files, +because the user is allowed to override. +
  • output-files +for local policy explain + +
  • 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 nil (the default is t). + +

    For instance, the method for test-op always returns nil, +so that tests are always run afresh. +Of course, the test-op for your system could depend +on a deterministically repeatable test-report-op, +and just read the results from the report files. + +

  • component-depends-on +When you add new operations, you probably need to explain +how they relate to loading, compiling, testing, etc., +in terms of dependencies between actions. + +

    That's where you typically define methods on component-depends-on. +Your method will take as arguments +some properly specialized operation +and a component denoting a current action, +and return a list of entries, +denoting the children actions that the current action depends on. +The format of entries is described below. + +

    It is strongly advised that +you should always append the results of (call-next-method) +to the results of your method, +or “interesting” failures will likely occur, +unless you're a true specialist of ASDF internals. + +

    Each entry returned by component-depends-on is itself a list. + +

    The first element of an entry is the name of an operation: +a symbol that you can use with make-instance +(ASDF will instead use with asdf::make-sub-operation), +to create a related operation for use in a build plan. +For instance, load-op and compile-op +are common such names, denoting the respective operations. + +

    The rest of an entry is a list of identifiers +each denote a component such that +the pair of the previous operation and this component +is a children action of current action. + +

    Identifiers follow the defsystem grammar +previously documented. +The main format for identifiers is a string or symbol +(that will be downcase as per coerce-name), +and looked up against the sibling list of the parent module's children components, +as per find-component. +As a special case, nil denotes the parent itself. +Other syntaxes are allowed, for instance to specify a component with a version. + +

+ +

Operations that print output should send that output to the standard +CL stream *standard-output*, as the Lisp compiler and loader do. + +

+ + +

6.2 Components

+ +

+A component represents a source file or +(recursively) a collection of components. +A system is (roughly speaking) a top-level component +that can be found via find-system. + +

A 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). + +

+— Function: find-system system-designator &optional (error-p t)
+
+

Given a system designator, find-system finds and returns a system. +If no system is found, an error of type +missing-component is thrown, +or nil is returned if error-p is false. + +

To find and update systems, find-system funcalls each element +in the *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: + +

    +
  • there is no system of that name in memory +
  • the pathname is different from that which was previously loaded +
  • the file's last-modified time exceeds the last-modified time +of the system in memory +
+ +

When system definitions are loaded from .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 defpackage and in-package forms +in his system definition files, however, +so that they can be loaded manually if need be. + +

The default value of *system-definition-search-functions* +is a list of two functions. +The first function looks in each of the directories given +by evaluating members of *central-registry* +for a file whose name is the name of the system and whose type is 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 source-registry. +Hence, it is strongly advised to define a system +foo in the corresponding file foo.asd. +

+ +

+ + +

6.2.1 Common attributes of components

+ +

All components, regardless of type, have the following attributes. +All attributes except name are optional. + +

6.2.1.1 Name
+ +

A component name is a string or a symbol. +If a symbol, its name is taken and lowercased. + +

Unless overridden by a :pathname attribute, +the name will be interpreted as a pathname specifier according +to a Unix-style syntax. +See Pathname specifiers. + +

6.2.1.2 Version identifier
+ +

+This optional attribute is used by the generic function +version-satisfies, which tests to see if :version +dependencies are satisfied. +the version should be a string of integers separated by dots, +for example ‘1.0.11’. +For more information on the semantics of version specifiers, see The defsystem grammar. + + + + + + + +

6.2.1.3 Required features
+ +

FIXME: This subsection seems to contradict the +defsystem grammar subsection, +which doesn't provide any obvious way to specify required features. +Furthermore, in 2009, discussions on the +asdf-devel mailing list +suggested that the specification of required features may be broken, +and that no one may have been using them for a while. +Please contact the +asdf-devel mailing list +if you are interested in getting this features feature fixed. + +

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. + +

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 +*features*. + +

6.2.1.4 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 + +

     :in-order-to ((compile-op (load-op "a" "b") (compile-op "c"))
+                   (load-op (load-op "foo")))
+
+

This means the following things: +

    +
  • before performing compile-op on this component, we must perform +load-op on a and b, and compile-op on c, +
  • before performing load-op, we have to load foo +
+ +

The syntax is approximately + +

(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)
+
+ +

Side note: + +

This is on a par with what ACL defsystem does. +mk-defsystem is less general: it has an implied dependency + +

  for all source file x, (load x) depends on (compile x)
+
+ +

and using a :depends-on argument to say that b depends on +a actually means that + +

  (compile b) depends on (load a)
+
+ +

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 (component-depends-on operation component), +which returns a list + +

     ((load-op "a") (load-op "b") (compile-op "c") ...)
+
+

component-depends-on can be subclassed for more specific +component/operation types: these need to (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 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. + + +

See the discussion of the semantics of :version in the defsystem +grammar. + + + + +

6.2.1.5 pathname
+ +

This attribute is optional and if absent (which is the usual case), +the component name will be used. + +

See Pathname specifiers, +for an explanation of how this attribute is interpreted. + +

Note that the 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. See Defining systems with defsystem. + +

6.2.1.6 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. + +

(component-property component property-name) and +associated setf method will allow +the programmatic update of this information. +Property names are compared as if by EQL, +so use symbols or keywords or something. + +

+ + + +

6.2.2 Pre-defined subclasses of component

+ +
+— 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 .h file from .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. +FIXME: describe these. +

+ +
+— Component: module
+
+

A module is a collection of sub-components. + +

A module component has the following extra initargs: + +

    +
  • :components the components contained in this module + +
  • :default-component-class +All children components which don't specify their class explicitly +are inferred to be of this type. + +
  • :if-component-dep-fails +This attribute was removed in ASDF 3. Do not use it. +Use :if-feature instead. + +
  • :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 :components, i.e. +all of them are loaded before a compile or load operation is performed on it. + +
+ +

The default operation knows how to traverse a module, so +most operations will not need to provide methods specialised on modules. + +

module may be subclassed to represent components such as +foreign-language linked libraries or archive files. +

+ +
+— Component: system
+
+

system is a subclass of module. + +

A system is a module with a few extra attributes for documentation +purposes; these are given elsewhere. +See The defsystem grammar. + +

Users can create new classes for their systems: +the default defsystem macro takes a :class keyword argument. +

+ +

+ + +

6.2.3 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. + +

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 +cl-source-file: + +

     (defclass unportable-cl-source-file (cl-source-file)
+       ())
+
+

Function 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 unportable-cl-source-file. + +

     (defmethod component-pathname ((component unportable-cl-source-file))
+       (merge-pathnames*
+        (coerce-pathname (format nil "~(~A~)/" (asdf:implementation-type)))
+        (call-next-method)))
+
+

The new component type is used in a defsystem form in this way: + +

     (defsystem :foo
+         :components
+         ((:file "packages")
+          ...
+          (:unportable-cl-source-file "threads"
+           :depends-on ("packages" ...))
+          ...
+         )
+
+

+ + +

6.3 Functions

+ +

+ +

+— version-satisfies: version version-spec
+

Does version satisfy the version-spec. A generic function. +ASDF provides built-in methods for version being a +component or string. version-spec should be a +string. + +

In the wild, we typically see version numbering only on components of +type system. + +

For more information about how version-satisfies interprets +version strings and specifications, see The defsystem grammar and +Common attributes of components. +

+ +

+ + +

7 Controlling where ASDF searches for systems

+ +

7.1 Configurations

+ +

Configurations specify paths where to find system files. + +

    + +
  1. 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. + +
  2. An application may explicitly initialize the source-registry configuration +using the configuration API +(see 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. + +
  3. The source registry will be configured from +the environment variable CL_SOURCE_REGISTRY if it exists. + +
  4. The source registry will be configured from +user configuration file +$XDG_CONFIG_DIRS/common-lisp/source-registry.conf +(which defaults to +~/.config/common-lisp/source-registry.conf) +if it exists. + +
  5. The source registry will be configured from +user configuration directory +$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/ +(which defaults to +~/.config/common-lisp/source-registry.conf.d/) +if it exists. + +
  6. The source registry will be configured from +system configuration file +/etc/common-lisp/source-registry.conf +if it exists/ + +
  7. The source registry will be configured from +system configuration directory +/etc/common-lisp/source-registry.conf.d/ +if it exists. + +
  8. 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 +:directory entries for $XDG_DATA_DIRS/common-lisp/systems/ and +:tree entries for $XDG_DATA_DIRS/common-lisp/source/. +For instance, SBCL will include directories for its contribs +when it can find them; it will look for them where SBCL was installed, +or at the location specified by the SBCL_HOME environment variable. + +
+ +

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. + +

7.2 Truenames and other dangers

+ +

One great innovation of the original ASDF was its ability to leverage +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 TRUENAME mechanism, +by setting the variable asdf:*resolve-symlinks* to 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. + +

7.3 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. + +

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 +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. + +

7.4 Backward Compatibility

+ +

For backward compatibility as well as to provide a practical backdoor for hackers, +ASDF will first search for .asd files in the directories specified in +asdf:*central-registry* +before it searches in the source registry above. + +

See Configuring ASDF to find your systems — old style. + +

By default, 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. + +

7.5 Configuration DSL

+ +

Here is the grammar of the s-expression (SEXP) DSL for source-registry +configuration: + + +

     ;; A configuration is a single SEXP starting with 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 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 sport said features:
+         :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
+     
+         ;; add a single directory to be scanned (no recursion)
+         (:directory DIRECTORY-PATHNAME-DESIGNATOR) |
+     
+         ;; 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 name
+     
+     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. "_darcs" will match #p"/foo/bar/_darcs/src/bar.asd"
+
+

Pathnames are designated using another DSL, +shared with the output-translations configuration DSL below. +The DSL is resolved by the function asdf::resolve-location, +to be documented and exported at some point in the future. + +

     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
+         ;; Not valid anymore: :SYSTEM-CACHE (was a security hazard)
+     
+     RELATIVE-COMPONENT-DESIGNATOR :=
+         (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) |
+         STRING | ;; relative directory pathname as interpreted by coerce-pathname.
+                  ;; 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)
+         ;; Not supported (anymore): :UID and :USERNAME
+
+

For instance, as a simple case, my ~/.config/common-lisp/source-registry.conf, +which is the default place ASDF looks for this configuration, once contained: +

     (:source-registry
+       (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
+       :inherit-configuration)
+
+

7.6 Configuration Directories

+ +

Configuration directories consist in files each containing +a list of directives without any enclosing (:source-registry ...) form. +The files will be sorted by namestring as if by string< and +the lists of directives of these files with be concatenated in order. +An implicit :inherit-configuration will be included +at the end of the list. + +

This allows for packaging software that has file granularity +(e.g. Debian's dpkg or some future version of clbuild) +to easily include configuration information about distributed software. + +

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 is conventionally "conf" +and as a limitation to some implementations (e.g. GNU clisp), +the type cannot be NIL. + +

Directories may be included by specifying a directory pathname +or namestring in an :include directive, e.g.: + +

     	(:include "/foo/bar/")
+
+

Hence, to achieve the same effect as +my example ~/.config/common-lisp/source-registry.conf above, +I could simply create a file +~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf +alone in its directory with the following contents: +

     (:tree "/home/fare/cl/")
+
+

7.6.1 The :here directive

+ +

The :here directive is an absolute pathname designator that +refers to the directory containing the configuration file currently +being processed. + +

The :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 dir/. Ordinarily, one +might simply have the user add a directive that would look something +like this: +

        (:tree  "path/to/dir")
+
+

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 dir/src/lisp/ and dir/extlib/lisp/, and +these are the only directories that should be searched. + +

In this case, X can put into dir/ a file asdf.conf that +contains the following: +

     (:source-registry
+        (:tree (:here "src/lisp/"))
+        (:tree (:here "extlib/lisp"))
+        (:directory (:here "outlier/")))
+
+

Then when someone else (call her Y) checks out a copy of this +repository, she need only add +

     (:include "/path/to/my/checkout/directory/asdf.conf")
+
+

to one of her previously-existing asdf source location configuration +files, or invoke 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. + +

7.7 Shell-friendly syntax for configuration

+ +

When considering environment variable CL_SOURCE_REGISTRY +ASDF will skip to next configuration if it's an empty string. +It will READ the string as a SEXP in the DSL +if it begins with a paren ( +and it will be interpreted much like TEXINPUTS +list of paths, where + +

* paths are separated + by a : (colon) on Unix platforms (including cygwin), + by a ; (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 // + 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. + +

7.8 Search Algorithm

+ +

+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 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 +(see Configurations above). + +

7.9 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. + +

7.10 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. + +

+— Function: initialize-source-registry &optional 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 PARAMETER, which can be + 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). +

+ +
+— Function: 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, 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. +

+ +
+— Function: ensure-source-registry &optional PARAMETER
+

checks whether a source registry has been initialized. + If not, initialize it with the given PARAMETER. +

+ +

Every time you use ASDF's find-system, or +anything that uses it (such as operate, load-system, etc.), +ensure-source-registry is called with parameter NIL, +which the first time around causes your configuration to be read. +If you change a configuration file, +you need to explicitly initialize-source-registry again, +or maybe simply to clear-source-registry (or clear-configuration) +which will cause the initialization to happen next time around. + +

7.11 Status

+ +

This mechanism is vastly successful, and we have declared +that 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 wrapping-source-registry +that everyone uses implicitly. + +

7.12 Rejected ideas

+ +

Alternatives I considered and rejected included: + +

    +
  1. Keep 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. + +
  2. Keep asdf:*central-registry* remains 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. + +
  3. Completely remove 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. + +
  4. Replace 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. +
+ +

I've been suggested the below features, but have rejected them, +for the sake of keeping ASDF no more complex than strictly necessary. + +

    +
  • More syntactic sugar: synonyms for the configuration directives, such as + (:add-directory X) for (:directory X), or (:add-directory-hierarchy X) + or (:add-directory X :recurse t) for (:tree X). + +
  • The possibility to register individual files instead of directories. + +
  • 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 USER-HOMEDIR-PATHNAME and $SBCL_HOME + Hopefully, these are already superseded by the :default-registry + +
  • Using the shell-unfriendly syntax /** instead of // to specify recursion + down a filesystem tree in the environment variable. + It isn't that Lisp friendly either. +
+ +

7.13 TODO

+ +
    +
  • Add examples +
+ +

7.14 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 to mine, not theirs. +But so are good design ideas and elegant implementation tricks. + +

— Francois-Rene Rideau fare@tunes.org, Mon, 22 Feb 2010 00:07:33 -0500 + +

+ + +

8 Controlling where ASDF saves compiled files

+ +

+Each Common Lisp implementation has its own format +for compiled files (fasls for short, 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 fasls, dfsls, cfsls and so on. +Worse yet, some implementations use the same file extension +while changing formats from version to version (or platform to platform) +which means that you'll have to recompile binaries +as you switch from one implementation to the next. + +

Since ASDF 2, ASDF includes the asdf-output-translations facility +to mitigate the problem. + +

8.1 Configurations

+ +

Configurations specify mappings from input locations to output locations. +Once again we rely on the XDG base directory specification for configuration. +See XDG base directory. + +

    + +
  1. 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. + +
  2. An application may explicitly initialize the output-translations +configuration using the Configuration API +in which case this takes precedence. +(see Configuration API.) +It may itself compute this configuration from the command-line, +from a script, from its own configuration file, etc. + +
  3. The source registry will be configured from +the environment variable ASDF_OUTPUT_TRANSLATIONS if it exists. + +
  4. The source registry will be configured from +user configuration file +$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf +(which defaults to +~/.config/common-lisp/asdf-output-translations.conf) +if it exists. + +
  5. The source registry will be configured from +user configuration directory +$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf.d/ +(which defaults to +~/.config/common-lisp/asdf-output-translations.conf.d/) +if it exists. + +
  6. The source registry will be configured from +system configuration file +/etc/common-lisp/asdf-output-translations.conf +if it exists. + +
  7. The source registry will be configured from +system configuration directory +/etc/common-lisp/asdf-output-translations.conf.d/ +if it exists. + +
+ +

Each of these configurations is specified as a SEXP +in a trival 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. + +

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. + +

8.2 Backward Compatibility

+ +

+ +

We purposefully do NOT provide backward compatibility with earlier versions of +ASDF-Binary-Locations (8 Sept 2009), +common-lisp-controller (7.0) or +cl-launch (2.35), +each of which had similar general capabilities. +The previous APIs of these programs were not designed +for configuration by the end-user +in an easy way with configuration files. +Recent versions of same packages use +the new asdf-output-translations API as defined below: +common-lisp-controller (7.2) and cl-launch (3.000). +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 +common-lisp-controller and/or 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 ASDF-Binary-Locations, +we provide a limited emulation mode: + +

+— Function: enable-asdf-binary-locations-compatibility &key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
+

This function will initialize the new asdf-output-translations facility in a way +that emulates the behavior of the old ASDF-Binary-Locations facility. +Where you would previously set global variables +*centralize-lisp-binaries*, +*default-toplevel-directory*, +*include-per-user-information*, +*map-all-source-files* or *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 :source-to-target-mappings keyword argument +will accept any valid pathname designator for asdf-output-translations +instead of just strings and pathnames. +

+ +

If you insist, you can also keep using the old 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 asdf-output-translations +with (asdf:disable-output-translations), +or you might experience “interesting” issues. + +

Also, note that output translation is enabled by default. +To disable it, use (asdf:disable-output-translations). + +

8.3 Configuration DSL

+ +

Here is the grammar of the SEXP DSL +for asdf-output-translations configuration: + +

;; 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 sport said features:
+    :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
+
+    ;; include a configuration file or directory
+    (:include PATHNAME-DESIGNATOR) |
+
+    ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.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 leaves pathname unmapped.
+    ABSOLUTE-COMPONENT-DESIGNATOR ;; same as in the source-registry language
+
+TRANSLATION-FUNCTION :=
+    SYMBOL | ;; symbol of 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 consisting of
+             ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR
+
+
+ +

Relative components better be either relative +or subdirectories of the path before them, or bust. + +

The last component, if not a pathname, is notionally completed by /**/*.*. +You can specify more fine-grained patterns +by using a pathname object as the last component +e.g. #p"some/path/**/foo*/bar-*.fasl" + +

You may use #+features to customize the configuration file. + +

The second designator of a mapping may be 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 t, +the mapping always matches. +When the first designator starts with :root, +the mapping matches any host and device. +In either of these cases, if the second designator +isn't t and doesn't start with :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 t, the mapping is the identity. +When the second designator starts with :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 enable-asdf-binary-locations-compatibility +with :centralize-lisp-binaries nil +which will do the same thing internally for you: +

  #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors)))
+          (wild-file (make-pathname :name :wild :version :wild :type :wild)))
+     `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root
+       (:root ,wild-subdir :implementation ,wild-file)))
+
+Starting with ASDF 2.011.4, you can use the simpler: + `(:root (:root :**/ :implementation :*.*.*)) + +

:include statements cause the search to recurse with the path specifications +from the file specified. + +

If the 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 directory-designator +the first element of which is the keyword :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. +The result of the function invocation should be the translated pathname. + +

An :inherit-configuration statement cause the search to recurse with the path +specifications from the next configuration. +See Configurations, above. + +

    +
  • :enable-user-cache is the same as (t :user-cache). +
  • :disable-cache is the same as (t t). +
  • :user-cache uses the contents of variable asdf::*user-cache* +which by default is the same as using +(:home ".cache" "common-lisp" :implementation). +
  • :system-cache uses the contents of variable asdf::*system-cache* +which by default is the same as using +("/var/cache/common-lisp" :uid :implementation-type) +(on Unix and cygwin), or something semi-sensible on Windows. +
+ +

8.4 Configuration Directories

+ +

Configuration directories consist in files each contains +a list of directives without any enclosing +(:output-translations ...) form. +The files will be sorted by namestring as if by string< and +the lists of directives of these files with be concatenated in order. +An implicit :inherit-configuration will be included +at the end of the list. + +

This allows for packaging software that has file granularity +(e.g. Debian's dpkg or some future version of clbuild) +to easily include 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 is conventionally "conf" +and as a limitation of some implementations, the type cannot be NIL. + +

Directories may be included by specifying a directory pathname +or namestring in an :include directive, e.g.: +

	(:include "/foo/bar/")
+
+ +

8.5 Shell-friendly syntax for configuration

+ +

When considering environment variable ASDF_OUTPUT_TRANSLATIONS +ASDF will skip to next configuration if it's an empty string. +It will READ the string as an SEXP in the DSL +if it begins with a paren ( +and it will be interpreted as a list of directories. +Directories should come by pairs, indicating a mapping directive. +Entries are separated +by a : (colon) on Unix platforms (including cygwin), +by a ; (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). + +

8.6 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). + +

8.7 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. + +

8.8 Output location API

+ +

The specified functions are exported from package ASDF. + +

+— Function: initialize-output-translations &optional 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 PARAMETER, which can be + 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). +

+ +
+— Function: disable-output-translations
+

will initialize output translations in a way + that maps every pathname to itself, + effectively disabling the output translation facility. +

+ +
+— Function: 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, 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. +

+ +
+— Function: ensure-output-translations &optional PARAMETER
+

checks whether output translations have been initialized. + If not, initialize them with the given PARAMETER. + This function will be called before any attempt to operate on a system. +

+ +
+— Function: apply-output-translations PATHNAME
+

Applies the configured output location translations to PATHNAME + (calls ensure-output-translations for the translations). +

+ +

Every time you use ASDF's output-files, or +anything that uses it (that may compile, such as operate, perform, etc.), +ensure-output-translations is called with parameter NIL, +which the first time around causes your configuration to be read. +If you change a configuration file, +you need to explicitly initialize-output-translations again, +or maybe clear-output-translations (or clear-configuration), +which will cause the initialization to happen next time around. + +

8.9 Credits for output translations

+ +

Thanks a lot to Bjorn Lindberg and Gary King for ASDF-Binary-Locations, +and to Peter van Eynde for Common Lisp Controller. + +

All bad design ideas and implementation bugs are to mine, not theirs. +But so are good design ideas and elegant implementation tricks. + +

— Francois-Rene Rideau fare@tunes.org + + + + + + + + + + + + + + + + + + + + + +

+ + +

9 Error handling

+ +

+ +

9.1 ASDF errors

+ +

If ASDF detects an incorrect system definition, it will signal a generalised instance of +SYSTEM-DEFINITION-ERROR. + +

Operations may go wrong (for example when source files contain errors). +These are signalled using generalised instances of +OPERATION-ERROR. + +

9.2 Compilation error and warning handling

+ +

+ASDF checks for warnings and errors when a file is compiled. +The variables *compile-file-warnings-behaviour* and +*compile-file-errors-behavior* +control the handling of any such events. +The valid values for these variables are +:error, :warn, and :ignore. + +

+ + +

10 Miscellaneous additional functionality

+ +

ASDF includes several additional features that are generally +useful for system definition and development. + +

10.1 Controlling file compilation

+ +

When declaring a component (system, module, file), +you can specify a keyword argument :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 nil +if no value is specified in any transitive parent. + +

The argument must be a either nil, a fbound symbol, +a lambda-expression (e.g. (lambda (thunk) ...(funcall thunk ...) ...)) +a function object (e.g. using #.#' but that's discouraged +because it prevents the introspection done by e.g. asdf-dependency-grovel), +or a string that when read yields a symbol or a lambda-expression. +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 compile-file* with various arguments; +the around-compile hook may supply additional keyword arguments +to pass to that call to compile-file*. + +

One notable argument that is heeded by compile-file* is +:compile-check, +a function called when the compilation was otherwise a success, +with the same arguments as compile-file; +the function shall return true if the compilation +and its resulting compiled file respected all system-specific invariants, +and false (nil) if it broke any of those invariants; +it may issue warnings or errors before it returns 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 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 *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 package-renaming system). + +

10.2 Controlling source file character encoding

+ +

Starting with ASDF 2.21, components accept a :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, +the default :autodetect is assumed. +By default, only :default, :utf-8 +and :autodetect are accepted. +:autodetect, the default, calls +*encoding-detection-hook* which by default always returns +*default-encoding* which itself defaults to :default. + +

In other words, there now are plenty of extension hooks, but +by default ASDF follows the backwards compatible behavior +of using whichever :default encoding your implementation uses, +which itself may or may not vary based on environment variables +and other locale settings. +In practice this means that only source code that only uses ASCII +is guaranteed to be read the same on all implementations +independently from any user setting. + +

Additionally, for backward-compatibility with older versions of ASDF +and/or with implementations that do not support unicode and its many encodings, +you may want to use +the reader conditionals #+asdf-unicode #+asdf-unicode +to protect any :encoding encoding statement +as :asdf-unicode will be present in *features* +only if you're using a recent ASDF +on an implementation that supports unicode. +We recommend that you avoid using unprotected :encoding specifications +until after ASDF 2.21 or later becomes widespread, hopefully by the end of 2012. + +

While it offers plenty of hooks for extension, +and one such extension is being developed (see below), +ASDF itself only recognizes one encoding beside :default, +and that is :utf-8, which is the 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 :asdf-unicode is absent, and +the :default external-format is used +to read even source files declared as :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 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 .asd files. +Indeed, on some implementations and configurations, +UTF-8 is already the :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 not use a BOM), +although it might be read incorrectly on some implementations. +In the future, we intend to make :utf-8 +the default value of *default-encoding*, +to be enforced everywhere, so at least the code is guaranteed +to be read correctly everywhere it can be. + +

If you need non-standard character encodings for your source code, +use the extension system asdf-encodings, by specifying +:defsystem-depends-on (:asdf-encodings) in your defsystem. +This extension system will register support for more encodings using the +*encoding-external-format-hook* facility, +so you can explicitly specify :encoding :latin1 +in your .asd file. +Using the *encoding-detection-hook* it will also +eventually implement some autodetection of a file's encoding +from an emacs-style -*- mode: lisp ; coding: latin1 -*- declaration, +or otherwise based on an analysis of octet patterns in the file. +At this point, asdf-encoding only supports the encodings +that are supported as part of your implementation. +Since the list varies depending on implementations, +we once again recommend you use :utf-8 everywhere, +which is the most portable (next is :latin1). + +

If you're not using a version of Quicklisp that has it, +you may get the source for asdf-encodings using git: +git clone git://common-lisp.net/projects/asdf/asdf-encodings.git +or +git clone ssh://common-lisp.net/project/asdf/git/asdf-encodings.git. +You can also browse the repository on +http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git. + +

In the future, we intend to change the default *default-encoding* +to :utf-8, which is already the de facto standard +for most libraries that use non-ASCII characters: +utf-8 works everywhere and was backhandedly enforced by +a lot of people using SBCL and utf-8 and sending reports to authors +so they make their packages compatible. +A survey showed only about a handful few libraries +are incompatible with non-UTF-8, and then, only in comments, +and we believe that authors will adopt UTF-8 when prompted. +See the April 2012 discussion on the asdf-devel mailing-list. +For backwards compatibility with users who insist on a non-UTF-8 encoding, +but cannot immediately transition to using asdf-encodings +(maybe because it isn't ready), it will still be possible to use +the :encoding :default option in your defsystem form +to restore the behavior of ASDF 2.20 and earlier. +This shouldn't be required in libraries, +because user pressure as mentioned above will already have pushed +library authors towards using UTF-8; +but authors of end-user programs might care. + +

When you use asdf-encodings, any further loaded .asd file +will use the autodetection algorithm to determine its encoding; +yet if you depend on this detection happening, +you may want to explicitly load asdf-encodings early in your build, +for by the time you can use :defsystem-depends-on, +it is already too late to load it. +In practice, this means that the *default-encoding* +is usually used for .asd files. +Currently, this defaults to :default for backwards compatibility, +and that means that you shouldn't rely on non-ASCII characters in a .asd file. +Since component (path)names are the only real data in these files, +and non-ASCII characters are not very portable for file names, +this isn't too much of an issue. +We still encourage you to use either plain ASCII or UTF-8 +in .asd files, +as we intend to make :utf-8 the default encoding in the future. +This might matter, for instance, in meta-data about author's names. + +

10.3 Miscellaneous Functions

+ +

Most of these functions are not exported by ASDF anymore, +but only used for private purposes of ASDF. +Please use ASDF-UTILS for the same functions exported from a stable library. + +

+— Function: coerce-pathname name &key type defaults
+
+

This function (available starting with ASDF 2.012.11) +takes an argument, and portably interprets it as a pathname. +If the argument name is a pathname or nil, it is passed through; +if it's a symbol, it's interpreted as a string by downcasing it; +if it's a string, it is first separated using / into substrings; +the leading substrings denote subdirectories of a relative pathname. +If type is :directory or the string ends with /, +the last substring is also a subdirectory; +if type is a string, it is used as the type of the pathname, and +the last substring is the name component of the pathname; +if type is nil, the last substring specifies both name and type components +of the pathname, with the last . separating them, or only the name component +if there's no last . or if there is only one dot and it's the first character. +The host, device and version components come from defaults, which defaults to +*default-pathname-defaults*; but that shouldn't matter if you use merge-pathnames*. + +

+ +
+— Function: merge-pathnames* &key specified defaults
+
+

This function is a replacement for merge-pathnames that uses the host and device +from the defaults rather than the 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. + +

+ +
+— Function: system-relative-pathname system name &key type
+
+

It's often handy to locate a file relative to some system. +The system-relative-pathname function meets this need. + +

It takes two mandatory arguments system and name +and a keyword argument type: +system is name of a system, whereas name and optionally type +specify a relative pathname, interpreted like a component pathname specifier +by coerce-pathname. See Pathname specifiers. + +

It returns a pathname built from the location of the system's +source directory and the relative pathname. For example: + +

          > (asdf:system-relative-pathname 'cl-ppcre "regex.data")
+          #P"/repository/other/cl-ppcre/regex.data"
+
+
+ +
+— Function: system-source-directory system-designator
+
+

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 system-source-directory to find such files. +Returns a pathname object. +The system-designator may be a string, symbol, or ASDF system object. +

+ +
+— Function: clear-system system-designator
+
+

It is sometimes useful to force recompilation of a previously loaded system. +In these cases, it may be useful to (asdf:clear-system :foo) +to remove the system from the table of currently loaded systems; +the next time the system foo or one that depends on it is re-loaded, +foo will then be loaded again. +Alternatively, you could touch foo.asd or +remove the corresponding fasls from the output file cache. +(It was once conceived that one should provide +a list of systems the recompilation of which to force +as the :force keyword argument to load-system; +but this has never worked, and though the feature was fixed in ASDF 2.000, +it remains cerror'ed out as nobody ever used it.) + +

Note that this does not and cannot by itself 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 datastructures +makes such a thing impossible in the general case. +If the software being re-loaded is not conceived with hot upgrade in mind, +this 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 update-instance-for-redefined-class +and much more are necessary for reloading to happen smoothly. +ASDF itself goes through notable pains to make such a hot upgrade possible +with respect to its own code, and what it does is ridiculously complex; +look at the beginning of asdf.lisp to see what it does. +

+ +
+— Function: run-program
+
+

run-program takes a COMMAND argument that is either +a list of a program 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. + +

output is its most important argument; +it specifies how the output is captured and processed. +If it is nil, then the output is not captured. +If it is :interactive, then +input and output are inherited from the current process, +which the subprocess can control until it exits. +Otherwise, the output is captured and redirected to a stream, +and processed by slurp-input-stream with the object as first argument. +See below. + +

element-type and external-format are passed on +to your Lisp implementation, when available, for creation of the output stream. + +

force-shell forces evaluation of the command through a shell, +even if it was passed as a list rather than a string. + +

ignore-error-status causes 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. + +

run-program works on all platforms supported by ASDF, except Genera. + +

+ +
+— Function: slurp-input-stream
+
+

It's 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 follow: + +

If the object is a function, the function is called with the stream as argument. + +

If the object is a cons, its first element is applied to its rest appended by +a list of the input stream. + +

If the object is an output stream, the contents of the input stream are copied to it. +If the linewise argument is provided, copying happens line by line, +and an optional prefix is printed before each line. +Otherwise, copying happen based on a buffer of size buffer-size, +using the element-type. + +

If the object is 'string or :string, the content is captured into a string +of the given element-type. + +

If the object is :lines, the content is captured as a list of strings, +one per line, without line ending. If the count argument is provided, +it is a maximum count of lines to be read. + +

If the object is :line, the content is capture as with :lines above, +and then its sub-object is extracted with the path argument, +which defaults to 0, extracting the first line. +A number will extract the corresponding line. +See the documentation for asdf-driver:sub-object. + +

If the object is :forms, the content is captured as a list of S-expressions, +as read by the Lisp reader. +If the count argument is provided, +it is a maximum count of lines to be read. +We recommend you control the syntax with such macro as +asdf-driver:with-safe-io-syntax. + +

If the object is :form, the content is capture as with :forms above, +and then its sub-object is extracted with the path argument, +which defaults to 0, extracting the first form. +A number will extract the corresponding form. +See the documentation for asdf-driver:sub-object. +We recommend you control the syntax with such macro as +asdf-driver:with-safe-io-syntax. + +

+ +
+— Function: run-shell-command
+
+

This function is obsolete and present only for the sake of backwards-compatibility: +“If it's not backwards, it's not compatible”. We 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 run-program above +available as part of ASDF since ASDF 3. + +

run-shell-command takes as arguments a format control-string +and arguments to be passed to 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). +

+ +

+ + +

11 Getting the latest version

+ +

Decide which version you want. +The master branch is where development happens; +its HEAD is usually OK, including the latest fixes and portability tweaks, +but an occasional regression may happen despite our (limited) test suite. + +

The release branch is what cautious people should be using; +it has usually been tested more, and releases are cut at a point +where there isn't any known unresolved issue. + +

You may get the ASDF source repository using git: +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 +http://common-lisp.net/gitweb?p=projects/asdf/asdf.git. + +

Discussion of ASDF development is conducted on the +mailing list +asdf-devel@common-lisp.net. +http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel + +

+ + +

12 FAQ

+ +

12.1 “Where do I report a bug?”

+ +

ASDF bugs are tracked on launchpad: https://launchpad.net/asdf. + +

If you're unsure about whether something is a bug, or for general discussion, +use the asdf-devel mailing list + +

12.2 “What has changed between ASDF 1 and ASDF 2?”

+ +

12.2.1 What are ASDF 1 and ASDF 2?

+ +

On May 31st 2010, we have released ASDF 2. +ASDF 2 refers to release 2.000 and later. +(Releases between 1.656 and 1.728 were development releases for ASDF 2.) +ASDF 1 to any release earlier than 1.369 or so. +If your ASDF doesn't sport a version, it's an old ASDF 1. + +

ASDF 2 and its release candidates push +:asdf2 onto *features* so that if you are writing +ASDF-dependent code you may check for this feature +to see if the new API is present. +All versions of ASDF should have the :asdf feature. + +

Additionally, all versions of ASDF 2 +define a function (asdf:asdf-version) you may use to query the version; +and the source code of recent versions of ASDF 2 features the version number +prominently on the second line of its source code. + +

If you are experiencing problems or limitations of any sort with ASDF 1, +we recommend that you should upgrade to ASDF 2, +or whatever is the latest release. + +

12.2.2 ASDF can portably name files in subdirectories

+ +

Common Lisp namestrings are not portable, +except maybe for logical pathnamestrings, +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 #.(make-pathname ...) and +#.(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. +See asdf:system-relative-pathname, +merge-pathnames*, +coerce-pathname. + +

On the other hand, there are places where systems used to accept namestrings +where you must now use an explicit pathname object: +(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...) +must now be written with the #p syntax: +(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...) + +

See Pathname specifiers. + +

12.2.3 Output translations

+ +

A popular feature added to ASDF was output pathname translation: +asdf-binary-locations, common-lisp-controller, +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, +asdf-output-translations, +with sensible defaults, adequate configuration languages, +a coherent set of configuration files and hooks, +and support for non-Unix platforms. + +

See Controlling where ASDF saves compiled files. + +

12.2.4 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 *central-registry* and +*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. + +

See Controlling where ASDF searches for systems. + +

12.2.5 Usual operations are made easier to the user

+ +

In ASDF 1, you had to use the awkward syntax +(asdf:oos 'asdf:load-op :foo) +to load a system, +and similarly for compile-op, test-op. + +

In ASDF 2, you can use shortcuts for the usual operations: +(asdf:load-system :foo), and +similarly for compile-system, test-system. + +

12.2.6 Many bugs have been fixed

+ +

The following issues and many others have been fixed: + +

    +
  • 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 :version and +the :force (system1 .. systemN) feature have been fixed. + +
  • 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 quadratic-time recursive appends. + +
  • Many features used to not be portable, +especially where pathnames were involved. +Windows support was notably quirky because of such non-portability. + +
  • 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, +except for GCL (due to GCL bugs). + +
  • Support was lacking for some implementations. +ABCL and GCL were notably wholly broken. +ECL extensions were not integrated with ASDF release. + +
  • The documentation was grossly out of date. + +
+ +

12.2.7 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 #+asdf2 to detect presence of ASDF 2, +(asdf:version-satisfies (asdf:asdf-version) "2.345.67") +to check the availability of a version no earlier than required. + +

12.2.8 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. + +

12.2.9 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. + +

12.2.10 Pitfalls of the transition to ASDF 2

+ +

The main pitfalls in upgrading to ASDF 2 seem to be related +to the output translation mechanism. + +

    +
  • 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. +See “How can I wholly disable the compiler output cache?”. + +
  • 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. + +
  • 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 enable-asdf-binary-locations-compatibility in +see Backward Compatibility. +But thou shalt not load ABL on top of ASDF 2. + +
+ +

Other issues include the following: + +

    +
  • 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 :pathname argument +to a defsystem and its components, +a logical pathname (or implementation-dependent hierarchical pathname) +must now be specified with #p syntax +where the namestring might have previously sufficed; +moreover when evaluation is desired #. must be used, +where it wasn't necessary in the toplevel :pathname argument +(but necessary in other :pathname arguments). + +
  • There is a slight performance bug, notably on SBCL, +when initially searching for asd files, +the implicit (directory "/configured/path/**/*.asd") +for every configured path (:tree "/configured/path/") +in your source-registry configuration can cause a slight pause. +Try to (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 :tree entry but only :directory entries +or shallow :tree entries. +Or you can fix your implementation to not be quite that slow +when recursing through directories. +Update: This performance bug fixed the hard way in 2.010. + +
  • 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. +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. + +
  • The mechanism by which one customizes a system so that Lisp files +may use a different extension from the default .lisp has changed. +Previously, the pathname for a component +was lazily computed when operating on a system, +and you would +(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 (defclass cl-source-file.lis (cl-source-file) ((type :initform "lis"))) +and use :default-component-class cl-source-file.lis +as argument to defsystem, +as detailed in a see How do I create a system definition where all the source files have a .cl extension? below. + +

    + +

+ +

12.3 Issues with installing the proper version of ASDF

+ +

12.3.1 “My Common Lisp implementation comes with an outdated version of ASDF. What to do?”

+ +

We recommend you upgrade ASDF. +See Upgrading ASDF. + +

If this does not work, it is a bug, and you should report it. +See report-bugs. +In the meantime, you can load asdf.lisp directly. +See Loading an otherwise installed ASDF. + +

12.3.2 “I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?”

+ +

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 release should be correct. +We trust you to thoroughly test it with your implementation +before you release it. +If there are any issues with the current release, +it's a bug that you should report upstream and that we will fix ASAP. + +

As to how to include ASDF, we recommend the following: + +

    +
  • If ASDF isn't loaded yet, then (require "asdf") +should load the version of ASDF that is bundled with your system. +If possible so should (require "ASDF"). +You may have it load some other version configured by the user, +if you allow such configuration. + +
  • If your system provides a mechanism to hook into 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. + +
  • You may, like SBCL, have ASDF be implicitly used to require systems +that are bundled with your Lisp distribution. +If you do have a few magic systems that come with your implementation +in a precompiled way such that one should only use the binary version +that goes with your distribution, like SBCL does, +then you should add them in the beginning of wrapping-source-registry. + +
  • If you have magic systems as above, like SBCL does, +then we explicitly ask you to NOT distribute +asdf.asd as part of those magic systems. +You should still include the file asdf.lisp in your source distribution +and precompile it in your binary distribution, +but 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 .asd file to e.g. +asdf-ecl and asdf-ecl.asd, or +sb-asdf and sb-asdf.asd. +Indeed, if you made 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. + +
  • 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 wrapping-source-registry, +and you are welcome to include asdf.asd amongst them. +Non-magic systems should be at the back of the wrapping-source-registry +while magic systems are at the front. + +
  • 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. + +
+ +

12.4 Issues with configuring ASDF

+ +

12.4.1 “How can I customize where fasl files are stored?”

+ +

See Controlling where ASDF saves compiled files. + +

Note that in the past there was an add-on to ASDF called +ASDF-binary-locations, developed by Gary King. +That add-on has been merged into ASDF proper, +then superseded by the asdf-output-translations facility. + +

Note that use of asdf-output-translations +can interfere with one aspect of your systems +— if your system uses *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 asdf:system-relative-pathname to locate a file +in the source directory of some system, and +use asdf:apply-output-translations to locate a file +whose pathname has been translated by the facility. + +

12.4.2 “How can I wholly disable the compiler output cache?”

+ +

To permanently disable the compiler output cache +for all future runs of ASDF, you can: + +

     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
+
+

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 asdf:initialize-output-translations). + +

To disable the compiler output cache in Lisp processes +run by your current shell, try (assuming bash or zsh) +(on Unix and cygwin only): + +

     export ASDF_OUTPUT_TRANSLATIONS=/:
+
+

To disable the compiler output cache just in the current Lisp process, +use (after loading ASDF but before using it): + +

     (asdf:disable-output-translations)
+
+

12.5 Issues with using and extending ASDF to define systems

+ +

12.5.1 “How can I cater for unit-testing in my system?”

+ +

ASDF provides a predefined test operation, test-op. +See test-op. +The test operation, however, is largely left to the system definer to specify. +test-op has been +a topic of considerable discussion on the +asdf-devel mailing list, +and on the +launchpad bug-tracker. + +

Here are some guidelines: + +

    +
  • For a given system, foo, you will want to define a corresponding +test system, such as foo-test. The reason that you will want this +separate system is that ASDF does not out of the box supply components +that are conditionally loaded. So if you want to have source files +(with the test definitions) that will not be loaded except when testing, +they should be put elsewhere. + +
  • The foo-test system can be defined in an asd file of its own or +together with foo. An aesthetic preference against cluttering up +the filesystem with extra asd files should be balanced against the +question of whether one might want to directly load foo-test. +Typically one would not want to do this except in early stages of +debugging. + +
  • Record that testing is implemented by foo-test. For example: +
              (defsystem foo
    +             :in-order-to ((test-op (test-op foo-test)))
    +             ....)
    +          
    +          (defsystem foo-test
    +             :depends-on (foo my-test-library ...)
    +             ....)
    +
    +
+ +

This procedure will allow you to support users who do not wish to +install your test framework. + +

One oddity of ASDF is that operate (see operate) +does not return a value. So in current versions of ASDF there is no +reliable programmatic means of determining whether or not a set of tests +has passed, or which tests have failed. The user must simply read the +console output. This limitation has been the subject of much +discussion. + +

12.5.2 “How can I cater for documentation generation in my system?”

+ +

The ASDF developers are currently working to add a doc-op +to the set of predefined ASDF operations. +See Predefined operations of ASDF. +See also https://bugs.launchpad.net/asdf/+bug/479470. + +

12.5.3 “How can I maintain non-Lisp (e.g. C) source files?”

+ +

See cffi's cffi-grovel. + +

+ +

12.5.4 “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 :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: + +

     (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")))
+
+

All of the files in the tree-impls module are at the top level, +instead of in a tree-impls/ subdirectory. + +

Note that the argument to :pathname can be either a pathname object or a string. +A pathname object can be constructed with the #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 +#.(make-pathname :directory '(:relative "foo" "bar")), +and similarly the current directory can only be portably specified as +#.(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 /-separated path from the current directory, +such that the empty string "" denotes the current directory, and +"foo/bar" (no trailing / required in the case of modules) +portably denotes the same subdirectory as above. +When files are specified, the last /-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). + +

12.5.5 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 cl-source-file.cl as +the :default-component-class argument to defsystem: + +

     (defsystem my-cl-system
+       :default-component-class cl-source-file.cl
+       ...)
+
+

Another builtin class cl-source-file.lsp is offered +for files ending in .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: + +

     ;; 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")))
+
+

Then you can use it as follows: +

     (defsystem my-cl-system
+       :default-component-class my-asdf-extension:cl-source-file.lis
+       ...)
+
+

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 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: + +

     (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
+       ...)
+
+

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 +before you use the class in a defsystem, +you also define the following method: + +

     (defmethod source-file-type ((f cl-source-file.lis) (s system))
+       (declare (ignorable f s))
+       "lis")
+
+ +

+ + +

13 TODO list

+ +

Here is an old list of things to do, +in addition to the bugs that are now tracked on launchpad: +https://launchpad.net/asdf. + +

13.1 Outstanding spec questions, things to add

+ +

** packaging systems + +

*** manual page component? + +

** style guide for .asd files + +

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. + +

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. + +

** extending defsystem with new options + +

You might not want to write a whole parser, +but just to add options to the existing syntax. +Reinstate parse-option or something akin. + +

** Diagnostics + +

A “dry run” of an operation can be made with the following form: + +

     (let ((asdf::*verbose-out* *standard-output*))
+       (loop :for (op . comp) :in
+         (asdf::traverse (make-instance '<operation-name> :force t)
+                         (asdf:find-system <system-name>))
+         :do (asdf:explain op comp)))
+
+

This uses unexported symbols. +What would be a nice interface for this functionality? + +

13.2 Missing bits in implementation

+ +

** reuse the same scratch package whenever a system is reloaded from disk + +

Have a package ASDF-USER instead of all these temporary packages? + +

** proclamations probably aren't + +

** A revert function + +

Other possible interface: have a “revert” function akin to make clean. + +

     (asdf:revert 'asdf:compile-op 'araneida)
+
+

would delete any files produced by (compile-system :araneida). +Of course, it wouldn't be able to do much about stuff in the image itself. + +

How would this work? + +

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, (load "use") depends-on (load "macros") is a peer, +whereas (load "use") depends-on (compile "use") +is more of a “subservient” relationship. + +

+ + +

14 Inspiration

+ +

14.1 mk-defsystem (defsystem-3.x)

+ +

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. + +

The surface defsystem syntax of asdf is more-or-less compatible with +mk-defsystem, except that we do not support +the source-foo and 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. + +

14.2 defsystem-4 proposal

+ +

Marco and Peter's proposal for defsystem 4 served as the driver for +many of the features in here. Notable differences are: + +

    +
  • We don't specify output files or output file extensions +as part of the system. + +

    If you want to find out what files an operation would create, +ask the operation. + +

  • We don't deal with CL packages + +

    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) + +

  • There is no proposal here that defsystem does version control. + +

    A system has a given version which can be used to check dependencies, +but that's all. +

+ +

The defsystem 4 proposal tends to look more at the external features, +whereas this one centres on a protocol for system introspection. + +

14.3 kmp's “The Description of Large Systems”, MIT AI Memo 801

+ +

Available in updated-for-CL form on the web at +http://nhplace.com/kent/Papers/Large-Systems.html + +

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 ] + + +

+ +

Concept Index

+ +

+ +

Function and Class Index

+ + + +

+ +

Variable Index

+ + + +
+
+

Footnotes

[1] +It is possible to further customize +the system definition file search. +That's considered advanced use, and covered later: +search forward for +*system-definition-search-functions*. +See Defining systems with defsystem.

+ +

[2] +ASDF will indeed call EVAL on each entry. +It will also skip entries that evaluate to NIL. + +

Strings and pathname objects are self-evaluating, +in which case the EVAL step does nothing; +but you may push arbitrary SEXP onto the central registry, +that will be evaluated to compute e.g. things that depend +on the value of shell variables or the identity of the user. + +

The variable asdf:*central-registry* is thus a list of +“system directory designators”. +A 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. +By “directory” here, we mean +“designator for a pathname with a supplied DIRECTORY component”. +

+ +

[3] +It is possible, though almost never necessary, to override this behaviour.

+ +
+ + + --- /dev/null +++ cl-asdf-3.0.0/doc/asdf.info @@ -0,0 +1,3960 @@ +This is asdf.info, produced by makeinfo version 4.13 from asdf.texinfo. + +INFO-DIR-SECTION Software development +START-INFO-DIR-ENTRY +* asdf: (asdf). Another System Definition Facility (for Common Lisp) +END-INFO-DIR-ENTRY + + This manual describes ASDF, a system definition facility for Common +Lisp programs and libraries. + + You can find the latest version of this manual at +`http://common-lisp.net/project/asdf/asdf.html'. + + ASDF Copyright (C) 2001-2013 Daniel Barlow and contributors. + + This manual Copyright (C) 2001-2013 Daniel Barlow and contributors. + + This manual revised (C) 2009-2013 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 +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +File: asdf.info, Node: Top, Next: Introduction, Prev: (dir), Up: (dir) + +asdf: another system definition facility +**************************************** + +This manual describes ASDF, a system definition facility for Common +Lisp programs and libraries. + + You can find the latest version of this manual at +`http://common-lisp.net/project/asdf/asdf.html'. + + ASDF Copyright (C) 2001-2013 Daniel Barlow and contributors. + + This manual Copyright (C) 2001-2013 Daniel Barlow and contributors. + + This manual revised (C) 2009-2013 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 +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +* Menu: + +* Introduction:: +* 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:: +* TODO list:: +* Inspiration:: +* Concept Index:: +* Function and Class Index:: +* Variable Index:: + + +File: asdf.info, Node: Introduction, Next: Loading ASDF, Prev: Top, Up: Top + +1 Introduction +************** + +ASDF is Another System Definition Facility: a tool for specifying how +systems of Common Lisp software are comprised 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. + + 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, one for +implementers of Common Lisp extensions who want to extend the build +system. *Note Loading a system: Using ASDF, to learn how to use ASDF +to load a system. *Note Defining systems with defsystem::, to learn +how to define a system of your own. *Note The object model of ASDF::, +for a description of the ASDF internals and how to extend ASDF. + + _Nota Bene_: We have released ASDF 2.000 on May 31st 2010, and ASDF +3.0 on January 31st 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 didn't use to, and has +been made to work with all actively used CL implementations and a few +more. *Note "What has changed between ASDF 1 and ASDF 2?": FAQ. +Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 or ASDF 3 +on the fly. 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. *Note Loading ASDF::. + + Also note that ASDF is not to be confused with ASDF-Install. +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 instead, which works great 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. + + +File: asdf.info, Node: Loading ASDF, Next: Configuring ASDF, Prev: Introduction, Up: Top + +2 Loading ASDF +************** + +2.1 Loading a pre-installed ASDF +================================ + +Most recent Lisp implementations include a copy of ASDF 2, and soon +ASDF 3. You can usually load this copy using Common Lisp's `require' +function: + + (require "asdf") + + As of the writing of this manual, the following implementations +provide ASDF 2 this way: abcl allegro ccl clisp cmucl ecl lispworks +mkcl sbcl xcl. The following implementation doesn't provide it yet but +will in an upcoming release: scl. The following implementations are +obsolete, not actively maintained, and most probably will never bundle +it: cormanlisp gcl genera mcl. + + If the implementation you are using doesn't provide ASDF 2 or ASDF 3, +see *note Loading an otherwise installed ASDF: Loading ASDF. below. If +that implementation is still actively maintained, you may also send a +bug report to your Lisp vendor and complain about their failing to +provide ASDF. + + NB: all implementations except clisp also accept `(require "ASDF")', +`(require 'asdf)' and `(require :asdf)'. For portability's sake, you +probably want to use `(require "asdf")'. + +2.2 Checking whether ASDF is loaded +=================================== + +To check whether ASDF is properly loaded in your current Lisp image, +you can run this form: + + (asdf:asdf-version) + + 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 an old version of ASDF. + + 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: + + (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")))) + + If it returns `NIL' then ASDF is not installed. Otherwise it should +return a string. If it returns `"1.0"', then it can actually be any +version before 1.77 or so, or some buggy variant of 1.x. + + 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. + +2.3 Upgrading ASDF +================== + +If your implementation provides ASDF 3 or later, you only need to +`(require "asdf")': ASDF will automatically look whether an updated +version of itself is available amongst the regularly configured +systems, before it compiles anything else. See *note Configuring +ASDF:: below. + + If your implementation does provide ASDF 2 or later, but not ASDF 3 +or later, and you want to upgrade to a more recent version, you need to +install and configure your ASDF as above, and additionally, you need to +explicitly tell ASDF to load itself, right after you require your +implementation's old ASDF 2: + + (require "asdf") + (asdf:load-system :asdf) + + If on the other hand, your implementation only provides an old ASDF, +you will require a special configuration step and an old-style loading. +Take special attention to not omit the trailing directory separator `/' +at the end of your pathname: + + (require "asdf") + (push #p"/PATH/TO/NEW/ASDF/" asdf:*central-registry*) + (asdf:oos 'asdf:load-op :asdf) + + Note that ASDF 1 won't redirect its output files, or at least won't +do it according to your usual ASDF 2 configuration. You therefore need +write access on the directory where you install the new ASDF, and make +sure you're not using it for multiple mutually incompatible +implementations. At worst, you may have to have multiple copies of the +new ASDF, e.g. one per implementation installation, to avoid clashes. +Note that to our knowledge all implementations that provide ASDF +provide ASDF 2 in their latest release, so you may want to upgrade your +implementation rather than go through that hoop. + + Finally, if you are using an unmaintained implementation that does +not provide ASDF at all, see *note Loading an otherwise installed ASDF: +Loading ASDF. below. + + Note that there are some limitations to upgrading ASDF: + * Previously loaded ASDF extension becomes invalid, and will need to + be reloaded. This applies to e.g. CFFI-Grovel, or to hacks used + by ironclad, etc. Since it isn't possible to automatically detect + what extensions are present that need to be invalidated, ASDF will + actually invalidate all previously loaded systems when it is + loaded on top of a different ASDF version, starting with ASDF + 2.014.8 (as far as releases go, 2.015); and it will automatically + attempt this self-upgrade as its very first step starting with + ASDF 3. + + * For this an many other reasons, it important reason to load, + configure and upgrade ASDF (if needed) as one of the very first + things done by your build and startup scripts. Until all + implementations provide ASDF 3 or later, it is safer if you + upgrade ASDF and its extensions as a special step at the very + beginning of whatever script you are running, before you start + using ASDF to load anything else; even afterwards, it is still a + good idea, to avoid having to load and reload code twice as it + gets invalidated. + + * 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 _not_ specify + `:depends-on (:asdf)', or `:depends-on ((:version :asdf "2.010"))', + but instead that they check that a recent enough ASDF is installed, + with such code as: + (unless (or #+asdf2 (asdf:version-satisfies + (asdf:asdf-version) *required-asdf-version*)) + (error "FOO requires ASDF ~A or later." *required-asdf-version*)) + + * 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. + +2.4 Loading an otherwise installed ASDF +======================================= + +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 `asdf.lisp' somewhere and load it with: + + (load "/path/to/your/installed/asdf.lisp") + + The single file `asdf.lisp' is all you normally need to use ASDF. + + You can extract this file from latest release tarball on the ASDF +website (http://common-lisp.net/project/asdf/). If you are daring and +willing to report bugs, you can get the latest and greatest version of +ASDF from its git repository. *Note 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. + + +File: asdf.info, Node: Configuring ASDF, Next: Using ASDF, Prev: Loading ASDF, Up: Top + +3 Configuring ASDF +****************** + +3.1 Configuring ASDF to find your systems +========================================= + +So it may compile and load your systems, ASDF must be configured to find +the `.asd' files that contain system definitions. + + Since ASDF 2, the preferred way to configure where ASDF finds your +systems is the `source-registry' facility, fully described in its own +chapter of this manual. *Note Controlling where ASDF searches for +systems::. + + The default location for a user to install Common Lisp software is +under `~/.local/share/common-lisp/source/'. If you install software +there (it can be a symlink), you don't need further configuration. If +you're installing software yourself at a location that isn't standard, +you have to tell ASDF where you installed it. See below. If you're +using some tool to install software (e.g. Quicklisp), the authors of +that tool should already have configured ASDF. + + The simplest way to add a path to your search path, say +`/home/luser/.asd-link-farm/' is to create the directory +`~/.config/common-lisp/source-registry.conf.d/' and there create a file +with any name of your choice, and with the type `conf', for instance +`42-asd-link-farm.conf' containing the line: + + `(:directory "/home/luser/.asd-link-farm/")' + + If you want all the subdirectories under `/home/luser/lisp/' to be +recursively scanned for `.asd' files, instead use: + + `(:tree "/home/luser/lisp/")' + + Note that your Operating System distribution or your system +administrator may already have configured system-managed libraries for +you. + + The required `.conf' extension allows you to have disabled files or +editor backups (ending in `~'), and works portably (for instance, it is +a pain to allow both empty and non-empty extension on CLISP). Excluded +are files the name of which start with a `.' character. It is +customary to start the filename with two digits that specify the order +in which the directories will be scanned. + + ASDF will automatically read your configuration the first time you +try to find a system. You can reset the source-registry configuration +with: + + (asdf:clear-source-registry) + + And you probably should do so before you dump your Lisp image, if +the configuration may change between the machine where you save it at +the time you save it and the machine you resume it at the time you +resume it. Actually, you should use `(asdf:clear-configuration)' +before you dump your Lisp image, which includes the above. + +3.2 Configuring ASDF to find your systems -- old style +====================================================== + +The old way to configure ASDF to find your systems is by `push'ing +directory pathnames onto the variable `asdf:*central-registry*'. + + 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 `~/.sbclrc'.) + + The `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(1). + + For instance, if you wanted ASDF to find the `.asd' file +`/home/me/src/foo/foo.asd' your initialization script could after it +loads ASDF with `(require "asdf")' configure it with: + + (push "/home/me/src/foo/" asdf:*central-registry*) + + 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(2) at which point the presence of the trailing directory name +separator is necessary to tell Lisp that you're discussing a directory +rather than a file. + + Typically, however, there are a lot of `.asd' files, and a common +idiom was to have to put a bunch of _symbolic links_ to `.asd' files in +a common directory and push _that_ directory (the "link farm") to the +`asdf:*central-registry*' instead of pushing each of the many involved +directories to the `asdf:*central-registry*'. ASDF knows how to follow +such _symlinks_ to the actual file location when resolving the paths of +system components (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 `#p"/home/me/cl/systems/"' (note the trailing slash) +is a member of `*central-registry*', you could set up the system FOO +for loading with asdf with the following commands at the shell: + + $ cd /home/me/cl/systems/ + $ ln -s ~/src/foo/foo.asd . + + 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. + +3.3 Configuring where ASDF stores object files +============================================== + +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 may be shared between +several versions of several Common Lisp implementations, between +several users using different compilation options and without write +privileges on shared source directories, etc. This also allows to keep +source directories uncluttered by plenty of object files. + + Starting with ASDF 2, the `asdf-output-translations' facility was +added to ASDF itself, that controls where object files will be stored. +This facility is fully described in a chapter of this manual, *note +Controlling where ASDF saves compiled files::. + + The simplest way to add a translation to your search path, say from +`/foo/bar/baz/quux/' to `/where/i/want/my/fasls/' is to create the +directory `~/.config/common-lisp/asdf-output-translations.conf.d/' and +there create a file with any name of your choice and the type `conf', +for instance `42-bazquux.conf' containing the line: + + `("/foo/bar/baz/quux/" "/where/i/want/my/fasls/")' + + To disable output translations for source under a given directory, +say `/toto/tata/' you can create a file `40-disable-toto.conf' with the +line: + + `("/toto/tata/")' + + To wholly disable output translations for all directories, you can +create a file `00-disable.conf' with the line: + + `(t t)' + + Note that your Operating System distribution or your system +administrator may already have configured translations for you. In +absence of any configuration, the default is to redirect everything +under an implementation-dependent subdirectory of +`~/.cache/common-lisp/'. *Note Controlling where ASDF searches for +systems::, for full details. + + The required `.conf' extension allows you to have disabled files or +editor backups (ending in `~'), and works portably (for instance, it is +a pain to allow both empty and non-empty extension on CLISP). Excluded +are files the name of which start with a `.' character. It is +customary to start the filename with two digits that specify the order +in which the directories will be scanned. + + ASDF will automatically read your configuration the first time you +try to find a system. You can reset the source-registry configuration +with: + + (asdf:clear-output-translations) + + And you probably should do so before you dump your Lisp image, if +the configuration may change between the machine where you save it at +the time you save it and the machine you resume it at the time you +resume it. (Once again, you should use `(asdf:clear-configuration)' +before you dump your Lisp image, which includes the above.) + + Finally 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 +just delegate this functionality to ASDF. + + ---------- Footnotes ---------- + + (1) It is possible to further customize the system definition file +search. That's considered advanced use, and covered later: search +forward for `*system-definition-search-functions*'. *Note Defining +systems with defsystem::. + + (2) ASDF will indeed call `EVAL' on each entry. It will also skip +entries that evaluate to `NIL'. + + Strings and pathname objects are self-evaluating, in which case the +`EVAL' step does nothing; but you may push arbitrary SEXP onto the +central registry, that will be evaluated to compute e.g. things that +depend on the value of shell variables or the identity of the user. + + The variable `asdf:*central-registry*' is thus a list of "system +directory designators". A "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. By "directory" here, we mean +"designator for a pathname with a supplied DIRECTORY component". + + +File: asdf.info, Node: Using ASDF, Next: Defining systems with defsystem, Prev: Configuring ASDF, Up: Top + +3.4 Resetting Configuration +=========================== + +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: + + -- Function: clear-configuration + undoes any ASDF configuration, regarding source-registry or + output-translations. + + If you use SBCL, CMUCL or SCL, you may use this snippet so that the +ASDF configuration be cleared automatically as you dump an image: + + #+(or cmu sbcl scl) + (pushnew 'clear-configuration + #+(or cmu scl) ext:*before-save-initializations* + #+sbcl sb-ext:*save-hooks*) + + For compatibility with all Lisp implementations, however, you might +want instead your build script to explicitly call +`(asdf:clear-configuration)' at an appropriate moment before dumping. + +4 Using ASDF +************ + +4.1 Loading a system +==================== + +The system FOO is loaded (and compiled, if necessary) by evaluating the +following Lisp form: + + (asdf:load-system :FOO) + + On some implementations (namely recent versions of ABCL, Allegro CL, +Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL and XCL), ASDF +hooks into the `CL:REQUIRE' facility and you can just use: + + (require :FOO) + + In older versions of ASDF, you needed to use `(asdf:oos +'asdf:load-op :FOO)'. If your ASDF is too old to provide +`asdf:load-system' though we recommend that you upgrade to ASDF 3. +*Note Loading an otherwise installed ASDF: Loading ASDF. + + Note the name of a system is specified as a string or a symbol, +typically a keyword. If a symbol (including a keyword), its name is +taken and lowercased. The name must be a suitable value for the +`:name' initarg to `make-pathname' in whatever filesystem the system is +to be found. 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 `:case :common', +which is reported not to work on some implementations + +4.2 Other Operations +==================== + +ASDF provides three commands for the most common system operations: +`load-system', `compile-system' or `test-system'. It also provides +`require-system', a version of `load-system' that skips trying to +update systems that are already loaded. + + Because ASDF is an extensible system for defining _operations_ on +_components_, it also provides a generic function `operate' (which is +usually abbreviated by `oos'). You'll use `oos' whenever you want to +do something beyond compiling, loading and testing. + + Output from ASDF and ASDF extensions are supposed to be sent to the +CL stream `*standard-output*', and so rebinding that stream around +calls to `asdf:operate' should redirect all output from ASDF operations. + + Reminder: before ASDF can operate on a system, however, it must be +able to find and load that system's definition. *Note Configuring ASDF +to find your systems: Configuring ASDF. + + For the advanced users, note that `require-system' calls +`load-system' with keyword arguments `:force-not (loaded-systems)'. +`loaded-systems' returns a list of the names of loaded systems. +`load-system' applies `operate' with the operation from +`*load-system-operation*', which by default is `load-op', the system, +and any provided keyword arguments. + +4.3 Summary +=========== + +To use ASDF: + + * Load ASDF itself into your Lisp image, either through `(require + "asdf")' or else through `(load "/path/to/asdf.lisp")'. + + * Make sure ASDF can find system definitions thanks to proper + source-registry configuration. + + * Load a system with `(asdf:load-system :my-system)' or use some + other operation on some system of your choice. + + +4.4 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. + + +File: asdf.info, Node: Defining systems with defsystem, Next: The object model of ASDF, Prev: Using ASDF, Up: Top + +5 Defining systems with defsystem +********************************* + +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:: + + +File: asdf.info, Node: The defsystem form, Next: A more involved example, Prev: Defining systems with defsystem, Up: Defining systems with defsystem + +5.1 The defsystem form +====================== + +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 `defsystem' form. This section begins with +an example of a system definition, then gives the full grammar of +`defsystem'. + + Let's look at a simple system. This is a complete file that would +usually be saved as `hello-lisp.asd': + + (in-package :asdf) + + (defsystem "hello-lisp" + :description "hello-lisp: a sample Lisp system." + :version "0.2.1" + :author "Joe User " + :licence "Public Domain" + :components ((:file "packages") + (:file "macros" :depends-on ("packages")) + (:file "hello" :depends-on ("macros")))) + + Some notes about this example: + + * The file starts with an `in-package' form to use package `asdf'. + You could instead start your definition by using a qualified name + `asdf:defsystem'. + + * If in addition to simply using `defsystem', you are going to + define functions, create ASDF extension, globally bind symbols, + etc., it is recommended that to avoid namespace pollution between + systems, you should create your own package for that purpose, for + instance replacing the above `(in-package :asdf)' with: + + (defpackage :foo-system + (:use :cl :asdf)) + + (in-package :foo-system) + + * The `defsystem' form defines a system named `hello-lisp' that + contains three source files: `packages', `macros' and `hello'. + + * The file `macros' depends on `packages' (presumably because the + package it's in is defined in `packages'), and the file `hello' + depends on `macros' (and hence, transitively on `packages'). This + means that ASDF will compile and load `packages' and `macros' + before starting the compilation of file `hello'. + + * The files are located in the same directory as the file with the + system definition. ASDF resolves symbolic links (or Windows + shortcuts) before loading the system definition file and stores + its location in the resulting system(1). This is a good thing + because the user can move the system sources without having to + edit the system definition. + + * Make sure you know how the `:version' numbers will be parsed! They + are parsed as period-separated lists of integers. I.e., in the + example, `0.2.1' is to be interpreted, roughly speaking, as `(0 2 + 1)'. In particular, version `0.2.1' is interpreted the same as + `0.0002.1' and is strictly version-less-than version `0.20.1', + even though the two are the same when interpreted as decimal + fractions. Instead of a string representing the version, the + `: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 `(:read-file-form :at + )', 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 an + access-at specifier with the (optional) :at keyword, by default + the specifier is 0, meaning the first form is returned. + + + ---------- Footnotes ---------- + + (1) It is possible, though almost never necessary, to override this +behaviour. + + +File: asdf.info, Node: A more involved example, Next: The defsystem grammar, Prev: The defsystem form, Up: Defining systems with defsystem + +5.2 A more involved example +=========================== + +Let's illustrate some more involved uses of `defsystem' via a slightly +convoluted example: + + (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"))) + + The `:module' component named `"mod"' is a collection of three files, +which will be located in a subdirectory of the main code directory named +`mod' (this location can be overridden; see the discussion of the +`:pathname' option in *note The defsystem grammar::). + + The method-form tokens provide a shorthand for defining methods on +particular components. This part + + :perform (compile-op :after (op c) + (do-something c)) + :explain (compile-op :after (op c) + (explain-something c)) + + has the effect of + + (defmethod perform :after ((op compile-op) (c (eql ...))) + (do-something c)) + (defmethod explain :after ((op compile-op) (c (eql ...))) + (explain-something c)) + + where `...' is the component in question. In this case `...' would +expand to something like + + (find-component (find-system "foo") "mod") + + For more details on the syntax of such forms, see *note The +defsystem grammar::. For more details on what these methods do, *note +Operations:: in *note The object model of ASDF::. + + +File: asdf.info, Node: The defsystem grammar, Next: Other code in .asd files, Prev: A more involved example, Up: Defining systems with defsystem + +5.3 The defsystem grammar +========================= + + system-definition := ( defsystem system-designator SYSTEM-OPTION* ) + + system-option := :defsystem-depends-on system-list + | :weakly-depends-on SYSTEM-LIST + | :class class-name (see discussion below) + | module-option + | option + + module-option := :components component-list + | :serial [ t | nil ] + + 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 ( DEPENDENCY-DEF* ) + | :in-order-to ( DEPENDENCY+ ) + + + system-list := ( SIMPLE-COMPONENT-NAME* ) + + component-list := ( COMPONENT-DEF* ) + + component-def := ( component-type simple-component-name OPTION* ) + + component-type := :module | :file | :static-file | other-component-type + + other-component-type := symbol-by-name (*note Component types: The defsystem grammar.) + + dependency-def := simple-component-name + | ( :feature name ) + | ( :version simple-component-name version-specifier) + + dependency := (dependent-op REQUIREMENT+) + requirement := (required-op REQUIRED-COMPONENT+) + | (feature feature-name) + dependent-op := operation-name + required-op := operation-name | feature + + simple-component-name := string + | symbol + + pathname-specifier := pathname | string | symbol + + method-form := (operation-name qual lambda-list &rest body) + qual := method qualifier + + component-dep-fail-option := :fail | :try-next | :ignore + + feature-expression := keyword | (:and FEATURE-EXPRESSION*) + | (:or FEATURE-EXPRESSION*) | (:not FEATURE-EXPRESSION) + +5.3.1 Component names +--------------------- + +Component names (`simple-component-name') may be either strings or +symbols. + +5.3.2 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 `my-component-type', in the +current package `my-system-asd' can be specified as +`:my-component-type', or `my-component-type'. + + `system' and its subclasses are _not_ allowed as component types for +such children components. + +5.3.3 System class names +------------------------ + +A system class name will be looked up in the same way as a Component +type (see above), except that only `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 `DEFSYSTEM-DEPENDS-ON', see below. +For such class names in the ASDF package, we recommend that the +`:class' option be specified using a keyword symbol, such as + + :class :MY-NEW-SYSTEM-SUBCLASS + + This practice will ensure that package name conflicts are avoided. +Otherwise, the symbol `MY-NEW-SYSTEM-SUBCLASS' will be read into the +current package _before_ it has been exported from the ASDF extension +loaded by `:defsystem-depends-on', causing a name conflict in the +current package. + +5.3.4 Defsystem depends on +-------------------------- + +The `:defsystem-depends-on' option to `defsystem' allows the programmer +to specify another ASDF-defined system or set of systems that must be +loaded _before_ the system definition is processed. Typically this is +used to load an ASDF extension that is used in the system definition. + +5.3.5 Weakly depends on +----------------------- + +We do _NOT_ recommend you use this feature. If you are tempted to +write a system FOO that weakly-depends-on a system BAR, we recommend +that you should instead write system FOO in a parametric way, and offer +some special variable and/or some hook to specialize its behavior; then +you should write a system FOO+BAR that does the hooking of things +together. + + The (deprecated) `:weakly-depends-on' option to `defsystem' allows +the programmer to specify another ASDF-defined system or set of systems +that ASDF should _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 +`defsystem', this option is accepted at any component, but it probably +only makes sense at the `defsystem' level. Programmers are cautioned +not to use this component option except at the `defsystem' level, as +this anomalous behavior may be removed without warning. + + Finally, you might look into the `asdf-system-connections' extension, +that will let you define additional code to be loaded when two systems +are simultaneously loaded. It may or may not be considered good style, +but at least it can be used in a way that has deterministic behavior +independent of load order, unlike `weakly-depends-on'. + +5.3.6 Pathname specifiers +------------------------- + +A pathname specifier (`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 `/' characters will be +interpreted as directory separators. Usually, Unix-style relative +pathnames are used (i.e. not starting with `/', as opposed to absolute +pathnames); they are relative to the path of the parent component. +Finally, depending on the `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 `component-type', or else it +will be extracted from the string itself (if applicable). + + For instance, the `component-type' `:module' wants a directory +pathname, and so a string `"foo/bar"' will be interpreted as the +pathname `#p"foo/bar/"'. On the other hand, the `component-type' +`:file' wants a file of type `lisp', and so a string `"foo/bar"' will +be interpreted as the pathname `#p"foo/bar.lisp"', and a string +`"foo/bar.quux"' will be interpreted as the pathname +`#p"foo/bar.quux.lisp"'. Finally, the `component-type' `:static-file' +wants a file without specifying a type, and so a string `"foo/bar"' +will be interpreted as the pathname `#p"foo/bar"', and a string +`"foo/bar.quux"' will be interpreted as the pathname `#p"foo/bar.quux"'. + + ASDF does not interpret the string `".."' to designate the parent +directory. This string will be passed through to the underlying +operating system for interpretation. We _believe_ that this will work +on all platforms where ASDF is deployed, but do not guarantee this +behavior. A pathname object with a relative directory component of +`:up' or `:back' is the only guaranteed way to specify a parent +directory. + + 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 +`:case :common' as argument to `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 `#p' +or `#.(make-pathname ...)'. Note however, that `#p...' is a shorthand +for `#.(parse-namestring ...)' and that the behavior of +`parse-namestring' is completely non-portable, unless you are using +Common Lisp `logical-pathname's (*note Using logical pathnames: The +defsystem grammar, below). Pathnames made with `#.(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 didn't +properly support parsing component names as strings specifying paths +with directories, and the cumbersome `#.(make-pathname ...)' syntax had +to be used. An alternative to `#.' read-time evaluation is to use +`(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. + +5.3.7 Version specifiers +------------------------ + +Version specifiers are parsed as period-separated lists of integers. +I.e., in the example, `0.2.1' is to be interpreted, roughly speaking, +as `(0 2 1)'. In particular, version `0.2.1' is interpreted the same as +`0.0002.1' and is strictly version-less-than version `0.20.1', even +though the two are the same when interpreted as decimal fractions. + + System definers are encouraged to use version identifiers of the form +X.Y.Z for major version, minor version (compatible API) and patch level. + + *Note Common attributes of components::. + +5.3.8 Using 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 `:pathname' specifier to components that use it, using such syntax +as `#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 _not_ otherwise directly supported in the ASDF +syntax for pathname specifiers as strings. + + The `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. + +5.3.9 Serial dependencies +------------------------- + +If the `: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 `:depends-on'. + + :serial t + :components ((:file "a") (:file "b") (:file "c")) + + is equivalent to + + :components ((:file "a") + (:file "b" :depends-on ("a")) + (:file "c" :depends-on ("a" "b"))) + +5.3.10 Source location +---------------------- + +The `:pathname' option is optional in all cases for systems defined via +`defsystem', and in the usual case the user is recommended not to +supply it. + + Instead, ASDF follows a hairy set of rules that are designed so that + 1. `find-system' will load a system from disk and have its pathname + default to the right place. + + 2. This pathname information will not be overwritten with + `*default-pathname-defaults*' (which could be somewhere else + altogether) if the user loads up the `.asd' file into his editor + and interactively re-evaluates that form. + + If a system is being loaded for the first time, its top-level +pathname will be set to: + + * The host/device/directory parts of `*load-truename*', if it is + bound. + + * `*default-pathname-defaults*', otherwise. + + If a system is being redefined, the top-level pathname will be + + * changed, if explicitly supplied or obtained from `*load-truename*' + (so that an updated source location is reflected in the system + definition) + + * changed if it had previously been set from + `*default-pathname-defaults*' + + * left as before, if it had previously been set from + `*load-truename*' and `*load-truename*' is currently unbound (so + that a developer can evaluate a `defsystem' form from within an + editor without clobbering its source location) + +5.3.11 if-feature option +------------------------ + +This option allows you to specify a feature expression to be evaluated +as if by `#+' 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 `#+' 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. This option was added in ASDF 3. + +5.3.12 if-component-dep-fails 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 `if-feature' option +instead. + + +File: asdf.info, Node: Other code in .asd files, Prev: The defsystem grammar, Up: Defining systems with defsystem + +5.4 Other code in .asd files +============================ + +Files containing `defsystem' forms are regular Lisp files that are +executed by `load'. Consequently, you can put whatever Lisp code you +like into these files (e.g., code that examines the compile-time +environment and adds appropriate features to `*features*'). However, +some conventions should be followed, so that users can control certain +details of execution of the Lisp in `.asd' files: + + * 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 `*standard-output*', so that users can easily + control the disposition of output from ASDF operations. + + +File: asdf.info, Node: The object model of ASDF, Next: Controlling where ASDF searches for systems, Prev: Defining systems with defsystem, Up: Top + +6 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 extensible protocol. + + This allows the addition of behaviours: for example, `cffi' adds +support of special FFI description files to interface with C libraries +and of wrapper files to embed C code in Lisp; `abcl-jar' supports +creating Java JAR archives in ABCL; and `poiu' supports for compiling +code in parallel using background processes. + + This chapter deals with `component's and `operation's. + + A `component' represents an individual source file or a group of +source files, and the things that get transformed into. A `system' is +a component at the top level of the component hierarchy. A +`source-file' is a component representing a single source-file and the +successive output files into which it is transformed. A `module' is an +intermediate component itself grouping several other components, +themselves source-files or further modules. + + An `Operation' represents a transformation that can be performed on +a component, turning them from source files to intermediate results to +final outputs. + + A pair of an `operation' and a `component' is called an `action'. +An `action' represents a particular build step to be `perform'ed, after +all its dependencies have been fulfilled. In the ASDF model, actions +depend on other actions. The term _action_ itself was used by Kent +Pitman in his old article, but was only used by ASDF hackers starting +with the ASDF 2; but the concept is ubiquitous since the very beginning +of ASDF 1, though previously implicit. + + Then, there are many _functions_ available to users, extenders and +implementers of ASDF to use, define or implement the activities that +are part of building your software. Though they manipulate `action's, +most of these functions do not take as an argument a reified pair (a +CONS cell) of an operation and a component; instead, they usually take +two separate arguments, which allows to take advantage of the power +CLOS-style multiple dispatch for fun and profit. + + There are many _hooks_ in which to add functionality, by customizing +the behavior of existing _functions_. + + Last but not least is the notion of _dependency_ between two actions. +The structure of dependencies between actions is a directed _dependency +graph_. ASDF is invoked by being told to _operate_ with some +_operation_ on some toplevel _system_; it will then _traverse_ the +graph and build a _plan_ that follows its structure. 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 _requiring_ and _required_ as applied to an action depending on +the other: the requiring action `depends-on' the completion of all +required actions before it may itself be `perform'ed. + + Using the `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 `load-op', `compile-op' or +`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 `prepare-op' and `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 `test-op' or `load-fasl-op' +remain at the system level, and are not propagated along the hierarchy, +but instead do something global on the system. + +* Menu: + +* Operations:: +* Components:: +* Functions:: + + +File: asdf.info, Node: Operations, Next: Components, Prev: The object model of ASDF, Up: The object model of ASDF + +6.1 Operations +============== + +An "operation" object of the appropriate type is instantiated whenever +the user wants to do something with a system like + + * compile all its files + + * load the files into a running lisp environment + + * copy its source files somewhere else + + 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. + + 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 `operate'. + + -- Generic function: `operate' OPERATION SYSTEM &rest INITARGS &key + `force' `force-not' `verbose' &allow-other-keys + -- Generic function: `oos' OPERATION SYSTEM &rest INITARGS &key + &allow-other-keys + `operate' invokes OPERATION on SYSTEM. `oos' is a synonym for + `operate'. + + OPERATION is a symbol that is passed, along with the supplied + INITARGS, to `make-instance' to create the operation object. + SYSTEM is a system designator. + + The INITARGS are passed to the `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. + + If FORCE is `:all', then all systems are forced to be recompiled + even if not modified since last compilation. If FORCE is `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 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 FORCE-NOT is `:all', then all systems are forced + not to be recompiled even if modified since last compilation. If + FORCE-NOT is `t', then only the system being loaded is forced not + to be recompiled even if modified since last compilation, but + other systems are not affected. If 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. FORCE takes precedences + over FORCE-NOT; both of them apply to systems that are + dependencies and were already compiled. + + To see what `operate' would do, you can use: + (asdf::traverse (make-instance operation-class initargs ...) (find-system system-name)) + + +* Menu: + +* Predefined operations of ASDF:: +* Creating new operations:: + + +File: asdf.info, Node: Predefined operations of ASDF, Next: Creating new operations, Prev: Operations, Up: Operations + +6.1.1 Predefined operations of ASDF +----------------------------------- + +All the operations described in this section are in the `asdf' package. +They are invoked via the `operate' generic function. + + (asdf:operate 'asdf:OPERATION-NAME :SYSTEM-NAME {OPERATION-OPTIONS ...}) + + -- Operation: `compile-op' &key `proclamations' + This operation compiles the specified component. If proclamations + are supplied, they will be proclaimed. This is a good place to + specify optimization settings. + + When creating a new component type, you should provide methods for + `compile-op'. + + When `compile-op' is invoked, component dependencies often cause + some parts of the system to be loaded as well as compiled. + Invoking `compile-op' does not necessarily load all the parts of + the system, though; use `load-op' to load a system. + + -- Operation: `load-op' &key `proclamations' + This operation loads a system. + + The default methods for `load-op' compile files before loading + them. For parity, your own methods on new component types should + probably do so too. + + -- Operation: `parent-load-op' &key `proclamations' + This operation ensures that the dependencies of a module, and its + parent, and so on, are loaded (as per `load-op') before the + components within that module may be operated upon. + + By default, all operations depend on this `parent-operation' for + actions on components to depend on this "parent operation" being + acted on the parent. + + The default methods for `load-op' compile files before loading + them. For parity, your own methods on new component types should + probably do so too. + + -- Operation: `load-source-op' + 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. + + -- Operation: `test-op' + This operation will perform some tests on the module. The default + method will do nothing. The default dependency is to require + `load-op' to be performed on the module first. The default + `operation-done-p' is that the operation is _never_ done -- we + assume that if you invoke the `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. + + People typically define `test-op' methods like thus: + (defmethod perform ((o asdf:test-op) (s (eql (asdf:find-system :MYSYSTEM)))) + (asdf:load-system :MYSYSTEM) + (eval (read-from-string "(some expression that runs the tests)")) + t) + + -- Operation: `load-fasl-op' + This operation will load and create if need be a single fasl file + for all the files in each loaded system. (Its compilation-only + equivalent is `asdf::fasl-op'.) + + Once you have created such a fasl, you can use + `precompiled-system' to deliver it in a way that is compatible + with clients having asdf dependencies on your system whether it is + distributed as source of as a single binary. + + On your build platform, you run something like that: + `(asdf:operate 'load-fasl-op :MYSYSTEM)' + + And on your delivery platform, a form like this is evaluated in a + prologue or at some point before you save your image: + (defsystem :mysystem :class :precompiled-system + :fasl (some expression that will evaluate to a pathname)) + + Of course, _before_ you define such systems, you should not forget + to `(asdf:clear-configuration)'. + + `load-fasl-op' is available on all actively supported Lisp + implementations, and on those implementations only, and only since + ASDF 3. This functionality was previously available for select + implementations, as part of a separate system `asdf-bundle', + itself descended from `asdf-ecl'. + + +File: asdf.info, Node: Creating new operations, Prev: Predefined operations of ASDF, Up: Operations + +6.1.2 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 `operation'. + + ASDF's pre-defined operations are in no way "privileged", but it is +requested that developers never use the `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. + + An operation must provide methods for the following generic functions +when invoked with an object of type `source-file': _FIXME describe this +better_ + + * `input-files' ASDF has a pretty clever default `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 + `component-pathname' of the component. + + * `output-files' The `output-files' method determines where the + method will put its files. It returns two values, a list of + pathnames, and a boolean. If the boolean is `T' then the + pathnames are marked not be translated by enclosing `:around' + methods. If the boolean is `NIL' then enclosing `:around' methods + may translate these pathnames, e.g. to ensure object files are + somehow stored in some implementation-dependent cache. + + * `perform' The `perform' method must call `output-files' to find + out where to put its files, because the user is allowed to + override. + + * `output-files' for local policy `explain' + + * `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 `nil' (the default is `t'). + + For instance, the method for `test-op' always returns `nil', so + that tests are always run afresh. Of course, the `test-op' for + your system could depend on a deterministically repeatable + `test-report-op', and just read the results from the report files. + + * `component-depends-on' When you add new operations, you probably + need to explain how they relate to loading, compiling, testing, + etc., in terms of dependencies between actions. + + That's where you typically define methods on + `component-depends-on'. Your method will take as arguments some + properly specialized operation and a component denoting a current + action, and return a list of entries, denoting the children + actions that the current action depends on. The format of entries + is described below. + + It is _strongly_ advised that you should always append the results + of `(call-next-method)' to the results of your method, or + "interesting" failures will likely occur, unless you're a true + specialist of ASDF internals. + + Each entry returned by `component-depends-on' is itself a list. + + The first element of an entry is the name of an operation: a + symbol that you can use with `make-instance' (ASDF will instead + use with `asdf::make-sub-operation'), to create a related + operation for use in a build plan. For instance, `load-op' and + `compile-op' are common such names, denoting the respective + operations. + + The rest of an entry is a list of identifiers each denote a + component such that the pair of the previous operation and this + component is a children action of current action. + + Identifiers follow the `defsystem' grammar previously documented. + The main format for identifiers is a string or symbol (that will + be downcase as per `coerce-name'), and looked up against the + sibling list of the parent module's children components, as per + `find-component'. As a special case, `nil' denotes the parent + itself. Other syntaxes are allowed, for instance to specify a + component with a version. + + + Operations that print output should send that output to the standard +CL stream `*standard-output*', as the Lisp compiler and loader do. + + +File: asdf.info, Node: Components, Next: Functions, Prev: Operations, Up: The object model of ASDF + +6.2 Components +============== + +A "component" represents a source file or (recursively) a collection of +components. A "system" is (roughly speaking) a top-level component +that can be found via `find-system'. + + A "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). + + -- Function: find-system system-designator &optional (error-p t) + Given a system designator, `find-system' finds and returns a + system. If no system is found, an error of type + `missing-component' is thrown, or `nil' is returned if `error-p' + is false. + + To find and update systems, `find-system' funcalls each element in + the `*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: + + * there is no system of that name in memory + + * the pathname is different from that which was previously + loaded + + * the file's `last-modified' time exceeds the `last-modified' + time of the system in memory + + When system definitions are loaded from `.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 `defpackage' + and `in-package' forms in his system definition files, however, so + that they can be loaded manually if need be. + + The default value of `*system-definition-search-functions*' is a + list of two functions. The first function looks in each of the + directories given by evaluating members of `*central-registry*' + for a file whose name is the name of the system and whose type is + `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 `source-registry'. Hence, it is strongly advised to define a + system FOO in the corresponding file FOO.ASD. + +* Menu: + +* Common attributes of components:: +* Pre-defined subclasses of component:: +* Creating new component types:: + + +File: asdf.info, Node: Common attributes of components, Next: Pre-defined subclasses of component, Prev: Components, Up: Components + +6.2.1 Common attributes of components +------------------------------------- + +All components, regardless of type, have the following attributes. All +attributes except `name' are optional. + +6.2.1.1 Name +............ + +A component name is a string or a symbol. If a symbol, its name is +taken and lowercased. + + Unless overridden by a `:pathname' attribute, the name will be +interpreted as a pathname specifier according to a Unix-style syntax. +*Note Pathname specifiers: The defsystem grammar. + +6.2.1.2 Version identifier +.......................... + +This optional attribute is used by the generic function +`version-satisfies', which tests to see if `:version' dependencies are +satisfied. the version should be a string of integers separated by +dots, for example `1.0.11'. For more information on the semantics of +version specifiers, see *note The defsystem grammar::. + +6.2.1.3 Required features +......................... + +_FIXME: This subsection seems to contradict the `defsystem' grammar +subsection, which doesn't provide any obvious way to specify required +features. Furthermore, in 2009, discussions on the asdf-devel mailing +list (http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel) +suggested that the specification of required features may be broken, +and that no one may have been using them for a while. Please contact +the asdf-devel mailing list +(http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel) if you are +interested in getting this features feature fixed._ + + 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. + + 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 +`*features*'. + +6.2.1.4 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 + + :in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) + (load-op (load-op "foo"))) + + This means the following things: + * before performing compile-op on this component, we must perform + load-op on A and B, and compile-op on C, + + * before performing `load-op', we have to load FOO + + The syntax is approximately + +(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) + + Side note: + + This is on a par with what ACL defsystem does. mk-defsystem is less +general: it has an implied dependency + + for all source file x, (load x) depends on (compile x) + + and using a `:depends-on' argument to say that B depends on A +_actually_ means that + + (compile b) depends on (load a) + + 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 `(component-depends-on operation +component)', which returns a list + + ((load-op "a") (load-op "b") (compile-op "c") ...) + + `component-depends-on' can be subclassed for more specific +component/operation types: these need to `(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 `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. + + See the discussion of the semantics of `:version' in the defsystem +grammar. + +6.2.1.5 pathname +................ + +This attribute is optional and if absent (which is the usual case), the +component name will be used. + + *Note Pathname specifiers: The defsystem grammar, for an explanation +of how this attribute is interpreted. + + Note that the `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. *Note Defining +systems with defsystem::. + +6.2.1.6 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. + + `(component-property component property-name)' and associated `setf' +method will allow the programmatic update of this information. +Property names are compared as if by `EQL', so use symbols or keywords +or something. + +* Menu: + +* Pre-defined subclasses of component:: +* Creating new component types:: + + +File: asdf.info, Node: Pre-defined subclasses of component, Next: Creating new component types, Prev: Common attributes of components, Up: Components + +6.2.2 Pre-defined subclasses of component +----------------------------------------- + + -- 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 `.h' file from + `.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. _FIXME: + describe these._ + + -- Component: module + A module is a collection of sub-components. + + A module component has the following extra initargs: + + * `:components' the components contained in this module + + * `:default-component-class' All children components which + don't specify their class explicitly are inferred to be of + this type. + + * `:if-component-dep-fails' This attribute was removed in ASDF + 3. Do not use it. Use `:if-feature' instead. + + * `: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 `:components', i.e. all of + them are loaded before a compile or load operation is + performed on it. + + + The default operation knows how to traverse a module, so most + operations will not need to provide methods specialised on modules. + + `module' may be subclassed to represent components such as + foreign-language linked libraries or archive files. + + -- Component: system + `system' is a subclass of `module'. + + A system is a module with a few extra attributes for documentation + purposes; these are given elsewhere. *Note The defsystem + grammar::. + + Users can create new classes for their systems: the default + `defsystem' macro takes a `:class' keyword argument. + + +File: asdf.info, Node: Creating new component types, Prev: Pre-defined subclasses of component, Up: Components + +6.2.3 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. + + _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 +`cl-source-file': + + (defclass unportable-cl-source-file (cl-source-file) + ()) + + Function `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 `unportable-cl-source-file'. + + (defmethod component-pathname ((component unportable-cl-source-file)) + (merge-pathnames* + (coerce-pathname (format nil "~(~A~)/" (asdf:implementation-type))) + (call-next-method))) + + The new component type is used in a `defsystem' form in this way: + + (defsystem :foo + :components + ((:file "packages") + ... + (:unportable-cl-source-file "threads" + :depends-on ("packages" ...)) + ... + ) + + +File: asdf.info, Node: Functions, Prev: Components, Up: The object model of ASDF + +6.3 Functions +============= + + -- version-satisfies: VERSION VERSION-SPEC + Does VERSION satisfy the VERSION-SPEC. A generic function. ASDF + provides built-in methods for VERSION being a `component' or + `string'. VERSION-SPEC should be a string. + + In the wild, we typically see version numbering only on components + of type `system'. + + For more information about how `version-satisfies' interprets + version strings and specifications, *note The defsystem grammar:: + and *note Common attributes of components::. + + +File: asdf.info, Node: Controlling where ASDF searches for systems, Next: Controlling where ASDF saves compiled files, Prev: The object model of ASDF, Up: Top + +7 Controlling where ASDF searches for systems +********************************************* + +7.1 Configurations +================== + +Configurations specify paths where to find system files. + + 1. 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. + + 2. An application may explicitly initialize the source-registry + configuration using the configuration API (*note Configuration + API: Controlling where ASDF searches for systems, 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. + + 3. The source registry will be configured from the environment + variable `CL_SOURCE_REGISTRY' if it exists. + + 4. The source registry will be configured from user configuration file + `$XDG_CONFIG_DIRS/common-lisp/source-registry.conf' (which + defaults to `~/.config/common-lisp/source-registry.conf') if it + exists. + + 5. The source registry will be configured from user configuration + directory `$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/' + (which defaults to `~/.config/common-lisp/source-registry.conf.d/') + if it exists. + + 6. The source registry will be configured from system configuration + file `/etc/common-lisp/source-registry.conf' if it exists/ + + 7. The source registry will be configured from system configuration + directory `/etc/common-lisp/source-registry.conf.d/' if it exists. + + 8. 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 `:directory' entries for + `$XDG_DATA_DIRS/common-lisp/systems/' and `:tree' entries for + `$XDG_DATA_DIRS/common-lisp/source/'. For instance, SBCL will + include directories for its contribs when it can find them; it + will look for them where SBCL was installed, or at the location + specified by the `SBCL_HOME' environment variable. + + + 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. + +7.2 Truenames and other dangers +=============================== + +One great innovation of the original ASDF was its ability to leverage +`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 `TRUENAME' +mechanism, by setting the variable ASDF:*RESOLVE-SYMLINKS* to `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. + +7.3 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. + +`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 `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. + +7.4 Backward Compatibility +========================== + +For backward compatibility as well as to provide a practical backdoor +for hackers, ASDF will first search for `.asd' files in the directories +specified in `asdf:*central-registry*' before it searches in the source +registry above. + + *Note Configuring ASDF to find your systems -- old style: +Configuring ASDF. + + By default, `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. + +7.5 Configuration DSL +===================== + +Here is the grammar of the s-expression (SEXP) DSL for source-registry +configuration: + + ;; A configuration is a single SEXP starting with 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 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 sport said features: + :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out + + ;; add a single directory to be scanned (no recursion) + (:directory DIRECTORY-PATHNAME-DESIGNATOR) | + + ;; 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 name + + 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. `"_darcs"' will match `#p"/foo/bar/_darcs/src/bar.asd"' + + Pathnames are designated using another DSL, shared with the +output-translations configuration DSL below. The DSL is resolved by +the function `asdf::resolve-location', to be documented and exported at +some point in the future. + + 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 + ;; Not valid anymore: :SYSTEM-CACHE (was a security hazard) + + RELATIVE-COMPONENT-DESIGNATOR := + (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | + STRING | ;; relative directory pathname as interpreted by coerce-pathname. + ;; 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) + ;; Not supported (anymore): :UID and :USERNAME + + For instance, as a simple case, my +`~/.config/common-lisp/source-registry.conf', which is the default +place ASDF looks for this configuration, once contained: + (:source-registry + (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" + :inherit-configuration) + +7.6 Configuration Directories +============================= + +Configuration directories consist in files each containing a list of +directives without any enclosing `(:source-registry ...)' form. The +files will be sorted by namestring as if by `string<' and the lists of +directives of these files with be concatenated in order. An implicit +`:inherit-configuration' will be included at the _end_ of the list. + + This allows for packaging software that has file granularity (e.g. +Debian's `dpkg' or some future version of `clbuild') to easily include +configuration information about distributed software. + + 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 is +conventionally `"conf"' and as a limitation to some implementations +(e.g. GNU clisp), the type cannot be `NIL'. + + Directories may be included by specifying a directory pathname or +namestring in an `:include' directive, e.g.: + + (:include "/foo/bar/") + + Hence, to achieve the same effect as my example +`~/.config/common-lisp/source-registry.conf' above, I could simply +create a file +`~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf' +alone in its directory with the following contents: + (:tree "/home/fare/cl/") + +7.6.1 The :here directive +------------------------- + +The `:here' directive is an absolute pathname designator that refers to +the directory containing the configuration file currently being +processed. + + The `: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 `dir/'. Ordinarily, one might +simply have the user add a directive that would look something like +this: + (:tree "path/to/dir") + 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 `dir/src/lisp/' and `dir/extlib/lisp/', and these are +the only directories that should be searched. + + In this case, X can put into `dir/' a file `asdf.conf' that contains +the following: + (:source-registry + (:tree (:here "src/lisp/")) + (:tree (:here "extlib/lisp")) + (:directory (:here "outlier/"))) + + Then when someone else (call her Y) checks out a copy of this +repository, she need only add + (:include "/path/to/my/checkout/directory/asdf.conf") + to one of her previously-existing asdf source location configuration +files, or invoke `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. + +7.7 Shell-friendly syntax for configuration +=========================================== + +When considering environment variable `CL_SOURCE_REGISTRY' ASDF will +skip to next configuration if it's an empty string. It will `READ' the +string as a SEXP in the DSL if it begins with a paren `(' and it will +be interpreted much like `TEXINPUTS' list of paths, where + + * paths are separated by a `:' (colon) on Unix platforms +(including cygwin), by a `;' (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 `//' 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. + +7.8 Search Algorithm +==================== + +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 +`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 (*note +Configurations: Controlling where ASDF searches for systems. above). + +7.9 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. + +7.10 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. + + -- Function: initialize-source-registry &optional 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 PARAMETER, which can be + `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). + + -- Function: 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, `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. + + -- Function: ensure-source-registry &optional PARAMETER + checks whether a source registry has been initialized. If not, + initialize it with the given PARAMETER. + + Every time you use ASDF's `find-system', or anything that uses it +(such as `operate', `load-system', etc.), `ensure-source-registry' is +called with parameter NIL, which the first time around causes your +configuration to be read. If you change a configuration file, you need +to explicitly `initialize-source-registry' again, or maybe simply to +`clear-source-registry' (or `clear-configuration') which will cause the +initialization to happen next time around. + +7.11 Status +=========== + +This mechanism is vastly successful, and we have declared that +`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 `wrapping-source-registry' that +everyone uses implicitly. + +7.12 Rejected ideas +=================== + +Alternatives I considered and rejected included: + + 1. Keep `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. + + 2. Keep `asdf:*central-registry*' remains 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. + + 3. Completely remove `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. + + 4. Replace `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. + + I've been suggested the below features, but have rejected them, for +the sake of keeping ASDF no more complex than strictly necessary. + + * More syntactic sugar: synonyms for the configuration directives, + such as `(:add-directory X)' for `(:directory X)', or + `(:add-directory-hierarchy X)' or `(:add-directory X :recurse + t)' for `(:tree X)'. + + * The possibility to register individual files instead of + directories. + + * 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 `USER-HOMEDIR-PATHNAME' and `$SBCL_HOME' + Hopefully, these are already superseded by the `:default-registry' + + * Using the shell-unfriendly syntax `/**' instead of `//' to + specify recursion down a filesystem tree in the environment + variable. It isn't that Lisp friendly either. + +7.13 TODO +========= + + * Add examples + +7.14 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 to mine, not theirs. +But so are good design ideas and elegant implementation tricks. + + -- Francois-Rene Rideau , Mon, 22 Feb 2010 00:07:33 +-0500 + + +File: asdf.info, Node: Controlling where ASDF saves compiled files, Next: Error handling, Prev: Controlling where ASDF searches for systems, Up: Top + +8 Controlling where ASDF saves compiled files +********************************************* + +Each Common Lisp implementation has its own format for compiled files +(fasls for short, 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 `fasl's, +`dfsl's, `cfsl's and so on. Worse yet, some implementations use the +same file extension while changing formats from version to version (or +platform to platform) which means that you'll have to recompile binaries +as you switch from one implementation to the next. + + Since ASDF 2, ASDF includes the `asdf-output-translations' facility +to mitigate the problem. + +8.1 Configurations +================== + +Configurations specify mappings from input locations to output +locations. Once again we rely on the XDG base directory specification +for configuration. *Note XDG base directory: Controlling where ASDF +searches for systems. + + 1. 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. + + 2. An application may explicitly initialize the output-translations + configuration using the Configuration API in which case this takes + precedence. (*note Configuration API: Controlling where ASDF + saves compiled files.) It may itself compute this configuration + from the command-line, from a script, from its own configuration + file, etc. + + 3. The source registry will be configured from the environment + variable `ASDF_OUTPUT_TRANSLATIONS' if it exists. + + 4. The source registry will be configured from user configuration file + `$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf' + (which defaults to + `~/.config/common-lisp/asdf-output-translations.conf') if it + exists. + + 5. The source registry will be configured from user configuration + directory + `$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf.d/' + (which defaults to + `~/.config/common-lisp/asdf-output-translations.conf.d/') if it + exists. + + 6. The source registry will be configured from system configuration + file `/etc/common-lisp/asdf-output-translations.conf' if it exists. + + 7. The source registry will be configured from system configuration + directory `/etc/common-lisp/asdf-output-translations.conf.d/' if + it exists. + + + Each of these configurations is specified as a SEXP in a trival +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. + + 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. + +8.2 Backward Compatibility +========================== + +We purposefully do NOT provide backward compatibility with earlier +versions of `ASDF-Binary-Locations' (8 Sept 2009), +`common-lisp-controller' (7.0) or `cl-launch' (2.35), each of which had +similar general capabilities. The previous APIs of these programs were +not designed for configuration by the end-user in an easy way with +configuration files. Recent versions of same packages use the new +`asdf-output-translations' API as defined below: +`common-lisp-controller' (7.2) and `cl-launch' (3.000). +`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 `common-lisp-controller' +and/or `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 `ASDF-Binary-Locations', we +provide a limited emulation mode: + + -- Function: enable-asdf-binary-locations-compatibility &key + centralize-lisp-binaries default-toplevel-directory + include-per-user-information map-all-source-files + source-to-target-mappings + This function will initialize the new `asdf-output-translations' + facility in a way that emulates the behavior of the old + `ASDF-Binary-Locations' facility. Where you would previously set + global variables *CENTRALIZE-LISP-BINARIES*, + *DEFAULT-TOPLEVEL-DIRECTORY*, *INCLUDE-PER-USER-INFORMATION*, + *MAP-ALL-SOURCE-FILES* or *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 `:source-to-target-mappings' + keyword argument will accept any valid pathname designator for + `asdf-output-translations' instead of just strings and pathnames. + + If you insist, you can also keep using the old +`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 `asdf-output-translations' with +`(asdf:disable-output-translations)', or you might experience +"interesting" issues. + + Also, note that output translation is enabled by default. To +disable it, use `(asdf:disable-output-translations)'. + +8.3 Configuration DSL +===================== + +Here is the grammar of the SEXP DSL for `asdf-output-translations' +configuration: + +;; 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 sport said features: + :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out + + ;; include a configuration file or directory + (:include PATHNAME-DESIGNATOR) | + + ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.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 leaves pathname unmapped. + ABSOLUTE-COMPONENT-DESIGNATOR ;; same as in the source-registry language + +TRANSLATION-FUNCTION := + SYMBOL | ;; symbol of 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 consisting of + ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR + + Relative components better be either relative or subdirectories of +the path before them, or bust. + + The last component, if not a pathname, is notionally completed by +`/**/*.*'. You can specify more fine-grained patterns by using a +pathname object as the last component e.g. +`#p"some/path/**/foo*/bar-*.fasl"' + + You may use `#+features' to customize the configuration file. + + The second designator of a mapping may be `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 `t', the mapping always matches. When +the first designator starts with `:root', the mapping matches any host +and device. In either of these cases, if the second designator isn't +`t' and doesn't start with `: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 `t', the mapping is the identity. +When the second designator starts with `: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 +`enable-asdf-binary-locations-compatibility' with +`:centralize-lisp-binaries nil' which will do the same thing internally +for you: + #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors))) + (wild-file (make-pathname :name :wild :version :wild :type :wild))) + `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root + (:root ,wild-subdir :implementation ,wild-file))) + Starting with ASDF 2.011.4, you can use the simpler: ``(:root (:root +:**/ :implementation :*.*.*))' + + `:include' statements cause the search to recurse with the path +specifications from the file specified. + + If the `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 `directory-designator' the first element +of which is the keyword `: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. The result of the function invocation +should be the translated pathname. + + An `:inherit-configuration' statement cause the search to recurse +with the path specifications from the next configuration. *Note +Configurations: Controlling where ASDF saves compiled files, above. + + * `:enable-user-cache' is the same as `(t :user-cache)'. + + * `:disable-cache' is the same as `(t t)'. + + * `:user-cache' uses the contents of variable `asdf::*user-cache*' + which by default is the same as using `(:home ".cache" + "common-lisp" :implementation)'. + + * `:system-cache' uses the contents of variable + `asdf::*system-cache*' which by default is the same as using + `("/var/cache/common-lisp" :uid :implementation-type)' (on Unix + and cygwin), or something semi-sensible on Windows. + +8.4 Configuration Directories +============================= + +Configuration directories consist in files each contains a list of +directives without any enclosing `(:output-translations ...)' form. +The files will be sorted by namestring as if by `string<' and the lists +of directives of these files with be concatenated in order. An +implicit `:inherit-configuration' will be included at the _end_ of the +list. + + This allows for packaging software that has file granularity (e.g. +Debian's `dpkg' or some future version of `clbuild') to easily include +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 is +conventionally `"conf"' and as a limitation of some implementations, +the type cannot be `NIL'. + + Directories may be included by specifying a directory pathname or +namestring in an `:include' directive, e.g.: + (:include "/foo/bar/") + +8.5 Shell-friendly syntax for configuration +=========================================== + +When considering environment variable `ASDF_OUTPUT_TRANSLATIONS' ASDF +will skip to next configuration if it's an empty string. It will +`READ' the string as an SEXP in the DSL if it begins with a paren `(' +and it will be interpreted as a list of directories. Directories +should come by pairs, indicating a mapping directive. Entries are +separated by a `:' (colon) on Unix platforms (including cygwin), by a +`;' (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). + +8.6 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). + +8.7 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. + +8.8 Output location API +======================= + +The specified functions are exported from package ASDF. + + -- Function: initialize-output-translations &optional 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 PARAMETER, which can be + `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). + + -- Function: disable-output-translations + will initialize output translations in a way that maps every + pathname to itself, effectively disabling the output + translation facility. + + -- Function: 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, `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. + + -- Function: ensure-output-translations &optional PARAMETER + checks whether output translations have been initialized. If + not, initialize them with the given PARAMETER. This function + will be called before any attempt to operate on a system. + + -- Function: apply-output-translations PATHNAME + Applies the configured output location translations to PATHNAME + (calls `ensure-output-translations' for the translations). + + Every time you use ASDF's `output-files', or anything that uses it +(that may compile, such as `operate', `perform', etc.), +`ensure-output-translations' is called with parameter NIL, which the +first time around causes your configuration to be read. If you change +a configuration file, you need to explicitly +`initialize-output-translations' again, or maybe +`clear-output-translations' (or `clear-configuration'), which will +cause the initialization to happen next time around. + +8.9 Credits for output translations +=================================== + +Thanks a lot to Bjorn Lindberg and Gary King for +`ASDF-Binary-Locations', and to Peter van Eynde for `Common Lisp +Controller'. + + All bad design ideas and implementation bugs are to mine, not theirs. +But so are good design ideas and elegant implementation tricks. + + -- Francois-Rene Rideau + + +File: asdf.info, Node: Error handling, Next: Miscellaneous additional functionality, Prev: Controlling where ASDF saves compiled files, Up: Top + +9 Error handling +**************** + +9.1 ASDF errors +=============== + +If ASDF detects an incorrect system definition, it will signal a +generalised instance of `SYSTEM-DEFINITION-ERROR'. + + Operations may go wrong (for example when source files contain +errors). These are signalled using generalised instances of +`OPERATION-ERROR'. + +9.2 Compilation error and warning handling +========================================== + +ASDF checks for warnings and errors when a file is compiled. The +variables *COMPILE-FILE-WARNINGS-BEHAVIOUR* and +*COMPILE-FILE-ERRORS-BEHAVIOR* control the handling of any such events. +The valid values for these variables are `:error', `:warn', and +`:ignore'. + + +File: asdf.info, Node: Miscellaneous additional functionality, Next: Getting the latest version, Prev: Error handling, Up: Top + +10 Miscellaneous additional functionality +***************************************** + +ASDF includes several additional features that are generally useful for +system definition and development. + +10.1 Controlling file compilation +================================= + +When declaring a component (system, module, file), you can specify a +keyword argument `: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 `nil' if no value is specified +in any transitive parent. + + The argument must be a either `nil', a fbound symbol, a +lambda-expression (e.g. `(lambda (thunk) ...(funcall thunk ...) ...)') +a function object (e.g. using `#.#'' but that's discouraged because it +prevents the introspection done by e.g. asdf-dependency-grovel), or a +string that when `read' yields a symbol or a lambda-expression. `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 `compile-file*' with various arguments; the +around-compile hook may supply additional keyword arguments to pass to +that call to `compile-file*'. + + One notable argument that is heeded by `compile-file*' is +`:compile-check', a function called when the compilation was otherwise +a success, with the same arguments as `compile-file'; the function +shall return true if the compilation and its resulting compiled file +respected all system-specific invariants, and false (`nil') if it broke +any of those invariants; it may issue warnings or errors before it +returns `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 `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 *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 `package-renaming' system). + +10.2 Controlling source file character encoding +=============================================== + +Starting with ASDF 2.21, components accept a `: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, the default `:autodetect' is assumed. By default, only +`:default', `:utf-8' and `:autodetect' are accepted. `:autodetect', +the default, calls `*encoding-detection-hook*' which by default always +returns `*default-encoding*' which itself defaults to `:default'. + + In other words, there now are plenty of extension hooks, but by +default ASDF follows the backwards compatible behavior of using +whichever `:default' encoding your implementation uses, which itself +may or may not vary based on environment variables and other locale +settings. In practice this means that only source code that only uses +ASCII is guaranteed to be read the same on all implementations +independently from any user setting. + + Additionally, for backward-compatibility with older versions of ASDF +and/or with implementations that do not support unicode and its many +encodings, you may want to use the reader conditionals `#+asdf-unicode +#+asdf-unicode' to protect any `:encoding _encoding_' statement as +`:asdf-unicode' will be present in `*features*' only if you're using a +recent ASDF on an implementation that supports unicode. We recommend +that you avoid using unprotected `:encoding' specifications until after +ASDF 2.21 or later becomes widespread, hopefully by the end of 2012. + + While it offers plenty of hooks for extension, and one such +extension is being developed (see below), ASDF itself only recognizes +one encoding beside `:default', and that is `:utf-8', which is the _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 `:asdf-unicode' is absent, and the `:default' +external-format is used to read even source files declared as `: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 `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 `.asd' files. Indeed, on some implementations and configurations, +UTF-8 is already the `: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 _not_ use a BOM), although it might be read incorrectly on some +implementations. In the future, we intend to make `:utf-8' the default +value of `*default-encoding*', to be enforced everywhere, so at least +the code is guaranteed to be read correctly everywhere it can be. + + If you need non-standard character encodings for your source code, +use the extension system `asdf-encodings', by specifying +`:defsystem-depends-on (:asdf-encodings)' in your `defsystem'. This +extension system will register support for more encodings using the +`*encoding-external-format-hook*' facility, so you can explicitly +specify `:encoding :latin1' in your `.asd' file. Using the +`*encoding-detection-hook*' it will also eventually implement some +autodetection of a file's encoding from an emacs-style `-*- mode: lisp +; coding: latin1 -*-' declaration, or otherwise based on an analysis of +octet patterns in the file. At this point, asdf-encoding only supports +the encodings that are supported as part of your implementation. Since +the list varies depending on implementations, we once again recommend +you use `:utf-8' everywhere, which is the most portable (next is +`:latin1'). + + If you're not using a version of Quicklisp that has it, you may get +the source for `asdf-encodings' using git: `git clone +git://common-lisp.net/projects/asdf/asdf-encodings.git' or `git clone +ssh://common-lisp.net/project/asdf/git/asdf-encodings.git'. You can +also browse the repository on +`http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git'. + + In the future, we intend to change the default `*default-encoding*' +to `:utf-8', which is already the de facto standard for most libraries +that use non-ASCII characters: utf-8 works everywhere and was +backhandedly enforced by a lot of people using SBCL and utf-8 and +sending reports to authors so they make their packages compatible. A +survey showed only about a handful few libraries are incompatible with +non-UTF-8, and then, only in comments, and we believe that authors will +adopt UTF-8 when prompted. See the April 2012 discussion on the +asdf-devel mailing-list. For backwards compatibility with users who +insist on a non-UTF-8 encoding, but cannot immediately transition to +using `asdf-encodings' (maybe because it isn't ready), it will still be +possible to use the `:encoding :default' option in your `defsystem' form +to restore the behavior of ASDF 2.20 and earlier. This shouldn't be +required in libraries, because user pressure as mentioned above will +already have pushed library authors towards using UTF-8; but authors of +end-user programs might care. + + When you use `asdf-encodings', any further loaded `.asd' file will +use the autodetection algorithm to determine its encoding; yet if you +depend on this detection happening, you may want to explicitly load +`asdf-encodings' early in your build, for by the time you can use +`:defsystem-depends-on', it is already too late to load it. In +practice, this means that the `*default-encoding*' is usually used for +`.asd' files. Currently, this defaults to `:default' for backwards +compatibility, and that means that you shouldn't rely on non-ASCII +characters in a .asd file. Since component (path)names are the only +real data in these files, and non-ASCII characters are not very +portable for file names, this isn't too much of an issue. We still +encourage you to use either plain ASCII or UTF-8 in `.asd' files, as we +intend to make `:utf-8' the default encoding in the future. This might +matter, for instance, in meta-data about author's names. + +10.3 Miscellaneous Functions +============================ + +Most of these functions are not exported by ASDF anymore, but only used +for private purposes of ASDF. Please use ASDF-UTILS for the same +functions exported from a stable library. + + -- Function: coerce-pathname name &key type defaults + This function (available starting with ASDF 2.012.11) takes an + argument, and portably interprets it as a pathname. If the + argument NAME is a pathname or `nil', it is passed through; if + it's a symbol, it's interpreted as a string by downcasing it; if + it's a string, it is first separated using `/' into substrings; + the leading substrings denote subdirectories of a relative + pathname. If TYPE is `:directory' or the string ends with `/', + the last substring is also a subdirectory; if TYPE is a string, it + is used as the type of the pathname, and the last substring is the + name component of the pathname; if TYPE is `nil', the last + substring specifies both name and type components of the pathname, + with the last `.' separating them, or only the name component if + there's no last `.' or if there is only one dot and it's the first + character. The host, device and version components come from + DEFAULTS, which defaults to *DEFAULT-PATHNAME-DEFAULTS*; but that + shouldn't matter if you use `merge-pathnames*'. + + + -- Function: merge-pathnames* &key specified defaults + This function is a replacement for `merge-pathnames' that uses the + host and device from the DEFAULTS rather than the 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. + + + -- Function: system-relative-pathname system name &key type + It's often handy to locate a file relative to some system. The + `system-relative-pathname' function meets this need. + + It takes two mandatory arguments SYSTEM and NAME and a keyword + argument TYPE: SYSTEM is name of a system, whereas NAME and + optionally TYPE specify a relative pathname, interpreted like a + component pathname specifier by `coerce-pathname'. *Note Pathname + specifiers: The defsystem grammar. + + It returns a pathname built from the location of the system's + source directory and the relative pathname. For example: + + > (asdf:system-relative-pathname 'cl-ppcre "regex.data") + #P"/repository/other/cl-ppcre/regex.data" + + + -- Function: system-source-directory system-designator + 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 + `system-source-directory' to find such files. Returns a pathname + object. The SYSTEM-DESIGNATOR may be a string, symbol, or ASDF + system object. + + -- Function: clear-system system-designator + It is sometimes useful to force recompilation of a previously + loaded system. In these cases, it may be useful to + `(asdf:clear-system :foo)' to remove the system from the table of + currently loaded systems; the next time the system `foo' or one + that depends on it is re-loaded, `foo' will then be loaded again. + Alternatively, you could touch `foo.asd' or remove the + corresponding fasls from the output file cache. (It was once + conceived that one should provide a list of systems the + recompilation of which to force as the `:force' keyword argument + to `load-system'; but this has never worked, and though the + feature was fixed in ASDF 2.000, it remains `cerror''ed out as + nobody ever used it.) + + Note that this does not and cannot by itself 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 + datastructures makes such a thing impossible in the general case. + If the software being re-loaded is not conceived with hot upgrade + in mind, this 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 `update-instance-for-redefined-class' + and much more are necessary for reloading to happen smoothly. + ASDF itself goes through notable pains to make such a hot upgrade + possible with respect to its own code, and what it does is + ridiculously complex; look at the beginning of `asdf.lisp' to see + what it does. + + -- Function: run-program + run-program takes a COMMAND argument that is either a list of a + program 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. + + `output' is its most important argument; it specifies how the + output is captured and processed. If it is `nil', then the output + is not captured. If it is `:interactive', then input and output + are inherited from the current process, which the subprocess can + control until it exits. Otherwise, the output is captured and + redirected to a stream, and processed by `slurp-input-stream' with + the object as first argument. See below. + + `element-type' and `external-format' are passed on to your Lisp + implementation, when available, for creation of the output stream. + + `force-shell' forces evaluation of the command through a shell, + even if it was passed as a list rather than a string. + + `ignore-error-status' causes `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. + + run-program works on all platforms supported by ASDF, except + Genera. + + + -- Function: slurp-input-stream + It's 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 follow: + + If the object is a function, the function is called with the + stream as argument. + + If the object is a cons, its first element is applied to its rest + appended by a list of the input stream. + + If the object is an output stream, the contents of the input + stream are copied to it. If the linewise argument is provided, + copying happens line by line, and an optional prefix is printed + before each line. Otherwise, copying happen based on a buffer of + size buffer-size, using the element-type. + + If the object is 'string or :string, the content is captured into + a string of the given element-type. + + If the object is :lines, the content is captured as a list of + strings, one per line, without line ending. If the count argument + is provided, it is a maximum count of lines to be read. + + If the object is :line, the content is capture as with :lines + above, and then its sub-object is extracted with the path argument, + which defaults to 0, extracting the first line. A number will + extract the corresponding line. See the documentation for + asdf-driver:sub-object. + + If the object is :forms, the content is captured as a list of + S-expressions, as read by the Lisp reader. If the count argument + is provided, it is a maximum count of lines to be read. We + recommend you control the syntax with such macro as + asdf-driver:with-safe-io-syntax. + + If the object is :form, the content is capture as with :forms + above, and then its sub-object is extracted with the path argument, + which defaults to 0, extracting the first form. A number will + extract the corresponding form. See the documentation for + asdf-driver:sub-object. We recommend you control the syntax with + such macro as asdf-driver:with-safe-io-syntax. + + + -- Function: run-shell-command + This function is obsolete and present only for the sake of + backwards-compatibility: "If it's not backwards, it's not + compatible". We 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 `run-program' above available as part + of ASDF since ASDF 3. + + `run-shell-command' takes as arguments a `format' control-string + and arguments to be passed to `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). + + +File: asdf.info, Node: Getting the latest version, Next: FAQ, Prev: Miscellaneous additional functionality, Up: Top + +11 Getting the latest version +***************************** + +Decide which version you want. The `master' branch is where +development happens; its `HEAD' is usually OK, including the latest +fixes and portability tweaks, but an occasional regression may happen +despite our (limited) test suite. + + The `release' branch is what cautious people should be using; it has +usually been tested more, and releases are cut at a point where there +isn't any known unresolved issue. + + You may get the ASDF source repository using git: `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 +`http://common-lisp.net/gitweb?p=projects/asdf/asdf.git'. + + Discussion of ASDF development is conducted on the mailing list +`asdf-devel@common-lisp.net'. +`http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel' + + +File: asdf.info, Node: FAQ, Next: TODO list, Prev: Getting the latest version, Up: Top + +12 FAQ +****** + +12.1 "Where do I report a bug?" +=============================== + +ASDF bugs are tracked on launchpad: `https://launchpad.net/asdf'. + + If you're unsure about whether something is a bug, or for general +discussion, use the asdf-devel mailing list +(http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel) + +12.2 "What has changed between ASDF 1 and ASDF 2?" +================================================== + +12.2.1 What are ASDF 1 and ASDF 2? +---------------------------------- + +On May 31st 2010, we have released ASDF 2. ASDF 2 refers to release +2.000 and later. (Releases between 1.656 and 1.728 were development +releases for ASDF 2.) ASDF 1 to any release earlier than 1.369 or so. +If your ASDF doesn't sport a version, it's an old ASDF 1. + + ASDF 2 and its release candidates push `:asdf2' onto `*features*' so +that if you are writing ASDF-dependent code you may check for this +feature to see if the new API is present. _All_ versions of ASDF +should have the `:asdf' feature. + + Additionally, all versions of ASDF 2 define a function +`(asdf:asdf-version)' you may use to query the version; and the source +code of recent versions of ASDF 2 features the version number +prominently on the second line of its source code. + + If you are experiencing problems or limitations of any sort with +ASDF 1, we recommend that you should upgrade to ASDF 2, or whatever is +the latest release. + +12.2.2 ASDF can portably name files in subdirectories +----------------------------------------------------- + +Common Lisp namestrings are not portable, except maybe for logical +pathnamestrings, 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 `#.(make-pathname ...)' +and `#.(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. *Note asdf:system-relative-pathname: Miscellaneous +additional functionality, `merge-pathnames*', `coerce-pathname'. + + On the other hand, there are places where systems used to accept +namestrings where you must now use an explicit pathname object: +`(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)' must now +be written with the `#p' syntax: `(defsystem ... :pathname +#p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)' + + *Note Pathname specifiers: The defsystem grammar. + +12.2.3 Output translations +-------------------------- + +A popular feature added to ASDF was output pathname translation: +`asdf-binary-locations', `common-lisp-controller', `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, +`asdf-output-translations', with sensible defaults, adequate +configuration languages, a coherent set of configuration files and +hooks, and support for non-Unix platforms. + + *Note Controlling where ASDF saves compiled files::. + +12.2.4 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 `*central-registry*' and +`*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. + + *Note Controlling where ASDF searches for systems::. + +12.2.5 Usual operations are made easier to the user +--------------------------------------------------- + +In ASDF 1, you had to use the awkward syntax `(asdf:oos 'asdf:load-op +:foo)' to load a system, and similarly for `compile-op', `test-op'. + + In ASDF 2, you can use shortcuts for the usual operations: +`(asdf:load-system :foo)', and similarly for `compile-system', +`test-system'. + +12.2.6 Many bugs have been fixed +-------------------------------- + +The following issues and many others have been fixed: + + * 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 :version and + the :force (system1 .. systemN) feature have been fixed. + + * 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 + quadratic-time recursive appends. + + * Many features used to not be portable, especially where pathnames + were involved. Windows support was notably quirky because of such + non-portability. + + * 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, except for GCL + (due to GCL bugs). + + * Support was lacking for some implementations. ABCL and GCL were + notably wholly broken. ECL extensions were not integrated with + ASDF release. + + * The documentation was grossly out of date. + + +12.2.7 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 `#+asdf2' to detect presence of +ASDF 2, `(asdf:version-satisfies (asdf:asdf-version) "2.345.67")' to +check the availability of a version no earlier than required. + +12.2.8 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. + +12.2.9 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. + +12.2.10 Pitfalls of the transition to ASDF 2 +-------------------------------------------- + +The main pitfalls in upgrading to ASDF 2 seem to be related to the +output translation mechanism. + + * 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. + *Note "How can I wholly disable the compiler output cache?": FAQ. + + * 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. + + * 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 `enable-asdf-binary-locations-compatibility' in *note Backward + Compatibility: Controlling where ASDF saves compiled files. But + thou shalt not load ABL on top of ASDF 2. + + + Other issues include the following: + + * 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 `:pathname' argument + to a `defsystem' and its components, a logical pathname (or + implementation-dependent hierarchical pathname) must now be + specified with `#p' syntax where the namestring might have + previously sufficed; moreover when evaluation is desired `#.' must + be used, where it wasn't necessary in the toplevel `:pathname' + argument (but necessary in other `:pathname' arguments). + + * There is a slight performance bug, notably on SBCL, when initially + searching for `asd' files, the implicit `(directory + "/configured/path/**/*.asd")' for every configured path `(:tree + "/configured/path/")' in your `source-registry' configuration can + cause a slight pause. Try to `(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 `:tree' entry but only + `:directory' entries or shallow `:tree' entries. Or you can fix + your implementation to not be quite that slow when recursing + through directories. _Update_: This performance bug fixed the + hard way in 2.010. + + * 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. _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. + + * The mechanism by which one customizes a system so that Lisp files + may use a different extension from the default `.lisp' has changed. + Previously, the pathname for a component was lazily computed when + operating on a system, and you would `(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 `(defclass cl-source-file.lis (cl-source-file) + ((type :initform "lis")))' and use `:default-component-class + cl-source-file.lis' as argument to `defsystem', as detailed in a + *note How do I create a system definition where all the source + files have a .cl extension?: FAQ. below. + + +12.3 Issues with installing the proper version of ASDF +====================================================== + +12.3.1 "My Common Lisp implementation comes with an outdated version of ASDF. What to do?" +------------------------------------------------------------------------------------------ + +We recommend you upgrade ASDF. *Note Upgrading ASDF: Loading ASDF. + + If this does not work, it is a bug, and you should report it. *Note +report-bugs: FAQ. In the meantime, you can load `asdf.lisp' directly. +*Note Loading an otherwise installed ASDF: Loading ASDF. + +12.3.2 "I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?" +------------------------------------------------------------------------------------- + +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 `release' should be +correct. We trust you to thoroughly test it with your implementation +before you release it. If there are any issues with the current +release, it's a bug that you should report upstream and that we will +fix ASAP. + + As to how to include ASDF, we recommend the following: + + * If ASDF isn't loaded yet, then `(require "asdf")' should load the + version of ASDF that is bundled with your system. If possible so + should `(require "ASDF")'. You may have it load some other + version configured by the user, if you allow such configuration. + + * If your system provides a mechanism to hook into `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. + + * You may, like SBCL, have ASDF be implicitly used to require systems + that are bundled with your Lisp distribution. If you do have a + few magic systems that come with your implementation in a + precompiled way such that one should only use the binary version + that goes with your distribution, like SBCL does, then you should + add them in the beginning of `wrapping-source-registry'. + + * If you have magic systems as above, like SBCL does, then we + explicitly ask you to _NOT_ distribute `asdf.asd' as part of those + magic systems. You should still include the file `asdf.lisp' in + your source distribution and precompile it in your binary + distribution, but `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 `.asd' file to e.g. `asdf-ecl' and `asdf-ecl.asd', or + `sb-asdf' and `sb-asdf.asd'. Indeed, if you made `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. + + * 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 `wrapping-source-registry', and you are + welcome to include `asdf.asd' amongst them. Non-magic systems + should be at the back of the `wrapping-source-registry' while + magic systems are at the front. + + * 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. + + +12.4 Issues with configuring ASDF +================================= + +12.4.1 "How can I customize where fasl files are stored?" +--------------------------------------------------------- + +*Note Controlling where ASDF saves compiled files::. + + Note that in the past there was an add-on to ASDF called +`ASDF-binary-locations', developed by Gary King. That add-on has been +merged into ASDF proper, then superseded by the +`asdf-output-translations' facility. + + Note that use of `asdf-output-translations' can interfere with one +aspect of your systems -- if your system uses `*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 `asdf:system-relative-pathname' to locate a file in the +source directory of some system, and use +`asdf:apply-output-translations' to locate a file whose pathname has +been translated by the facility. + +12.4.2 "How can I wholly disable the compiler output cache?" +------------------------------------------------------------ + +To permanently disable the compiler output cache for all future runs of +ASDF, you can: + + 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 + + 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 `asdf:initialize-output-translations'). + + To disable the compiler output cache in Lisp processes run by your +current shell, try (assuming `bash' or `zsh') (on Unix and cygwin only): + + export ASDF_OUTPUT_TRANSLATIONS=/: + + To disable the compiler output cache just in the current Lisp +process, use (after loading ASDF but before using it): + + (asdf:disable-output-translations) + +12.5 Issues with using and extending ASDF to define systems +=========================================================== + +12.5.1 "How can I cater for unit-testing in my system?" +------------------------------------------------------- + +ASDF provides a predefined test operation, `test-op'. *Note test-op: +Predefined operations of ASDF. The test operation, however, is largely +left to the system definer to specify. `test-op' has been a topic of +considerable discussion on the asdf-devel mailing list +(http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel), and on the +launchpad bug-tracker (https://launchpad.net/asdf). + + Here are some guidelines: + + * For a given system, FOO, you will want to define a corresponding + test system, such as FOO-TEST. The reason that you will want this + separate system is that ASDF does not out of the box supply + components that are conditionally loaded. So if you want to have + source files (with the test definitions) that will not be loaded + except when testing, they should be put elsewhere. + + * The FOO-TEST system can be defined in an asd file of its own or + together with FOO. An aesthetic preference against cluttering up + the filesystem with extra asd files should be balanced against the + question of whether one might want to directly load FOO-TEST. + Typically one would not want to do this except in early stages of + debugging. + + * Record that testing is implemented by FOO-TEST. For example: + (defsystem FOO + :in-order-to ((test-op (test-op FOO-TEST))) + ....) + + (defsystem FOO-TEST + :depends-on (FOO MY-TEST-LIBRARY ...) + ....) + + This procedure will allow you to support users who do not wish to +install your test framework. + + One oddity of ASDF is that `operate' (*note operate: Operations.) +does not return a value. So in current versions of ASDF there is no +reliable programmatic means of determining whether or not a set of tests +has passed, or which tests have failed. The user must simply read the +console output. This limitation has been the subject of much +discussion. + +12.5.2 "How can I cater for documentation generation in my system?" +------------------------------------------------------------------- + +The ASDF developers are currently working to add a `doc-op' to the set +of predefined ASDF operations. *Note Predefined operations of ASDF::. +See also `https://bugs.launchpad.net/asdf/+bug/479470'. + +12.5.3 "How can I maintain non-Lisp (e.g. C) source files?" +----------------------------------------------------------- + +See `cffi''s `cffi-grovel'. + +12.5.4 "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 `: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: + + (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"))) + + All of the files in the `tree-impls' module are at the top level, +instead of in a `tree-impls/' subdirectory. + + Note that the argument to `:pathname' can be either a pathname +object or a string. A pathname object can be constructed with the +`#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 `#.(make-pathname :directory +'(:relative "foo" "bar"))', and similarly the current directory can +only be portably specified as `#.(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 `/'-separated +path from the current directory, such that the empty string `""' +denotes the current directory, and `"foo/bar"' (no trailing `/' +required in the case of modules) portably denotes the same subdirectory +as above. When files are specified, the last `/'-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). + +12.5.5 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 +`cl-source-file.cl' as the `:default-component-class' argument to +`defsystem': + + (defsystem my-cl-system + :default-component-class cl-source-file.cl + ...) + + Another builtin class `cl-source-file.lsp' is offered for files +ending in `.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: + + ;; 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"))) + + Then you can use it as follows: + (defsystem my-cl-system + :default-component-class my-asdf-extension:cl-source-file.lis + ...) + + 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 `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: + + (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 + ...) + + 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 +_before_ you use the class in a `defsystem', you also define the +following method: + + (defmethod source-file-type ((f cl-source-file.lis) (s system)) + (declare (ignorable f s)) + "lis") + + +File: asdf.info, Node: TODO list, Next: Inspiration, Prev: FAQ, Up: Top + +13 TODO list +************ + +Here is an old list of things to do, in addition to the bugs that are +now tracked on launchpad: `https://launchpad.net/asdf'. + +13.1 Outstanding spec questions, things to add +============================================== + +** packaging systems + + *** manual page component? + + ** style guide for .asd files + + 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. + + 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. + + ** extending defsystem with new options + + You might not want to write a whole parser, but just to add options +to the existing syntax. Reinstate `parse-option' or something akin. + + ** Diagnostics + + A "dry run" of an operation can be made with the following form: + + (let ((asdf::*verbose-out* *standard-output*)) + (loop :for (op . comp) :in + (asdf::traverse (make-instance ' :force t) + (asdf:find-system )) + :do (asdf:explain op comp))) + + This uses unexported symbols. What would be a nice interface for +this functionality? + +13.2 Missing bits in implementation +=================================== + +** reuse the same scratch package whenever a system is reloaded from +disk + + Have a package ASDF-USER instead of all these temporary packages? + + ** proclamations probably aren't + + ** A revert function + + Other possible interface: have a "revert" function akin to `make +clean'. + + (asdf:revert 'asdf:compile-op 'araneida) + + would delete any files produced by `(compile-system :araneida)'. Of +course, it wouldn't be able to do much about stuff in the image itself. + + How would this work? + + `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, `(load "use") depends-on (load "macros")' is +a peer, whereas `(load "use") depends-on (compile "use")' is more of a +"subservient" relationship. + + +File: asdf.info, Node: Inspiration, Next: Concept Index, Prev: TODO list, Up: Top + +14 Inspiration +************** + +14.1 mk-defsystem (defsystem-3.x) +================================= + +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. + + The surface defsystem syntax of asdf is more-or-less compatible with +`mk-defsystem', except that we do not support the `source-foo' and +`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. + +14.2 defsystem-4 proposal +========================= + +Marco and Peter's proposal for defsystem 4 served as the driver for +many of the features in here. Notable differences are: + + * We don't specify output files or output file extensions as part of + the system. + + If you want to find out what files an operation would create, ask + the operation. + + * We don't deal with CL packages + + 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) + + * There is no proposal here that `defsystem' does version control. + + A system has a given version which can be used to check + dependencies, but that's all. + + The defsystem 4 proposal tends to look more at the external features, +whereas this one centres on a protocol for system introspection. + +14.3 kmp's "The Description of Large Systems", MIT AI Memo 801 +============================================================== + +Available in updated-for-CL form on the web at +`http://nhplace.com/kent/Papers/Large-Systems.html' + + 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 ] + + +File: asdf.info, Node: Concept Index, Next: Function and Class Index, Prev: Inspiration, Up: Top + +Concept Index +************* + +[index] +* Menu: + +* :asdf: Introduction. (line 6) +* :asdf2: Introduction. (line 6) +* :asdf3: Introduction. (line 6) +* :defsystem-depends-on: The defsystem grammar. + (line 102) +* :version <1>: Common attributes of components. + (line 22) +* :version <2>: The defsystem grammar. + (line 209) +* :version: The defsystem form. (line 76) +* :weakly-depends-on: The defsystem grammar. + (line 110) +* ASDF versions: Introduction. (line 6) +* ASDF-BINARY-LOCATIONS compatibility: Controlling where ASDF saves compiled files. + (line 81) +* asdf-output-translations: Controlling where ASDF saves compiled files. + (line 6) +* ASDF-related features: Introduction. (line 6) +* component: Components. (line 6) +* link farm: Loading ASDF. (line 6) +* logical pathnames: The defsystem grammar. + (line 223) +* operation: Operations. (line 6) +* pathname specifiers: The defsystem grammar. + (line 139) +* serial dependencies: The defsystem grammar. + (line 269) +* system: Components. (line 6) +* system designator: Components. (line 6) +* system directory designator: Loading ASDF. (line 6) +* Testing for ASDF: Introduction. (line 6) +* version specifiers: The defsystem grammar. + (line 209) + + +File: asdf.info, Node: Function and Class Index, Next: Variable Index, Prev: Concept Index, Up: Top + +Function and Class Index +************************ + +[index] +* Menu: + +* apply-output-translations: Controlling where ASDF saves compiled files. + (line 356) +* clear-configuration: Using ASDF. (line 11) +* clear-output-translations <1>: Controlling where ASDF saves compiled files. + (line 341) +* clear-output-translations: Configuring ASDF. (line 114) +* clear-source-registry: Controlling where ASDF searches for systems. + (line 372) +* clear-system: Miscellaneous additional functionality. + (line 237) +* coerce-pathname: Miscellaneous additional functionality. + (line 184) +* compile-op: Predefined operations of ASDF. + (line 12) +* compile-system: Loading ASDF. (line 6) +* disable-output-translations: Controlling where ASDF saves compiled files. + (line 336) +* enable-asdf-binary-locations-compatibility: Controlling where ASDF saves compiled files. + (line 107) +* ensure-output-translations: Controlling where ASDF saves compiled files. + (line 351) +* ensure-source-registry: Controlling where ASDF searches for systems. + (line 381) +* find-system: Components. (line 15) +* initialize-output-translations: Controlling where ASDF saves compiled files. + (line 327) +* initialize-source-registry: Controlling where ASDF searches for systems. + (line 363) +* load-fasl-op: Predefined operations of ASDF. + (line 74) +* load-op: Predefined operations of ASDF. + (line 25) +* load-source-op: Predefined operations of ASDF. + (line 45) +* load-system: Loading ASDF. (line 6) +* merge-pathnames*: Miscellaneous additional functionality. + (line 203) +* module: Pre-defined subclasses of component. + (line 23) +* oos <1>: Operations. (line 31) +* oos: Loading ASDF. (line 6) +* operate <1>: Operations. (line 29) +* operate: Loading ASDF. (line 6) +* OPERATION-ERROR: Error handling. (line 6) +* parent-load-op: Predefined operations of ASDF. + (line 32) +* require-system: Loading ASDF. (line 6) +* run-program: Miscellaneous additional functionality. + (line 269) +* run-shell-command: Miscellaneous additional functionality. + (line 344) +* slurp-input-stream: Miscellaneous additional functionality. + (line 300) +* source-file: Pre-defined subclasses of component. + (line 7) +* source-file-type: FAQ. (line 287) +* system: Pre-defined subclasses of component. + (line 50) +* SYSTEM-DEFINITION-ERROR: Error handling. (line 6) +* system-relative-pathname: Miscellaneous additional functionality. + (line 212) +* system-source-directory: Miscellaneous additional functionality. + (line 229) +* test-op: Predefined operations of ASDF. + (line 54) +* test-system: Loading ASDF. (line 6) +* VERSION: Functions. (line 7) +* version-satisfies <1>: Functions. (line 6) +* version-satisfies: Common attributes of components. + (line 22) + + +File: asdf.info, Node: Variable Index, Prev: Function and Class Index, Up: Top + +Variable Index +************** + +[index] +* Menu: + +* *central-registry*: Loading ASDF. (line 6) +* *compile-file-errors-behavior*: Error handling. (line 19) +* *compile-file-warnings-behaviour*: Error handling. (line 19) +* *default-source-registry-exclusions*: Controlling where ASDF searches for systems. + (line 319) +* *features*: Introduction. (line 6) +* *system-definition-search-functions*: Components. (line 6) +* ASDF_OUTPUT_TRANSLATIONS: Controlling where ASDF saves compiled files. + (line 6) + + + +Tag Table: +Node: Top1687 +Node: Introduction3739 +Node: Loading ASDF5819 +Node: Configuring ASDF13441 +Ref: Configuring ASDF-Footnote-121589 +Ref: Configuring ASDF-Footnote-221821 +Node: Using ASDF22534 +Node: Defining systems with defsystem26818 +Node: The defsystem form27204 +Ref: The defsystem form-Footnote-130782 +Node: A more involved example30865 +Node: The defsystem grammar32911 +Node: Other code in .asd files48068 +Node: The object model of ASDF48909 +Node: Operations53459 +Ref: operate54369 +Node: Predefined operations of ASDF56386 +Ref: test-op58611 +Node: Creating new operations60836 +Node: Components65086 +Node: Common attributes of components67568 +Node: Pre-defined subclasses of component73369 +Node: Creating new component types75730 +Node: Functions77100 +Node: Controlling where ASDF searches for systems77732 +Node: Controlling where ASDF saves compiled files99371 +Node: Error handling117256 +Node: Miscellaneous additional functionality118088 +Node: Getting the latest version137613 +Node: FAQ138639 +Ref: report-bugs160174 +Node: TODO list165062 +Node: Inspiration167463 +Node: Concept Index169763 +Node: Function and Class Index172291 +Node: Variable Index177777 + +End Tag Table --- cl-asdf-3.0.0.orig/doc/asdf.texinfo +++ cl-asdf-3.0.0/doc/asdf.texinfo @@ -6,27 +6,21 @@ @c We use @&key, etc to escape & from TeX in lambda lists -- @c so we need to define them for info as well. -@macro &allow-other-keys +@macro AallowOtherKeys &allow-other-keys @end macro -@macro &optional +@macro Aoptional &optional @end macro -@macro &rest +@macro Arest &rest @end macro -@macro &key +@macro Akey &key @end macro -@macro &body +@macro Abody &body @end macro -@macro &curly -{ -@end macro -@macro &ylruc -} -@end macro @c for install-info @dircategory Software development @@ -1012,7 +1006,7 @@ simple-component-name := string pathname-specifier := pathname | string | symbol -method-form := (operation-name qual lambda-list @&rest body) +method-form := (operation-name qual lambda-list @Arest body) qual := method qualifier component-dep-fail-option := :fail | :try-next | :ignore @@ -1484,8 +1478,8 @@ and easier than having them all be @code Operations are invoked on systems via @code{operate}. @anchor{operate} -@deffn {Generic function} @code{operate} @var{operation} @var{system} @&rest @var{initargs} @&key @code{force} @code{force-not} @code{verbose} @&allow-other-keys -@deffnx {Generic function} @code{oos} @var{operation} @var{system} @&rest @var{initargs} @&key @&allow-other-keys +@deffn {Generic function} @code{operate} @var{operation} @var{system} @Arest @var{initargs} @Akey @code{force} @code{force-not} @code{verbose} @AallowOtherKeys +@deffnx {Generic function} @code{oos} @var{operation} @var{system} @Arest @var{initargs} @Akey @AallowOtherKeys @code{operate} invokes @var{operation} on @var{system}. @code{oos} is a synonym for @code{operate}. @@ -1540,7 +1534,7 @@ They are invoked via the @code{operate} (asdf:operate 'asdf:@var{operation-name} :@var{system-name} @{@var{operation-options ...}@}) @end lisp -@deffn Operation @code{compile-op} @&key @code{proclamations} +@deffn Operation @code{compile-op} @Akey @code{proclamations} This operation compiles the specified component. If proclamations are supplied, they will be proclaimed. @@ -1557,7 +1551,7 @@ does not necessarily load all the parts use @code{load-op} to load a system. @end deffn -@deffn Operation @code{load-op} @&key @code{proclamations} +@deffn Operation @code{load-op} @Akey @code{proclamations} This operation loads a system. @@ -1565,7 +1559,7 @@ The default methods for @code{load-op} c For parity, your own methods on new component types should probably do so too. @end deffn -@deffn Operation @code{parent-load-op} @&key @code{proclamations} +@deffn Operation @code{parent-load-op} @Akey @code{proclamations} This operation ensures that the dependencies of a module, and its parent, and so on, are loaded (as per @code{load-op}) @@ -1652,7 +1646,7 @@ itself descended from @code{asdf-ecl}. @end deffn -@c @deffn Operation test-system-version @&key minimum +@c @deffn Operation test-system-version @Akey minimum @c Asks the system whether it satisfies a version requirement. @@ -2583,7 +2577,7 @@ The specified functions are exported fro Thus for ASDF the corresponding functions are in package ASDF, and for XCVB the corresponding functions are in package XCVB. -@defun initialize-source-registry @&optional PARAMETER +@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 @@ -2608,7 +2602,7 @@ and for XCVB the corresponding functions where to look for systems not yet defined. @end defun -@defun ensure-source-registry @&optional PARAMETER +@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 @@ -2828,7 +2822,7 @@ as configured by the system distributor, Nevertheless, if you are a fan of @code{ASDF-Binary-Locations}, we provide a limited emulation mode: -@defun enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings +@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 @@ -3071,7 +3065,7 @@ To explicitly flush any information cach The specified functions are exported from package ASDF. -@defun initialize-output-translations @&optional PARAMETER +@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 @@ -3102,7 +3096,7 @@ The specified functions are exported fro where to look for systems not yet defined. @end defun -@defun ensure-output-translations @&optional PARAMETER +@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. @@ -3401,7 +3395,7 @@ Most of these functions are not exported but only used for private purposes of ASDF. Please use ASDF-UTILS for the same functions exported from a stable library. -@defun coerce-pathname name @&key type defaults +@defun coerce-pathname name @Akey type defaults This function (available starting with ASDF 2.012.11) takes an argument, and portably interprets it as a pathname. @@ -3421,7 +3415,7 @@ The host, device and version components @end defun -@defun merge-pathnames* @&key specified defaults +@defun merge-pathnames* @Akey specified defaults This function is a replacement for @code{merge-pathnames} that uses the host and device from the @var{defaults} rather than the @var{specified} pathname when the latter @@ -3431,7 +3425,7 @@ of the absolute pathnames they are relat @end defun -@defun system-relative-pathname system name @&key type +@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.