X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=ce7a1db5a4b9e5be49312a4d39e2d15f06dd8ff2;hb=8aaa977f8614614517e62e212914fdbd19c1b7e9;hp=e2d7bb28c22bc806f14737e001fe4a68c95a71be;hpb=ae537cfb47286ccc945afd75c768e0411141f8f8;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index e2d7bb2..ce7a1db 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,19 +1,25 @@ -;;; This is asdf: Another System Definition Facility. 1.96 +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- +;;; This is ASDF 2.26: Another System Definition Facility. ;;; -;;; Feedback, bug reports, and patches are all welcome: please mail to -;;; . But note first that the canonical -;;; source for asdf is presently the cCLan CVS repository at -;;; +;;; 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 CVS HEAD -;;; is the latest development version, whereas the revision tagged -;;; RELEASE may be slightly older but is considered `stable' - -;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; 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 @@ -33,112 +39,1125 @@ ;;; 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. - -;;; the problem with writing a defsystem replacement is bootstrapping: -;;; we can't use defsystem to compile it. Hence, all in one file - -(defpackage #:asdf - (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous - #:hyperdocumentation #:hyperdoc - - #:compile-op #:load-op #:load-source-op #:test-system-version - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - - #:input-files #:output-files #:perform ; operation methods - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - - #:component-depends-on - - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - - #:operation-on-warnings - #:operation-on-failure - - ;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*asdf-revision* - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-dependency - #:circular-dependency ; errors - #:duplicate-names - - #:retry - #:accept ; restarts - - ) - (:use :cl)) - -#+nil -(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") - - -(in-package #:asdf) - -(defvar *asdf-revision* (let* ((v "1.96") - (colon (or (position #\: v) -1)) - (dot (position #\. v))) - (and v colon dot - (list (parse-integer v :start (1+ colon) - :junk-allowed t) - (parse-integer v :start (1+ dot) - :junk-allowed t))))) - -(defvar *compile-file-warnings-behaviour* :warn) -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) +;;; +;;; -- 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 ()) + +(cl:in-package :common-lisp-user) +#+genera (in-package :future-common-lisp-user) + +#-(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.") + +;;;; Create and setup packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See these two eval-when forms, and more near the end of the file. + +#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this + +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; Before we do anything, some implementation-dependent tweaks + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below + #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 + (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (pushnew :gcl-pre2.7 *features*)) + #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) + (pushnew :asdf-unicode *features*) + ;;; make package if it doesn't exist yet. + ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. + (unless (find-package :asdf) + (make-package :asdf :use '(:common-lisp)))) + +(in-package :asdf) + +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; This would belong amongst implementation-dependent tweaks above, + ;;; except that the defun has to be in package asdf. + #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) + #+mkcl (require :cmp) + #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics + + ;;; Package setup, step 2. + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil) + (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. + (defun find-symbol* (s p) + (find-symbol (string s) p)) + ;; Strip out formatting that is not supported on Genera. + ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) + (defmacro compatfmt (format) + #-(or gcl genera) format + #+(or gcl genera) + (loop :for (unsupported . replacement) :in + (append + '(("~3i~_" . "")) + #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do + (loop :for found = (search unsupported format) :while found :do + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) + (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version + ;; can help you do these changes in synch (look at the source for documentation). + ;; Relying on its automation, the version is now redundantly present on top of this file. + ;; "2.345" would be an official release + ;; "2.345.6" would be a development version in the official upstream + ;; "2.345.0.7" would be your seventh local modification of official release 2.345 + ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 + (asdf-version "2.26") + (existing-asdf (find-class 'component nil)) + (existing-version *asdf-version*) + (already-there (equal asdf-version existing-version))) + (unless (and existing-asdf already-there) + (when (and existing-asdf *asdf-verbose*) + (format *trace-output* + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version)) + (labels + ((present-symbol-p (symbol package) + (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) + (present-symbols (package) + ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera + (let (l) + (do-symbols (s package) + (when (present-symbol-p s package) (push s l))) + (reverse l))) + (unlink-package (package) + (let ((u (find-package package))) + (when u + (ensure-unintern u (present-symbols u)) + (loop :for p :in (package-used-by-list u) :do + (unuse-package u p)) + (delete-package u)))) + (ensure-exists (name nicknames use) + (let ((previous + (remove-duplicates + (mapcar #'find-package (cons name nicknames)) + :from-end t))) + ;; do away with packages with conflicting (nick)names + (map () #'unlink-package (cdr previous)) + ;; reuse previous package with same name + (let ((p (car previous))) + (cond + (p + (rename-package p name nicknames) + (ensure-use p use) + p) + (t + (make-package name :nicknames nicknames :use use)))))) + (intern* (symbol package) + (intern (string symbol) package)) + (remove-symbol (symbol package) + (let ((sym (find-symbol* symbol package))) + (when sym + #-cormanlisp (unexport sym package) + (unintern sym package) + sym))) + (ensure-unintern (package symbols) + (loop :with packages = (list-all-packages) + :for sym :in symbols + :for removed = (remove-symbol sym package) + :when removed :do + (loop :for p :in packages :do + (when (eq removed (find-symbol* sym p)) + (unintern removed p))))) + (ensure-shadow (package symbols) + (shadow symbols package)) + (ensure-use (package use) + (dolist (used (package-use-list package)) + (unless (member (package-name used) use :test 'string=) + (unuse-package used) + (do-external-symbols (sym used) + (when (eq sym (find-symbol* sym package)) + (remove-symbol sym package))))) + (dolist (used (reverse use)) + (do-external-symbols (sym used) + (unless (eq sym (find-symbol* sym package)) + (remove-symbol sym package))) + (use-package used package))) + (ensure-fmakunbound (package symbols) + (loop :for name :in symbols + :for sym = (find-symbol* name package) + :when sym :do (fmakunbound sym))) + (ensure-export (package export) + (let ((formerly-exported-symbols nil) + (bothly-exported-symbols nil) + (newly-exported-symbols nil)) + (do-external-symbols (sym package) + (if (member sym export :test 'string-equal) + (push sym bothly-exported-symbols) + (push sym formerly-exported-symbols))) + (loop :for sym :in export :do + (unless (member sym bothly-exported-symbols :test 'equal) + (push sym newly-exported-symbols))) + (loop :for user :in (package-used-by-list package) + :for shadowing = (package-shadowing-symbols user) :do + (loop :for new :in newly-exported-symbols + :for old = (find-symbol* new user) + :when (and old (not (member old shadowing))) + :do (unintern old user))) + (loop :for x :in newly-exported-symbols :do + (export (intern* x package))))) + (ensure-package (name &key nicknames use unintern + shadow export redefined-functions) + (let* ((p (ensure-exists name nicknames use))) + (ensure-unintern p (append unintern #+cmu redefined-functions)) + (ensure-shadow p shadow) + (ensure-export p export) + #-cmu (ensure-fmakunbound p redefined-functions) + p))) + (macrolet + ((pkgdcl (name &key nicknames use export + redefined-functions unintern shadow) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',unintern + :redefined-functions ',redefined-functions))) + (pkgdcl + :asdf + :use (:common-lisp) + :redefined-functions + (#:perform #:explain #:output-files #:operation-done-p + #:perform-with-restarts #:component-relative-pathname + #:system-source-file #:operate #:find-component #:find-system + #:apply-output-translations #:translate-pathname* #:resolve-location + #:system-relative-pathname + #:inherit-source-registry #:process-source-registry + #:process-source-registry-directive + #:compile-file* #:source-file-type) + :unintern + (#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component + #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function + :export + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command + #: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 #:compile-op #:load-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 + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:cl-source-file.cl #:cl-source-file.lsp + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:module-components-by-name + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + #:component-depends-on + #:component-encoding + #:component-external-format + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:map-systems + + #:operation-description + #:operation-on-warnings + #:operation-on-failure + #:component-visited-p + + #:*system-definition-search-functions* ; variables + #:*central-registry* + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*load-system-operation* + #:*asdf-verbose* + #:*verbose-out* + + #:asdf-version + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #: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 + + #: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* + #: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 #:loaded-systems + #:resolve-location + #:asdf-message + #: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 + + ;; Utilities: please use asdf-utils instead + #| + ;; #:aif #:it + ;; #:appendf #:orf + #:length=n-p + #:remove-keys #:remove-keyword + #:first-char #:last-char #:string-suffix-p + #:coerce-name + #:directory-pathname-p #:ensure-directory-pathname + #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root + #:getenv #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:probe-file* + #:find-symbol* #:strcat + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:read-file-forms + #:resolve-symlinks #:truenamize + #:split-string + #:component-name-to-pathname-components + #:split-name-type + #:subdirectories #:directory-files + #:while-collecting + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* + #:*wild-path* #:wilden + #:directorize-pathname-host-device|# + ))) + #+genera (import 'scl:boolean :asdf) + (setf *asdf-version* asdf-version + *upgraded-p* (if existing-version + (cons existing-version *upgraded-p*) + *upgraded-p*)))))) + +;;;; ------------------------------------------------------------------------- +;;;; User-visible parameters +;;;; +(defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. + +Defaults to T.") + +(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 #+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? Valid values are :error, :warn, and :ignore. +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") (defvar *verbose-out* nil) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; utility stuff +(defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + +(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.") + +(defvar *compile-op-compile-file-function* 'compile-file* + "Function used to compile lisp files.") + + + +#+allegro +(eval-when (: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))) + +;;;; ------------------------------------------------------------------------- +;;;; Resolve forward references + +(declaim (ftype (function (t) t) + format-arguments format-control + error-name error-pathname error-condition + duplicate-names-name + error-component error-operation + module-components module-components-by-name + circular-dependency-components + condition-arguments condition-form + condition-format condition-location + coerce-name) + (ftype (function (&optional t) (values)) initialize-source-registry) + #-(or cormanlisp gcl-pre2.7) + (ftype (function (t t) t) (setf module-components-by-name))) + +;;;; ------------------------------------------------------------------------- +;;;; Compatibility various implementations +#+cormanlisp +(progn + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun translate-logical-pathname (x) x) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl + (read-from-string + "(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) + (ccl:define-entry-point (_system \"system\") ((name :string)) :int) + ;; Note: ASDF may expect user-homedir-pathname to provide + ;; the pathname of the current user's home directory, whereas + ;; MCL by default provides the directory from which MCL was started. + ;; See http://code.google.com/p/mcl/wiki/Portability + (defun current-user-homedir-pathname () + (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) + (defun probe-posix (posix-namestring) + \"If a file exists for the posix namestring, return the pathname\" + (ccl::with-cstrs ((cpath posix-namestring)) + (ccl::rlet ((is-dir :boolean) + (fsref :fsref)) + (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) + (ccl::%path-from-fsref fsref is-dir))))))")) + +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities + +(macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + `(progn + #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) + #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( + ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + `(declaim (notinline ,name))) + (,',def ,name ,formals ,@rest))))) + (defdef defgeneric* defgeneric) + (defdef defun* defun)) + +(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)))))) (defmacro aif (test then &optional else) + "Anaphoric version of IF, On Lisp style" `(let ((it ,test)) (if it ,then ,else))) -(defun pathname-sans-name+type (pathname) +(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* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" + (cond + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute ,@directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error (compatfmt "~@") directory)))) + +(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))))))))))) + +(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. +Also, if either argument is NIL, then the other argument is returned unmodified." + (when (null specified) (return-from merge-pathnames* defaults)) + (when (null defaults) (return-from merge-pathnames* specified)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl + (let* ((specified (pathname specified)) + (defaults (pathname defaults)) + (directory (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* pathname-parent-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, -and NIL NAME and TYPE components" - (make-pathname :name nil :type nil :defaults pathname)) +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) (define-modify-macro appendf (&rest args) - append "Append onto list") + append "Append onto list") ;; only to be used on short lists. + +(define-modify-macro orf (&rest args) + or "or a flag") + +(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* asdf-message (format-string &rest format-args) + (declare (dynamic-extent format-args)) + (apply 'format *verbose-out* format-string format-args)) + +(defun* split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +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\")." + (catch nil + (let ((list nil) (words 0) (end (length string))) + (flet ((separatorp (char) (find char separator)) + (done () (throw nil (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* split-name-type (filename) + (let ((unspecific + ;; Giving :unspecific as argument to make-pathname is not portable. + ;; See CLHS make-pathname and 19.2.2.2.3. + ;; We only use it on implementations that support it, + #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) + (destructuring-bind (name &optional (type unspecific)) + (split-string filename :max 2 :separator ".") + (if (equal name "") + (values filename unspecific) + (values name type))))) + +(defun* component-name-to-pathname-components (s &key force-directory force-relative) + "Splits the path string S, returning three values: +A flag that is either :absolute or :relative, indicating + how the rest of the values are to be interpreted. +A directory path --- a list of strings, suitable for + use with MAKE-PATHNAME when prepended with the flag + value. +A filename with type extension, possibly NIL in the + case of a directory pathname. +FORCE-DIRECTORY forces S to be interpreted as a directory +pathname \(third return value will be NIL, final component +of S will be treated as part of the directory path. + +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 s string) + (when (find #\: s) + (error (compatfmt "~@") s)) + (let* ((components (split-string s :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char s) #\/) + (progn + (when force-relative + (error (compatfmt "~@") s)) + (values :absolute (cdr components))) + (values :relative nil)) + (values :relative components)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) + (setf components (substitute :back ".." components :test #'equal)) + (cond + ((equal last-comp "") + (values relative components nil)) ; "" already removed + (force-directory + (values relative components nil)) + (t + (values relative (butlast components) last-comp)))))) + +(defun* remove-keys (key-names args) + (loop :for (name val) :on args :by #'cddr + :unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + :append (list name val))) + +(defun* remove-keyword (key args) + (loop :for (k v) :on args :by #'cddr + :unless (eq k key) + :append (list k v))) + +(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) (find-symbol* 'getenv :mk-ext)) 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* 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) + "Converts the non-wild pathname designator PATHSPEC to directory form." + (cond + ((stringp pathspec) + (ensure-directory-pathname (pathname pathspec))) + ((not (pathnamep pathspec)) + (error (compatfmt "~@") pathspec)) + ((wild-pathname-p pathspec) + (error (compatfmt "~@") pathspec)) + ((directory-pathname-p pathspec) + pathspec) + (t + (make-pathname :directory (append (or (pathname-directory pathspec) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil + :defaults pathspec)))) + +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun* ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + +(defun* absolute-pathname-p (pathspec) + (and (typep pathspec '(or pathname string)) + (eq :absolute (car (pathname-directory (pathname pathspec)))))) + +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." + ;; The defaults are required notably because they provide the default host + ;; to the below make-pathname, which may crucially matter to people using + ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* + (etypecase name + ((or null pathname) + name) + (symbol + (coerce-pathname (string-downcase name) :type type :defaults defaults)) + (string + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) + (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 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") + (coerce-pathname name :type type :defaults defaults)) + +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + +(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* string-suffix-p (s suffix) + (check-type s string) + (check-type suffix string) + (let ((start (- (length s) (length suffix)))) + (and (<= 0 start) + (string-equal s suffix :start1 start)))) + +(defun* read-file-forms (file) + (with-open-file (in file) + (loop :with eof = (list nil) + :for form = (read in nil eof) + :until (eq form eof) + :collect form))) + +(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* probe-file* (p) + "when given a pathname P, probes the filesystem for a file or directory +with given pathname and if it exists return its truename." + (etypecase p + (null nil) + (string (probe-file* (parse-namestring p))) + (pathname (unless (wild-pathname-p p) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (aif (find-symbol* '#:probe-pathname :ext) + `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) + +(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) + "Resolve as much of a pathname as possible" + (block nil + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p (merge-pathnames* pathname defaults))) + (when (typep p 'logical-pathname) (return p)) + (let ((found (probe-file* p))) + (when found (return found))) + (unless (absolute-pathname-p p) + (let ((true-defaults (ignore-errors (truename defaults)))) + (when true-defaults + (setf p (merge-pathnames pathname true-defaults))))) + (unless (absolute-pathname-p p) (return p)) + (let ((sofar (probe-file* (pathname-root p)))) + (unless sofar (return p)) + (flet ((solution (directories) + (merge-pathnames* + (make-pathname :host nil :device nil + :directory `(:relative ,@directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) + sofar))) + (loop :with directory = (normalize-pathname-directory-component + (pathname-directory p)) + :for component :in (cdr directory) + :for rest :on (cdr directory) + :for more = (probe-file* + (merge-pathnames* + (make-pathname :directory `(:relative ,component)) + sofar)) :do + (if more + (setf sofar more) + (return (solution rest))) + :finally + (return (solution nil)))))))) + +(defun* resolve-symlinks (path) + #-allegro (truenamize path) + #+allegro (if (typep path 'logical-pathname) + path + (excl:pathname-resolve-symbolic-links path))) + +(defun* resolve-symlinks* (path) + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path)) + +(defun* ensure-pathname-absolute (path) + (cond + ((absolute-pathname-p path) path) + ((stringp path) (ensure-pathname-absolute (pathname path))) + ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) + (t (let ((resolved (resolve-symlinks path))) + (assert (absolute-pathname-p resolved)) + resolved)))) + +(defun* default-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + +(defun* lispize-pathname (input-file) + (make-pathname :type "lisp" :defaults input-file)) + +(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") +(defparameter *wild-file* + (make-pathname :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*) :directory nil)) +(defparameter *wild-directory* + (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) +(defparameter *wild-path* + (merge-pathnames *wild-file* *wild-inferiors*)) + +(defun* wilden (path) + (merge-pathnames* *wild-path* path)) + +#-scl +(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (last-char (namestring foo)))) + +#-scl +(defun* directorize-pathname-host-device (pathname) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (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) + (component-name-to-pathname-components root-string :force-directory t) + (declare (ignore relative filename)) + (let ((new-base + (make-pathname :defaults root + :directory `(:absolute ,@path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) + +#+scl +(defun* directorize-pathname-host-device (pathname) + (let ((scheme (ext:pathname-scheme pathname)) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) + (flet ((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))) + +;;;; ------------------------------------------------------------------------- +;;;; ASDF Interface, in terms of generic functions. +(defgeneric* find-system (system &optional error-p)) +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* mark-operation-done (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) +(defgeneric* component-operation-time (operation component)) +(defgeneric* operation-description (operation component) + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) + +(defgeneric* system-source-file (system) + (:documentation "Return the source file in which system is defined.")) + +(defgeneric* component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defgeneric* component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; classes, condiitons +(defgeneric* component-relative-pathname (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) + +(defgeneric* component-property (component property)) + +(defgeneric* (setf component-property) (new-value component property)) + +(defgeneric* component-external-format (component)) + +(defgeneric* component-encoding (component)) + +(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) + (defgeneric* (setf module-components-by-name) (new-value module))) + +(defgeneric* version-satisfies (component version)) + +(defgeneric* find-component (base path) + (:documentation "Finds the component with PATH starting from BASE module; +if BASE is nil, then the component is assumed to be a system.")) + +(defgeneric* source-file-type (component system)) + +(defgeneric* operation-ancestor (operation) + (:documentation + "Recursively chase the operation's parent pointer until we get to +the head of the tree")) + +(defgeneric* component-visited-p (operation component) + (:documentation "Returns the value stored by a call to +VISIT-COMPONENT, if that has been called, otherwise NIL. +This value stored will be a cons cell, the first element +of which is a computed key, so not interesting. The +CDR wil be the DATA value stored by VISIT-COMPONENT; recover +it as (cdr (component-visited-p op c)). + In the current form of ASDF, the DATA value retrieved is +effectively a boolean, indicating whether some operations are +to be performed in order to do OPERATION X COMPONENT. If the +data value is NIL, the combination had been explored, but no +operations needed to be performed.")) + +(defgeneric* visit-component (operation component data) + (:documentation "Record DATA as being associated with OPERATION +and COMPONENT. This is a side-effecting function: the association +will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the +OPERATION\). + No evidence that DATA is ever interesting, beyond just being +non-NIL. Using the data field is probably very risky; if there is +already a record for OPERATION X COMPONENT, DATA will be quietly +discarded instead of recorded. + Starting with 2.006, TRAVERSE will store an integer in data, +so that nodes can be sorted in decreasing order of traversal.")) + + +(defgeneric* (setf visiting-component) (new-value operation component)) + +(defgeneric* component-visiting-p (operation component)) + +(defgeneric* component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is a class + designator and each is a component + designator, which means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on 's presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defgeneric* component-self-dependencies (operation component)) + +(defgeneric* traverse (operation component) + (:documentation +"Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) + + +;;;; ------------------------------------------------------------------------- +;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 +(when *upgraded-p* + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* + (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") + m (asdf-version))) + (when (member 'components-by-name added) + (compute-module-components-by-name m)) + (when (typep m 'system) + (when (member 'source-file added) + (%set-system-source-file + (probe-asd (component-name m) (component-pathname m)) m) + (when (equal (component-name m) "asdf") + (setf (component-version m) *asdf-version*)))))))) + +;;;; ------------------------------------------------------------------------- +;;;; Classes, Conditions (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. @@ -153,39 +1172,105 @@ and NIL NAME and TYPE components" ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply 'format s (format-control c) (format-arguments c))))) + +(define-condition load-system-definition-error (system-definition-error) + ((name :initarg :name :reader error-name) + (pathname :initarg :pathname :reader error-pathname) + (condition :initarg :condition :reader error-condition)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) - ((components :initarg :components :reader circular-dependency-components))) + ((components :initarg :components :reader circular-dependency-components)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) - ((name :initarg :name :reader duplicate-names-name))) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) +(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))) +(define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s (compatfmt "~@") + (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) +(define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s (compatfmt "~@<~? (will be skipped)~@:>") + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) +(define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) +(define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) + (defclass component () - ((name :accessor component-name :initarg :name :documentation + ((name :accessor component-name :initarg :name :type string :documentation "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! (version :accessor component-version :initarg :version) - (in-order-to :initform nil :initarg :in-order-to) - ;;; XXX crap name - (do-first :initform nil :initarg :do-first) + (description :accessor component-description :initarg :description) + (long-description :accessor component-long-description :initarg :long-description) + ;; This one below is used by POIU - http://www.cliki.net/poiu + ;; a parallelizing extension of ASDF that compiles in multiple parallel + ;; slave processes (forked on demand) and loads in the master process. + ;; Maybe in the future ASDF may use it internally instead of in-order-to. + (load-dependencies :accessor component-load-dependencies :initform nil) + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). They are represented + ;; alists of operations to dependencies (other actions) in each component. + ;; There are two kinds of dependencies, each stored in its own slot: + ;; in-order-to and do-first dependencies. These two kinds are related to + ;; the fact that some actions modify the filesystem, + ;; whereas other actions modify the current image, and + ;; this implies a difference in how to interpret timestamps. + ;; in-order-to dependencies will trigger re-performing the action + ;; when the timestamp of some dependency + ;; makes the timestamp of current action out-of-date; + ;; do-first dependencies do not trigger such re-performing. + ;; Therefore, a FASL must be recompiled if it is obsoleted + ;; by any of its FASL dependencies (in-order-to); but + ;; it needn't be recompiled just because one of these dependencies + ;; hasn't yet been loaded in the current image (do-first). + ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; 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 backwards compatible. + ;; See our ASDF 2 paper for more complete explanations. + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + (do-first :initform nil :initarg :do-first + :accessor component-do-first) ;; 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 @@ -194,278 +1279,718 @@ and NIL NAME and TYPE components" ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) - (operation-times :initform (make-hash-table ) + ;; the absolute-pathname is computed based on relative-pathname... + (absolute-pathname) + (operation-times :initform (make-hash-table) :accessor component-operation-times) + (around-compile :initarg :around-compile) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) +(defun* component-find-path (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)))) + + ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) - (format s "~@<~A, required by ~A~@:>" + (format s (compatfmt "~@<~A, required by ~A~@:>") (call-next-method c nil) (missing-required-by c))) -(defun sysdef-error (format &rest arguments) - (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) +(defun* sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments)) ;;;; methods: components (defmethod print-object ((c missing-component) s) - (format s "~@" + (format s (compatfmt "~@") (missing-requires c) - (missing-version c) (when (missing-parent c) - (component-name (missing-parent c))))) + (coerce-name (missing-parent c))))) -(defgeneric component-system (component) - (:documentation "Find the top-level system containing COMPONENT")) +(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))))) (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) -(defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity t) - (ignore-errors - (prin1 (component-name c) stream)))) +(defvar *default-component-class* 'cl-source-file) -(defclass module (component) - ((components :initform nil :accessor module-components :initarg :components) - ;; what to do if we can't satisfy a dependency of one of this module's - ;; components. This allows a limited form of conditional processing - (if-component-dep-fails :initform :fail - :accessor module-if-component-dep-fails - :initarg :if-component-dep-fails) - (default-component-class :accessor module-default-component-class - :initform 'cl-source-file :initarg :default-component-class))) - -(defgeneric component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) - -(defun component-parent-pathname (component) - (aif (component-parent component) - (component-pathname it) - *default-pathname-defaults*)) +(defun* compute-module-components-by-name (module) + (let ((hash (make-hash-table :test 'equal))) + (setf (module-components-by-name module) hash) + (loop :for c :in (module-components module) + :for name = (component-name c) + :for previous = (gethash name (module-components-by-name module)) + :do + (when previous + (error 'duplicate-names :name name)) + :do (setf (gethash name (module-components-by-name module)) c)) + hash)) -(defgeneric component-relative-pathname (component) - (:documentation "Extracts the relative pathname applicable for a particular component.")) - -(defmethod component-relative-pathname ((component module)) - (or (slot-value component 'relative-pathname) - (make-pathname - :directory `(:relative ,(component-name component)) - :host (pathname-host (component-parent-pathname component))))) +(defclass module (component) + ((components + :initform nil + :initarg :components + :accessor module-components) + (components-by-name + :accessor module-components-by-name) + ;; What to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing. + (if-component-dep-fails + :initform :fail + :initarg :if-component-dep-fails + :accessor module-if-component-dep-fails) + (default-component-class + :initform nil + :initarg :default-component-class + :accessor module-default-component-class))) + +(defun* component-parent-pathname (component) + ;; No default anymore (in particular, no *default-pathname-defaults*). + ;; If you force component to have a NULL pathname, you better arrange + ;; for any of its children to explicitly provide a proper absolute pathname + ;; wherever a pathname is actually wanted. + (let ((parent (component-parent component))) + (when parent + (component-pathname parent)))) (defmethod component-pathname ((component component)) - (let ((*default-pathname-defaults* (component-parent-pathname component))) - (merge-pathnames (component-relative-pathname component)))) - -(defgeneric component-property (component property)) + (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-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) -(defgeneric (setf component-property) (new-value component property)) - (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)))))) - -(defclass system (module) - ((description :accessor system-description :initarg :description) - (long-description - :accessor system-long-description :initarg :long-description) + (acons property new-value (slot-value c 'properties))))) + new-value) + +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +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) + (funcall *encoding-detection-hook* pathname)) + +(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)))) + +(defun* default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backwards 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)) + +(defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c))) + +(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) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) + (;; description and long-description are now available for all component's, + ;; but now also inherited from component, but we add the legacy accessor + (description :accessor system-description :initarg :description) + (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence))) - -;;; version-satisfies - -;;; with apologies to christophe rhodes ... -(defun split (string &optional max (ws '(#\Space #\Tab))) - (flet ((is-ws (char) (find char ws))) - (nreverse - (let ((list nil) (start 0) (words 0) end) - (loop - (when (and max (>= words (1- max))) - (return (cons (subseq string start) list))) - (setf end (position-if #'is-ws string :start start)) - (push (subseq string start end) list) - (incf words) - (unless end (return list)) - (setf start (1+ end))))))) - -(defgeneric version-satisfies (component version)) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license) + (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade + :writer %set-system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) + +;;;; ------------------------------------------------------------------------- +;;;; version-satisfies (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) (return-from version-satisfies t)) - (let ((x (mapcar #'parse-integer - (split (component-version c) nil '(#\.)))) - (y (mapcar #'parse-integer - (split version nil '(#\.))))) + (version-satisfies (component-version c) version)) + +(defun* asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." + *asdf-version*) + +(defun* parse-version (string &optional on-error) + "Parse a version string as a series of natural integers separated by dots. +Return a (non-null) list of integers if the string is valid, NIL otherwise. +If on-error is error, warn, or designates a function of compatible signature, +the function is called with an explanation of what is wrong with the argument. +NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" + (and + (or (stringp string) + (when on-error + (funcall on-error "~S: ~S is not a string" + 'parse-version string)) nil) + (or (loop :for prev = nil :then c :for c :across string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (when on-error + (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version string)) nil) + (mapcar #'parse-integer (split-string string :separator ".")))) + +(defmethod version-satisfies ((cver string) version) + (let ((x (parse-version cver 'warn)) + (y (parse-version version 'warn))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) - (and (= (car x) (car y)) + (and x y (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding systems +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 -(defvar *defined-systems* (make-hash-table :test 'equal)) -(defun coerce-name (name) - (typecase name - (component (component-name name)) - (symbol (string-downcase (symbol-name name))) - (string name) - (t (sysdef-error "~@" name)))) +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(progn +(defparameter *link-initial-dword* 76) +(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) + +(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 () + nil))))) + +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(defun* make-defined-systems-table () + (make-hash-table :test 'equal)) + +(defvar *defined-systems* (make-defined-systems-table) + "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* coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error (compatfmt "~@") name)))) + +(defun* system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +(defun* registered-systems () + (loop :for (() . system) :being :the :hash-values :of *defined-systems* + :collect (coerce-name system))) + +(defun* register-system (system) + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) + (unless (eq system (cdr (gethash name *defined-systems*))) + (setf (gethash name *defined-systems*) + (cons (get-universal-time) system))))) + +(defun* clear-system (name) + "Clear the entry for a system in the database of systems previously loaded. +Note that this does NOT in any way cause the code of the system to be unloaded." + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. + (remhash (coerce-name name) *defined-systems*)) + +(defun* map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (maphash #'(lambda (_ datum) + (declare (ignore _)) + (destructuring-bind (_ . def) datum + (declare (ignore _)) + (funcall fn def))) + *defined-systems*)) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defvar *system-definition-search-functions* - '(sysdef-central-registry-search)) - -(defun system-definition-pathname (system) - (some (lambda (x) (funcall x system)) - *system-definition-search-functions*)) - -(defvar *central-registry* - '(*default-pathname-defaults* - #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" - #+nil "telent:asdf;systems;")) - -(defun sysdef-central-registry-search (system) - (let ((name (coerce-name system))) +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-search *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; 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-find-asdf)))) + +(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 compatibilily. +Going forward, we recommend new users should be using the source-registry. +") + +(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) features))) + ((eq :or (car x)) + (some #'(lambda (x) (featurep x features)) (cdr x))) + ((eq :and (car x)) + (every #'(lambda (x) (featurep x features)) (cdr x))) + (t + (error "Malformed feature specification ~S" x)))) + +(defun* os-unix-p () + (featurep '(:or :unix :cygwin :darwin))) + +(defun* os-windows-p () + (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) + +(defun* probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) + (when file + (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 :version :newest :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 (coerce-name system)) + (to-remove nil) + (to-replace nil)) (block nil - (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local)))) - (if (and file (probe-file file)) - (return file))))))) - -(defun make-temporary-package () + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir))) + (when defaults + (cond ((directory-pathname-p defaults) + (let ((file (probe-asd name defaults))) + (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 () + :report (lambda (s) + (format s (compatfmt "~@") + (ensure-directory-pathname defaults) dir)) + (push (cons dir (ensure-directory-pathname defaults)) 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)))))))))) + +(defun* make-temporary-package () (flet ((try (counter) (ignore-errors - (make-package (format nil "ASDF~D" counter) - :use '(:cl :asdf))))) + (make-package (format nil "~A~D" :asdf counter) + :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) -(defun find-system (name &optional (error-p t)) +(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 operation-done-p 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?) + (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname))) + (progn + (when (and pathname *asdf-verbose*) + (warn (compatfmt "~@") + pathname)) + 0))) + +(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* + (funcall thunk) + (let ((*systems-being-defined* (make-hash-table :test 'equal))) + (funcall thunk)))) + +(defmacro with-system-definitions ((&optional) &body body) + `(call-with-system-definitions #'(lambda () ,@body))) + +(defun* load-sysdef (name pathname) + ;; Tries to load system definition with canonical NAME from PATHNAME. + (with-system-definitions () + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error #'(lambda (condition) + (error 'load-system-definition-error + :name name :pathname pathname + :condition condition)))) + (let ((*package* package) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname))) + (external-format (encoding-external-format (detect-encoding pathname)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") + pathname package) + (load pathname :external-format external-format))) + (delete-package package))))) + +(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 (gethash name *defined-systems*)) - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (let ((*package* package)) - (format - *verbose-out* - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. - on-disk - *package*) - (load on-disk)) - (delete-package package)))) - (let ((in-memory (gethash name *defined-systems*))) - (if in-memory - (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) - (cdr in-memory)) - (if error-p (error 'missing-component :requires name)))))) - -(defun register-system (name system) - (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) - (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) - -(defun system-registered-p (name) - (gethash (coerce-name name) *defined-systems*)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp + (setf pathname (resolve-symlinks* pathname)) + (when (and pathname (not (absolute-pathname-p pathname))) + (setf pathname (ensure-pathname-absolute pathname)) + (when found-system + (%set-system-source-file pathname found-system))) + (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp + (system-source-file previous) pathname))) + (%set-system-source-file pathname previous) + (setf previous-time nil)) + (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) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date 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)))))) + +(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) + (setf fallback (coerce-name fallback) + requested (coerce-name requested)) + (when (equal requested fallback) + (let ((registered (cdr (gethash fallback *defined-systems*)))) + (or registered + (apply 'make-instance 'system + :name fallback :source-file source-file keys))))) + +(defun* sysdef-find-asdf (name) + ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. + (find-system-fallback name "asdf" :version *asdf-version*)) + + +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(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 ((module module) (name string)) + (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! + (compute-module-components-by-name module)) + (values (gethash name (module-components-by-name module)))) + +(defmethod find-component ((component component) (name symbol)) + (if name + (find-component component (coerce-name name)) + component)) + +(defmethod find-component ((module module) (name cons)) + (find-component (find-component module (car name)) (cdr name))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding components -(defgeneric find-component (module name &optional version) - (:documentation "Finds the component with name NAME present in the -MODULE module; if MODULE is nil, then the component is assumed to be a -system.")) - -(defmethod find-component ((module module) name &optional version) - (if (slot-boundp module 'components) - (let ((m (find name (module-components module) - :test #'equal :key #'component-name))) - (if (and m (version-satisfies m version)) m)))) +;;; component subclasses +(defclass source-file (component) + ((type :accessor source-file-explicit-type :initarg :type :initform nil))) + +(defclass cl-source-file (source-file) + ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) +(defclass c-source-file (source-file) + ((type :initform "c"))) +(defclass java-source-file (source-file) + ((type :initform "java"))) +(defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) + ((type :initform "html"))) -;;; a component with no parent is a system -(defmethod find-component ((module (eql nil)) name &optional version) - (let ((m (find-system name nil))) - (if (and m (version-satisfies m version)) m))) +(defmethod source-file-type ((component module) (s module)) + (declare (ignorable component s)) + :directory) +(defmethod source-file-type ((component source-file) (s module)) + (declare (ignorable s)) + (source-file-explicit-type component)) -;;; component subclasses +(defmethod component-relative-pathname ((component component)) + (coerce-pathname + (or (slot-value component 'relative-pathname) + (component-name component)) + :type (source-file-type component (component-system component)) + :defaults (component-parent-pathname component))) -(defclass source-file (component) ()) +;;;; ------------------------------------------------------------------------- +;;;; Operations -(defclass cl-source-file (source-file) ()) -(defclass c-source-file (source-file) ()) -(defclass java-source-file (source-file) ()) -(defclass static-file (source-file) ()) -(defclass doc-file (static-file) ()) -(defclass html-file (doc-file) ()) - -(defgeneric source-file-type (component system)) -(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") -(defmethod source-file-type ((c c-source-file) (s module)) "c") -(defmethod source-file-type ((c java-source-file) (s module)) "java") -(defmethod source-file-type ((c html-file) (s module)) "html") -(defmethod source-file-type ((c static-file) (s module)) nil) - -(defmethod component-relative-pathname ((component source-file)) - (let ((relative-pathname (slot-value component 'relative-pathname))) - (if relative-pathname - (merge-pathnames - relative-pathname - (make-pathname - :type (source-file-type component (component-system component)))) - (let* ((*default-pathname-defaults* - (component-parent-pathname component)) - (name-type - (make-pathname - :name (component-name component) - :type (source-file-type component - (component-system component))))) - name-type)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; operations - -;;; one of these is instantiated whenever (operate ) is called +;;; one of these is instantiated whenever #'operate is called (defclass operation () - ((forced :initform nil :initarg :force :accessor operation-forced) + (;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of the specified system, + ;; but not recurse to other systems we depend on. + ;; :ALL (or any other atom) to force all systems + ;; including other systems we depend on. + ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) + ;; to force systems named in a given list + ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 + (forced :initform nil :initarg :force :accessor operation-forced) + (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) - (visited-nodes :initform nil :accessor operation-visited-nodes) - (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) + (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) @@ -474,31 +1999,30 @@ system.")) (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force + &key force force-not &allow-other-keys) - (declare (ignore slot-names force)) - ;; empty method to disable initarg validity checking - ) - -(defgeneric perform (operation component)) -(defgeneric operation-done-p (operation component)) -(defgeneric explain (operation component)) -(defgeneric output-files (operation component)) -(defgeneric input-files (operation component)) - -(defun node-for (o c) + ;; the &allow-other-keys disables initarg validity checking + (declare (ignorable operation slot-names force force-not)) + (macrolet ((frob (x) ;; normalize forced and forced-not slots + `(when (consp (,x operation)) + (setf (,x operation) + (mapcar #'coerce-name (,x operation)))))) + (frob operation-forced) (frob operation-forced-not)) + (values)) + +(defun* node-for (o c) (cons (class-name (class-of o)) c)) -(defgeneric operation-ancestor (operation) - (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) - (defmethod operation-ancestor ((operation operation)) (aif (operation-parent operation) (operation-ancestor it) operation)) -(defun make-sub-operation (c o dep-c dep-o) +(defun* make-sub-operation (c o dep-c dep-o) + "C is a component, O is an operation, DEP-C is another +component, and DEP-O, confusingly enough, is an operation +class specifier, not an operation." (let* ((args (copy-list (operation-original-initargs o))) (force-p (getf args :force))) ;; note explicit comparison with T: any other non-NIL force value @@ -508,423 +2032,815 @@ system.")) (not (eql c dep-c))) (when (eql force-p t) (setf (getf args :force) nil)) - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args)) ((subtypep (type-of o) dep-o) o) (t - (apply #'make-instance dep-o + (apply 'make-instance dep-o :parent o :original-initargs args args))))) -(defgeneric visit-component (operation component data)) - (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) - (push (cons (node-for o c) data) - (operation-visited-nodes (operation-ancestor o))))) - -(defgeneric component-visited-p (operation component)) + (setf (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o))) + (cons t data)))) (defmethod component-visited-p ((o operation) (c component)) - (assoc (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) - -(defgeneric (setf visiting-component) (new-value operation component)) + (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o)))) (defmethod (setf visiting-component) (new-value operation component) ;; MCL complains about unused lexical variables - (declare (ignorable new-value operation component))) + (declare (ignorable operation component)) + new-value) (defmethod (setf visiting-component) (new-value (o operation) (c component)) (let ((node (node-for o c)) (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal))))) - -(defgeneric component-visiting-p (operation component)) + (setf (gethash node (operation-visiting-nodes a)) t) + (remhash node (operation-visiting-nodes a))) + new-value)) (defmethod component-visiting-p ((o operation) (c component)) - (let ((node (cons o c))) - (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + (let ((node (node-for o c))) + (gethash node (operation-visiting-nodes (operation-ancestor o))))) -(defgeneric component-depends-on (operation component)) +(defmethod component-depends-on ((op-spec symbol) (c component)) + ;; Note: we go from op-spec to operation via make-instance + ;; to allow for specialization through defmethod's, even though + ;; it's a detour in the default case below. + (component-depends-on (make-instance op-spec) c)) (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (class-name (class-of o)) - (slot-value c 'in-order-to)))) - -(defgeneric component-self-dependencies (operation component)) + (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) - (let ((all-deps (component-depends-on o c))) - (remove-if-not (lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) (self-deps (component-self-dependencies operation c))) (if self-deps - (mapcan (lambda (dep) - (destructuring-bind (op name) dep - (output-files (make-instance op) - (find-component parent name)))) + (mapcan #'(lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) self-deps) ;; no previous operations needed? I guess we work with the ;; original source file, then (list (component-pathname c))))) -(defmethod input-files ((operation operation) (c module)) nil) +(defmethod input-files ((operation operation) (c module)) + (declare (ignorable operation c)) + nil) + +(defmethod component-operation-time (o c) + (gethash (type-of o) (component-operation-times c))) (defmethod operation-done-p ((o operation) (c component)) - (flet ((fwd-or-return-t (file) - ;; if FILE-WRITE-DATE returns NIL, it's possible that the - ;; user or some other agent has deleted an input file. If - ;; that's the case, well, that's not good, but as long as - ;; the operation is otherwise considered to be done we - ;; could continue and survive. - (let ((date (file-write-date file))) - (cond - (date) - (t - (warn "~@" - file o c) - (return-from operation-done-p t)))))) - (let ((out-files (output-files o c)) - (in-files (input-files o c))) - (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (apply #'max - (mapcar #'fwd-or-return-t in-files)))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) - -;;; So you look at this code and think "why isn't it a bunch of -;;; methods". And the answer is, because standard method combination -;;; runs :before methods most->least-specific, which is back to front -;;; for our purposes. And CLISP doesn't have non-standard method -;;; combinations, so let's keep it simple and aspire to portability - -(defgeneric traverse (operation component)) -(defmethod traverse ((operation operation) (c component)) - (let ((forced nil)) - (labels ((do-one-dep (required-op required-c required-v) - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (error 'missing-dependency :required-by c - :version required-v - :requires required-c))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) - (do-dep (op dep) - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency :required-by c - :requires (car dep) :version nil))) - (t - (dolist (d dep) - (cond ((consp d) - (assert (string-equal - (symbol-name (first d)) - "VERSION")) - (appendf forced - (do-one-dep op (second d) (third d)))) - (t - (appendf forced (do-one-dep op d nil))))))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c)) + (op-time (component-operation-time o c))) + (flet ((earliest-out () + (reduce #'min (mapcar #'safe-file-write-date out-files))) + (latest-in () + (reduce #'max (mapcar #'safe-file-write-date in-files)))) + (cond + ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much. + ;; e.g. operations on systems, modules that have no immediate action, + ;; but are only meaningful through traversed dependencies + t) + ((not out-files) + ;; an operation without output-files is probably meant + ;; for its side-effects in the current image, + ;; assumed to be idem-potent, + ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. + (and op-time (>= op-time (latest-in)))) + ((not in-files) + ;; an operation with output-files and no input-files + ;; is probably meant for its side-effects on the file-system, + ;; assumed to have to be done everytime. + ;; (I don't think there is any such case in ASDF unless extended) + nil) + (t + ;; an operation with both input and output files is assumed + ;; as computing the latter from the former, + ;; assumed to have been done if the latter are all older + ;; than the former. + ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. + ;; We use >= instead of > to play nice with generated files. + ;; This opens a race condition if an input file is changed + ;; after the output is created but within the same second + ;; of filesystem time; but the same race condition exists + ;; whenever the computation from input to output takes more + ;; than one second of filesystem time (or just crosses the + ;; second). So that's cool. + (and + (every #'probe-file* in-files) + (every #'probe-file* out-files) + (>= (earliest-out) (latest-in)))))))) + + + +;;; For 1.700 I've done my best to refactor TRAVERSE +;;; by splitting it up in a bunch of functions, +;;; so as to improve the collection and use-detection algorithm. --fare +;;; The protocol is as follows: we pass around operation, dependency, +;;; bunch of other stuff, and a force argument. Return a force flag. +;;; The returned flag is T if anything has changed that requires a rebuild. +;;; The force argument is a list of components that will require a rebuild +;;; if the flag is T, at which point whoever returns the flag has to +;;; mark them all as forced, and whoever recurses again can use a NIL list +;;; as a further argument. + +(defvar *forcing* nil + "This dynamically-bound variable is used to force operations in +recursive calls to traverse.") + +(defgeneric* do-traverse (operation component collect)) + +(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) + (cond + ((atom dep-spec) + (resolve-dependency-name component dep-spec)) + ;; Structured dependencies --- this parses keywords. + ;; The keywords could conceivably be broken out and cleanly (extensibly) + ;; processed by EQL methods. But for now, here's what we've got. + ((eq :version (first dep-spec)) + ;; https://bugs.launchpad.net/asdf/+bug/527788 + (resolve-dependency-name component (second dep-spec) (third dep-spec))) + ((eq :feature (first dep-spec)) + ;; This particular subform is not documented and + ;; has always been broken in the past. + ;; Therefore no one uses it, and I'm cerroring it out, + ;; after fixing it + ;; See https://bugs.launchpad.net/asdf/+bug/518467 + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") + (when (find (second dep-spec) *features* :test 'string-equal) + (resolve-dependency-name component (third dep-spec)))) + (t + (error (compatfmt "~@ ), (:feature ), or .~@:>") dep-spec)))) + +(defun* do-one-dep (op c collect dep-op dep-c) + ;; Collects a partial plan for performing dep-op on dep-c + ;; as dependencies of a larger plan involving op and c. + ;; Returns t if this should force recompilation of those who depend on us. + ;; dep-op is an operation class name (not an operation object), + ;; whereas dep-c is a component object.n + (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) + +(defun* do-dep (op c collect dep-op-spec dep-c-specs) + ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs + ;; as dependencies of a larger plan involving op and c. + ;; Returns t if this should force recompilation of those who depend on us. + ;; dep-op-spec is either an operation class name (not an operation object), + ;; or the magic symbol asdf:feature. + ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, + ;; and the plan will succeed if that keyword is present in *feature*, + ;; or fail if it isn't + ;; (at which point c's :if-component-dep-fails will kick in). + ;; If dep-op-spec is an operation class name, + ;; then dep-c-specs specifies a list of sibling component of c, + ;; as per resolve-dependency-spec, such that operating op on c + ;; depends on operating dep-op-spec on each of them. + (cond ((eq dep-op-spec 'feature) + (if (member (car dep-c-specs) *features*) + nil + (error 'missing-dependency + :required-by c + :requires (list :feature (car dep-c-specs))))) + (t + (let ((flag nil)) + (dolist (d dep-c-specs) + (when (do-one-dep op c collect dep-op-spec + (resolve-dependency-spec c d)) + (setf flag t))) + flag)))) + +(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes + +(defun* do-collect (collect x) + (funcall collect x)) + +(defmethod do-traverse ((operation operation) (c component) collect) + (let ((*forcing* *forcing*) + (flag nil)) ;; return value: must we rebuild this and its dependencies? + (labels + ((update-flag (x) + (orf flag x)) + (dep (op comp) + (update-flag (do-dep operation c collect op comp)))) + ;; Have we been visited yet? If so, just process the result. (aif (component-visited-p operation c) - (return-from traverse - (if (cdr it) (list (cons 'pruned-op c)) nil))) + (progn + (update-flag (cdr it)) + (return-from do-traverse flag))) ;; dependencies - (if (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) + (when (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) - (loop for (required-op . deps) in (component-depends-on operation c) - do (do-dep required-op deps)) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) + (unwind-protect + (block nil + (when (typep c 'system) ;; systems can be forced or forced-not + (let ((ancestor (operation-ancestor operation))) + (flet ((match? (f) + (and f (or (not (consp f)) ;; T or :ALL + (member (component-name c) f :test #'equal))))) + (cond + ((match? (operation-forced ancestor)) + (setf *forcing* t)) + ((match? (operation-forced-not ancestor)) + (return)))))) + ;; first we check and do all the dependencies for the module. + ;; Operations planned in this loop will show up + ;; in the results, and are consumed below. + (let ((*forcing* nil)) + ;; upstream dependencies are never forced to happen just because + ;; the things that depend on them are.... + (loop + :for (required-op . deps) :in (component-depends-on operation c) + :do (dep required-op deps))) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + ;; This is set based on the results of the + ;; dependencies and whether we are in the + ;; context of a *forcing* call... + ;; inter-system dependencies do NOT trigger + ;; building components + (*forcing* + (or *forcing* + (and flag (not (typep c 'system))))) + (error nil)) + (while-collecting (internal-collect) + (dolist (kid (module-components c)) + (handler-case + (update-flag + (do-traverse operation kid #'internal-collect)) + #-genera + (missing-dependency (condition) + (when (eq (module-if-component-dep-fails c) + :fail) (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) - (setf (visiting-component operation c) nil) - (visit-component operation c (and forced t)) - forced))) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error))))))) + (update-flag (or *forcing* (not (operation-done-p operation c)))) + ;; For sub-operations, check whether + ;; the original ancestor operation was forced, + ;; or names us amongst an explicit list of things to force... + ;; except that this check doesn't distinguish + ;; between all the things with a given name. Sigh. + ;; BROKEN! + (when flag + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (component-do-first c))))) + (loop :for (required-op . deps) :in do-first + :do (do-dep operation c collect required-op deps))) + (do-collect collect (vector module-ops)) + (do-collect collect (cons operation c))))) + (setf (visiting-component operation c) nil))) + (visit-component operation c (when flag (incf *visit-count*))) + flag)) + +(defun* flatten-tree (l) + ;; You collected things into a list. + ;; Most elements are just things to collect again. + ;; A (simple-vector 1) indicate that you should recurse into its contents. + ;; This way, in two passes (rather than N being the depth of the tree), + ;; you can collect things with marginally constant-time append, + ;; achieving linear time collection instead of quadratic time. + (while-collecting (c) + (labels ((r (x) + (if (typep x '(simple-vector 1)) + (r* (svref x 0)) + (c x))) + (r* (l) + (dolist (x l) (r x)))) + (r* l)))) +(defmethod traverse ((operation operation) (c component)) + (flatten-tree + (while-collecting (collect) + (let ((*visit-count* 0)) + (do-traverse operation c #'collect))))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error - "~@" + (compatfmt "~@") (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) + (declare (ignorable operation c)) nil) +(defmethod mark-operation-done ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (reduce #'max + (cons (get-universal-time) + (mapcar #'safe-file-write-date (input-files operation 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: + #|(when *asdf-verbose* (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 "~@") + (operation-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (operation-description operation component))) + (mark-operation-done operation component) + (return))))) + (defmethod explain ((operation operation) (component component)) - (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") + (operation-description operation component))) -;;; compile-op +(defmethod operation-description (operation component) + (format nil (compatfmt "~@<~A on ~A~@:>") + (class-of operation) component)) + +;;;; ------------------------------------------------------------------------- +;;;; compile-op (defclass compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) (on-warnings :initarg :on-warnings :accessor operation-on-warnings :initform *compile-file-warnings-behaviour*) (on-failure :initarg :on-failure :accessor operation-on-failure - :initform *compile-file-failure-behaviour*))) + :initform *compile-file-failure-behaviour*) + (flags :initarg :flags :accessor compile-op-flags + :initform 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))) + +(defun* ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) (defmethod perform :before ((operation compile-op) (c source-file)) - (map nil #'ensure-directories-exist (output-files operation c))) + (ensure-all-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) - (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time))) + (mark-operation-done operation c)) + +(defgeneric* around-compile-hook (component)) +(defgeneric* call-with-around-compile-hook (component thunk)) + +(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))))) + +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + +(defmethod call-with-around-compile-hook ((c component) thunk) + (let ((hook (around-compile-hook c))) + (if hook + (funcall (ensure-function hook) thunk) + (funcall thunk)))) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) - #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + ;; on some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (output-file (first (output-files operation c))) + (*compile-file-warnings-behaviour* (operation-on-warnings operation)) + (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file) - ;(declare (ignore output)) - (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - "~@" - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (call-with-around-compile-hook + c #'(lambda (&rest flags) + (apply *compile-op-compile-file-function* source-file + :output-file output-file + :external-format (component-external-format c) + (append flags (compile-op-flags operation))))) + (unless output + (error 'compile-error :component c :operation operation)) (when failure-p (case (operation-on-failure operation) (:warn (warn - "~@" + (compatfmt "~@") operation c)) (:error (error 'compile-failed :component c :operation operation)) (:ignore nil))) - (unless output - (error 'compile-error :component c :operation operation))))) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + (compatfmt "~@") + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil)))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) - #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) - #+:broken-fasl-loader (list (component-pathname c))) + (declare (ignorable operation)) + (let* ((p (lispize-pathname (component-pathname c))) + (f (compile-file-pathname ;; fasl + p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) + #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file + #+ecl (if (use-ecl-byte-compiler-p) + (list f) + (list (compile-file-pathname p :type :object) f)) + #+mkcl (list o f) + #-(or ecl mkcl) (list f))) (defmethod perform ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) -;;; load-op +(defmethod input-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) + nil) + +(defmethod operation-description ((operation compile-op) component) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + +(defmethod operation-description ((operation compile-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + + +;;;; ------------------------------------------------------------------------- +;;;; load-op -(defclass load-op (operation) ()) +(defclass basic-load-op (operation) ()) + +(defclass load-op (basic-load-op) ()) + +(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 (make-sub-operation c o c 'compile-op) c))))) (defmethod perform ((o load-op) (c cl-source-file)) - (mapcar #'load (input-files o c))) + (map () #'load + #-(or ecl mkcl) + (input-files o c) + #+(or ecl mkcl) + (loop :for i :in (input-files o c) + :unless (string= (pathname-type i) "fas") + :collect (compile-file-pathname (lispize-pathname i))))) (defmethod perform ((operation load-op) (c static-file)) + (declare (ignorable operation c)) nil) + (defmethod operation-done-p ((operation load-op) (c static-file)) + (declare (ignorable operation c)) t) -(defmethod output-files ((o operation) (c component)) +(defmethod output-files ((operation operation) (c component)) + (declare (ignorable operation c)) nil) (defmethod component-depends-on ((operation load-op) (c component)) + (declare (ignorable operation)) (cons (list 'compile-op (component-name c)) (call-next-method))) -;;; load-source-op +(defmethod operation-description ((operation load-op) component) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component cl-source-file)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +;;;; ------------------------------------------------------------------------- +;;;; load-source-op -(defclass load-source-op (operation) ()) +(defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) + (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) - (and (load source) + (and (call-with-around-compile-hook + c #'(lambda () (load source :external-format (component-external-format c)))) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation load-source-op) (c component)) + (declare (ignorable operation c)) nil) -;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) - (let ((what-would-load-op-do (cdr (assoc 'load-op - (slot-value c 'in-order-to))))) - (mapcar (lambda (dep) - (if (eq (car dep) 'load-op) - (cons 'load-source-op (cdr dep)) - dep)) - what-would-load-op-do))) + (declare (ignorable o)) + (loop :with what-would-load-op-do = (component-depends-on 'load-op c) + :for (op . co) :in what-would-load-op-do + :when (eq op 'load-op) :collect (cons 'load-source-op co))) (defmethod operation-done-p ((o load-source-op) (c source-file)) + (declare (ignorable o)) (if (or (not (component-property c 'last-loaded-as-source)) - (> (file-write-date (component-pathname c)) + (> (safe-file-write-date (component-pathname c)) (component-property c 'last-loaded-as-source))) nil t)) +(defmethod operation-description ((operation load-source-op) component) + (declare (ignorable operation)) + (format nil (compatfmt "~@") + component)) + +(defmethod operation-description ((operation load-source-op) (component module)) + (declare (ignorable operation)) + (format nil (compatfmt "~@") component)) + + +;;;; ------------------------------------------------------------------------- +;;;; test-op + (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) + (declare (ignorable operation c)) + nil) + +(defmethod operation-done-p ((operation test-op) (c system)) + "Testing a system is _never_ done." + (declare (ignorable operation c)) nil) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; invoking operations - -(defun operate (operation-class system &rest args) - (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (steps (traverse op system))) +(defmethod component-depends-on :around ((o test-op) (c system)) + (declare (ignorable o)) + (cons `(load-op ,(component-name c)) (call-next-method))) + + +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations + +(defgeneric* operate (operation-class system &key &allow-other-keys)) +(defgeneric* perform-plan (plan &key)) + +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + ;; 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)))) + t)))) + +;;;; Try to upgrade of ASDF. If a different version was used, return T. +;;;; We need do that before we operate on anything that depends on ASDF. +(defun* upgrade-asdf () + (let ((version (asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (operate 'load-op :asdf :verbose nil)) + (cleanup-upgraded-asdf version))) + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) - -(defun oos (&rest args) - "Alias of OPERATE function" - (apply #'operate args)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; syntax - -(defun remove-keyword (key arglist) - (labels ((aux (key arglist) - (cond ((null arglist) nil) - ((eq key (car arglist)) (cddr arglist)) - (t (cons (car arglist) (cons (cadr arglist) - (remove-keyword - key (cddr arglist)))))))) - (aux key arglist))) + (loop :for (op . component) :in steps :do + (perform-with-restarts op component))))) + +(defmethod operate (operation-class system &rest args + &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force + &allow-other-keys) + (declare (ignore force)) + (with-system-definitions () + (let* ((op (apply 'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) + (system (etypecase system + (system system) + ((or string symbol) (find-system system))))) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((steps (traverse op system))) + (when (and (not (equal '("asdf") (component-find-path system))) + (find '("asdf") (mapcar 'cdr steps) + :test 'equal :key 'component-find-path) + (upgrade-asdf)) + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, then + ;; invalidate all existing system + ;; retry the whole thing with the new OPERATE function, + ;; which on some implementations + ;; has a new symbol shadowing the current one. + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))) + (perform-plan steps) + (values op steps))))) + +(defun* oos (operation-class system &rest args &key force verbose version + &allow-other-keys) + (declare (ignore force verbose version)) + (apply 'operate operation-class system args)) + +(let ((operate-docstring + "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. +")) + (setf (documentation 'oos 'function) + (format nil + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" + operate-docstring)) + (setf (documentation 'operate 'function) + operate-docstring)) + +(defun* load-system (system &rest keys &key force verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. +See OPERATE for details." + (declare (ignore force verbose version)) + (apply 'operate *load-system-operation* system keys) + t) -(defmacro defsystem (name &body options) - (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options - (let ((component-options (remove-keyword :class options))) - `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - #+clisp - (sysdef-error "Cannot redefine the existing system ~A with a different class" s) - #-clisp - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name))))) - (parse-component-form nil (apply - #'list - :module (coerce-name ',name) - :pathname - (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) - *default-pathname-defaults*) - ',component-options)))))) - - -(defun class-for-type (parent type) - (let ((class - (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.(package-name *package*))) - nil))) - (or class - (and (eq type :file) - (or (module-default-component-class parent) - (find-class 'cl-source-file))) - (sysdef-error "~@" type)))) - -(defun maybe-add-tree (tree op1 op2 c) +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + +(defun component-loaded-p (c) + (and (gethash 'load-op (component-operation-times (find-component c nil))) t)) + +(defun 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 (loaded-systems) keys)) + +(defun* compile-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE +for details." + (declare (ignore force verbose version)) + (apply 'operate 'compile-op system args) + t) + +(defun* test-system (system &rest args &key force verbose version + &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for +details." + (declare (ignore force verbose version)) + (apply 'operate 'test-op system args) + t) + +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(defun* load-pathname () + (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) + +(defun* determine-system-pathname (pathname) + ;; The defsystem macro calls us to determine + ;; the pathname of a system as follows: + ;; 1. the one supplied, + ;; 2. derived from *load-pathname* via load-pathname + ;; 3. taken from the *default-pathname-defaults* via default-directory + (let* ((file-pathname (load-pathname)) + (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) + (or (and pathname (subpathname directory-pathname pathname :type :directory)) + directory-pathname + (default-directory)))) + +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + (symbol (find-class x errorp environment)))) + +(defun* class-for-type (parent type) + (or (loop :for symbol :in (list + type + (find-symbol* type *package*) + (find-symbol* type :asdf)) + :for class = (and 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 module = parent :then (component-parent module) :while module + :thereis (module-default-component-class module)) + *default-component-class*) nil)) + (sysdef-error "don't recognize component type ~A" type))) + +(defun* maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. Returns the new tree (which probably shares structure with the old one)" (let ((first-op-tree (assoc op1 tree))) (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) + (if (find c (cdr it) :test #'equal) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) @@ -932,7 +2848,7 @@ Returns the new tree (which probably shares structure with the old one)" tree) (acons op1 (list (list op2 c)) tree)))) -(defun union-of-dependencies (&rest deps) +(defun* union-of-dependencies (&rest deps) (let ((new-tree nil)) (dolist (dep deps) (dolist (op-tree dep) @@ -943,230 +2859,1658 @@ Returns the new tree (which probably shares structure with the old one)" new-tree)) -(defun remove-keys (key-names args) - (loop for ( name val ) on args by #'cddr - unless (member (symbol-name name) key-names - :key #'symbol-name :test 'equal) - append (list name val))) +(defvar *serial-depends-on* nil) -(defvar *serial-depends-on*) +(defun* sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@")) + type name value)) -(defun parse-component-form (parent options) +(defun* check-component-input (type name weakly-depends-on + depends-on components in-order-to) + "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)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(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))) + ;; clear methods, then add the new ones + (setf (component-inline-methods component) nil)) + +(defun* %define-component-inline-methods (ret rest) + (dolist (name +asdf-methods+) + (let ((keyword (intern (symbol-name name) :keyword))) + (loop :for data = rest :then (cddr data) + :for key = (first data) + :for value = (second data) + :while data + :when (eq key keyword) :do + (destructuring-bind (op qual (o c) &body body) value + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))))) + +(defun* %refresh-component-inline-methods (component rest) + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest)) + +(defun* parse-component-form (parent options) (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync - components pathname default-component-class + components pathname perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to + weakly-depends-on depends-on serial in-order-to + do-first + (version nil versionp) ;; list ends &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) (check-component-input type name weakly-depends-on depends-on components in-order-to) (when (and parent - (find-component parent name) - ;; ignore the same object when rereading the defsystem - (not - (typep (find-component parent name) - (class-for-type parent type)))) + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) (error 'duplicate-names :name name)) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) - (ret - (or (find-component parent name) - (make-instance (class-for-type parent type))))) + (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@") + version name parent))) + + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) + (ret (find-component parent name))) (when weakly-depends-on - (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) - (when (boundp '*serial-depends-on*) - (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) - (apply #'reinitialize-instance - ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) + (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + (when *serial-depends-on* + (push *serial-depends-on* depends-on)) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) + (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) - (loop for c-form in components - for c = (parse-component-form ret c-form) - collect c - if serial - do (push (component-name c) *serial-depends-on*)))) - - ;; check for duplicate names - (let ((name-hash (make-hash-table :test #'equal))) - (loop for c in (module-components ret) - do - (if (gethash (component-name c) - name-hash) - (error 'duplicate-names - :name (component-name c)) - (setf (gethash (component-name c) - name-hash) - t))))) - - (setf (slot-value ret 'in-order-to) + (loop + :for c-form :in components + :for c = (parse-component-form ret c-form) + :for name = (component-name c) + :collect c + :when serial :do (setf *serial-depends-on* name)))) + (compute-module-components-by-name ret)) + + (setf (component-load-dependencies ret) depends-on) ;; Used by POIU + + (setf (component-in-order-to ret) (union-of-dependencies in-order-to `((compile-op (compile-op ,@depends-on)) - (load-op (load-op ,@depends-on)))) - (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - - (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) (remove-method (symbol-function n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret)))) - ret))) - -(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) - "A partial test of the values of a component." - (when weakly-depends-on (warn "We got one! XXXXX")) - (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)) - (unless (and (listp in-order-to) (listp (car in-order-to))) - (sysdef-error-component ":in-order-to must be NIL or a list of components." - type name in-order-to))) - -(defun sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") - type name value)) - -(defun resolve-symlinks (path) - #-allegro (truename path) - #+allegro (excl:pathname-resolve-symbolic-links path) - ) + (load-op (load-op ,@depends-on))))) + (setf (component-do-first ret) + (union-of-dependencies + do-first + `((compile-op (load-op ,@depends-on))))) -;;; optional extras + (%refresh-component-inline-methods ret rest) + ret))) -;;; run-shell-command functions for other lisp implementations will be -;;; gratefully accepted, if they do the same thing. If the docstring -;;; is ambiguous, send a bug report +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + +(defun* do-defsystem (name &rest options + &key pathname (class 'system) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) + (component-options (remove-keys '(:class) options))) + (setf (gethash name *systems-being-defined*) system) + (apply 'load-systems defsystem-depends-on) + ;; We change-class (when necessary) AFTER we load the defsystem-dep's + ;; since the class might not be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-pathname pathname) + component-options))))) -(defun run-shell-command (control-string &rest args) +(defmacro defsystem (name &body options) + `(apply 'do-defsystem ',name ',options)) + +;;;; --------------------------------------------------------------------------- +;;;; run-shell-command +;;;; +;;;; run-shell-command functions for other lisp implementations will be +;;;; gratefully accepted, if they do the same thing. +;;;; If the docstring is ambiguous, send a bug report. +;;;; +;;;; WARNING! The function below is mostly dysfunctional. +;;;; For instance, it will probably run fine on most implementations on Unix, +;;;; which will hopefully use the shell /bin/sh (which we force in some cases) +;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell. +;;;; But behavior on Windows may vary wildly between implementations, +;;;; either relying on your having installed a POSIX sh, or going through +;;;; the CMD.EXE interpreter, for a totally different meaning, depending on +;;;; what is easily expressible in said implementation. +;;;; +;;;; We probably should move this functionality to its own system and deprecate +;;;; use of it from the asdf package. However, this would break unspecified +;;;; existing software, so until a clear alternative exists, we can't deprecate +;;;; it, and even after it's been deprecated, we will support it for a few +;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 +;;;; +;;;; As a suggested replacement which is portable to all ASDF-supported +;;;; implementations and operating systems except Genera, I recommend +;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives. + +(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." - (let ((command (apply #'format nil control-string args))) - (format *verbose-out* "; $ ~A~%" command) - #+sbcl - (sb-ext:process-exit-code - (sb-ext:run-program - #+win32 "sh" #-win32 "/bin/sh" - (list "-c" command) - #+win32 #+win32 :search t - :input nil :output *verbose-out*)) + (let ((command (apply 'format nil control-string args))) + (asdf-message "; $ ~A~%" command) + + #+abcl + (ext:run-shell-command command :output *verbose-out*) + + #+allegro + ;; will this fail if command has embedded quotes - it seems to work + (multiple-value-bind (stdout stderr exit-code) + (excl.osi:command-output + #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command) + #+mswindows command ; BEWARE! + :input nil :whole nil + #+mswindows :show-window #+mswindows :hide) + (asdf-message "~{~&~a~%~}~%" stderr) + (asdf-message "~{~&~a~%~}~%" stdout) + exit-code) + + #+clisp + ;; CLISP returns NIL for exit status zero. + (if *verbose-out* + (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" + command)) + (outstream (ext:run-shell-command new-command :output :stream :wait t))) + (multiple-value-bind (retval out-lines) + (unwind-protect + (parse-clisp-shell-output outstream) + (ignore-errors (close outstream))) + (asdf-message "~{~&~a~%~}~%" out-lines) + retval)) + ;; there will be no output, just grab up the exit status + (or (ext:run-shell-command command :output nil :wait t) 0)) + + #+clozure + (nth-value 1 + (ccl:external-process-status + (ccl:run-program + (cond + ((os-unix-p) "/bin/sh") + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! + (t (error "Unsupported OS"))) + (if (os-unix-p) (list "-c" command) '()) + :input nil :output *verbose-out* :wait t))) #+(or cmu scl) (ext:process-exit-code (ext:run-program "/bin/sh" - (list "-c" command) + (list "-c" command) :input nil :output *verbose-out*)) - #+allegro - (excl:run-shell-command command :input nil :output *verbose-out*) - - #+lispworks - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :output-stream *verbose-out*) - - #+clisp ;XXX not exactly *verbose-out*, I know - (ext:run-shell-command command :output :terminal :wait t) + #+cormanlisp + (win32:system command) - #+openmcl - (nth-value 1 - (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output *verbose-out* - :wait t))) #+ecl ;; courtesy of Juan Jose Garcia Ripoll - (si:system command) - #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) - (error "RUN-SHELL-PROGRAM not implemented for this Lisp") - )) + (ext:system command) + + #+gcl + (lisp:system command) + #+lispworks + (apply 'system:call-system-showing-output command + :show-cmd nil :prefix "" :output-stream *verbose-out* + (when (os-unix-p) '(:shell-type "/bin/sh"))) + + #+mcl + (ccl::with-cstrs ((%command command)) (_system %command)) + + #+mkcl + ;; This has next to no chance of working on basic Windows! + ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH. + (multiple-value-bind (io process exit-code) + (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh" + (list "-c" command) + :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it + #-windows '(:search nil)) + (declare (ignore io process)) + exit-code) -(defgeneric hyperdocumentation (package name doc-type)) -(defmethod hyperdocumentation ((package symbol) name doc-type) - (hyperdocumentation (find-package package) name doc-type)) + #+sbcl + (sb-ext:process-exit-code + (apply 'sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out* + #+win32 '(:search t) #-win32 nil)) + + #+xcl + (ext:run-shell-command command) + + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl) + (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) + +#+clisp +(defun* parse-clisp-shell-output (stream) + "Helper function for running shell commands under clisp. Parses a specially- +crafted output string to recover the exit status of the shell command and a +list of lines of output." + (loop :with status-prefix = "ASDF-EXIT-STATUS " + :with prefix-length = (length status-prefix) + :with exit-status = -1 :with lines = () + :for line = (read-line stream nil nil) + :while line :do (push line lines) :finally + (let* ((last (car lines)) + (status (and last (>= (length last) prefix-length) + (string-equal last status-prefix :end1 prefix-length) + (parse-integer last :start prefix-length :junk-allowed t)))) + (when status + (setf exit-status status) + (pop lines) (when (equal "" (car lines)) (pop lines))) + (return (values exit-status (reverse lines)))))) + +;;;; --------------------------------------------------------------------------- +;;;; system-relative-pathname + +(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + +(defmethod system-source-file ((system system)) + ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed + (unless (slot-boundp system 'source-file) + (%set-system-source-file + (probe-asd (component-name system) (component-pathname system)) system)) + (%system-source-file system)) +(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* relativize-directory (directory) + (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 (pathname-directory p)) + :defaults p))) + +(defun* system-relative-pathname (system name &key type) + (subpathname (system-source-directory system) name :type type)) + + +;;; --------------------------------------------------------------------------- +;;; implementation-identifier +;;; +;;; produce a string to identify current implementation. +;;; Initially stolen from SLIME's SWANK, rewritten since. +;;; We're back to runtime checking, for the sake of e.g. ABCL. + +(defun* first-feature (features) + (dolist (x features) + (multiple-value-bind (val feature) + (if (consp x) (values (first x) (cons :or (rest x))) (values x x)) + (when (featurep feature) (return val))))) + +(defun implementation-type () + (first-feature + '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu + :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) + +(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 :amd64 :x86-64 :x86_64 :x8664-target (: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))))) + +(defun* hostname () + ;; Note: untested on RMCL + #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+cormanlisp "localhost" ;; is there a better way? Does it matter? + #+allegro (excl.osi:gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) + + +;;; --------------------------------------------------------------------------- +;;; Generic support for configuration files + +(defun inter-directory-separator () + (if (os-unix-p) #\: #\;)) + +(defun* user-homedir () + (truenamize + (pathname-directory-pathname + #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) + #+mcl (current-user-homedir-pathname) + #-(or cormanlisp mcl) (user-homedir-pathname)))) + +(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args) + (when (plusp (length x)) + (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)))) + (when want-absolute + (unless (absolute-pathname-p p) + (cerror "ignore relative pathname" + "Invalid relative pathname ~A~@[ ~?~]" x fmt args) + (return-from ensure-pathname* nil))) + p))) +(defun* split-pathnames* (x want-absolute want-directory fmt &rest args) + (loop :for dir :in (split-string + x :separator (string (inter-directory-separator))) + :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args))) +(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) + (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x)) +(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) + (and (plusp (length s)) + (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s))) +(defun* getenv-absolute-directory (x) + (getenv-pathname x :want-absolute t :want-directory t)) +(defun* getenv-absolute-directories (x) + (getenv-pathnames x :want-absolute t :want-directory t)) + +(defun* 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) ".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) + (aif + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (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* hidden-file-p (pathname) + (equal (first-char (pathname-name pathname)) #\.)) + +(defun* directory* (pathname-spec &rest keys &key &allow-other-keys) + (apply 'directory pathname-spec + (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+clozure '(:follow-links nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl) + '(:resolve-symlinks nil)))))) + +(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." + (let ((files (sort (ignore-errors + (remove-if + 'hidden-file-p + (directory* (make-pathname :name :wild :type "conf" :defaults directory)))) + #'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))) + + +;;; --------------------------------------------------------------------------- +;;; asdf-output-translations +;;; +;;; this code is heavily inspired from +;;; asdf-binary-translations, common-lisp-controller and cl-launch. +;;; --------------------------------------------------------------------------- + +(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.") + +(defvar *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)))) + +(defun* output-translations () + (car *output-translations*)) + +(defun* (setf output-translations) (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) + new-value) + +(defun* output-translations-initialized-p () + (and *output-translations* t)) + +(defun* clear-output-translations () + "Undoes any initialization of the output translations. +You might want to call that before you dump an image that would be resumed +with a different configuration, so the configuration would be re-read then." + (setf *output-translations* '()) + (values)) + +(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) + (values (or null pathname) &optional)) + resolve-location)) + +(defun* resolve-relative-location-component (x &key directory wilden) + (let ((r (etypecase x + (pathname x) + (string (coerce-pathname x :type (when directory :directory))) + (cons + (if (null (cdr x)) + (resolve-relative-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + (car x) :directory t :wilden nil))) + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :directory directory :wilden wilden) + car)))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (coerce-pathname (implementation-identifier) :type :directory)) + ((eql :implementation-type) + (coerce-pathname (string-downcase (implementation-type)) :type :directory)) + ((eql :hostname) + (coerce-pathname (hostname) :type :directory))))) + (when (absolute-pathname-p r) + (error (compatfmt "~@") x)) + (if (or (pathnamep x) (not wilden)) r (wilden r)))) + +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + +(defun* resolve-absolute-location-component (x &key directory wilden) + (let* ((r + (etypecase x + (pathname x) + (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if directory (ensure-directory-pathname p) p))) + (cons + (return-from resolve-absolute-location-component + (if (null (cdr x)) + (resolve-absolute-location-component + (car x) :directory directory :wilden wilden) + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :directory directory :wilden wilden) + (resolve-absolute-location-component + (car x) :directory t :wilden nil))))) + ((eql :root) + ;; special magic! we encode such paths as relative pathnames, + ;; but it means "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location-component + (let ((p (make-pathname :directory '(:relative)))) + (if wilden (wilden p) p)))) + ((eql :home) (user-homedir)) + ((eql :here) + (resolve-location (or *here-directory* + ;; give semantics in the case of use interactively + :default-directory) + :directory t :wilden nil)) + ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) + ((eql :system-cache) + (error "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration")) + ((eql :default-directory) (default-directory)))) + (s (if (and wilden (not (pathnamep x))) + (wilden r) + r))) + (unless (absolute-pathname-p s) + (error (compatfmt "~@") x)) + s)) + +(defun* resolve-location (x &key directory wilden) + (if (atom x) + (resolve-absolute-location-component x :directory directory :wilden wilden) + (loop :with path = (resolve-absolute-location-component + (car x) :directory (and (or directory (cdr x)) t) + :wilden (and wilden (null (cdr x)))) + :for (component . morep) :on (cdr x) + :for dir = (and (or morep directory) t) + :for wild = (and wilden (not morep)) + :do (setf path (merge-pathnames* + (resolve-relative-location-component + component :directory dir :wilden wild) + path)) + :finally (return path)))) + +(defun* location-designator-p (x) + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache :system-cache :default-directory)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :default-directory :*/ :**/ :*.*.* + :implementation :implementation-type))))) + (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))))) + +(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. + #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t))) + (when h `((,(truenamize h) ,*wild-inferiors*) ()))) + ;; The below two are not needed: no precompiled ASDF system there + #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ()) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; We enable the user cache by default, and here is the place we do: + :enable-user-cache)) + +(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) +(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) + +(defun* user-output-translations-pathname (&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)) +(declaim (ftype (function (t &key (:collect (or symbol function))) t) + inherit-output-translations)) +(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) + process-output-translations-directive)) + +(defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) +(defmethod process-output-translations ((pathname pathname) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file* pathname) + (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* 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 :directory t :wilden t))) + (if (absolute-pathname-p loc) (truenamize 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 :directory t :wilden t) + trusrc)) + (wilddst (merge-pathnames* *wild-file* trudst))) + (funcall collect (list wilddst t)) + (funcall collect (list trusrc trudst))))))))))) + +(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* 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)))) + +(defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop :with p = (truenamize 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))))) + +(defmethod output-files :around (operation component) + "Translate output files, unless asked not to" + operation component ;; hush genera, not convinced by declare ignorable(!) + (values + (multiple-value-bind (files fixedp) (call-next-method) + (if fixedp + files + (mapcar #'apply-output-translations files))) + t)) + +(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (if (absolute-pathname-p output-file) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) + (apply-output-translations + (apply 'compile-file-pathname input-file + (if output-file keys (remove-keyword :output-file keys)))))) + +(defun* tmpize-pathname (x) + (make-pathname + :name (strcat "ASDF-TMP-" (pathname-name x)) + :defaults x)) + +(defun* delete-file-if-exists (x) + (when (and x (probe-file* x)) + (delete-file x))) + +(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys) + (let* ((keywords (remove-keyword :compile-check keys)) + (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) + (tmp-file (tmpize-pathname output-file)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keywords) + (cond + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) + (t + (setf status :success))) + (cond + ((and (ecase status + ((:success :warn :ignore) t) + ((:error nil))) + (or (not compile-check) + (apply compile-check input-file :output-file tmp-file keywords))) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (t ;; error or failed check + (delete-file-if-exists output-truename) + (setf output-truename nil failure-p t))) + (values output-truename warnings-p failure-p)))) + +#+abcl +(defun* translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (let* ((p (pathname (first (pathname-device source)))) + (root (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device p))))) + (apply-output-translations + (merge-pathnames* + (relativize-pathname-directory source) + (merge-pathnames* + (relativize-pathname-directory (ensure-directory-pathname p)) + root))))) + +;;;; ----------------------------------------------------------------- +;;;; Compatibility mode for ASDF-Binary-Locations + +(defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L."))) + +(defun* enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + (subpathname (user-homedir) ".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)) + #+(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* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) + (mapped-files (if map-all-source-files *wild-file* + (make-pathname :type fasl-type :defaults *wild-file*))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + ,@source-to-target-mappings + ((:root ,*wild-inferiors* ,mapped-files) + (,@destination-directory ,mapped-files)) + (t t) + :ignore-inherited-configuration)))) + +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 + +;; 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. +You might want to call that before you dump an image that would be resumed +with a different configuration, so the configuration would be re-read then." + (setf *source-registry* nil) + (values)) + +(defparameter *wild-asd* + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) + +(defun* filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (typep f 'logical-pathname) f) + (let* ((u (ignore-errors (funcall merger f)))) + ;; 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 doesn't have :version :newest + (and u (equal (ignore-errors (truename u)) (truename f)) u))) + :when p :collect p) + entries)) + +(defun* directory-files (directory &optional (pattern *wild-file*)) + (let ((dir (pathname directory))) + (when (typep dir 'logical-pathname) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (error "Invalid wild pattern in logical directory ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f)))))))) + +(defun* directory-asd-files (directory) + (directory-files directory *wild-asd*)) + +(defun* 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-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + +(defun* collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) + +(defun* collect-sub*directories-asd-files + (directory &key + (exclude *default-source-registry-exclusions*) + collect) + (collect-sub*directories + directory + (constantly t) + #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) + #'(lambda (dir) (collect-asds-in-directory dir collect)))) + +(defun* validate-source-registry-directive (directive) + (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* (coerce-pathname "source-registry.conf")) +(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/")) + +(defun* wrapping-source-registry () + `(:source-registry + #+ecl (:tree ,(translate-logical-pathname "SYS:")) + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) + #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) + :inherit-configuration + #+cmu (:tree #p"modules:") + #+scl (:tree #p"file://modules/"))) +(defun* default-source-registry () + `(:source-registry + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) + (:directory ,(default-directory)) + ,@(loop :for dir :in + `(,@(when (os-unix-p) + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (subpathname (user-homedir) ".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)) +(declaim (ftype (function (t &key (:register (or symbol function))) t) + inherit-source-registry)) +(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) + process-source-registry-directive)) + +(defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) +(defmethod process-source-registry ((pathname pathname) &key inherit register) + (cond + ((directory-pathname-p pathname) + (let ((*here-directory* (truenamize pathname))) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register))) + ((probe-file* pathname) + (let ((*here-directory* (pathname-directory-pathname pathname))) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register))) + (t + (inherit-source-registry inherit :register register)))) +(defmethod process-source-registry ((string string) &key inherit register) + (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* 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 :directory t))))) + ((:tree) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :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) -(defun hyperdoc (name doc-type) - (hyperdocumentation (symbol-package name) name doc-type)) +(defun* flatten-source-registry (&optional parameter) + (remove-duplicates + (while-collecting (collect) + (let ((*default-pathname-defaults* (default-directory))) + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register #'(lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude)))))) + :test 'equal :from-end t)) + +;; Will read the configuration and initialize all internal variables. +(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 *asdf-verbose* + (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*)) + (setf *source-registry-parameter* parameter) + (setf *source-registry* (make-hash-table :test 'equal)) + (compute-source-registry parameter)) + +;; Checks an initial variable to see whether the state is initialized +;; or cleared. In the former case, return current configuration; in +;; 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 (coerce-name system) *source-registry*))) + +(defun* clear-configuration () + (clear-source-registry) + (clear-output-translations)) + + +;;; ECL and MKCL support for COMPILE-OP / LOAD-OP +;;; +;;; In ECL and MKCL, these operations produce both +;;; FASL files and the object files that they are built from. +;;; Having both of them allows us to later on reuse the object files +;;; for bundles, libraries, standalone executables, etc. +;;; +;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes +;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. +;;; +;;; Also, register-pre-built-system. +#+(or ecl mkcl) +(progn + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) + + #+(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* + :unless (eq f 'module-provide-asdf) + :collect #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l))))) + + (setf *compile-op-compile-file-function* 'compile-file-keeping-object) + + (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys) + (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys) + #+mkcl progn + (multiple-value-bind (object-file flags1 flags2) + (apply 'compile-file* input-file + #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys) + (values (and object-file + (compiler::build-fasl + (compile-file-pathname object-file + #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t) + #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)) + object-file) + flags1 + flags2))))) + +;;;; ----------------------------------------------------------------------- +;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL +;;;; +(defun* module-provide-asdf (name) + (handler-bind + ((style-warning #'muffle-warning) + #-genera + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream)) + (system (find-system (string-downcase name) nil))) + (when system + (require-system system :verbose nil) + t)))) + +#+(or abcl clisp clozure cmu ecl mkcl sbcl) +(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) + (when x + (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*)))) + + +;;;; ------------------------------------------------------------------------- +;;;; Cleanups after hot-upgrade. +;;;; Things to do in case we're upgrading from a previous version of ASDF. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; + +;;; If a previous version of ASDF failed to read some configuration, try again. +(when *ignored-configuration-form* + (clear-configuration) + (setf *ignored-configuration-form* nil)) + +;;;; ----------------------------------------------------------------- +;;;; Done! +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) + +#+mkcl +(progn + (defvar *loading-asdf-bundle* nil) + (unless *loading-asdf-bundle* + (let ((*central-registry* + (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*)) + (*loading-asdf-bundle* t)) + (clear-system :asdf-bundle) ;; we hope to force a reload. + (multiple-value-bind (result bundling-error) + (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle)) + (unless result + (format *error-output* + "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%" + bundling-error)))))) + +#+allegro +(eval-when (:compile-toplevel :execute) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) (pushnew :asdf *features*) +(pushnew :asdf2 *features*) -#+sbcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") - (pushnew :sbcl-hooks-require *features*))) +(provide :asdf) -#+(and sbcl sbcl-hooks-require) -(progn - (defun module-provide-asdf (name) - (handler-bind ((style-warning #'muffle-warning)) - (let* ((*verbose-out* (make-broadcast-stream)) - (system (asdf:find-system name nil))) - (when system - (asdf:operate 'asdf:load-op name) - t)))) - - (defun contrib-sysdef-search (system) - (let* ((name (coerce-name system)) - (home (truename (sb-ext:posix-getenv "SBCL_HOME"))) - (contrib (merge-pathnames - (make-pathname :directory `(:relative ,name) - :name name - :type "asd" - :case :local - :version :newest) - home))) - (probe-file contrib))) - - (pushnew - '(merge-pathnames "site-systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - *central-registry*) - - (pushnew - '(merge-pathnames ".sbcl/systems/" - (user-homedir-pathname)) - *central-registry*) - - (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) - (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) - -(provide 'asdf) +;;; Local Variables: +;;; mode: lisp +;;; End: