diff --git a/.gitignore b/.gitignore index 9216362dd69613fe0e8bd6308017267a24386fa2..342f79ddeb472b9592592b6883b87463eb802ace 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,10 @@ # really this is private to my build process -push -resbcl -reccl -reecl -regcl +? +?? +??? +???? +????? +generate-asdf.lisp # Temporary files from documentation build doc/asdf/ @@ -53,4 +54,4 @@ debian/files debian/patches/ .pc -/.DS_Store \ No newline at end of file +/.DS_Store diff --git a/Makefile b/Makefile index 7d57cee61425a4c40d73c999cc6e00ad6df06c95..426e7468bab80c407f7e4b395ca352713a7b53df 100644 --- a/Makefile +++ b/Makefile @@ -43,7 +43,7 @@ archive: --eval "(rewrite-license)" --eval "(quit)" bin/make-tarball -archive-copy: archive +archive-copy: archive tmp/asdf.lisp git checkout release bin/rsync-cp tmp/asdf*.tar.gz $(webhome_private)/archives bin/link-tarball $(clnet_home) @@ -51,6 +51,10 @@ archive-copy: archive ${MAKE} push git checkout master +tmp/asdf.lisp: $(wildcard *.lisp) + mkdir -p tmp + cat header.lisp package.lisp implementation.lisp utility.lisp upgrade.lisp pathname.lisp os.lisp component.lisp system.lisp find-system.lisp find-component.lisp lisp-build.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp configuration.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp user.lisp footer.lisp > $@ + push: git status git push --tags cl.net release master @@ -139,8 +143,8 @@ test-upgrade: { echo "upgrade FAILED" ; exit 1 ;} ;; esac ; \ done ; done 2>&1 | tee tmp/results/${lisp}-upgrade.text -test-forward-references: - ${SBCL} --noinform --no-userinit --no-sysinit --load asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null +test-forward-references: tmp/asdf.lisp + ${SBCL} --noinform --no-userinit --no-sysinit --load tmp/asdf.lisp --load test/script-support.lisp --eval '(asdf-test::exit-lisp 0)' 2>&1 | cmp - /dev/null test-lisp: @cd test; ${MAKE} clean;./run-tests.sh ${lisp} ${test-glob} @@ -173,13 +177,13 @@ debian-package: mrproper # Replace SBCL's ASDF with the current one. -- Not recommended now that SBCL has ASDF2. # for casual users, just use (asdf:load-system :asdf) -replace-sbcl-asdf: - ${SBCL} --eval '(compile-file "asdf.lisp" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)' +replace-sbcl-asdf: tmp/asdf.lisp + ${SBCL} --eval '(compile-file "$<" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)' # Replace CCL's ASDF with the current one. -- Not recommended now that CCL has ASDF2. # for casual users, just use (asdf:load-system :asdf) -replace-ccl-asdf: - ${CCL} --eval '(progn(compile-file "asdf.lisp" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))' +replace-ccl-asdf: tmp/asdf.lisp + ${CCL} --eval '(progn(compile-file "$<" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))' WRONGFUL_TAGS := 1.37 1.1720 README RELEASE STABLE # Delete wrongful tags from local repository diff --git a/action.lisp b/action.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f6479213aec76056350beb734997c8e912de45c2 --- /dev/null +++ b/action.lisp @@ -0,0 +1,234 @@ +;;;; ------------------------------------------------------------------------- +;;;; Actions + +(defpackage :asdf/action + (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation) + #+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of) + (:export + #:action + #:explain #:operation-description + #:downward-operation #:upward-operation + #:file-component + #:source-file #:c-source-file #:java-source-file + #:static-file #:doc-file #:html-file + #:operation-error #:error-component #:error-operation + #:component-depends-on #:component-self-dependencies + #:input-files #:output-files #:output-file #:operation-done-p + #:action-status #:action-stamp #:action-done-p + #:component-operation-time #:mark-operation-done #:compute-action-stamp + #:perform #:perform-with-restarts #:retry #:accept)) +(in-package :asdf/action) + +(deftype action () '(cons operation component)) ;; a step to be performed while building the system + +;;;; self-description + +(defgeneric* operation-description (operation component) ;; ASDF3: rename to action-description + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) +(defmethod operation-description (operation component) + (format nil (compatfmt "~@<~A on ~A~@:>") + (class-of operation) component)) + +(defgeneric* explain (operation component)) +(defmethod explain ((o operation) (c component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c))) + + +;;;; Error + +(define-condition operation-error (error) ;; Bad, backward-compatible name + ;; We want to rename it to action-error, but that breaks upgrade on SBCL. + ;; Before to rename it, fix these other culprits, too: + ;; cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) + + +;;;; Dependencies + +(defgeneric* component-depends-on (operation component) ;; ASDF3: rename to component-dependencies + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + (<operation> <component>*), where <operation> is a class + designator and each <component> is a component + designator, which means that the component depends on + <operation> having been performed on each <component>; or + + (FEATURE <feature>), which means that the component depends + on <feature>'s presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) +(defgeneric* component-self-dependencies (operation component)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies + +(defmethod component-self-dependencies ((o operation) (c component)) + (loop :for (o-spec . c-spec) :in (component-depends-on o c) + :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature" + :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep))) + :collect (cons (find-operation o o-spec) c))) + +;;;; upward-operation, downward-operation +;; These together handle actions that propagate along the component hierarchy. +;; Downward operations like load-op or compile-op propagate down the hierarchy: +;; operation on a parent depends-on operation on its children. +(defclass downward-operation (operation) ()) +;; Upward operations like prepare-op propagate up the component hierarchy: +;; operation on a child depends-on operation on its parent. +(defclass upward-operation (operation) ()) + +(defmethod component-depends-on ((o downward-operation) (c parent-component)) + `((,o ,@(component-children c)) ,@(call-next-method))) +;; For backward-compatibility reasons, a system inherits from module and is a child-component +;; so we must guard against this case. ASDF3: remove that. +(defmethod component-depends-on ((o upward-operation) (c child-component)) + `(,@(aif (component-parent c) `((,o ,it))) ,@(call-next-method))) + + +;;;; Inputs, Outputs, and invisible dependencies +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) +(defgeneric* operation-done-p (operation component) + (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) + +(defmethod operation-done-p ((o operation) (c component)) + (declare (ignorable o c)) + t) + +(defmethod output-files ((o operation) (c component)) + (declare (ignorable o c)) + nil) +(defun* output-file (operation component) + "The unique output file of performing OPERATION on COMPONENT" + (let ((files (output-files operation component))) + (assert (length=n-p files 1)) + (first files))) + +(defmethod input-files ((o operation) (c parent-component)) + (declare (ignorable o c)) + nil) + + +;;;; File components + +(defclass file-component (child-component) + ((type :accessor file-type :initarg :type))) ; no default +(defclass source-file (file-component) + ((type :initform nil))) ;; NB: many systems have come to rely on this default. +(defclass c-source-file (source-file) + ((type :initform "c"))) +(defclass java-source-file (source-file) + ((type :initform "java"))) +(defclass static-file (source-file) + ((type :initform nil))) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) + ((type :initform "html"))) + +(defmethod input-files ((o operation) (c file-component)) + (or (loop :for (dep-o) :in (component-self-dependencies o c) + :append (or (output-files dep-o c) (input-files dep-o c))) + ;; no non-trivial previous operations needed? + ;; I guess we work with the original source file, then + (list (component-pathname c)))) + +(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename. + (declare (ignorable component system)) + :directory) +(defmethod source-file-type ((component file-component) system) + (declare (ignorable system)) + (file-type component)) + + +;;;; Done performing + +(defgeneric* component-operation-time (operation component)) ;; ASDF3: hide it behind plan-action-stamp +(defgeneric* mark-operation-done (operation component)) ;; ASDF3: hide it behind (setf plan-action-stamp) +(defgeneric* compute-action-stamp (plan operation component &key just-done) + (:documentation "Has this action been successfully done already, +and at what known timestamp has it been done at or will it be done at? +Takes two keywords JUST-DONE and PLAN: +JUST-DONE is a boolean that is true if the action was just successfully performed, +at which point we want compute the actual stamp and warn if files are missing; +otherwise we are making plans, anticipating the effects of the action. +PLAN is a plan object modelling future effects of actions, +or NIL to denote what actually happened. +Returns two values: +* a STAMP saying when it was done or will be done, + or T if the action has involves files that need to be recomputed. +* a boolean DONE-P that indicates whether the action has actually been done, + and both its output-files and its in-image side-effects are up to date.")) + +(defclass action-status () + ((stamp + :initarg :stamp :reader action-stamp + :documentation "STAMP associated with the ACTION if it has been completed already +in some previous image, or T if it needs to be done.") + (done-p + :initarg :done-p :reader action-done-p + :documentation "a boolean, true iff the action was already done (before any planned action).")) + (:documentation "Status of an action")) + +(defmethod print-object ((status action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) + +(defmethod component-operation-time ((o operation) (c component)) + (gethash (type-of o) (component-operation-times c))) + +(defmethod mark-operation-done ((o operation) (c component)) + (setf (gethash (type-of o) (component-operation-times c)) + (compute-action-stamp nil o c :just-done t))) + + +;;;; Perform + +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) + +(defmethod perform :before ((o operation) (c component)) + (ensure-all-directories-exist (output-files o c))) +(defmethod perform :after ((o operation) (c component)) + (mark-operation-done o c)) +(defmethod perform ((o operation) (c parent-component)) + (declare (ignorable o c)) + nil) +(defmethod perform ((o operation) (c source-file)) + (sysdef-error + (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>") + (class-of o) (class-of c))) + +(defmethod perform-with-restarts (operation component) + ;; TOO verbose, especially as the default. Add your own :before method + ;; to perform-with-restart or perform if you want that: + #|(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 "~@<Retry ~A.~@:>") + (operation-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") + (operation-description operation component))) + (mark-operation-done operation component) + (return))))) + diff --git a/asdf.asd b/asdf.asd index f45aa735663970ddc31d5b462865ce9f3f8354e9..9f246d4599e720caaa2df40906077193780ee1c2 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.61" ;; to be automatically updated by bin/bump-revision + :version "2.26.62" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/asdf.lisp b/asdf.lisp deleted file mode 100644 index 0e1ff3c01545ee22d3499d6d6b5f7ff283acaeb2..0000000000000000000000000000000000000000 --- a/asdf.lisp +++ /dev/null @@ -1,5322 +0,0 @@ -;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.61: Another System Definition Facility. -;;; -;;; Feedback, bug reports, and patches are all welcome: -;;; please mail to <asdf-devel@common-lisp.net>. -;;; Note first that the canonical source for ASDF is presently -;;; <URL:http://common-lisp.net/project/asdf/>. -;;; -;;; If you obtained this copy from anywhere else, and you experience -;;; trouble using it, or find bugs, you may want to check at the -;;; location above for a more recent version (and for documentation -;;; and test files, if your copy came without them) before reporting -;;; bugs. There are usually two "supported" revisions - the git master -;;; branch is the latest development version, whereas the git release -;;; branch may be slightly older but is considered `stable' - -;;; -- LICENSE START -;;; (This is the MIT / X Consortium license as taken from -;;; http://www.opensource.org/licenses/mit-license.html on or about -;;; Monday; July 13, 2009) -;;; -;;; Copyright (c) 2001-2012 Daniel Barlow and contributors -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining -;;; a copy of this software and associated documentation files (the -;;; "Software"), to deal in the Software without restriction, including -;;; without limitation the rights to use, copy, modify, merge, publish, -;;; distribute, sublicense, and/or sell copies of the Software, and to -;;; permit persons to whom the Software is furnished to do so, subject to -;;; the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be -;;; included in all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;;; -;;; -- LICENSE END - -;;; The problem with writing a defsystem replacement is bootstrapping: -;;; we can't use defsystem to compile it. Hence, all in one file. - -#+xcvb (module ()) - -(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. - -(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 'ignorable pcl::*variable-declarations-without-argument*) - (pushnew :gcl<2.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)))) - -#+gcl (defpackage :asdf (:use :cl) ;; GCL treats defpackage magically and needs this - #+gcl<2.7 (:shadowing-import-from :system :*load-pathname*) ;; GCL 2.6 sucks - #+gcl<2.7 (:shadow :type-of)) - -(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 - - ;;; Important notice for whom it concerns. The crux of the matter is that - ;;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. - (defun asdf-upgrade-error () - (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ - Otherwise, when you upgrade ASDF, you must do it before you operate on any system.~%")) - - ;;; 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) - (loop :for (unsupported . replacement) :in - (append - '(("~3i~_" . "")) - #+(or genera gcl<2.7) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :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.61") - (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))) - #-ecl (ensure-fmakunbound (package symbols) - (loop :for name :in symbols - :for sym = (find-symbol* name package) - :when sym :do (fmakunbound sym))) - #-ecl (ensure-fmakunbound-setf (package symbols) - (loop :for name :in symbols - :for sym = (find-symbol* name package) - :when sym :do #-gcl (fmakunbound `(setf ,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 fmakunbound fmakunbound-setf) - (let* ((p (ensure-exists name nicknames use))) - #-ecl (ensure-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL - #-ecl (ensure-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf - (ensure-unintern p unintern) - (ensure-shadow p shadow) - (ensure-export p export) - p))) - (macrolet - ((pkgdcl (name &key nicknames use export - fmakunbound fmakunbound-setf unintern shadow) - `(ensure-package - ',name :nicknames ',nicknames :use ',use :export ',export - :shadow ',shadow :unintern ',unintern - :fmakunbound ',fmakunbound :fmakunbound-setf ',fmakunbound-setf))) - (pkgdcl - :asdf - :use (:common-lisp) - :fmakunbound - (#:perform #:explain #:output-files #:operation-done-p #:traverse-action #:traverse - #:compute-action-stamp #:component-load-dependencies #:action-valid-p - #:component-depends-on #:perform-plan #:mark-operation-done #:operation-forced - #:perform-with-restarts #:component-relative-pathname - #:system-source-file #:operate #:find-system #:find-component #:find-operation - #:apply-output-translations #:translate-pathname* #:resolve-location - #:system-relative-pathname #:source-file-type #:builtin-system-p - #:inherit-source-registry #:process-source-registry #:process-source-registry-directive - #:compile-file* #:source-file-type #:trivial-system-p) - :fmakunbound-setf (#:output-translations) - :unintern - (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector - #:do-dep #:do-one-dep #:do-traverse #:visit-action #:component-visited-p - #+(or ecl mkcl) #:output-files #+ecl #:trivial-system-p - #:loaded-systems ; makes for annoying SLIME completion - #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function - :export - (#:defsystem #:find-system #:locate-system #:coerce-name - #:oos #:operate #:traverse #:perform-plan - #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component #:component-find-path - #:compile-system #:load-system #:load-systems - #:require-system #:test-system #:clear-system - #:operation #:upward-operation #:downward-operation - #:load-op #:prepare-op #:compile-op #:load-fasl-op - #:prepare-source-op #:load-source-op #:test-op - #:feature #:version #:version-satisfies #:upgrade-asdf - #:implementation-identifier #:implementation-type #:hostname - #:input-files #:output-files #:output-file #:perform - #:operation-done-p #:explain #:component-sibling-dependencies - #:component-load-dependencies #:run-shell-command ; deprecated, do not use - #:precompiled-system #:compiled-file - #+ecl #:make-build #+mkcl #:bundle-system - - #:component #:parent-component #:child-component #:system #:module - #:source-file #:c-source-file #:java-source-file - #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp - #:static-file #:doc-file #:html-file :text-file - #:source-file-type - #:unix-dso - - #:component-children ; component accessors - #:component-children-by-name - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - #:component-encoding - #:component-external-format - - #:component-depends-on ; backward-compatible name rather than action-depends-on - #:module-components ; backward-compatibility - #:operation-on-warnings #:operation-on-failure ; backward-compatibility - - #: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 - - #:*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 #:already-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))) - #+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 #+(or mkcl sbcl) :error #+clisp :ignore :warn) - "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) -when compiling a file? 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) - -(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-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 - component-children component-children-by-name - circular-dependency-actions - condition-arguments condition-form - condition-format condition-location - coerce-name) - (ftype (function (&optional t) (values)) initialize-source-registry) - #-(or cormanlisp gcl<2.7) - (ftype (function (t t) t) (setf component-children-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))))))")) - -#+genera -(unless (fboundp 'ensure-directories-exist) - (defun ensure-directories-exist (path) - (fs:create-directories-recursively (pathname path)))) - -#+gcl<2.7 -(progn ;; Doesn't support either logical-pathnames or output-translations. - (deftype logical-pathname () nil) - (defun wild-pathname-p (path) (declare (ignore path)) nil) - (defun translate-logical-pathname (x) x) - (defvar *compile-file-pathname* nil) - (defun pathname-match-p (in-pathname wild-pathname) - (declare (ignore in-wildname wild-wildname)) nil) - (defun translate-pathname (source from-wildname to-wildname &key) - (declare (ignore from-wildname to-wildname)) source) - (defun type-of (x) (class-name (class-of x))) - (defun %print-unreadable-object (object stream type identity thunk) - (format stream "#<~@[~S ~]" (when type (type-of object))) - (funcall thunk) - (format stream "~@[ ~X~]>" (when identity (system:address object)))) - (defmacro with-compilation-unit (options &body body) - (declare (ignore options)) `(progn ,@body)) - (defmacro print-unreadable-object ((object stream &key type identity) &body body) - `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body))) - (defun ensure-directories-exist (path) - (run-shell-command "mkdir -p ~S" (namestring (pathname-directory-pathname path))))) - -;;;; ------------------------------------------------------------------------- -;;;; General Purpose Utilities - -(macrolet - ((defdef (def* def) - `(defmacro ,def* (name formals &rest rest) - `(progn - #+(or ecl gcl) - ,(when (and #+gcl<2.7 (symbolp name)) - `(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-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" - #+gcl<2.7 (setf directory (substitute :back :parent directory)) - (cond - #-(or cmu sbcl scl) ;; these implementations already normalize directory components. - ((stringp directory) `(:absolute ,directory)) - #+gcl<2.7 - ((and (consp directory) (eq :root (first directory))) - `(:absolute ,@(rest directory))) - ((or (null directory) - (and (consp directory) (member (first directory) '(:absolute :relative)))) - directory) - #+gcl<2.7 - ((consp directory) - `(:relative ,@directory)) - (t - (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") 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* denormalize-pathname-directory-component (directory-component) - #-gcl<2.7 directory-component - #+gcl<2.7 - (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) - directory-component))) - (cond - ((and (consp d) (eq :relative (first d))) (rest d)) - ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) - (t d)))) - -(defun* make-pathname* (&rest keys &key (directory nil directoryp) - host device name type version defaults) - (declare (ignore host device name type version defaults)) - (apply 'make-pathname - (append (when directoryp - `(:directory ,(denormalize-pathname-directory-component directory))) - keys))) - -(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, TYPE and VERSION components" - (when pathname - (make-pathname* :name nil :type nil :version nil - :directory (merge-pathname-directory-components - '(:relative :back) (pathname-directory pathname)) - :defaults pathname))) - -(define-modify-macro appendf (&rest args) - append "Append onto list") ;; only to be used on short lists. - -(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* list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) - (dolist (x list h) (setf (gethash x h) t))) - -(defun* asdf-message (format-string &rest format-args) - #-gcl<2.7 (declare (dynamic-extent format-args)) - (when *verbose-out* - (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 "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s)) - (let* ((components (split-string s :separator "/")) - (last-comp (car (last components)))) - (multiple-value-bind (relative components) - (if (equal (first components) "") - (if (equal (first-char s) #\/) - (progn - (when force-relative - (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s)) - (values :absolute (cdr components))) - (values :relative nil)) - (values :relative components)) - (setf components (remove-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 "~@<Invalid pathname designator ~S~@:>") pathspec)) - ((wild-pathname-p pathspec) - (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec)) - ((directory-pathname-p pathspec) - pathspec) - (t - (make-pathname* :directory (append (or (normalize-pathname-directory-component - (pathname-directory pathspec)) - (list :relative)) - (list (file-namestring pathspec))) - :name nil :type nil :version nil :defaults pathspec)))) - -(defun* absolute-pathname-p (pathspec) - (and (typep pathspec '(or pathname string)) - (eq :absolute (car (normalize-pathname-directory-component - (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 backward-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))) - #+gcl<2.7 - '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename (subpathname (ensure-directory-pathname 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* (or #+cormanlisp "*" :wild)) -(defparameter *wild-file* - (make-pathname :directory nil :name *wild* :type *wild* - :version (or #-(or abcl xcl) *wild*))) -(defparameter *wild-directory* - (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "*" *wild*)) - :name nil :type nil :version nil)) -(defparameter *wild-inferiors* - (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "**" :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))) - -(defun* add-pathname-suffix (pathname suffix) - (make-pathname :name (strcat (pathname-name pathname) suffix) - :defaults pathname)) - -(defun* tmpize-pathname (x) - (add-pathname-suffix x "-ASDF-TMP")) - -(defun* rename-file-overwriting-target (source target) - #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic - (posix:copy-file source target :method :rename) - #-clisp - (rename-file source target - #+clozure :if-exists #+clozure :rename-and-delete)) - -(defun* call-with-staging-pathname (pathname fun) - "Calls fun with a staging pathname, and atomically -renames the staging pathname to the pathname in the end. -Note: this protects only against failure of the program, -not against concurrent attempts. -For the latter case, we ought pick random suffix and atomically open it." - (let* ((pathname (pathname pathname)) - (staging (tmpize-pathname pathname))) - (unwind-protect - (multiple-value-prog1 - (funcall fun staging) - (rename-file-overwriting-target staging pathname)) - (when (probe-file* staging) - (delete-file staging))))) - -(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) - `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) - -(defun* stamp< (x y) - (etypecase x - (null (and y t)) - ((eql t) nil) - (real (etypecase y - (null nil) - ((eql t) t) - (real (< x y)))))) -;;(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) -;;(defun* stamp*< (&rest list) (stamps< list)) -(defun* stamp<= (x y) (not (stamp< y x))) -(defun* earlier-stamp (x y) (if (stamp< x y) x y)) -(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) -(defun* earliest-stamp (&rest list) (stamps-earliest list)) -(defun* later-stamp (x y) (if (stamp< x y) y x)) -(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) -(defun* latest-stamp (&rest list) (stamps-latest list)) -(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp) - -(defun* safe-file-write-date (pathname) - ;; If FILE-WRITE-DATE returns NIL, it's possible that - ;; the user or some other agent has deleted an input file. - ;; Also, generated files will not exist at the time planning is done - ;; and calls compute-action-stamp which calls safe-file-write-date. - ;; So it is very possible that we can't get a valid file-write-date, - ;; and we can survive and we will continue the planning - ;; as if the file were very old. - ;; (or should we treat the case in a different, special way?) - (and pathname (probe-file* pathname) (ignore-errors (file-write-date 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) ;; ASDF3: eliminate? - (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) -(defgeneric* mark-operation-done (operation component)) ;; ASDF3: rename to stamp-action -(defgeneric* explain (operation component)) -(defgeneric* output-files (operation component)) -(defgeneric* input-files (operation component)) -(defgeneric* component-operation-time (operation component)) -(defgeneric* component-description (component)) -(defgeneric* operation-description (operation component) ;; ASDF3: rename to action-description - (: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-name (component) - (:documentation "Name of the COMPONENT, unique relative to its parent")) - -(defgeneric* component-system (component) - (:documentation "Find the top-level system containing COMPONENT")) - -(defgeneric* component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) - -(defgeneric* component-relative-pathname (component) - (:documentation "Returns a pathname for the component argument intended to be -interpreted relative to the pathname of that component's parent. -Despite the function's name, the return value may be an absolute -pathname, because an absolute pathname may be interpreted relative to -another pathname in a degenerate way.")) - -(defgeneric* component-property (component property)) - -#-gcl<2.7 -(defgeneric* (setf component-property) (new-value component property)) - -(defgeneric* component-external-format (component)) - -(defgeneric* component-encoding (component)) - -#-gcl<2.7 -(eval-when (:compile-toplevel :load-toplevel :execute) - (defgeneric* (setf component-children-by-name) (new-value parent))) - -(defgeneric* version-satisfies (component version)) - -(defgeneric* find-component (base path) - (:documentation "Find a component by resolving the PATH starting from BASE parent")) - -(defgeneric* find-operation (base path) - (:documentation "Find an operation by resolving the PATH starting from BASE parent")) - -(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-depends-on (operation component) ;; ASDF3: rename to component-dependencies - (:documentation - "Returns a list of dependencies needed by the component to perform - the operation. A dependency has one of the following forms: - - (<operation> <component>*), where <operation> is a class - designator and each <component> is a component - designator, which means that the component depends on - <operation> having been performed on each <component>; or - - (FEATURE <feature>), which means that the component depends - on <feature>'s presence in *FEATURES*. - - Methods specialized on subclasses of existing component types - should usually append the results of CALL-NEXT-METHOD to the - list.")) - -(defgeneric* component-self-dependencies (operation component)) - -(defgeneric* traverse (operation component &key &allow-other-keys) - (:documentation -"Generate and return a plan for performing OPERATION on COMPONENT. - -The plan returned is a list of dotted-pairs. Each pair is the CONS -of ASDF operation object and a COMPONENT object. The pairs will be -processed in order by OPERATE.")) - -(defgeneric* compute-action-stamp (plan operation component &key just-done) - (:documentation "Has this action been successfully done already, -and at what known timestamp has it been done at or will it be done at? -Takes two keywords JUST-DONE and PLAN: -JUST-DONE is a boolean that is true if the action was just successfully performed, -at which point we want compute the actual stamp and warn if files are missing; -otherwise we are making plans, anticipating the effects of the action. -PLAN is a plan object modelling future effects of actions, -or NIL to denote what actually happened. -Returns two values: -* a STAMP saying when it was done or will be done, - or T if the action has involves files that need to be recomputed. -* a boolean DONE-P that indicates whether the action has actually been done, - and both its output-files and its in-image side-effects are up to date.")) - -(defgeneric* builtin-system-p (system)) -(defgeneric* action-forced-p (plan operation component)) -(defgeneric* action-forced-not-p (plan operation component)) - -;; for backward-compatibility only. Used by swank.asd for swank-loader. -(defgeneric* operation-forced (operation)) - -;;;; ------------------------------------------------------------------------- -;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun* compute-children-by-name (module) - (let ((hash (make-hash-table :test 'equal))) - (setf (component-children-by-name module) hash) - (loop :for c :in (component-children module) - :for name = (component-name c) - :for previous = (gethash name hash) - :do (when previous (error 'duplicate-names :name name)) - (setf (gethash name hash) c)) - hash)) - (when *upgraded-p* - ;; override previous definition from 2.018 to 2.26, not needed - ;; since we've stopped trying to recycle previously-installed systems. - (handler-bind ((style-warning #'muffle-warning)) - (when (find-class 'operation nil) - (eval - '(progn - (defun* make-sub-operation (c o dep-c dep-o) - (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)) - (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) - (declare (ignorable o slot-names initargs)) (values)) - (defmethod reinitialize-instance :after ((c component) &rest initargs &key) - (declare (ignorable c initargs)) (values)) - (defmethod reinitialize-instance :after ((m module) &rest initargs &key) - (declare (ignorable m initargs)) (values)) - (defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable m added deleted plist)) - (when (and (member 'children added) (member 'components deleted)) - (setf (slot-value m 'children) - ;; old ECLs provide an alist instead of a plist(!) - (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist))) - (getf plist 'components))) - (compute-children-by-name m)) - (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. - ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function - ;; over print-object; this is always conditions::%print-condition for - ;; condition objects, which in turn does inheritance of :report options at - ;; run-time. fortunately, inheritance means we only need this kludge here in - ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmu (:report print-object)) - -(define-condition formatted-system-definition-error (system-definition-error) - ((format-control :initarg :format-control :reader format-control) - (format-arguments :initarg :format-arguments :reader format-arguments)) - (:report (lambda (c s) - (apply 'format s (format-control c) (format-arguments c))))) - -(define-condition load-system-definition-error (system-definition-error) - ((name :initarg :name :reader error-name) - (pathname :initarg :pathname :reader error-pathname) - (condition :initarg :condition :reader error-condition)) - (:report (lambda (c s) - (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") - (error-name c) (error-pathname c) (error-condition c))))) - -(define-condition circular-dependency (system-definition-error) - ((actions :initarg :actions :reader circular-dependency-actions)) - (:report (lambda (c s) - (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") - (circular-dependency-actions c))))) - -(define-condition duplicate-names (system-definition-error) - ((name :initarg :name :reader duplicate-names-name)) - (:report (lambda (c s) - (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") - (duplicate-names-name c))))) - -(define-condition missing-component (system-definition-error) - ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) - (parent :initform nil :reader missing-parent :initarg :parent))) - -(define-condition 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) ;; OBSOLETE NAME. - ;; We want to rename it to operation-error, but that breaks upgrade on SBCL. - ;; Before to rename it, fix these culprits: - ;; cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel - ((component :reader error-component :initarg :component) - (operation :reader error-operation :initarg :operation)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") - (type-of c) (error-operation c) (error-component c))))) - -(define-condition compile-error (operation-error) ()) -(define-condition compile-failed (compile-error) ()) -(define-condition compile-warned (compile-error) ()) - -(define-condition invalid-configuration () - ((form :reader condition-form :initarg :form) - (location :reader condition-location :initarg :location) - (format :reader condition-format :initarg :format) - (arguments :reader condition-arguments :initarg :arguments :initform nil)) - (:report (lambda (c s) - (format s (compatfmt "~@<~? (will be skipped)~@:>") - (condition-format c) - (list* (condition-form c) (condition-location c) - (condition-arguments c)))))) -(define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) -(define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) - -(defclass component () - ((name :accessor component-name :initarg :name :type string :documentation - "Component name: designator for a string composed of portable pathname characters") - ;; We might want to constrain version with - ;; :type (and string (satisfies parse-version)) - ;; but we cannot until we fix all systems that don't use it correctly! - (version :accessor component-version :initarg :version) - (description :accessor component-description :initarg :description) - (long-description :accessor component-long-description :initarg :long-description) - (sibling-dependencies :accessor component-sibling-dependencies :initform nil) - (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) - ;; In the ASDF object model, dependencies exist between *actions* - ;; (an action is a pair of operation and component). - ;; Dependencies are represented as alists of operations - ;; to dependencies (other actions) in each component. - ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: - ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. - ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) - ;; and do-first things that modify the current image (such as loading a fasl). - ;; These are now unified because we now correctly propagate timestamps between dependencies. - ;; Happily, no one seems to have used do-first too much, but the name in-order-to remains. - ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! - ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. - ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. - ;; See our ASDF 2 paper for more complete explanations. - (in-order-to :initform nil :initarg :in-order-to - :accessor component-in-order-to) - ;; methods defined using the "inline" style inside a defsystem form: - ;; need to store them somewhere so we can delete them when the system - ;; is re-evaluated - (inline-methods :accessor component-inline-methods :initform nil) - ;; 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) - ;; 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) - ;; For backward-compatibility, this slot is part of component rather than child-component - (parent :initarg :parent :initform nil :reader component-parent))) - - -;; Components are organized in a hierarchical tree, -;; that typically (but not necessarily) follows the filesystem hierarchy. -(defclass child-component (component) ()) - -(defclass parent-component (component) - ((children - :initform nil - :initarg :components - :reader module-components ; backward-compatibility - :accessor component-children) - (children-by-name - :reader module-components-by-name ; backward-compatibility - :accessor component-children-by-name) - (default-component-class - :initform nil - :initarg :default-component-class - :accessor module-default-component-class))) - -(defclass module (child-component parent-component) - ()) - -(defun* component-load-dependencies (component) - ;; Old deprecated name for the same thing. Please update your software. - (component-sibling-dependencies component)) - -(defun* component-find-path (component) - (check-type component (or null component)) - (reverse - (loop :for c = component :then (component-parent c) - :while c :collect (component-name c)))) - -(defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity nil) - (format stream "~{~S~^ ~}" (component-find-path c)))) - - -;;;; methods: conditions - -(defmethod print-object ((c missing-dependency) s) - (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)) - -;;;; methods: components - -(defmethod print-object ((c missing-component) s) - (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>") - (missing-requires c) - (when (missing-parent c) - (coerce-name (missing-parent c))))) - -(defmethod print-object ((c missing-component-of-version) s) - (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>") - (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)) - -(defvar *default-component-class* 'cl-source-file) - -(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)) - (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 "~@<Invalid relative pathname ~S for component ~S~@:>") - 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))) - -(defmethod (setf component-property) (new-value (c component) property) - (let ((a (assoc property (slot-value c 'properties) :test #'equal))) - (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties))))) - new-value) - -(defclass proto-system () ; slots to keep when resetting a system - ;; To preserve identity for all objects, we'd need keep the components slots - ;; but also to modify parse-component-form to reset the recycled objects. - ((name) (source-file) #|(children) (children-by-names)|#)) - -;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component. -(defclass system (module proto-system) - (;; {,long-}description is now inherited from component, but we add the legacy accessors - (description :accessor system-description) - (long-description :accessor system-long-description) - (author :accessor system-author :initarg :author) - (maintainer :accessor system-maintainer :initarg :maintainer) - (licence :accessor system-licence :initarg :licence - :accessor system-license :initarg :license) - (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL - (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) - -(defmethod component-pathname ((system system)) - (if (or (slot-boundp system 'relative-pathname) - (slot-boundp system 'absolute-pathname) - (slot-value system 'source-file)) - (call-next-method) - (default-directory))) - -;;; component subclasses - -(defclass file-component (child-component) - ((type :accessor file-type :initarg :type))) ; no default -(defclass source-file (file-component) - ((type :initform nil))) ;; NB: many systems have come to rely on this default. -(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) - ((type :initform nil))) -(defclass doc-file (static-file) ()) -(defclass html-file (doc-file) - ((type :initform "html"))) - -(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename. - (declare (ignorable component system)) - :directory) -(defmethod source-file-type ((component file-component) system) - (declare (ignorable system)) - (file-type component)) - -(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))) - -;;;; Encodings -(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) - (if (and pathname (probe-file pathname)) - (funcall *encoding-detection-hook* pathname) - *default-encoding*)) - -(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 backward-compatibility only. Explicit usage discouraged. - (:utf-8 *utf-8-external-format*) - (otherwise - (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") 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))) - -;;;; ------------------------------------------------------------------------- -;;;; version-satisfies - -(defmethod version-satisfies ((c component) version) - (unless (and version (slot-boundp c 'version)) - (when version - (warn "Requested version ~S but component ~S has no version" version c)) - (return-from version-satisfies t)) - (version-satisfies (component-version c) version)) - -(defun* asdf-version () - "Exported interface to the version of ASDF currently installed. A string. -You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." - *asdf-version*) - -(defun* parse-version (string &optional on-error) - "Parse a version string as a series of natural integers separated by dots. -Return a (non-null) list of integers if the string is valid, NIL otherwise. -If on-error is error, warn, or designates a function of compatible signature, -the function is called with an explanation of what is wrong with the argument. -NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" - (and - (or (stringp string) - (when on-error - (funcall on-error "~S: ~S is not a string" - 'parse-version string)) nil) - (or (loop :for prev = nil :then c :for c :across string - :always (or (digit-char-p c) - (and (eql c #\.) prev (not (eql prev #\.)))) - :finally (return (and c (digit-char-p c)))) - (when on-error - (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" - 'parse-version string)) nil) - (mapcar #'parse-integer (split-string string :separator ".")))) - -(defmethod version-satisfies ((cver string) version) - (let ((x (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 x y (= (car x) (car y)) - (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) - -;;;; ----------------------------------------------------------------- -;;;; Windows shortcut support. Based on: -;;;; -;;;; Jesse Hager: The Windows Shortcut File Format. -;;;; http://www.wotsit.org/list.asp?fc=13 - -#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. -(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 (c) - (declare (ignore c)) - 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 "~@<Invalid component designator: ~3i~_~A~@:>") 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 (aif (ignore-errors (system-source-file system)) (safe-file-write-date it)) 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." - (loop :for (nil . system) :being :the hash-values :of *defined-systems* - :do (funcall fn system))) - -;;; 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* '()) - -(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 - (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 "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>") - 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 "~@<Coerce entry to ~a, replace ~a and continue.~@:>") - (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 "~A~D" :asdf counter) - :use '(:cl :asdf))))) - (do* ((counter 0 (+ counter 1)) - (package (try counter) (try counter))) - (package package)))) - -(defmethod find-system ((name null) &optional (error-p t)) - (declare (ignorable name)) - (when error-p - (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) - -(defmethod find-system (name &optional (error-p t)) - (find-system (coerce-name name) error-p)) - -(defvar *systems-being-defined* nil - "A hash-table of systems currently being defined keyed by name, or NIL") -(defvar *systems-being-operated* nil - "A boolean indicating that some systems are being operated on") - -(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 #-gcl<2.7 :external-format #-gcl<2.7 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 (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)) - (unless (and (equal pathname (and previous (system-source-file previous))) - (stamp<= (safe-file-write-date pathname) previous-time)) - ;; only load when it's a different pathname, or newer file content - (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 "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") 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 ((parent parent-component) (name string)) - (unless (slot-boundp parent 'children-by-name) ;; SBCL may miss the u-i-f-r-c method!!! - (compute-children-by-name parent)) - (values (gethash name (component-children-by-name parent)))) - -(defmethod find-component (base (name symbol)) - (if name - (find-component base (coerce-name name)) - base)) - -(defmethod find-component ((c component) (name cons)) - (find-component (find-component c (car name)) (cdr name))) - -(defmethod find-component (base (actual component)) - (declare (ignorable base)) - actual) - -(defgeneric* resolve-dependency-combination (component combinator arguments)) - -(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 "~@<Retry loading ~3i~_~A.~@:>") 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) - (if (atom dep-spec) - (resolve-dependency-name component dep-spec) - (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))) - -(defmethod resolve-dependency-combination (component combinator arguments) - (error (compatfmt "~@<Bad dependency ~S for ~S~@:>") - (cons combinator arguments) component)) - -(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) - (declare (ignorable combinator)) - (when (featurep (first arguments)) - (resolve-dependency-spec component (second arguments)))) - -(defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) - (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788 - (resolve-dependency-name component (first arguments) (second arguments))) - -;;;; ------------------------------------------------------------------------- -;;;; Operations - -;;; one of these is instantiated whenever #'operate is called - -(defclass operation () - ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) - :initform nil :initarg :original-initargs :accessor operation-original-initargs))) - -(defmethod initialize-instance :after ((o operation) &rest initargs - &key force force-not system verbose &allow-other-keys) - (declare (ignorable force force-not system verbose)) - (unless (slot-boundp o 'original-initargs) - (setf (operation-original-initargs o) initargs))) - -(defmethod print-object ((o operation) stream) - (print-unreadable-object (o stream :type t :identity nil) - (ignore-errors - (format stream "~{~S~^ ~}" (operation-original-initargs o))))) - -(defparameter *operations* (make-hash-table :test 'equal)) -(defun* make-operation (operation-class &rest initargs) - (let ((key (cons operation-class initargs))) - (multiple-value-bind (operation foundp) (gethash key *operations*) - (if foundp operation - (setf (gethash key *operations*) - (apply 'make-instance operation-class initargs)))))) -(defmethod find-operation (context (sub operation)) - (declare (ignorable context)) - sub) -(defmethod find-operation (context (sub symbol)) - (apply 'make-operation sub (operation-original-initargs context))) -(defmethod operation-original-initargs ((op null)) op) - -(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) - -(defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies - -(defmethod component-self-dependencies ((o operation) (c component)) - (loop :for (o-spec . c-spec) :in (component-depends-on o c) - :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature" - :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep))) - :collect (cons (find-operation o o-spec) c))) - -(defmethod output-files ((o operation) (c component)) - (declare (ignorable o c)) - nil) - -(defun* output-file (operation component) - "The unique output file of performing OPERATION on COMPONENT" - (let ((files (output-files operation component))) - (assert (length=n-p files 1)) - (first files))) - -(defmethod input-files ((o operation) (c parent-component)) - (declare (ignorable o c)) - nil) - -(defmethod input-files ((o operation) (c file-component)) - (or (loop :for (dep-o) :in (component-self-dependencies o c) - :append (or (output-files dep-o c) (input-files dep-o c))) - ;; no non-trivial previous operations needed? - ;; I guess we work with the original source file, then - (list (component-pathname c)))) - -(defmethod perform :after ((o operation) (c component)) - (mark-operation-done o c)) - -(defmethod operation-done-p ((o operation) (c component)) - (declare (ignorable o c)) - t) - -(deftype action () '(cons operation component)) ;; a step to be performed while building the system - -;;; upward-operation, downward-operation and sibling-operation work together -;;; to handle modules and files along the module hierarchy: - -;; Downward operations like load-op or compile-op propagate down the component hierarchy: -;; operation on a parent depends-on operation on its children. -(defclass downward-operation (operation) ()) -(defmethod component-depends-on ((o downward-operation) (c parent-component)) - `((,o ,@(component-children c)) ,@(call-next-method))) - -;; Upward operations, like prepare-op, propagate up the component hierarchy: -;; operation on a child depends-on operation on its parent. -;; For backward-compatibility reasons, a system inherits from module and is a child-component -;; so we must guard against this case. ASDF3: remove that. -(defclass upward-operation (operation) ()) -(defmethod component-depends-on ((o upward-operation) (c child-component)) - `(,@(aif (component-parent c) `((,o ,it))) ,@(call-next-method))) - -;; Our default operations: loading into the current lisp image -(defclass basic-load-op (operation) ()) -(defclass load-op (basic-load-op downward-operation) ()) -(defclass prepare-op (upward-operation) ()) - -(defmethod component-depends-on ((o prepare-op) (c component)) - (declare (ignorable o)) - `((load-op ,@(loop :for dep :in (component-sibling-dependencies c) - :collect (resolve-dependency-spec c dep))) - ,@(call-next-method))) - -(defmethod perform ((o prepare-op) (c component)) - (declare (ignorable o c)) - nil) -(defmethod input-files ((o prepare-op) (c component)) - (declare (ignorable o c)) - nil) -(defmethod input-files ((o prepare-op) (s system)) - (declare (ignorable o)) - (aif (system-source-file s) (list it))) - - -;;; The TRAVERSE protocol is as follows: we pass around operation, dependency, -;;; and bunch of other stuff. Functions return a stamp. -;;; The returned stamp is T if anything has changed that required a rebuild. - -(defun* action-override-p (plan operation component override-accessor) - (declare (ignorable operation)) - (let* ((override (funcall override-accessor plan))) - (and override - (if (typep override 'hash-table) - (gethash (coerce-name (component-system (find-component () component))) override) - t)))) - -(defgeneric* needed-in-image-p (operation component)) -(defmethod needed-in-image-p ((o operation) (c component)) - ;; We presume that actions that modify the filesystem don't need be run - ;; in the current image if they have already been done in another, - ;; and can be run in another process (e.g. a fork), - ;; whereas those that don't are meant to side-effect the current image and can't. - (not (output-files o c))) - -(defclass plan-traversal () - ((forced :initform nil :initarg :force :accessor plan-forced) - (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) - (total-action-count :initform 0 :accessor plan-total-action-count) - (planned-action-count :initform 0 :accessor plan-planned-action-count) - (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) - (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) - (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) - (visiting-action-list :initform () :accessor plan-visiting-action-list))) - -(defun* normalize-forced-systems (x system) - (etypecase x - ((member nil :all) x) - (cons (list-to-hash-set (mapcar #'coerce-name x))) - ((eql t) (list-to-hash-set (list (coerce-name system)))))) - -(defmethod initialize-instance :after ((plan plan-traversal) - &key (force () fp) (force-not () fnp) system &allow-other-keys) - (with-slots (forced forced-not) plan - (when fp (setf forced (normalize-forced-systems force system))) - (when fnp (setf forced-not (normalize-forced-systems force-not system))))) - -(defclass sequential-plan (plan-traversal) - ((actions-r :initform nil :accessor plan-actions-r))) - -(defgeneric* plan-action-status (plan operation component) - (:documentation "Returns the ACTION-STATUS associated to -the action of OPERATION on COMPONENT in the PLAN")) - -(defgeneric* (setf plan-action-status) (new-status plan operation component) - (:documentation "Sets the ACTION-STATUS associated to -the action of OPERATION on COMPONENT in the PLAN")) - -(defgeneric* plan-record-dependency (plan operation component)) - -(defgeneric* visiting-action-p (plan operation component)) - -(defgeneric* (setf visiting-action-p) (new-value plan operation component)) - -(defclass action-status () - ((stamp - :initarg :stamp :reader action-stamp - :documentation "STAMP associated with the ACTION if it has been completed already -in some previous image, or T if it needs to be done.") - (done-p - :initarg :done-p :reader action-done-p - :documentation "a boolean, true iff the action was already done (before any planned action).")) - (:documentation "Status of an action")) - -(defmethod print-object ((status action-status) stream) - (print-unreadable-object (status stream :type t) - (with-slots (stamp done-p) status - (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) - -(defclass planned-action-status (action-status) - ((planned-p - :initarg :planned-p :reader action-planned-p - :documentation "a boolean, true iff the action was included in the plan.") - (index - :initarg :index :reader action-index - :documentation "an integer, counting all traversed actions in traversal order.")) - (:documentation "Status of an action in a plan")) - -(defmethod print-object ((status planned-action-status) stream) - (print-unreadable-object (status stream :type t) - (with-slots (stamp done-p planned-p) status - (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p)))) - -;; TODO: eliminate NODE-FOR, use CONS. -;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. -(defun* node-for (o c) (cons (type-of o) c)) - -(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) - (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) - -(defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) - (or (and (action-forced-not-p plan o c) (plan-action-status nil o c)) - (values (gethash (node-for o c) (plan-visited-actions plan))))) - -(defmethod component-operation-time ((o operation) (c component)) - (gethash (type-of o) (component-operation-times c))) - -(defmethod mark-operation-done ((o operation) (c component)) - (setf (gethash (type-of o) (component-operation-times c)) - (compute-action-stamp nil o c :just-done t))) - -(defun* action-already-done-p (plan operation component) - (action-done-p (plan-action-status plan operation component))) - -(defmethod plan-action-status ((plan null) (o operation) (c component)) - (declare (ignorable plan)) - (multiple-value-bind (stamp done-p) (component-operation-time o c) - (make-instance 'action-status :stamp stamp :done-p done-p))) - -(defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) - (declare (ignorable plan)) - (let ((to (type-of o)) - (times (component-operation-times c))) - (if (action-done-p new-status) - (remhash to times) - (setf (gethash to times) (action-stamp new-status)))) - new-status) - -(defmethod action-forced-p (plan operation component) - (and (action-override-p plan operation component 'plan-forced) - (not (builtin-system-p (component-system component))))) -(defmethod action-forced-not-p (plan operation component) - (and (action-override-p plan operation component 'plan-forced-not) - (not (action-forced-p plan operation component)))) - -(defgeneric action-valid-p (plan operation component) - (:documentation "Is this action valid to include amongst dependencies?")) -(defmethod action-valid-p (plan operation (c component)) - (declare (ignorable plan operation)) - (aif (component-if-feature c) (featurep it) t)) -(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil) -(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil) -(defmethod action-valid-p ((plan plan-traversal) (o operation) (s system)) - (and (not (action-forced-not-p plan o s)) (call-next-method))) - - -;;; Computing stamps and traversing the dependency graph of actions. - -(defun* visit-dependencies (plan operation component fun &aux stamp) - (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) - :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature - :do (loop :with dep-o = (find-operation operation dep-o-spec) - :for dep-c-spec :in dep-c-specs - :for dep-c = (resolve-dependency-spec component dep-c-spec) - :when (action-valid-p plan dep-o dep-c) - :do (latest-stamp-f stamp (funcall fun dep-o dep-c)))) - stamp) - -(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) - ;; In a distant future, safe-file-write-date and component-operation-time - ;; shall also be parametrized by the plan, or by a second model object. - (let* ((stamp-lookup #'(lambda (o c) (aif (plan-action-status plan o c) (action-stamp it) t))) - (out-files (output-files o c)) - (in-files (input-files o c)) - ;; Three kinds of actions: - (out-op (and out-files t)) ; those that create files on the filesystem - ;(image-op (and in-files (null out-files))) ; those that load stuff into the image - ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing - ;; When was the thing last actually done? (Now, or ask.) - (op-time (or just-done (component-operation-time o c))) - ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) - (dep-stamp (visit-dependencies plan o c stamp-lookup)) - ;; Time stamps from the files at hand, and whether any is missing - (out-stamps (mapcar #'safe-file-write-date out-files)) - (in-stamps (mapcar #'safe-file-write-date in-files)) - (missing-in - (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) - (missing-out - (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) - (all-present (not (or missing-in missing-out))) - ;; Has any input changed since we last generated the files? - (earliest-out (stamps-earliest out-stamps)) - (latest-in (stamps-latest (cons dep-stamp in-stamps))) - (up-to-date-p (stamp<= latest-in earliest-out)) - ;; If everything is up to date, the latest of inputs and outputs is our stamp - (done-stamp (stamps-latest (cons latest-in out-stamps)))) - ;; Warn if some files are missing: - ;; either our model is wrong or some other process is messing with our files. - (when (and just-done (not all-present)) - (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ - ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" - (operation-description o c) - missing-in (length missing-in) (and missing-in missing-out) - missing-out (length missing-out))) - ;; Note that we use stamp<= instead of stamp< to play nice with generated files. - ;; Any race condition is intrinsic to the limited timestamp resolution. - (if (or just-done ;; The done-stamp is valid: if we're just done, or - ;; if all filesystem effects are up-to-date and there's no invalidating reason. - (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) - (values done-stamp ;; return the hard-earned timestamp - (or just-done - (or out-op ;; a file-creating op is done when all files are up to date - ;; a image-effecting a placeholder op is done when it was actually run, - (and op-time (eql op-time done-stamp))))) ;; with the matching stamp - ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet - (values t nil)))) - -(defgeneric call-while-visiting-action (plan operation component function) - (:documentation "Detect circular dependencies")) -(defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) - (with-accessors ((action-set plan-visiting-action-set) - (action-list plan-visiting-action-list)) plan - (let ((action (cons operation component))) - (aif (gethash action action-set) - (error 'circular-dependency :actions - (member action (reverse action-list) :test 'equal)) - (progn - (setf (gethash action action-set) t) - (push action action-list) - (unwind-protect - (funcall fun) - (pop action-list) - (setf (gethash action action-set) nil))))))) - -(defmacro while-visiting-action ((p o c) &body body) - `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))) - -(defgeneric* traverse-action (plan operation component needed-in-image-p)) - -(defmethod (setf plan-action-status) :after - (new-status (p sequential-plan) (o operation) (c component)) - (when (action-planned-p new-status) - (push (cons o c) (plan-actions-r p)))) - -(defmethod plan-record-dependency ((plan sequential-plan) - (operation operation) (component component)) - (declare (ignorable plan operation component)) - (values)) - -(defmethod traverse-action (plan operation component needed-in-image-p) - (block nil - (unless (action-valid-p plan operation component) (return nil)) - (plan-record-dependency plan operation component) - (let* ((aniip (needed-in-image-p operation component)) - (eniip (and aniip needed-in-image-p)) - (status (plan-action-status plan operation component))) - (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) - ;; Already visited with sufficient need-in-image level: just return the stamp. - (return (action-stamp status))) - (labels ((visit-action (niip) - (visit-dependencies plan operation component - #'(lambda (o c) (traverse-action plan o c niip))) - (multiple-value-bind (stamp done-p) - (compute-action-stamp plan operation component) - (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) - (cond - ((and add-to-plan-p (not niip)) ;; if we need to do it, - (visit-action t)) ;; then we need to do it in the image! - (t - (setf (plan-action-status plan operation component) - (make-instance - 'planned-action-status - :stamp stamp - :done-p (and done-p (not add-to-plan-p)) - :planned-p add-to-plan-p - :index (if status (action-index status) (incf (plan-total-action-count plan))))) - (when add-to-plan-p - (incf (plan-planned-action-count plan)) - (unless aniip - (incf (plan-planned-output-action-count plan)))) - stamp)))))) - (while-visiting-action (plan operation component) ; maintain context, handle circularity. - (visit-action eniip)))))) - -(defun* traverse-sequentially (operation component &rest keys &key &allow-other-keys) - (let ((plan (apply 'make-instance 'sequential-plan :system (component-system component) keys))) - (traverse-action plan operation component t) - (reverse (plan-actions-r plan)))) - -(defmethod traverse ((o operation) (c component) &rest keys &key &allow-other-keys) - (apply 'traverse-sequentially o c keys)) - -(defmethod perform ((o operation) (c source-file)) - (sysdef-error - (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>") - (class-of o) (class-of c))) - -(defmethod perform ((o operation) (c parent-component)) - (declare (ignorable o c)) - nil) - -(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 "~@<Retry ~A.~@:>") - (operation-description operation component)))) - (accept () - :report - (lambda (s) - (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") - (operation-description operation component))) - (mark-operation-done operation component) - (return))))) - -(defmethod explain ((o operation) (c component)) - (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (operation-description o c))) - -(defmethod operation-description (operation component) - (format nil (compatfmt "~@<~A on ~A~@:>") - (class-of operation) component)) - -;;;; ------------------------------------------------------------------------- -;;;; compile-op - -(defclass basic-compile-op (operation) - ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) - (flags :initarg :flags :accessor compile-op-flags - :initform nil))) -(defclass compile-op (basic-compile-op downward-operation) ()) - -;; backward-compatibility -(defgeneric* operation-on-warnings (operation)) -(defgeneric* operation-on-failure (operation)) -#-gcl<2.7 (defgeneric* (setf operation-on-warnings) (x operation)) -#-gcl<2.7 (defgeneric* (setf operation-on-failure) (x operation)) -(defmethod operation-on-warnings ((o operation)) - (declare (ignorable o)) *compile-file-warnings-behaviour*) -(defmethod operation-on-failure ((o operation)) - (declare (ignorable o)) *compile-file-failure-behaviour*) -(defmethod (setf operation-on-warnings) (x (o operation)) - (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) -(defmethod (setf operation-on-failure) (x (o operation)) - (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) - -(defun* ensure-all-directories-exist (pathnames) - (dolist (pathname pathnames) - (ensure-directories-exist (translate-logical-pathname pathname)))) - -(defmethod perform :before ((o operation) (c component)) - (ensure-all-directories-exist (output-files o 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)))))))) - -(defun* call-around-hook (hook function) - (funcall (or (ensure-function hook) 'funcall) function)) - -(defmethod call-with-around-compile-hook ((c component) function) - (call-around-hook (around-compile-hook c) function)) - -;;; perform is required to check output-files to find out where to put -;;; its answers, in case it has been overridden for site policy -(defun* perform-lisp-compilation (o c) - (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, - ;; we consult input-files, the first of which should be the one to compile-file - (input-file (first (input-files o c))) - ;; on some implementations, there are more than one output-file, - ;; but the first one should always be the primary fasl that gets loaded. - (output-file (first (output-files o c)))) - (multiple-value-bind (output warnings-p failure-p) - (call-with-around-compile-hook - c #'(lambda (&rest flags) - (apply *compile-file-function* input-file - :output-file output-file - #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c) - (append flags (compile-op-flags o))))) - (unless output - (error 'compile-error :component c :operation o)) - (when failure-p - (case *compile-file-failure-behaviour* - (:warn (warn - (compatfmt "~@<COMPILE-FILE failed while performing ~A.~@:>") - (operation-description o c))) - (:error (error 'compile-failed :component c :operation o)) - (:ignore nil))) - (when warnings-p - (case *compile-file-warnings-behaviour* - (:warn (warn - (compatfmt "~@<COMPILE-FILE warned while performing ~A.~@:>") - (operation-description o c))) - (:error (error 'compile-warned :component c :operation o)) - (:ignore nil)))))) - -(defmethod perform ((o compile-op) (c cl-source-file)) - (perform-lisp-compilation o c)) - -(defmethod output-files ((o compile-op) (c cl-source-file)) - (declare (ignorable o)) - (let* ((i (first (input-files o c))) - (f (compile-file-pathname - i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) - #+mkcl (o (compile-file-pathname i :fasl-p nil))) ;; object file - #+ecl (if (use-ecl-byte-compiler-p) - (list f) - (list f (compile-file-pathname i :type :object))) - #+mkcl (list f o) - #-(or ecl mkcl) (list f))) - -(defmethod component-depends-on ((o compile-op) (c component)) - (declare (ignorable o)) - `((prepare-op ,c) ,@(call-next-method))) - -(defmethod perform ((o compile-op) (c static-file)) - (declare (ignorable o c)) - nil) - -(defmethod output-files ((o compile-op) (c static-file)) - (declare (ignorable o c)) - nil) - -(defmethod operation-description ((o compile-op) (c component)) - (declare (ignorable o)) - (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c)) - -(defmethod operation-description ((o compile-op) (c parent-component)) - (declare (ignorable o)) - (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") c)) - - -;;;; ------------------------------------------------------------------------- -;;;; 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 (find-operation o 'compile-op) c))))) - -(defmethod perform ((o load-op) (c cl-source-file)) - (load (first (input-files o c)))) - -(defmethod perform ((o load-op) (c static-file)) - (declare (ignorable o c)) - nil) - -(defmethod component-depends-on ((o load-op) (c component)) - (declare (ignorable o)) - `((prepare-op ,c) ,@(call-next-method))) - -(defmethod component-depends-on ((o load-op) (c source-file)) - (declare (ignorable o)) - `((compile-op ,c) ,@(call-next-method))) - -(defmethod operation-description ((o load-op) component) - (declare (ignorable o)) - (format nil (compatfmt "~@<loading ~3i~_~A~@:>") - component)) - -(defmethod operation-description ((o load-op) (c cl-source-file)) - (declare (ignorable o)) - (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c)) - -(defmethod operation-description ((o load-op) (c parent-component)) - (declare (ignorable o)) - (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") c)) - -(defmethod operation-description ((o prepare-op) (c component)) - (declare (ignorable o)) - (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c)) - - -;;;; ------------------------------------------------------------------------- -;;;; load-source-op - -(defclass load-source-op (basic-load-op downward-operation) ()) -(defclass prepare-source-op (upward-operation) ()) - -(defmethod component-depends-on ((o prepare-source-op) (c source-file)) - (declare (ignorable o)) - `((load-source-op ,@(component-sibling-dependencies c)) ,@(call-next-method))) -(defmethod input-files ((o prepare-source-op) (c component)) - (declare (ignorable o c)) - nil) -(defmethod input-files ((o prepare-source-op) (s system)) - (declare (ignorable o)) - (aif (system-source-file s) (list it))) -(defmethod perform ((o prepare-source-op) (c component)) - (declare (ignorable o c)) - nil) - -(defmethod component-depends-on ((o load-source-op) (c component)) - (declare (ignorable o)) - `((prepare-source-op ,c) ,@(call-next-method))) - -(defun perform-lisp-load-source (o c) - (call-with-around-compile-hook - c #'(lambda () (load (first (input-files o c)) - #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c))))) - -(defmethod perform ((o load-source-op) (c cl-source-file)) - (perform-lisp-load-source o c)) - -(defmethod perform ((o load-source-op) (c static-file)) - (declare (ignorable o c)) - nil) - -(defmethod output-files ((o load-source-op) (c component)) - (declare (ignorable o c)) - nil) - -(defmethod operation-description ((o load-source-op) c) - (declare (ignorable o)) - (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c)) - -(defmethod operation-description ((o load-source-op) (c parent-component)) - (declare (ignorable o)) - (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c)) - -(defmethod operation-description ((o prepare-source-op) (c component)) - (declare (ignorable o)) - (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c)) - - -;;;; ------------------------------------------------------------------------- -;;;; test-op - -(defclass test-op (operation) ()) - -(defmethod perform ((o test-op) (c component)) - (declare (ignorable o c)) - nil) - -(defmethod operation-done-p ((o test-op) (c system)) - "Testing a system is _never_ done." - (declare (ignorable o c)) - nil) - -(defmethod component-depends-on ((o test-op) (c system)) - (declare (ignorable o)) - `((load-op ,c) ,@(call-next-method))) - - -;;;; ------------------------------------------------------------------------- -;;;; Invoking Operations - -(defgeneric* operate (operation-class system &key &allow-other-keys)) -(defgeneric* perform-plan (plan &key)) -(defgeneric* plan-operates-on-p (plan component)) - -(defvar *post-upgrade-hook* ()) - -;;;; 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) - (funcall (find-symbol* 'load-system :asdf) :asdf) ;; load ASDF a second time, the right way. - (map () 'funcall *post-upgrade-hook*) - ;; 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 plan-operates-on-p ((plan list) (component-path list)) - (find component-path (mapcar 'cdr plan) - :test 'equal :key 'component-find-path)) - -(defmethod perform-plan ((steps list) &key) - (let ((*package* *package*) - (*readtable* *readtable*)) - (with-compilation-unit () - (loop :for (op . component) :in steps :do - (perform-with-restarts op component))))) - -(defmethod operate :around (operation-class system - &key verbose - (on-warnings *compile-file-warnings-behaviour*) - (on-failure *compile-file-failure-behaviour*) &allow-other-keys) - (declare (ignorable operation-class system)) - (with-system-definitions () - (let* ((*asdf-verbose* verbose) - (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) - (*compile-file-warnings-behaviour* on-warnings) - (*compile-file-failure-behaviour* on-failure)) - (call-next-method)))) - -(defmethod operate (operation-class system &rest args &key version &allow-other-keys) - (let* ((system (etypecase system - (system system) - ((or string symbol) (find-system system)))) - ;; I'd like to remove-keys :force :force-not :verbose, but swank.asd relies on :force (!). - (op (apply 'make-operation operation-class args)) - (systems-being-operated *systems-being-operated*) - (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))) - (check-type system system) - (setf (gethash (coerce-name system) *systems-being-operated*) system) - (flet ((upgrade () - ;; If we needed to upgrade ASDF to achieve our goal, - ;; then do it specially as the first thing, - ;; which will invalidate all existing systems; - ;; afterwards, try again with the new OPERATE function, - ;; which on some implementations may be a new symbol. - (unless (gethash "asdf" *systems-being-operated*) - (upgrade-asdf) - (return-from operate - (apply (find-symbol* 'operate :asdf) operation-class system args))))) - (when systems-being-operated ;; Upgrade if loading a system from another one. - (upgrade)) - (unless (version-satisfies system version) - (error 'missing-component-of-version :requires system :version version)) - (let ((plan (apply 'traverse op system args))) - (when (plan-operates-on-p plan '("asdf")) - (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time. - (perform-plan plan) - (values op plan))))) - -(defun* oos (operation-class system &rest args - &key force force-not verbose version &allow-other-keys) - (declare (ignore force force-not 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. - -The :FORCE or :FORCE-NOT argument to OPERATE can be: -T to force the inside of the specified system to be rebuilt (resp. not), - without recursively forcing the other systems we depend on. -:ALL to force all systems including other systems we depend on to be rebuilt (resp. not). -(SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list -:FORCE has precedence over :FORCE-NOT. -")) - (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 force-not verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." - (declare (ignore force force-not verbose version)) - (apply 'operate *load-system-operation* system keys) - t) - -(defun* load-systems (&rest systems) - (map () 'load-system systems)) - -(defun* component-loaded-p (c) - (action-already-done-p nil (make-instance 'load-op) (find-component c ()))) - -(defun* already-loaded-systems () - (remove-if-not 'component-loaded-p (registered-systems))) - -(defun* require-system (s &rest keys &key &allow-other-keys) - (apply 'load-system s :force-not (already-loaded-systems) keys)) - -(defun* compile-system (system &rest args &key force force-not verbose version &allow-other-keys) - "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." - (declare (ignore force force-not verbose version)) - (apply 'operate 'compile-op system args) - t) - -(defun* test-system (system &rest args &key force force-not verbose version &allow-other-keys) - "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." - (declare (ignore force force-not verbose version)) - (apply 'operate 'test-op system args) - t) - -;;;; ------------------------------------------------------------------------- -;;;; 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) - #+gcl<2.7 (keyword nil) - (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 p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) - *default-component-class*) nil)) - (sysdef-error "don't recognize component type ~A" type))) - -(defvar *serial-depends-on* nil) - -(defun* sysdef-error-component (msg type name value) - (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) - type name value)) - -(defun* check-component-input (type name weakly-depends-on - depends-on components 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 - (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)) - -;; Resolve away the dubious and deprecated option :IF-COMPONENT-DEP-FAILS -;; and its companion ASDF:FEATURE pseudo-dependency. -;; THIS IS ONLY PARTIAL SUPPORT: it won't recurse into dependencies -;; to accumulate feature conditions. -;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL -;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. -(defun resolve-if-component-dep-fails (if-component-dep-fails component) - (asdf-message "The system definition for ~S uses deprecated ~ - ASDF option :IF-COMPONENT-DEP-DAILS. ~ - Starting with ASDF 2.27, please use :IF-FEATURE instead" - (coerce-name (component-system component))) - ;; This only supports the pattern of use of the "feature" seen in the wild - (check-type component parent-component) - (check-type if-component-dep-fails (member :fail :ignore :try-next)) - (unless (eq if-component-dep-fails :fail) - (loop :with o = (make-instance 'compile-op) - :for c :in (component-children component) :do - (loop :for (feature? feature) :in (component-depends-on o c) - :when (eq feature? 'feature) :do - (setf (component-if-feature c) feature))))) - -(defun* 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 - perform explain output-files operation-done-p - weakly-depends-on depends-on serial in-order-to - do-first if-component-dep-fails - (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) - (not ;; ignore the same object when rereading the defsystem - (typep (find-component parent name) - (class-for-type parent type)))) - (error 'duplicate-names :name name)) - (when versionp - (unless (parse-version version nil) - (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") - version name parent))) - (when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27")) - (let* ((args `(:name ,(coerce-name name) - :pathname ,pathname - ,@(when parent `(:parent ,parent)) - ,@(remove-keys - '(components pathname if-component-dep-fails - 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 - (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 'parent-component) - (let ((*serial-depends-on* nil)) - (setf (component-children ret) - (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-children-by-name ret)) - (setf (component-sibling-dependencies ret) depends-on) ;; Used by POIU. ASDF3: rename to component-depends-on - (setf (component-in-order-to ret) in-order-to) - (%refresh-component-inline-methods ret rest) - (when if-component-dep-fails (resolve-if-component-dep-fails if-component-dep-fails ret)) - ret))) - -(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)) - (load-pathname (load-pathname)) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (safe-file-write-date load-pathname)) - (register-system (make-instance 'system :name name :source-file load-pathname)))) - (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 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))))) - -(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))) - (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) - :input nil :output *verbose-out*)) - - #+cormanlisp - (win32:system command) - - #+ecl ;; courtesy of Juan Jose Garcia Ripoll - (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) - - #+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)) - (slot-value system 'source-file)) -(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) - (let ((directory (normalize-pathname-directory-component 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 (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 "~@<One and only one of ~S or ~S is required.~@:>") - :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 "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") - description forms)) - (funcall validator (car forms) :location file))) - -(defun* hidden-file-p (pathname) - (equal (first-char (pathname-name pathname)) #\.)) - -(defun* 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* set-output-translations (new-value) - (setf *output-translations* - (list - (stable-sort (copy-list new-value) #'> - :key #'(lambda (x) - (etypecase (car x) - ((eql t) -1) - (pathname - (let ((directory (pathname-directory (car x)))) - (if (listp directory) (length directory) 0)))))))) - new-value) -(defsetf output-translations set-output-translations) ; works with gcl 2.6 - -(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 "~@<pathname ~S is not relative~@:>") x)) - (if (or (pathnamep x) (not wilden)) r (wilden r)))) - -(defvar *here-directory* nil - "This special variable is bound to the currect directory during calls to -PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here -directive.") - -(defun* resolve-absolute-location-component (x &key directory wilden) - (let* ((r - (etypecase x - (pathname x) - (string (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 "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") 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 "~@<Environment string isn't: ~3i~_~S~@:>") string)) - ((eql (char string 0) #\") - (parse-output-translations-string (read-from-string string) :location location)) - ((eql (char string 0) #\() - (validate-output-translations-form (read-from-string string) :location location)) - (t - (loop - :with inherit = nil - :with directives = () - :with start = 0 - :with end = (length string) - :with source = nil - :with separator = (inter-directory-separator) - :for i = (or (position separator string :start start) end) :do - (let ((s (subseq string start i))) - (cond - (source - (push (list source (if (equal "" s) nil s)) directives) - (setf source nil)) - ((equal "" s) - (when inherit - (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) - (setf inherit t) - (push :inherit-configuration directives)) - (t - (setf source s))) - (setf start (1+ i)) - (when (> start end) - (when source - (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") - string)) - (unless inherit - (push :ignore-inherited-configuration directives)) - (return `(:output-translations ,@(nreverse directives))))))))) - -(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* lisp-implementation-directory (&key truename) - (let ((dir - (ignore-errors - #+clozure (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:")) - #+(or ecl mkcl) #p"SYS:" - #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int) - (funcall it) - (getenv-pathname "SBCL_HOME" :want-directory t))))) - (if (and dir truename) - (let ((*default-pathname-defaults* #p"")) (truename dir)) - dir))) - -(defun* wrapping-output-translations () - `(:output-translations - ;; Some implementations have precompiled ASDF systems, - ;; so we must disable translations for implementation paths. - #+(or #|clozure|# ecl mkcl sbcl) - ,@(let ((h (lisp-implementation-directory :truename t))) (when h `(((,h ,*wild-inferiors*) ())))) - #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) - ;; All-import, here is where we want user stuff to be: - :inherit-configuration - ;; These are for convenience, and can be overridden by the user: - #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; We enable the user cache by default, and here is the place we do: - :enable-user-cache)) - -(defparameter *output-translations-file* (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 #-gcl<2.7 pathname #+gcl<2.7 t) &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* fasl-type (&rest keys) - "pathname TYPE for lisp FASt Loading files" - (declare (ignorable keys)) - #-ecl (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) - #+ecl (pathname-type (apply 'compile-file-pathname "foo.lisp" keys))) - -(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 'fasl-type 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* 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-overwriting-target 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)) - (flet ((normalize-device (pathname) - (if (find :windows *features*) - pathname - (make-pathname :defaults pathname :device :unspecific)))) - (let* ((jar - (pathname (first (pathname-device source)))) - (target-root-directory-namestring - (format nil "/___jar___file___root___/~@[~A/~]" - (and (find :windows *features*) - (pathname-device jar)))) - (relative-source - (relativize-pathname-directory source)) - (relative-jar - (relativize-pathname-directory (ensure-directory-pathname jar))) - (target-root-directory - (normalize-device - (pathname-directory-pathname - (parse-namestring target-root-directory-namestring)))) - (target-root - (merge-pathnames* relative-jar target-root-directory)) - (target - (merge-pathnames* relative-source target-root))) - (normalize-device (apply-output-translations target))))) - -;;;; ----------------------------------------------------------------- -;;;; 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 (fasl-type)) - (mapped-files (if map-all-source-files *wild-file* - (make-pathname :type fasl-type :defaults *wild-file*))) - (destination-directory - (if centralize-lisp-binaries - `(,default-toplevel-directory - ,@(when include-per-user-information - (cdr (pathname-directory (user-homedir)))) - :implementation ,*wild-inferiors*) - `(:root ,*wild-inferiors* :implementation)))) - (initialize-output-translations - `(:output-translations - ,@source-to-target-mappings - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) - ((: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 "~@<Environment string isn't: ~3i~_~S~@:>") string)) - ((find (char string 0) "\"(") - (validate-source-registry-form (read-from-string string) :location location)) - (t - (loop - :with inherit = nil - :with directives = () - :with start = 0 - :with end = (length string) - :with separator = (inter-directory-separator) - :for pos = (position separator string :start start) :do - (let ((s (subseq string start (or pos end)))) - (flet ((check (dir) - (unless (absolute-pathname-p dir) - (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) - dir)) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? - (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) - (t - (push `(:directory ,(check s)) directives)))) - (cond - (pos - (setf start (1+ pos))) - (t - (unless inherit - (push '(:ignore-inherited-configuration) directives)) - (return `(:source-registry ,@(nreverse directives)))))))))) - -(defun* register-asd-directory (directory &key recurse exclude collect) - (if (not recurse) - (collect-asds-in-directory directory collect) - (collect-sub*directories-asd-files - directory :exclude exclude :collect collect))) - -(defparameter *default-source-registries* - '(environment-source-registry - user-source-registry - user-source-registry-directory - 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 #-gcl<2.7 pathname #+gcl<2.7 t) &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* 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 "~@<In source-registry entry ~A~@[/~*~] ~ - found several entries for ~A - picking ~S over ~S~:>") - directory recurse name (gethash name h) asd))) - (t - (setf (gethash name registry) asd) - (setf (gethash name h) asd)))))) - h))) - (values)) - -(defvar *source-registry-parameter* nil) - -(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) - (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-file-function* 'compile-file-keeping-object) - - (defun* compile-file-keeping-object (input-file &rest keys &key output-file &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 - :output-file (compile-file-pathname - output-file . #+ecl (:type :object) #+mkcl (:fasl-p nil)) keys) - (values (and object-file - (compiler::build-fasl - output-file #+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 "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") - 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)) - -;;; -;;; BUNDLE-OP -;;; -;;; This operation takes all components from one or more systems and -;;; creates a single output file, which may be -;;; a FASL, a statically linked library, a shared library, etc. -;;; The different targets are defined by specialization. -;;; - -(defclass bundle-op (operation) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) - (name-suffix :initarg :name-suffix :initform nil) - #+ecl (type :reader bundle-op-type) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) - #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) - #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) - -(defclass fasl-op (bundle-op) - ((type :initform :fasl))) - -(defclass lib-op (bundle-op) - ((type :initform :lib))) - -(defclass dll-op (bundle-op) - ((type :initform :dll))) - -(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies - -(defclass monolithic-bundle-op (monolithic-op bundle-op) - ((prologue-code :accessor monolithic-op-prologue-code) - (epilogue-code :accessor monolithic-op-epilogue-code))) - -(defun* operation-monolithic-p (op) - (typep op 'monolithic-op)) - -(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ()) - -(defclass monolithic-lib-op (monolithic-bundle-op lib-op) - ((type :initform :lib))) - -(defclass monolithic-dll-op (monolithic-bundle-op dll-op) - ((type :initform :dll))) - -(defclass program-op (monolithic-bundle-op) - ((type :initform :program))) - -(defmethod initialize-instance :after ((instance bundle-op) &rest initargs - &key (name-suffix nil name-suffix-p) - &allow-other-keys) - (declare (ignorable initargs name-suffix)) - (unless name-suffix-p - (setf (slot-value instance 'name-suffix) - (if (operation-monolithic-p instance) ".all-systems" ".system"))) - (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&rest original-initargs - &key lisp-files prologue-code epilogue-code - &allow-other-keys) - (slot-value instance 'original-initargs) - (setf (slot-value instance 'original-initargs) - (remove-keys '(lisp-files epilogue-code prologue-code) original-initargs) - (monolithic-op-prologue-code instance) prologue-code - (monolithic-op-epilogue-code instance) epilogue-code) - #-ecl (assert (null lisp-files)) - #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) - (setf (bundle-op-build-args instance) - (remove-keys '(type monolithic name-suffix) - (slot-value instance 'original-initargs)))) - -(defmethod bundle-op-build-args :around ((o lib-op)) - (declare (ignorable o)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) - -(defun* gather-components (operation system - &key other-systems filter-type include-self) - ;; This function creates a list of actions pairing the operation with sub-components of system - ;; and its dependencies if requested. - ;; This list may be restricted to sub-components of SYSTEM - ;; if GATHER-ALL = NIL (default), and it may include the system itself. - (let ((tree (traverse-sequentially (make-operation 'load-op) system - :force (if other-systems :all t) - :force-not (if other-systems nil :all)))) - `(,@(loop :for (op . component) :in tree - :when (and (typep op 'load-op) - (typep component filter-type)) - :collect (progn - (when (eq component system) (setf include-self nil)) - `(,operation . ,component))) - ,@(and include-self `((,operation . ,system)))))) - -(defgeneric* trivial-system-p (component)) - -(defun* user-system-p (s) - (and (typep s 'system) - (not (builtin-system-p s)) - (not (trivial-system-p s)))) - -(deftype user-system () '(and system (satisfies user-system-p))) - -;;; -;;; BUNDLE-SUB-OPERATIONS -;;; -;;; Builds a list of pairs (operation . component) -;;; which contains all the dependencies of this bundle. -;;; This list is used by TRAVERSE and also by INPUT-FILES. -;;; The dependencies depend on the strategy, as explained below. -;;; -(defgeneric* bundle-sub-operations (operation component)) -;;; -;;; First we handle monolithic bundles. -;;; These are standalone systems which contain everything, -;;; including other ASDF systems required by the current one. -;;; A PROGRAM is always monolithic. -;;; -;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL -;;; -;;; Gather the static libraries of all components. -;;; -(defmethod bundle-sub-operations ((o monolithic-bundle-op) c) - (gather-components (find-operation o 'lib-op) c :filter-type 'user-system :include-self t)) - -;;; -;;; STATIC LIBRARIES -;;; -;;; Gather the object files of all components -;;; and, if monolithic, also of systems and subsystems. -;;; -(defmethod bundle-sub-operations ((o lib-op) c) - (gather-components (find-operation o 'compile-op) c - :other-systems (operation-monolithic-p o) - :filter-type '(not system))) -;;; -;;; SHARED LIBRARIES -;;; -;;; Gather the dynamically linked libraries of all components. -;;; They will be linked into this new shared library, -;;; together with the static library of this module. -;;; -(defmethod bundle-sub-operations ((o dll-op) c) - `((,(find-operation o 'lib-op) . ,c))) -;;; -;;; FASL FILES -;;; -;;; Gather the statically linked library of this component. -;;; -(defmethod bundle-sub-operations ((o fasl-op) c) - `((,(find-operation o 'lib-op) . ,c))) - -#-mkcl -(defmethod component-depends-on ((o bundle-op) (c system)) - `(,@(loop :for (op . dep) :in (bundle-sub-operations o c) - :when (user-system-p dep) :collect (list op dep)) - ,@(call-next-method))) - -(defmethod component-depends-on ((o lib-op) (c system)) - (declare (ignorable o)) - `((compile-op ,c) ,@(call-next-method))) - -(defmethod component-depends-on ((o bundle-op) c) - (declare (ignorable o c)) - nil) - -#-mkcl -(defmethod input-files ((o bundle-op) (c system)) - (loop :for (sub-op . sub-c) :in (bundle-sub-operations o c) - :nconc (output-files sub-op sub-c))) - -#-mkcl -(defmethod output-files ((o bundle-op) (c system)) - (list (compile-file-pathname - (make-pathname - :name (strcat (component-name c) (slot-value o 'name-suffix) - #|"-" (string-downcase (implementation-type))|#) - :type "lisp" - :defaults (system-source-directory c)) - #+ecl :type #+ecl (bundle-op-type o)))) - -(defun* select-operation (monolithic type) - (ecase type - ((:binary) - (if monolithic 'monolithic-binary-op 'binary-op)) - ((:dll :shared-library) - (if monolithic 'monolithic-dll-op 'dll-op)) - ((:lib :static-library) - (if monolithic 'monolithic-lib-op 'lib-op)) - ((:fasl) - (if monolithic 'monolithic-fasl-op 'fasl-op)) - ((:program) - 'program-op))) - -(defun* make-build (system &rest args &key (monolithic nil) (type :fasl) - (move-here nil move-here-p) - &allow-other-keys) - (let* ((operation-name (select-operation monolithic type)) - (move-here-path (if (and move-here - (typep move-here '(or pathname string))) - (pathname move-here) - (merge-pathnames "./asdf-output/"))) - (operation (apply #'operate operation-name - system - (remove-keys '(monolithic type move-here) args))) - (system (find-system system)) - (files (and system (output-files operation system)))) - (if (or move-here (and (null move-here-p) - (member operation-name '(:program :binary)))) - (loop :with dest-path = (truename (ensure-directories-exist move-here-path)) - :for f :in files - :for new-f = (make-pathname :name (pathname-name f) - :type (pathname-type f) - :defaults dest-path) - :do (rename-file-overwriting-target f new-f) - :collect new-f) - files))) - -;;; -;;; LOAD-FASL-OP -;;; -;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. -;;; - -(defclass load-fasl-op (basic-load-op) ()) - -(defmethod component-depends-on ((o load-fasl-op) (c system)) - (declare (ignorable o)) - `((load-fasl-op ,@(loop :for dep :in (component-sibling-dependencies c) - :collect (resolve-dependency-spec c dep))) - (,(if (user-system-p c) 'fasl-op 'load-op) ,c) - ,@(call-next-method))) - -(defmethod input-files ((o load-fasl-op) (c system)) - (when (user-system-p c) - (output-files (find-operation o 'fasl-op) c))) - -(defmethod perform ((o load-fasl-op) c) - (declare (ignorable o c)) - nil) - -(defmethod perform ((o load-fasl-op) (c system)) - (aif (first (input-files o c)) (load it))) - -(defmethod mark-operation-done :after ((o load-fasl-op) (c system)) - (mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components? - -;;; -;;; PRECOMPILED FILES -;;; -;;; This component can be used to distribute ASDF systems in precompiled form. -;;; Only useful when the dependencies have also been precompiled. -;;; - -(defclass compiled-file (file-component) - ((type :initform #-(or ecl mkcl) (fasl-type) #+(or ecl mkcl) "fasb"))) - -(defmethod trivial-system-p ((s system)) - (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) - -(defmethod output-files (o (c compiled-file)) - (declare (ignorable o c)) - nil) -(defmethod input-files (o (c compiled-file)) - (declare (ignorable o)) - (component-pathname c)) -(defun perform-lisp-load-fasl (o c) - (load (first (input-files o c)))) -(defmethod perform ((o load-op) (c cl-source-file)) - (perform-lisp-load-fasl o c)) -(defmethod perform ((o load-source-op) (c compiled-file)) - (perform (find-operation o 'load-op) c)) -(defmethod perform ((o load-fasl-op) (c compiled-file)) - (perform (find-operation o 'load-op) c)) -(defmethod perform (o (c compiled-file)) - (declare (ignorable o c)) - nil) - -;;; -;;; Pre-built systems -;;; -(defclass prebuilt-system (system) - ((static-library :accessor prebuilt-system-static-library :initarg :lib))) - -(defmethod builtin-system-p ((s system)) - (let* ((system (find-system s nil)) - (sysdir (and system (component-pathname system))) - (impdir (lisp-implementation-directory :truename t))) - (and sysdir impdir (pathname-match-p (truename sysdir) (wilden impdir)) t))) - -(defmethod trivial-system-p ((s prebuilt-system)) - (declare (ignorable s)) - t) - -(defmethod output-files ((o lib-op) (c prebuilt-system)) - (declare (ignorable o)) - (values (list (prebuilt-system-static-library c)) - t)) ; Advertise that we do not want this path renamed by asdf-output-translations - -(defmethod perform ((o lib-op) (c prebuilt-system)) - (first (output-files o c))) - -(defmethod component-depends-on ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - -(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - -(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system)) - (declare (ignorable o)) - (error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c)) - -(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - -;;; -;;; PREBUILT SYSTEM CREATOR -;;; - -(defclass binary-op (bundle-op) - ()) - -(defclass monolithic-binary-op (binary-op monolithic-bundle-op) - ()) - -(defun* binary-op-dependencies (o s) - (multiple-value-bind (lib-op fasl-op) - (if (operation-monolithic-p o) - (values 'monolithic-lib-op 'monolithic-fasl-op) - (values 'lib-op 'fasl-op)) - `((,(find-operation o lib-op) ,s) - (,(find-operation o fasl-op) ,s)))) - -(defmethod component-depends-on ((o binary-op) (s system)) - `(,@(loop :for dep :in (binary-op-dependencies o s) - :append (apply #'component-depends-on dep)) - ,@(call-next-method))) - -(defmethod input-files ((o binary-op) (s system)) - (loop :for dep :in (binary-op-dependencies o s) - :append (apply #'input-files dep))) - -(defmethod output-files ((o binary-op) (s system)) - (list* (merge-pathnames* (make-pathname :name (component-name s) - :type "asd") - (component-relative-pathname s)) - (loop :for dep :in (binary-op-dependencies o s) - :append (apply #'output-files dep)))) - -(defmethod perform ((o binary-op) (s system)) - (let* ((dependencies (binary-op-dependencies o s)) - (library (first (apply #'output-files (first dependencies)))) - (fasl (first (apply #'output-files (second dependencies)))) - (filename (first (output-files o s))) - (name (component-name s)) - (name-keyword (intern (string name) (find-package :keyword)))) - (dolist (dep dependencies) - (apply #'perform dep)) - (with-open-file (s filename :direction :output :if-exists :supersede - :if-does-not-exist :create) - (format s ";;; Prebuilt ASDF definition for system ~A" name) - (format s ";;; Built for ~A ~A on a ~A/~A ~A" - (lisp-implementation-type) - (lisp-implementation-version) - (software-type) - (machine-type) - (software-version)) - (let ((*package* (find-package :keyword))) - (pprint `(defsystem ,name-keyword - :class asdf::prebuilt-system - :components ((:compiled-file ,(pathname-name fasl))) - :lib ,(make-pathname :name (pathname-name library) - :type (pathname-type library))) - s))))) - -(defun* copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) - "Copy the contents of the INPUT stream into the OUTPUT stream, -using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver - (with-open-stream (input input) - (loop - :for buffer = (make-array (list buffer-size) :element-type element-type) - :for end = (read-sequence buffer input) - :until (zerop end) - :do (write-sequence buffer output :end end) - (when (< end buffer-size) (return))))) - -(defun* concatenate-files (inputs output) - (with-open-file (o output :element-type '(unsigned-byte 8) - :direction :output :if-exists :rename-and-delete) - (dolist (input inputs) - (with-open-file (i input :element-type '(unsigned-byte 8) - :direction :input :if-does-not-exist :error) - (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) - -(defun* combine-fasls (inputs output) - #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) - (declare (ignore inputs output)) - #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) - (error "~S is not supported on ~A" 'combine-fasls (implementation-type)) - #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) - #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) - #+lispworks - (let (fasls) - (unwind-protect - (progn - (loop :for i :in inputs - :for n :from 1 - :for f = (add-pathname-suffix - output (format nil "-FASL~D" n)) - :do #-lispworks-personal-edition (lispworks:copy-file i f) - #+lispworks-personal-edition (concatenate-files (list i) f) - (push f fasls)) - (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) - (eval `(scm:defsystem :fasls-to-concatenate - (:default-pathname ,(pathname-directory-pathname output)) - :members - ,(loop :for f :in (reverse fasls) - :collect `(,(namestring f) :load-only t)))) - (scm:concatenate-system output :fasls-to-concatenate)) - (loop :for f :in fasls :do (ignore-errors (delete-file f))) - (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) - -#-(or ecl mkcl) -(defmethod perform ((o bundle-op) (c system)) - (let* ((input-files (input-files o c)) - (fasl-files (remove (fasl-type) input-files :key #'pathname-type :test-not #'string=)) - (non-fasl-files (remove (fasl-type) input-files :key #'pathname-type :test #'string=)) - (output-files (output-files o c)) - (output-file (first output-files))) - (when input-files - (assert output-files) - (when non-fasl-files - (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" - (implementation-type) non-fasl-files)) - (when (and (typep o 'monolithic-bundle-op) - (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) - (error "prologue-code and epilogue-code are not supported on ~A" - (implementation-type))) - (with-staging-pathname (output-file) - (combine-fasls fasl-files output-file))))) - -(defmethod output-files ((o fasl-op) (c source-file)) - (declare (ignorable o c)) - nil) - -(defmethod input-files ((o fasl-op) (c source-file)) - (declare (ignorable o c)) - nil) - -(defclass precompiled-system (system) - ((fasl :initarg :fasl :reader %system-fasl))) - -(defgeneric* system-fasl (system)) -(defmethod system-fasl ((system precompiled-system)) - (let* ((f (%system-fasl system)) - (p (etypecase f - ((or pathname string) f) - (function (funcall f)) - (cons (eval f))))) - (pathname p))) - -(defmethod input-files ((o load-op) (s precompiled-system)) - (declare (ignorable o)) - (list (system-fasl s))) - -(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) - (declare (ignorable o)) - `((load-op ,s) ,@(call-next-method))) - -#| ;; Example use: -(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) -(asdf:load-system :precompiled-asdf-utils) -|# - -#+ecl -(defmethod output-files ((o fasl-op) (c system)) - (declare (ignorable o c)) - (loop :for file :in (call-next-method) - :collect (make-pathname :type "fasb" :defaults file))) - -#+ecl -(defmethod perform ((o bundle-op) (c system)) - (let* ((object-files (remove "fas" (input-files o c) - :key #'pathname-type :test #'string=)) - (output (output-files o c))) - (apply #'c::builder (bundle-op-type o) (first output) - :lisp-files (append object-files (bundle-op-lisp-files o)) - (append (bundle-op-build-args o) - (when (and (typep o 'monolithic-bundle-op) - (monolithic-op-prologue-code o)) - `(:prologue-code ,(monolithic-op-prologue-code o))) - (when (and (typep o 'monolithic-bundle-op) - (monolithic-op-epilogue-code o)) - `(:epilogue-code ,(monolithic-op-epilogue-code o))))))) - -#+mkcl -(progn -;;; -;;; BUNDLE-SUB-OPERATIONS -;;; -;;; Builds a list of pairs (operation . component) which contains all the -;;; dependencies of this bundle. -;;; - -(defun* mkcl-bundle-sub-operations (op sys) - (gather-components (find-operation op 'compile-op) sys - :other-systems nil - :filter-type '(not system))) - -(defun* files-to-bundle (operation system) - (loop :for (o . c) :in (mkcl-bundle-sub-operations operation system) - :for sub-files = (output-files o c) - :when sub-files :collect (first sub-files))) - -(defmethod component-depends-on ((o bundle-op) (c system)) - (declare (ignorable o)) - `((compile-op ,c) ,@(call-next-method))) - -(defmethod output-files ((o bundle-op) (c system)) - (let* ((name (component-name c)) - (static-lib-name (merge-pathnames - (compiler::builder-internal-pathname name :static-library) - (component-relative-pathname c))) - (fasl-bundle-name (merge-pathnames - (compiler::builder-internal-pathname name :fasb) - (component-relative-pathname c)))) - (list static-lib-name fasl-bundle-name))) - -(defmethod perform ((o bundle-op) (c system)) - (let ((object-files (files-to-bundle o c)) - (output (output-files o c))) - (when (bundle-op-do-static-library-p o) - (apply #'compiler::build-static-library (first output) - :lisp-object-files object-files (bundle-op-build-args o))) - (when (bundle-op-do-fasb-p o) - (apply #'compiler::build-bundle (second output) - :lisp-object-files object-files (bundle-op-build-args o))))) - -(defun* bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'bundle-op system args)) -);mkcl - -;;; -;;; Concatenate sources -;;; - -(defclass concatenated-source-system (system) - ((concatenated-source-file - :initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file) - (translate-output-p - :initform t :initarg :translate-output-p :reader system-translate-output-p))) - -(defmethod system-concatenated-source-file ((s system)) - (declare (ignorable s)) - nil) -(defmethod system-translate-output-p ((s system)) - (declare (ignorable s)) - t) - -(defclass concatenate-source-op (operation) ()) -(defclass load-concatenated-source-op (basic-load-op operation) ()) -(defclass compile-concatenated-source-op (basic-compile-op operation) ()) -(defclass load-compiled-concatenated-source-op (basic-load-op operation) ()) -(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) -(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) -(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) -(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) - -(defmethod input-files ((o concatenate-source-op) (s system)) - (loop :with op = (make-operation 'compile-op) - :with components = (gather-components op s - :include-self nil - :filter-type 'source-file - :other-systems (operation-monolithic-p o)) - :with non-cl-source-files = nil - :with encoding = (or (component-encoding s) *default-encoding*) - :with other-encodings = '() - :with around-compile = (around-compile-hook s) - :with other-around-compile = '() - :for (o . c) :in components - :do (cond - ((typep c 'cl-source-file) - (let ((e (component-encoding c))) - (unless (equal e encoding) - (pushnew e other-encodings :test 'equal))) - (let ((a (around-compile-hook c))) - (unless (equal a around-compile) - (pushnew a other-around-compile :test 'equal)))) - (t - (push c non-cl-source-files))) - :append (input-files o c) :into inputs - :finally - (when non-cl-source-files - (warn "~S depends on these non CL source files: ~A" - 'concatenated-source-op non-cl-source-files)) - (when other-encodings - (warn "~S uses encoding ~A but has sources that use these encodings: ~A" - 'concatenated-source-op encoding other-encodings)) - (when other-around-compile - (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" - 'concatenated-source-op around-compile other-around-compile)) - (return inputs))) - -(defmethod output-files ((o concatenate-source-op) (s system)) - (declare (ignorable o)) - (let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp"))) - (top (system-translate-output-p s))) - (values (list (system-relative-pathname s of)) (not top)))) -(defmethod input-files ((o load-concatenated-source-op) (s system)) - (output-files (find-operation o 'concatenate-source-op) s)) -(defmethod input-files ((o compile-concatenated-source-op) (s system)) - (output-files (find-operation o 'concatenate-source-op) s)) -(defmethod output-files ((o compile-concatenated-source-op) (s system)) - (let ((input (first (input-files o s)))) - (list (compile-file-pathname input)))) -(defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) - (output-files (find-operation o 'compile-concatenated-source-op) s)) - -(defmethod perform ((o concatenate-source-op) (s system)) - (let ((inputs (input-files o s)) - (output (output-file o s))) - (concatenate-files inputs output))) -(defmethod perform ((o load-concatenated-source-op) (s system)) - (perform-lisp-load-source o s)) -(defmethod perform ((o compile-concatenated-source-op) (s system)) - (perform-lisp-compilation o s)) -(defmethod perform ((o load-compiled-concatenated-source-op) (s system)) - (perform-lisp-load-fasl o s)) - -(defmethod component-depends-on ((o concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) -(defmethod component-depends-on ((o load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s))) -(defmethod component-depends-on ((o compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((concatenate-source-op ,s))) -(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((compile-concatenated-source-op ,s))) - -(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) -(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) -(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) -(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))) - -;;;; ----------------------------------------------------------------- -;;;; Done! -(when *load-verbose* - (asdf-message ";; ASDF, version ~a~%" (asdf-version))) - -#+allegro -(eval-when (:compile-toplevel :execute) - (when (boundp 'excl:*warn-on-nested-reader-conditionals*) - (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) - -#+(or ecl mkcl) -(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) - -(dolist (f '(:asdf :asdf2 :asdf2.27)) (pushnew f *features*)) - -(provide :asdf) - -;;; Local Variables: -;;; mode: lisp -;;; End: diff --git a/backward-interface.lisp b/backward-interface.lisp new file mode 100644 index 0000000000000000000000000000000000000000..beaea616a3a63f139d8802c04530d6fcf1359192 --- /dev/null +++ b/backward-interface.lisp @@ -0,0 +1,249 @@ +;;;; ------------------------------------------------------------------------- +;;; Backward-compatible interfaces + +(defpackage :asdf/backward-interface + (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/os + :asdf/component :asdf/system :asdf/operation :asdf/action + :asdf/lisp-build :asdf/operate :asdf/output-translations) + (:export + #:*asdf-verbose* + #:component-load-dependencies + #:enable-asdf-binary-locations-compatibility + #:merge-component-name-type + #:operation-forced + #:operation-on-failure + #:operation-on-warnings + #:run-shell-command + #:system-definition-pathname)) + +(in-package :asdf/backward-interface) + +(defvar *asdf-verbose* nil) ; worked around by cl-protobufs. It was a mistake to introduce it. mea culpa -fare + +(defun* component-load-dependencies (component) + ;; Old deprecated name for the same thing. Please update your software. + (component-sibling-dependencies component)) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backward-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)) + +(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader. +(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) + +(defgeneric* operation-on-warnings (operation)) +(defgeneric* operation-on-failure (operation)) +#-gcl<2.7 (defgeneric* (setf operation-on-warnings) (x operation)) +#-gcl<2.7 (defgeneric* (setf operation-on-failure) (x operation)) +(defmethod operation-on-warnings ((o operation)) + (declare (ignorable o)) *compile-file-warnings-behaviour*) +(defmethod operation-on-failure ((o operation)) + (declare (ignorable o)) *compile-file-failure-behaviour*) +(defmethod (setf operation-on-warnings) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) +(defmethod (setf operation-on-failure) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) + +(defun* system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + + +;;;; ASDF-Binary-Locations compatibility + +(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 (fasl-type)) + (mapped-files (if map-all-source-files *wild-file* + (make-pathname :type fasl-type :defaults *wild-file*))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + ,@source-to-target-mappings + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) + ((:root ,*wild-inferiors* ,mapped-files) + (,@destination-directory ,mapped-files)) + (t t) + :ignore-inherited-configuration)))) + +(defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L."))) + + +;;;; run-shell-command +;; +;; 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))) + (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) + :input nil :output *verbose-out*)) + + #+cormanlisp + (win32:system command) + + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (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) + + #+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)))))) + diff --git a/backward-internals.lisp b/backward-internals.lisp new file mode 100644 index 0000000000000000000000000000000000000000..063e3df4fe699cd2be745f5dd7ca85b99413d8fa --- /dev/null +++ b/backward-internals.lisp @@ -0,0 +1,66 @@ +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility + +(defpackage :asdf/backward-internals + (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname + :asdf/system :asdf/component :asdf/find-system :asdf/action) + (:export ;; for internal use + #:%refresh-component-inline-methods + #:%resolve-if-component-dep-fails)) +(in-package :asdf/backward-internals) + +;;;; Backward compatibility with "inline methods" + +(defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + +(defun* %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf + ;; But this is hardly performance-critical + #'(lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods component))) + ;; clear methods, then add the new ones + (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)) + +;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute +;; and the companion asdf:feature pseudo-dependency. +;; This won't recurse into dependencies to accumulate feature conditions. +;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL +;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. +(defun %resolve-if-component-dep-fails (if-component-dep-fails component) + (asdf-message "The system definition for ~S uses deprecated ~ + ASDF option :IF-COMPONENT-DEP-DAILS. ~ + Starting with ASDF 2.27, please use :IF-FEATURE instead" + (coerce-name (component-system component))) + ;; This only supports the pattern of use of the "feature" seen in the wild + (check-type component parent-component) + (check-type if-component-dep-fails (member :fail :ignore :try-next)) + (unless (eq if-component-dep-fails :fail) + (loop :with o = (make-instance 'compile-op) + :for c :in (component-children component) :do + (loop :for (feature? feature) :in (component-depends-on o c) + :when (eq feature? 'feature) :do + (setf (component-if-feature c) feature))))) + diff --git a/bin/bump-version b/bin/bump-version index f37226570d0b5b2f8644e96249ebefdb6cc40191..9ac83866060ec0deee168799649b849023082bde 100755 --- a/bin/bump-version +++ b/bin/bump-version @@ -5,19 +5,21 @@ NEWVER="${1}" PROG="$0" ASDFDIR="$(cd $(dirname $PROG)/.. ; /bin/pwd)" ## readlink -f doesn't work on BSD -ASDFLISP=${ASDFDIR}/asdf.lisp -ASDFASD=${ASDFDIR}/asdf.asd if [ -z "$NEWVER" ] ; then - OLDVER="$(grep ' (asdf-version "' $ASDFLISP | cut -d\" -f2)" + OLDVER="$(grep ' (asdf-version "' ${ASDFDIR}/header.lisp | cut -d\" -f2)" NEWVER="$(echo $OLDVER | perl -npe 's/([0-9].[0-9]+)(\.([0-9]+))?/"${1}.".($3+1)/e')" fi echo "Setting ASDF version to $NEWVER" -perl -i.bak -npe 's/^( \(asdf-version "|;;; This is ASDF )[0-9.]+("\)|:)/${1}'"$NEWVER"'${2}/' $ASDFLISP -perl -i.bak -npe 's/^( :version ")[0-9.]+(")/${1}'"$NEWVER"'${2}/' $ASDFASD +for i in ${ASDFDIR}/header.lisp ${ASDFDIR}/upgrade.lisp ; do + perl -i.bak -npe 's/^( \(asdf-version "|;;; This is ASDF )[0-9.]+("\)|:)/${1}'"$NEWVER"'${2}/' $i +done +for i in ${ASDFDIR}/asdf.asd ; do # ${ASDFDIR}/generate-asdf.asd + perl -i.bak -npe 's/^( :version ")[0-9.]+(")/${1}'"$NEWVER"'${2}/' $i +done + cat<<EOF To complete the version change, you may: - git add -u - git commit + git commit -a git tag $NEWVER EOF diff --git a/bin/make-tarball b/bin/make-tarball index 5afa79fddbf9d08cf69e63e2a9e664bd9cce9802..c117150e267217577d65437d7de53cc9437a996e 100755 --- a/bin/make-tarball +++ b/bin/make-tarball @@ -16,10 +16,6 @@ fi mkdir tmp archive_file="tmp/asdf-$tag.tar.gz" - echo "Create tmp/asdf.tar.gz with tag $tag" git archive $tag --prefix="asdf/" --format=tar | \ gzip > $archive_file -echo "Extract tmp/asdf.lisp" -tar --to-stdout -zxf $archive_file asdf/asdf.lisp > tmp/asdf.lisp - diff --git a/bundle.lisp b/bundle.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ed61f78043fc568bbb2409986c27e76b54a9d1a1 --- /dev/null +++ b/bundle.lisp @@ -0,0 +1,515 @@ +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle + +(defpackage :asdf/bundle + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + (:export + #:bundle-op #:bundle-op-build-args + #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op + #:monolithic-op #:monolithic-bundle-op + #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op + #:program-op #:compiled-file #:precompiled-system #:prebuild-system + #:operation-monolithic-p + #:user-system-p #:user-system #:trivial-system-p + #:bundle-sub-operations #:gather-components + #+ecl #:make-build + #+mkcl #:mkcl-bundle-sub-operations #+mkcl #:files-to-bundle #+mkcl #:bundle-system + #+(or ecl mkcl) #:register-pre-built-system + #:system-fasl)) +(in-package :asdf/bundle) + +(defclass bundle-op (operation) + ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (name-suffix :initarg :name-suffix :initform nil) + #+ecl (type :reader bundle-op-type) + #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) + #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) + #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) + +(defclass fasl-op (bundle-op) + ((type :initform :fasl))) + +(defclass load-fasl-op (basic-load-op) ()) + +(defclass lib-op (bundle-op) + ((type :initform :lib))) + +(defclass dll-op (bundle-op) + ((type :initform :dll))) + +(defclass binary-op (bundle-op) + ()) + +(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies + +(defclass monolithic-bundle-op (monolithic-op bundle-op) + ((prologue-code :accessor monolithic-op-prologue-code) + (epilogue-code :accessor monolithic-op-epilogue-code))) + +(defclass monolithic-binary-op (binary-op monolithic-bundle-op) + ()) + +(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ()) + +(defclass monolithic-lib-op (monolithic-bundle-op lib-op) + ((type :initform :lib))) + +(defclass monolithic-dll-op (monolithic-bundle-op dll-op) + ((type :initform :dll))) + +(defclass program-op (monolithic-bundle-op) + ((type :initform :program))) + +(defclass compiled-file (file-component) + ((type :initform #-(or ecl mkcl) (fasl-type) #+(or ecl mkcl) "fasb"))) + +(defclass precompiled-system (system) + ((fasl :initarg :fasl :reader %system-fasl))) + +(defclass prebuilt-system (system) + ((static-library :accessor prebuilt-system-static-library :initarg :lib))) + +;;; +;;; BUNDLE-OP +;;; +;;; This operation takes all components from one or more systems and +;;; creates a single output file, which may be +;;; a FASL, a statically linked library, a shared library, etc. +;;; The different targets are defined by specialization. +;;; + +(defun* operation-monolithic-p (op) + (typep op 'monolithic-op)) + +(defmethod initialize-instance :after ((instance bundle-op) &rest initargs + &key (name-suffix nil name-suffix-p) + &allow-other-keys) + (declare (ignorable initargs name-suffix)) + (format t "IIBO a ~S with ~S" (type-of instance) initargs) + (unless name-suffix-p + (setf (slot-value instance 'name-suffix) + (if (operation-monolithic-p instance) ".all-systems" ".system"))) + (when (typep instance 'monolithic-bundle-op) + (destructuring-bind (&rest original-initargs + &key lisp-files prologue-code epilogue-code + &allow-other-keys) + (operation-original-initargs instance) + (setf (operation-original-initargs instance) + (remove-keys '(lisp-files epilogue-code prologue-code) original-initargs) + (monolithic-op-prologue-code instance) prologue-code + (monolithic-op-epilogue-code instance) epilogue-code) + #-ecl (assert (null lisp-files)) + #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) + (setf (bundle-op-build-args instance) + (remove-keys '(type monolithic name-suffix) + (operation-original-initargs instance)))) + +(defmethod bundle-op-build-args :around ((o lib-op)) + (declare (ignorable o)) + (let ((args (call-next-method))) + (remf args :ld-flags) + args)) + +(defun* gather-components (operation system + &key other-systems filter-type include-self) + ;; This function creates a list of actions pairing the operation with sub-components of system + ;; and its dependencies if requested. + ;; This list may be restricted to sub-components of SYSTEM + ;; if GATHER-ALL = NIL (default), and it may include the system itself. + (let ((tree (traverse-sequentially (make-operation 'load-op) system + :force (if other-systems :all t) + :force-not (if other-systems nil :all)))) + `(,@(loop :for (op . component) :in tree + :when (and (typep op 'load-op) + (typep component filter-type)) + :collect (progn + (when (eq component system) (setf include-self nil)) + `(,operation . ,component))) + ,@(and include-self `((,operation . ,system)))))) + +(defgeneric* trivial-system-p (component)) + +(defun* user-system-p (s) + (and (typep s 'system) + (not (builtin-system-p s)) + (not (trivial-system-p s)))) + +(deftype user-system () '(and system (satisfies user-system-p))) + +;;; +;;; BUNDLE-SUB-OPERATIONS +;;; +;;; Builds a list of pairs (operation . component) +;;; which contains all the dependencies of this bundle. +;;; This list is used by TRAVERSE and also by INPUT-FILES. +;;; The dependencies depend on the strategy, as explained below. +;;; +(defgeneric* bundle-sub-operations (operation component)) +;;; +;;; First we handle monolithic bundles. +;;; These are standalone systems which contain everything, +;;; including other ASDF systems required by the current one. +;;; A PROGRAM is always monolithic. +;;; +;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL +;;; +;;; Gather the static libraries of all components. +;;; +(defmethod bundle-sub-operations ((o monolithic-bundle-op) c) + (gather-components (find-operation o 'lib-op) c :filter-type 'user-system :include-self t)) + +;;; +;;; STATIC LIBRARIES +;;; +;;; Gather the object files of all components +;;; and, if monolithic, also of systems and subsystems. +;;; +(defmethod bundle-sub-operations ((o lib-op) c) + (gather-components (find-operation o 'compile-op) c + :other-systems (operation-monolithic-p o) + :filter-type '(not system))) +;;; +;;; SHARED LIBRARIES +;;; +;;; Gather the dynamically linked libraries of all components. +;;; They will be linked into this new shared library, +;;; together with the static library of this module. +;;; +(defmethod bundle-sub-operations ((o dll-op) c) + `((,(find-operation o 'lib-op) . ,c))) +;;; +;;; FASL FILES +;;; +;;; Gather the statically linked library of this component. +;;; +(defmethod bundle-sub-operations ((o fasl-op) c) + `((,(find-operation o 'lib-op) . ,c))) + +#-mkcl +(defmethod component-depends-on ((o bundle-op) (c system)) + `(,@(loop :for (op . dep) :in (bundle-sub-operations o c) + :when (user-system-p dep) :collect (list op dep)) + ,@(call-next-method))) + +(defmethod component-depends-on ((o lib-op) (c system)) + (declare (ignorable o)) + `((compile-op ,c) ,@(call-next-method))) + +(defmethod component-depends-on ((o bundle-op) c) + (declare (ignorable o c)) + nil) + +#-mkcl +(defmethod input-files ((o bundle-op) (c system)) + (loop :for (sub-op . sub-c) :in (bundle-sub-operations o c) + :nconc (output-files sub-op sub-c))) + +#-mkcl +(defmethod output-files ((o bundle-op) (c system)) + (list (compile-file-pathname + (make-pathname + :name (strcat (component-name c) (slot-value o 'name-suffix) + #|"-" (string-downcase (implementation-type))|#) + :type "lisp" + :defaults (system-source-directory c)) + #+ecl :type #+ecl (bundle-op-type o)))) + +(defun* select-operation (monolithic type) + (ecase type + ((:binary) + (if monolithic 'monolithic-binary-op 'binary-op)) + ((:dll :shared-library) + (if monolithic 'monolithic-dll-op 'dll-op)) + ((:lib :static-library) + (if monolithic 'monolithic-lib-op 'lib-op)) + ((:fasl) + (if monolithic 'monolithic-fasl-op 'fasl-op)) + ((:program) + 'program-op))) + +(defun* make-build (system &rest args &key (monolithic nil) (type :fasl) + (move-here nil move-here-p) + &allow-other-keys) + (let* ((operation-name (select-operation monolithic type)) + (move-here-path (if (and move-here + (typep move-here '(or pathname string))) + (pathname move-here) + (merge-pathnames "./asdf-output/"))) + (operation (apply #'operate operation-name + system + (remove-keys '(monolithic type move-here) args))) + (system (find-system system)) + (files (and system (output-files operation system)))) + (if (or move-here (and (null move-here-p) + (member operation-name '(:program :binary)))) + (loop :with dest-path = (truename (ensure-directories-exist move-here-path)) + :for f :in files + :for new-f = (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files))) + +;;; +;;; LOAD-FASL-OP +;;; +;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. +;;; + +(defmethod component-depends-on ((o load-fasl-op) (c system)) + (declare (ignorable o)) + `((load-fasl-op ,@(loop :for dep :in (component-sibling-dependencies c) + :collect (resolve-dependency-spec c dep))) + (,(if (user-system-p c) 'fasl-op 'load-op) ,c) + ,@(call-next-method))) + +(defmethod input-files ((o load-fasl-op) (c system)) + (when (user-system-p c) + (output-files (find-operation o 'fasl-op) c))) + +(defmethod perform ((o load-fasl-op) c) + (declare (ignorable o c)) + nil) + +(defmethod perform ((o load-fasl-op) (c system)) + (aif (first (input-files o c)) (load it))) + +(defmethod mark-operation-done :after ((o load-fasl-op) (c system)) + (mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components? + +;;; +;;; PRECOMPILED FILES +;;; +;;; This component can be used to distribute ASDF systems in precompiled form. +;;; Only useful when the dependencies have also been precompiled. +;;; + +(defmethod trivial-system-p ((s system)) + (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) + +(defmethod output-files (o (c compiled-file)) + (declare (ignorable o c)) + nil) +(defmethod input-files (o (c compiled-file)) + (declare (ignorable o)) + (component-pathname c)) +(defmethod perform ((o load-op) (c compiled-file)) + (declare (ignorable o)) + (load (first (input-files o c)))) +(defmethod perform ((o load-source-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) +(defmethod perform ((o load-fasl-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) +(defmethod perform (o (c compiled-file)) + (declare (ignorable o c)) + nil) + +;;; +;;; Pre-built systems +;;; +(defmethod trivial-system-p ((s prebuilt-system)) + (declare (ignorable s)) + t) + +(defmethod output-files ((o lib-op) (c prebuilt-system)) + (declare (ignorable o)) + (values (list (prebuilt-system-static-library c)) + t)) ; Advertise that we do not want this path renamed by asdf-output-translations + +(defmethod perform ((o lib-op) (c prebuilt-system)) + (first (output-files o c))) + +(defmethod component-depends-on ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + +(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + +(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system)) + (declare (ignorable o)) + (error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c)) + +(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + +;;; +;;; PREBUILT SYSTEM CREATOR +;;; + +(defun* binary-op-dependencies (o s) + (multiple-value-bind (lib-op fasl-op) + (if (operation-monolithic-p o) + (values 'monolithic-lib-op 'monolithic-fasl-op) + (values 'lib-op 'fasl-op)) + `((,(find-operation o lib-op) ,s) + (,(find-operation o fasl-op) ,s)))) + +(defmethod component-depends-on ((o binary-op) (s system)) + `(,@(loop :for dep :in (binary-op-dependencies o s) + :append (apply #'component-depends-on dep)) + ,@(call-next-method))) + +(defmethod input-files ((o binary-op) (s system)) + (loop :for dep :in (binary-op-dependencies o s) + :append (apply #'input-files dep))) + +(defmethod output-files ((o binary-op) (s system)) + (list* (merge-pathnames* (make-pathname :name (component-name s) + :type "asd") + (component-relative-pathname s)) + (loop :for dep :in (binary-op-dependencies o s) + :append (apply #'output-files dep)))) + +(defmethod perform ((o binary-op) (s system)) + (let* ((dependencies (binary-op-dependencies o s)) + (library (first (apply #'output-files (first dependencies)))) + (fasl (first (apply #'output-files (second dependencies)))) + (filename (first (output-files o s))) + (name (component-name s)) + (name-keyword (intern (string name) (find-package :keyword)))) + (dolist (dep dependencies) + (apply #'perform dep)) + (with-open-file (s filename :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format s ";;; Prebuilt ASDF definition for system ~A" name) + (format s ";;; Built for ~A ~A on a ~A/~A ~A" + (lisp-implementation-type) + (lisp-implementation-version) + (software-type) + (machine-type) + (software-version)) + (let ((*package* (find-package :keyword))) + (pprint `(defsystem ,name-keyword + :class prebuilt-system + :components ((:compiled-file ,(pathname-name fasl))) + :lib ,(make-pathname :name (pathname-name library) + :type (pathname-type library))) + s))))) + +#-(or ecl mkcl) +(defmethod perform ((o bundle-op) (c system)) + (let* ((input-files (input-files o c)) + (fasl-files (remove (fasl-type) input-files :key #'pathname-type :test-not #'string=)) + (non-fasl-files (remove (fasl-type) input-files :key #'pathname-type :test #'string=)) + (output-files (output-files o c)) + (output-file (first output-files))) + (when input-files + (assert output-files) + (when non-fasl-files + (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" + (implementation-type) non-fasl-files)) + (when (and (typep o 'monolithic-bundle-op) + (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) + (error "prologue-code and epilogue-code are not supported on ~A" + (implementation-type))) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) + +(defmethod output-files ((o fasl-op) (c source-file)) + (declare (ignorable o c)) + nil) + +(defmethod input-files ((o fasl-op) (c source-file)) + (declare (ignorable o c)) + nil) + +(defgeneric* system-fasl (system)) +(defmethod system-fasl ((system precompiled-system)) + (let* ((f (%system-fasl system)) + (p (etypecase f + ((or pathname string) f) + (function (funcall f)) + (cons (eval f))))) + (pathname p))) + +(defmethod input-files ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (list (system-fasl s))) + +(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + `((load-op ,s) ,@(call-next-method))) + +#| ;; Example use: +(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) +(asdf:load-system :precompiled-asdf-utils) +|# + +#+ecl +(defmethod output-files ((o fasl-op) (c system)) + (declare (ignorable o c)) + (loop :for file :in (call-next-method) + :collect (make-pathname :type "fasb" :defaults file))) + +#+ecl +(defmethod perform ((o bundle-op) (c system)) + (let* ((object-files (remove "fas" (input-files o c) + :key #'pathname-type :test #'string=)) + (output (output-files o c))) + (apply #'c::builder (bundle-op-type o) (first output) + :lisp-files (append object-files (bundle-op-lisp-files o)) + (append (bundle-op-build-args o) + (when (and (typep o 'monolithic-bundle-op) + (monolithic-op-prologue-code o)) + `(:prologue-code ,(monolithic-op-prologue-code o))) + (when (and (typep o 'monolithic-bundle-op) + (monolithic-op-epilogue-code o)) + `(:epilogue-code ,(monolithic-op-epilogue-code o))))))) + +#+mkcl +(progn +;;; +;;; BUNDLE-SUB-OPERATIONS +;;; +;;; Builds a list of pairs (operation . component) which contains all the +;;; dependencies of this bundle. +;;; + +(defun* mkcl-bundle-sub-operations (op sys) + (gather-components (find-operation op 'compile-op) sys + :other-systems nil + :filter-type '(not system))) + +(defun* files-to-bundle (operation system) + (loop :for (o . c) :in (mkcl-bundle-sub-operations operation system) + :for sub-files = (output-files o c) + :when sub-files :collect (first sub-files))) + +(defmethod component-depends-on ((o bundle-op) (c system)) + (declare (ignorable o)) + `((compile-op ,c) ,@(call-next-method))) + +(defmethod output-files ((o bundle-op) (c system)) + (let* ((name (component-name c)) + (static-lib-name (merge-pathnames + (compiler::builder-internal-pathname name :static-library) + (component-relative-pathname c))) + (fasl-bundle-name (merge-pathnames + (compiler::builder-internal-pathname name :fasb) + (component-relative-pathname c)))) + (list static-lib-name fasl-bundle-name))) + +(defmethod perform ((o bundle-op) (c system)) + (let ((object-files (files-to-bundle o c)) + (output (output-files o c))) + (when (bundle-op-do-static-library-p o) + (apply #'compiler::build-static-library (first output) + :lisp-object-files object-files (bundle-op-build-args o))) + (when (bundle-op-do-fasb-p o) + (apply #'compiler::build-bundle (second output) + :lisp-object-files object-files (bundle-op-build-args o))))) + +(defun* bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'bundle-op system args)) +);mkcl + +#+(or ecl mkcl) +(defun* register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) diff --git a/component.lisp b/component.lisp new file mode 100644 index 0000000000000000000000000000000000000000..bc1a90dbb3fe3a3ec848e9b37895ed2519242986 --- /dev/null +++ b/component.lisp @@ -0,0 +1,237 @@ +;;;; ------------------------------------------------------------------------- +;;;; Components + +(defpackage :asdf/component + (:use :common-lisp :asdf/implementation :asdf/utility :asdf/pathname :asdf/upgrade) + (:export + #:component #:component-find-path + #:component-name #:component-pathname #:component-relative-pathname + #:component-parent #:component-system #:component-parent-pathname + #:source-file-type ;; backward-compatibility + #:component-in-order-to #:component-sibling-dependencies + #:component-if-feature #:around-compile-hook + #:component-description #:component-long-description + #:component-version #:version-satisfies + #:component-properties #:component-property ;; backward-compatibility only. DO NOT USE! + #:component-inline-methods ;; backward-compatibility only. DO NOT USE! + #:component-operation-times ;; For internal use only. + ;; portable ASDF encoding and implementation-specific external-format + #:component-external-format #:component-encoding + #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding + #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format + #:*default-encoding* #:*utf-8-external-format* + )) +(in-package :asdf/component) + +(defgeneric* component-name (component) + (:documentation "Name of the COMPONENT, unique relative to its parent")) +(defgeneric* component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) +(defgeneric* component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) +(defgeneric* component-relative-pathname (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) +(defgeneric* component-property (component property)) +#-gcl<2.7 +(defgeneric* (setf component-property) (new-value component property)) +(defgeneric* component-external-format (component)) +(defgeneric* component-encoding (component)) +(defgeneric* version-satisfies (component version)) +(defgeneric* source-file-type (component system)) + +(with-upgrade (:when (find-class 'component nil)) + (defmethod reinitialize-instance :after ((c component) &rest initargs &key) + (declare (ignorable c initargs)) (values))) + +(defclass component () + ((name :accessor component-name :initarg :name :type string :documentation + "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! + (version :accessor component-version :initarg :version) + (description :accessor component-description :initarg :description) + (long-description :accessor component-long-description :initarg :long-description) + (sibling-dependencies :accessor component-sibling-dependencies :initform nil) + (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). + ;; Dependencies are represented as alists of operations + ;; to dependencies (other actions) in each component. + ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: + ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. + ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) + ;; and do-first things that modify the current image (such as loading a fasl). + ;; These are now unified because we now correctly propagate timestamps between dependencies. + ;; Happily, no one seems to have used do-first too much, but the name in-order-to remains. + ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. + ;; See our ASDF 2 paper for more complete explanations. + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES. + ;; 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) + ;; 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) + ;; For backward-compatibility, this slot is part of component rather than child-component + (parent :initarg :parent :initform nil :reader component-parent))) + +(defun* component-find-path (component) + (check-type component (or null component)) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~{~S~^ ~}" (component-find-path c)))) + +(defmethod component-system ((component component)) + (aif (component-parent component) + (component-system it) + component)) + + +;;;; component pathnames + +(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)) + (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 "~@<Invalid relative pathname ~S for component ~S~@:>") + pathname (component-find-path component))) + (setf (slot-value component 'absolute-pathname) pathname) + pathname))) + +(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)) ;; backward-compatibility + :defaults (component-parent-pathname component))) + + +;;;; General component-property - ASDF3: remove? Define clean subclasses, not messy "properties". + +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value) + + +;;;; Encodings + +(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) + (if (and pathname (probe-file pathname)) + (funcall *encoding-detection-hook* pathname) + *default-encoding*)) + +(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 backward-compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") 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))) + + +;;;; around-compile-hook + +(defgeneric* around-compile-hook (component)) +(defmethod around-compile-hook ((c component)) + (cond + ((slot-boundp c 'around-compile) + (slot-value c 'around-compile)) + ((component-parent c) + (around-compile-hook (component-parent c))))) + + +;;;; version-satisfies + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (when version + (warn "Requested version ~S but component ~S has no version" version c)) + (return-from version-satisfies t)) + (version-satisfies (component-version c) version)) + +(defmethod version-satisfies ((cver string) version) + (version-compatible-p cver version)) diff --git a/concatenate-source.lisp b/concatenate-source.lisp new file mode 100644 index 0000000000000000000000000000000000000000..669dbe28eafcb7f2b93c86f4802e5df12782febd --- /dev/null +++ b/concatenate-source.lisp @@ -0,0 +1,125 @@ +;;;; ------------------------------------------------------------------------- +;;;; Concatenate-source + +(defpackage :asdf/concatenate-source + (:use :common-lisp :asdf/utility :asdf/os + :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/defsystem + :asdf/action :asdf/lisp-action :asdf/bundle) + (:export + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op + #:concatenated-source-system + #:system-concatenated-source-file + #:system-translate-output-p)) +(in-package :asdf/concatenate-source) + +;;; +;;; Concatenate sources +;;; +(defclass concatenate-source-op (operation) ()) +(defclass load-concatenated-source-op (basic-load-op operation) ()) +(defclass compile-concatenated-source-op (basic-compile-op operation) ()) +(defclass load-compiled-concatenated-source-op (basic-load-op operation) ()) +(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) +(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) +(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) +(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) + +(defclass concatenated-source-system (system) + ((concatenated-source-file + :initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file) + (translate-output-p + :initform t :initarg :translate-output-p :reader system-translate-output-p))) + +(defmethod system-concatenated-source-file ((s system)) + (declare (ignorable s)) + nil) +(defmethod system-translate-output-p ((s system)) + (declare (ignorable s)) + t) + +(defmethod input-files ((o concatenate-source-op) (s system)) + (loop :with op = (make-operation 'compile-op) + :with components = (gather-components op s + :include-self nil + :filter-type 'source-file + :other-systems (operation-monolithic-p o)) + :with non-cl-source-files = nil + :with encoding = (or (component-encoding s) *default-encoding*) + :with other-encodings = '() + :with around-compile = (around-compile-hook s) + :with other-around-compile = '() + :for (o . c) :in components + :do (cond + ((typep c 'cl-source-file) + (let ((e (component-encoding c))) + (unless (equal e encoding) + (pushnew e other-encodings :test 'equal))) + (let ((a (around-compile-hook c))) + (unless (equal a around-compile) + (pushnew a other-around-compile :test 'equal)))) + (t + (push c non-cl-source-files))) + :append (input-files o c) :into inputs + :finally + (when non-cl-source-files + (warn "~S depends on these non CL source files: ~A" + 'concatenated-source-op non-cl-source-files)) + (when other-encodings + (warn "~S uses encoding ~A but has sources that use these encodings: ~A" + 'concatenated-source-op encoding other-encodings)) + (when other-around-compile + (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" + 'concatenated-source-op around-compile other-around-compile)) + (return inputs))) + +(defmethod output-files ((o concatenate-source-op) (s system)) + (declare (ignorable o)) + (let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp"))) + (top (system-translate-output-p s))) + (values (list (system-relative-pathname s of)) (not top)))) +(defmethod input-files ((o load-concatenated-source-op) (s system)) + (output-files (find-operation o 'concatenate-source-op) s)) +(defmethod input-files ((o compile-concatenated-source-op) (s system)) + (output-files (find-operation o 'concatenate-source-op) s)) +(defmethod output-files ((o compile-concatenated-source-op) (s system)) + (let ((input (first (input-files o s)))) + (list (compile-file-pathname input)))) +(defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) + (output-files (find-operation o 'compile-concatenated-source-op) s)) + +(defmethod perform ((o concatenate-source-op) (s system)) + (let ((inputs (input-files o s)) + (output (output-file o s))) + (concatenate-files inputs output))) +(defmethod perform ((o load-concatenated-source-op) (s system)) + (perform-lisp-load-source o s)) +(defmethod perform ((o compile-concatenated-source-op) (s system)) + (perform-lisp-compilation o s)) +(defmethod perform ((o load-compiled-concatenated-source-op) (s system)) + (perform-lisp-load-fasl o s)) + +(defmethod component-depends-on ((o concatenate-source-op) (s system)) + (declare (ignorable o s)) nil) +(defmethod component-depends-on ((o load-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s))) +(defmethod component-depends-on ((o compile-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((concatenate-source-op ,s))) +(defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((compile-concatenated-source-op ,s))) + +(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system)) + (declare (ignorable o s)) nil) +(defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) +(defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) +(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system)) + (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))) + diff --git a/configuration.lisp b/configuration.lisp new file mode 100644 index 0000000000000000000000000000000000000000..81c92999879c690a30fa17ef5b8a8f8312f918dd --- /dev/null +++ b/configuration.lisp @@ -0,0 +1,283 @@ +;;;; --------------------------------------------------------------------------- +;;;; Generic support for configuration files + +(defpackage :asdf/configuration + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os) + (:export + #:get-folder-path + #:user-configuration-directories #:system-configuration-directories + #:in-first-directory + #:in-user-configuration-directory #:in-system-configuration-directory + #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory + #:configuration-inheritance-directive-p + #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* + #:*clear-configuration-hook* #:clear-configuration + #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* + #:resolve-relative-location-component #:resolve-absolute-location-component + )) +(in-package :asdf/configuration) + +(define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s (compatfmt "~@<~? (will be skipped)~@:>") + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) + +(defun* get-folder-path (folder) + (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path + #+(and lispworks mswindows) (sys:get-folder-path folder) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + (ecase folder + (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) + (:appdata (getenv-absolute-directory "APPDATA")) + (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) + +(defun* user-configuration-directories () + (let ((dirs + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") + :collect (subpathname* dir "common-lisp/")))) + ,@(when (os-windows-p) + `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") + ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) + ,(subpathname (user-homedir) ".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 (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 "~@<One and only one of ~S or ~S is required.~@:>") + :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 "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") + description forms)) + (funcall validator (car forms) :location file))) + +(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." + (let ((files (sort (ignore-errors + (remove-if + 'hidden-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))) + +(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 "~@<pathname ~S is not relative~@:>") x)) + (if (or (pathnamep x) (not wilden)) r (wilden r)))) + +(defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + +(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* 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 "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") 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))))) + + +(defvar *clear-configuration-hook* '()) + +(defun* clear-configuration () + (map () #'funcall *clear-configuration-hook*)) + diff --git a/defsystem.lisp b/defsystem.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f0f7dc042981cf6b378eca2032286e32ad1f29b5 --- /dev/null +++ b/defsystem.lisp @@ -0,0 +1,173 @@ +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(defpackage :asdf/defsystem + (:use :common-lisp :asdf/utility :asdf/pathname + :asdf/component :asdf/system :asdf/find-system :asdf/find-component + :asdf/lisp-action :asdf/operate + :asdf/backward-internals) + #+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of) + (:export + #:defsystem #:do-defsystem #:parse-component-form + #:*default-component-class* + )) +(in-package :asdf/defsystem) + +;;; 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)))) + +;;; Component class + +(defvar *default-component-class* 'cl-source-file) + +(defun* class-for-type (parent type) + (or (loop :for symbol :in (list + type + (find-symbol* type *package* nil) + (find-symbol* type :asdf/interface nil)) + :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 p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) nil)) + (sysdef-error "don't recognize component type ~A" type))) + +;;; Check inputs + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") + (duplicate-names-name c))))) + +(defun* sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) + type name value)) + +(defun* check-component-input (type name weakly-depends-on + depends-on components 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))) + +;;; Main parsing function + +(defun* parse-component-form (parent options &key previous-serial-component) + (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 + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to + do-first if-component-dep-fails + (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) + (not ;; ignore the same object when rereading the defsystem + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (when versionp + (unless (parse-version version nil) + (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") + version name parent))) + (when do-first (error "DO-FIRST is not supported anymore since ASDF 2.27")) + (let* ((args `(:name ,(coerce-name name) + :pathname ,pathname + ,@(when parent `(:parent ,parent)) + ,@(remove-keys + '(components pathname if-component-dep-fails + 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 + (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + (when previous-serial-component + (push previous-serial-component 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 'parent-component) + (setf (component-children ret) + (loop + :with previous-component = nil + :for c-form :in components + :for c = (parse-component-form ret c-form + :previous-serial-component previous-component) + :for name = (component-name c) + :collect c + :when serial :do (setf previous-component name))) + (compute-children-by-name ret)) + (setf (component-sibling-dependencies ret) depends-on) ;; Used by POIU. ASDF3: rename to component-depends-on + (setf (component-in-order-to ret) in-order-to) + (%refresh-component-inline-methods ret rest) + (when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails ret)) + ret))) + +(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)) + (load-pathname (load-pathname)) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (safe-file-write-date load-pathname)) + (register-system (make-instance 'system :name name :source-file load-pathname)))) + (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 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))))) + +(defmacro defsystem (name &body options) + `(apply 'do-defsystem ',name ',options)) diff --git a/find-component.lisp b/find-component.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f184a1bb171b9cc39e62b195b0650ce873054485 --- /dev/null +++ b/find-component.lisp @@ -0,0 +1,128 @@ +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(defpackage :asdf/find-component + (:use :common-lisp :asdf/utility :asdf/os + :asdf/component :asdf/system :asdf/find-system) + (:export + #:find-component + #:resolve-dependency-name #:resolve-dependency-spec + #:resolve-dependency-combination + ;; Conditions + #:missing-component #:missing-component-of-version #:retry + #:missing-dependency #:missing-dependency-of-version + #:missing-requires #:missing-parent + #:missing-required-by #:missing-version + )) + +(in-package :asdf/find-component) + +;;;; Missing component conditions + +(define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(defmethod print-object ((c missing-dependency) s) + (format s (compatfmt "~@<~A, required by ~A~@:>") + (call-next-method c nil) (missing-required-by c))) + +(define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + +(defmethod print-object ((c missing-component) s) + (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>") + (missing-requires c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + +(defmethod print-object ((c missing-component-of-version) s) + (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>") + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + + +;;;; Finding components + +(defgeneric* find-component (base path) + (:documentation "Find a component by resolving the PATH starting from BASE parent")) +(defgeneric* resolve-dependency-combination (component combinator arguments)) + +(defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) + +(defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + +(defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + +(defmethod find-component ((parent parent-component) (name string)) + (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! + (values (gethash name (component-children-by-name parent)))) + +(defmethod find-component (base (name symbol)) + (if name + (find-component base (coerce-name name)) + base)) + +(defmethod find-component ((c component) (name cons)) + (find-component (find-component c (car name)) (cdr name))) + +(defmethod find-component (base (actual component)) + (declare (ignorable base)) + actual) + +(defun* resolve-dependency-name (component name &optional version) + (loop + (restart-case + (return + (let ((comp (find-component (component-parent component) name))) + (unless comp + (error 'missing-dependency + :required-by component + :requires name)) + (when version + (unless (version-satisfies comp version) + (error 'missing-dependency-of-version + :required-by component + :version version + :requires name))) + comp)) + (retry () + :report (lambda (s) + (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") 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) + (if (atom dep-spec) + (resolve-dependency-name component dep-spec) + (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))) + +(defmethod resolve-dependency-combination (component combinator arguments) + (error (compatfmt "~@<Bad dependency ~S for ~S~@:>") + (cons combinator arguments) component)) + +(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) + (declare (ignorable combinator)) + (when (featurep (first arguments)) + (resolve-dependency-spec component (second arguments)))) + +(defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) + (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788 + (resolve-dependency-name component (first arguments) (second arguments))) + diff --git a/find-system.lisp b/find-system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..75feca66b2fa50f4df48001edc3223db2fcb505f --- /dev/null +++ b/find-system.lisp @@ -0,0 +1,326 @@ +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(defpackage :asdf/find-system + (:use :common-lisp :asdf/implementation :asdf/utility :asdf/upgrade :asdf/pathname :asdf/os + :asdf/component :asdf/system) + (:export + #:coerce-name #:find-system #:locate-system #:load-sysdef #:with-system-definitions + #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems + #:system-definition-error #:missing-component #:missing-requires #:missing-parent + #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error + #:load-system-definition-error #:error-name #:error-pathname #:error-condition + #:*system-definition-search-functions* #:search-for-system-definition + #:*central-registry* #:probe-asd #:sysdef-central-registry-search + #:make-temporary-package #:find-system-if-being-defined #:*systems-being-defined* + #:find-system-fallback #:sysdef-find-asdf + #:make-defined-systems-table #:*defined-systems* + ;; defined in source-registry, but specially mentioned here: + #:initialize-source-registry #:sysdef-source-registry-search)) +(in-package :asdf/find-system) + +(declaim (ftype (function (&optional t) *) initialize-source-registry)) ; forward reference + +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (parent :initform nil :reader missing-parent :initarg :parent))) + +(define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply 'format s (format-control c) (format-arguments c))))) + +(define-condition load-system-definition-error (system-definition-error) + ((name :initarg :name :reader error-name) + (pathname :initarg :pathname :reader error-pathname) + (condition :initarg :condition :reader error-condition)) + (:report (lambda (c s) + (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") + (error-name c) (error-pathname c) (error-condition c))))) + +(defun* sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments)) + +(defun* 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 "~@<Invalid component designator: ~3i~_~A~@:>") 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 (aif (ignore-errors (system-source-file system)) (safe-file-write-date it)) 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." + (loop :for (nil . system) :being :the hash-values :of *defined-systems* + :do (funcall fn system))) + +;;; 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* '()) + +(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* 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 + (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 "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>") + 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 "~@<Coerce entry to ~a, replace ~a and continue.~@:>") + (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 "~A~D" :asdf counter) + :use '(:cl :asdf/interface))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) + (when error-p + (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) + +(defmethod find-system (name &optional (error-p t)) + (find-system (coerce-name name) error-p)) + +(defvar *systems-being-defined* nil + "A hash-table of systems currently being defined keyed by name, or NIL") + +(defun* find-system-if-being-defined (name) + (when *systems-being-defined* + (gethash (coerce-name name) *systems-being-defined*))) + +(defun* call-with-system-definitions (thunk) + (if *systems-being-defined* + (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 #-gcl<2.7 :external-format #-gcl<2.7 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 (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)) + (unless (and (equal pathname (and previous (system-source-file previous))) + (stamp<= (safe-file-write-date pathname) previous-time)) + ;; only load when it's a different pathname, or newer file content + (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 "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") 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))) diff --git a/footer.lisp b/footer.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c1c4ec12f0fd581630294d0a5be712f762853f7c --- /dev/null +++ b/footer.lisp @@ -0,0 +1,70 @@ +;;;; ----------------------------------------------------------------------- +;;;; ASDF Footer: last words and cleanup + +(defpackage :asdf/footer + (:use :common-lisp + :asdf/package :asdf/implementation + :asdf/utility :asdf/pathname :asdf/os :asdf/lisp-build + :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action + :asdf/operate :asdf/bundle :asdf/concatenate-source + :asdf/configuration :asdf/output-translations :asdf/source-registry + :asdf/backward-internals :asdf/defsystem :asdf/backward-interface :asdf/interface)) +(in-package :asdf/footer) + +;;;; Hook ASDF into the implementation's REQUIRE and other entry points. + +#+(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*)))) + +#+(or ecl mkcl) +(progn + (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) + + #+(or (and ecl win32) (and mkcl windows)) + (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) + (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) + + (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* + (loop :for f :in #+ecl ext:*module-provider-functions* + #+mkcl mk-ext::*module-provider-functions* + :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)))))) + + +;;;; 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! + +#+allegro +(eval-when (:compile-toplevel :execute) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) + +(dolist (f '(:asdf :asdf2 :asdf2.27)) (pushnew f *features*)) + +(provide :asdf) + +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) + +;;; Local Variables: +;;; mode: lisp +;;; End: diff --git a/generate-asdf.asd b/generate-asdf.asd new file mode 100644 index 0000000000000000000000000000000000000000..c165825ce3c401ec2496aeb6994e34b48d3de136 --- /dev/null +++ b/generate-asdf.asd @@ -0,0 +1,55 @@ +;;; -*- mode: lisp -*- + +(defsystem :generate-asdf + :licence "MIT" + :description "Generate a monolithic asdf.lisp from all its components" + ;; :defsystem-depends-on (:asdf/bundle) + :class :concatenated-source-system + ;; :include-dependencies t + :translate-output-p nil + :output-file "tmp/asdf.lisp" +#| + :depends-on (:asdf-header + :asdf-package + :asdf-portability + :asdf-utility + :asdf-pathname + :asdf-upgrade + :asdf-interface + :asdf-lisp-build + :asdf-action + :asdf-bundle + :asdf-backward-compat + :asdf-footer)) +|# + :serial t + :components + ((:file "header") + (:module + "code" :pathname "" :components + ((:file "package") + (:file "implementation" :depends-on ("package")) + (:file "utility" :depends-on ("implementation")) + (:file "pathname" :depends-on ("utility")) + (:file "os" :depends-on ("pathname")) + (:file "upgrade" :depends-on ("utility")) + (:file "component" :depends-on ("pathname")) + (:file "system" :depends-on ("component")) + (:file "find-system" :depends-on ("system")) + (:file "find-component" :depends-on ("find-system")) + (:file "lisp-build" :depends-on ("pathname")) + (:file "operation" :depends-on ("utility")) + (:file "action" :depends-on ("find-component" "operation")) + (:file "lisp-action" :depends-on ("action" "lisp-build")) + (:file "plan" :depends-on ("action")) + (:file "operate" :depends-on ("plan")) + (:file "configuration" :depends-on ("pathname")) + (:file "output-translations" :depends-on ("configuration" "operate")) + (:file "source-registry" :depends-on ("configuration" "find-system")) + (:file "backward-internals" :depends-on ("action" "operate")) + (:file "defsystem" :depends-on ("backward-internals")) + (:file "bundle" :depends-on ("lisp-action")) + (:file "concatenate-source" :depends-on ("lisp-action")) + (:file "backward-interface" :depends-on ("lisp-action")))) + (:file "user") + (:file "footer" :depends-on ("interface")))) diff --git a/header.lisp b/header.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ccd50ff86ab113eaec5397ba57ede6c0725569c6 --- /dev/null +++ b/header.lisp @@ -0,0 +1,48 @@ +;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- +;;; This is ASDF 2.26.62: Another System Definition Facility. +;;; +;;; Feedback, bug reports, and patches are all welcome: +;;; please mail to <asdf-devel@common-lisp.net>. +;;; Note first that the canonical source for ASDF is presently +;;; <URL:http://common-lisp.net/project/asdf/>. +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the git master +;;; branch is the latest development version, whereas the git release +;;; branch may be slightly older but is considered `stable' + +;;; -- LICENSE START +;;; (This is the MIT / X Consortium license as taken from +;;; http://www.opensource.org/licenses/mit-license.html on or about +;;; Monday; July 13, 2009) +;;; +;;; Copyright (c) 2001-2012 Daniel Barlow and contributors +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; -- LICENSE END + +;;; The problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file. + +#+xcvb (module ()) diff --git a/implementation.lisp b/implementation.lisp new file mode 100644 index 0000000000000000000000000000000000000000..efb8aabcfd93bb6908c1bbb1ba9bfe6ab29a75f3 --- /dev/null +++ b/implementation.lisp @@ -0,0 +1,143 @@ +;;;; ------------------------------------------------------------------------- +;;;; Handle ASDF portability to multiple implementations + +(defpackage :asdf/implementation + (:use :common-lisp :asdf/package) + #+cormanlisp + (:export + #:logical-pathname #:translate-logical-pathname + #:make-broadcast-stream #:file-namestring) + #+ecl (:export #:use-ecl-byte-compiler-p) + #+genera (:import-from :scl #:boolean) + #+genera (:export #:boolean #:ensure-directories-exist) + (:export + #:strcat #:compatfmt + #:asdf-message #:*asdf-verbose* #:*verbose-out*)) +(in-package :asdf/implementation) + +#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us port it.") + +;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. + + +;;;; Early meta-level tweaks + +#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) + clozure lispworks (and sbcl sb-unicode) scl) +(eval-when (:load-toplevel :compile-toplevel :execute) + (pushnew :asdf-unicode *features*)) + +#+allegro +(eval-when (:load-toplevel :compile-toplevel :execute) + (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 + (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))) + +#+ecl +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + (unless (use-ecl-byte-compiler-p) (require :cmp))) + +#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 +(eval-when (:load-toplevel :compile-toplevel :execute) + (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 lacks output-translations and more. + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (shadow 'type-of :asdf/implementation) + (pushnew 'ignorable pcl::*variable-declarations-without-argument*) + (pushnew :gcl<2.7 *features*))) + +#+mkcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (require :cmp) + (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics + + +;;;; Compatibility layers + +#+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)))) + +#+gcl<2.7 +(progn ;; Doesn't support either logical-pathnames or output-translations. + (deftype logical-pathname () nil) + (defun type-of (x) (class-name (class-of x))) + (defun wild-pathname-p (path) (declare (ignore path)) nil) + (defun translate-logical-pathname (x) x) + (defvar *compile-file-pathname* nil) + (defun pathname-match-p (in-pathname wild-pathname) + (declare (ignore in-wildname wild-wildname)) nil) + (defun translate-pathname (source from-wildname to-wildname &key) + (declare (ignore from-wildname to-wildname)) source) + (defun %print-unreadable-object (object stream type identity thunk) + (format stream "#<~@[~S ~]" (when type (type-of object))) + (funcall thunk) + (format stream "~@[ ~X~]>" (when identity (system:address object)))) + (defmacro with-compilation-unit (options &body body) + (declare (ignore options)) `(progn ,@body)) + (defmacro print-unreadable-object ((object stream &key type identity) &body body) + `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body))) + (defun ensure-directories-exist (path) + (run-shell-command "mkdir -p ~S" (namestring (pathname-directory-pathname path))))) + +#+genera +(unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl + (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))))))")) + + +;;;; compatfmt: avoid fancy format directives when unsupported +;; Confirm (?) has to be inside an eval-when to make Lispworks happy + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings))) + +(defmacro compatfmt (format) + #+(or gcl genera) + (loop :for (unsupported . replacement) + :in (append + '(("~3i~_" . "")) + #+(or genera gcl<2.7) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do + (loop :for found = (search unsupported format) :while found :do + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) + format) + +(defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. +(defvar *verbose-out* nil) + +(defun asdf-message (format-string &rest format-args) + (apply 'format *verbose-out* format-string format-args)) + diff --git a/interface.lisp b/interface.lisp new file mode 100644 index 0000000000000000000000000000000000000000..446c09967981e970bc905cd92c7e90e822c8ac74 --- /dev/null +++ b/interface.lisp @@ -0,0 +1,159 @@ +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. + +(defpackage :asdf/interface + (:nicknames :asdf) + (:use :common-lisp + :asdf/package :asdf/implementation :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-build :asdf/lisp-action + :asdf/configuration :asdf/output-translations :asdf/source-registry + :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source + :asdf/backward-interface) + ;; TODO: automatically generate interface by merging select used packages? + (:export + #:defsystem #:find-system #:locate-system #:coerce-name + #:oos #:operate #:traverse #:perform-plan + #:system-definition-pathname #:with-system-definitions + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems + #:require-system #:test-system #:clear-system + #:operation #:upward-operation #:downward-operation + #:load-op #:prepare-op #:compile-op #:load-fasl-op + #:prepare-source-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf + #:implementation-identifier #:implementation-type #:hostname + #:input-files #:output-files #:output-file #:perform + #:operation-done-p #:explain #:component-sibling-dependencies + #:component-load-dependencies #:run-shell-command ; deprecated, do not use + #:precompiled-system #:compiled-file + #+ecl #:make-build #+mkcl #:bundle-system + + #:component #:parent-component #:child-component #:system #:module + #:source-file #:c-source-file #:java-source-file + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:static-file #:doc-file #:html-file :text-file + #:source-file-type + + #:component-children ; component accessors + #:component-children-by-name + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + #:component-encoding + #:component-external-format + + #:component-depends-on ; backward-compatible name rather than action-depends-on + #:module-components ; backward-compatibility + #:operation-on-warnings #:operation-on-failure ; backward-compatibility + + #: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 + + #:*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 #:already-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)) + +(in-package :asdf/interface) + +(with-upgrade (:when (fboundp 'make-sub-operation)) + (defun* make-sub-operation (c o dep-c dep-o) + (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) + +#| + (pkgdcl + :asdf + :use (:common-lisp) + :fmakunbound + (#:perform #:explain #:output-files #:operation-done-p #:traverse-action #:traverse + #:compute-action-stamp #:component-load-dependencies #:action-valid-p + #:component-depends-on #:perform-plan #:mark-operation-done #:operation-forced + #:perform-with-restarts #:component-relative-pathname + #:system-source-file #:operate #:find-system #:find-component #:find-operation + #:apply-output-translations #:translate-pathname* #:resolve-location + #:system-relative-pathname #:source-file-type #:builtin-system-p + #:inherit-source-registry #:process-source-registry #:process-source-registry-directive + #:compile-file* #:source-file-type #:trivial-system-p) + :fmakunbound-setf (#:output-translations) + :unintern + (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector + #:do-dep #:do-one-dep #:do-traverse #:visit-action #:component-visited-p + #+(or ecl mkcl) #:output-files #+ecl #:trivial-system-p + #:loaded-systems ; makes for annoying SLIME completion + #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function + :export +|# diff --git a/lisp-action.lisp b/lisp-action.lisp new file mode 100644 index 0000000000000000000000000000000000000000..fd9be8a9e0606c9496c2188b68f05eb26ae6dff7 --- /dev/null +++ b/lisp-action.lisp @@ -0,0 +1,226 @@ +;;;; ------------------------------------------------------------------------- +;;;; Actions to build Common Lisp software + +(defpackage :asdf/lisp-action + (:use :common-lisp :asdf/utility :asdf/lisp-build + :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) + (:export + #:compile-error #:compile-failed #:compile-warned #:try-recompiling + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:basic-load-op #:basic-compile-op + #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op + #:call-with-around-compile-hook + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source)) +(in-package :asdf/lisp-action) + +;;;; Conditions + +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + + +;;;; Component classes + + +(defclass cl-source-file (source-file) + ((type :initform "lisp"))) +(defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl"))) +(defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp"))) + + +;;;; Operation classes + +(defclass basic-load-op (operation) ()) +(defclass basic-compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (flags :initarg :flags :accessor compile-op-flags + :initform nil))) + +;;; Our default operations: loading into the current lisp image +(defclass load-op (basic-load-op downward-operation) ()) +(defclass prepare-op (upward-operation) ()) +(defclass compile-op (basic-compile-op downward-operation) ()) + +(defclass load-source-op (basic-load-op downward-operation) ()) +(defclass prepare-source-op (upward-operation) ()) + +(defclass test-op (operation) ()) + + +;;;; prepare-op, compile-op and load-op + +;;; prepare-op +(defmethod operation-description ((o prepare-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c)) +(defmethod component-depends-on ((o prepare-op) (c component)) + (declare (ignorable o)) + `((load-op ,@(loop :for dep :in (component-sibling-dependencies c) + :collect (resolve-dependency-spec c dep))) + ,@(call-next-method))) +(defmethod perform ((o prepare-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod input-files ((o prepare-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod input-files ((o prepare-op) (s system)) + (declare (ignorable o)) + (aif (system-source-file s) (list it))) + +;;; compile-op +(defmethod operation-description ((o compile-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c)) +(defmethod operation-description ((o compile-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") c)) +(defgeneric* call-with-around-compile-hook (component thunk)) +(defmethod call-with-around-compile-hook ((c component) function) + (call-around-hook (around-compile-hook c) function)) +(defun* perform-lisp-compilation (o c) + (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, + ;; we consult input-files, the first of which should be the one to compile-file + (input-file (first (input-files o c))) + ;; on some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (output-file (first (output-files o c)))) + (multiple-value-bind (output warnings-p failure-p) + (call-with-around-compile-hook + c #'(lambda (&rest flags) + (apply *compile-file-function* input-file + :output-file output-file + #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c) + (append flags (compile-op-flags o))))) + (unless output + (error 'compile-error :component c :operation o)) + (when failure-p + (case *compile-file-failure-behaviour* + (:warn (warn + (compatfmt "~@<COMPILE-FILE failed while performing ~A.~@:>") + (operation-description o c))) + (:error (error 'compile-failed :component c :operation o)) + (:ignore nil))) + (when warnings-p + (case *compile-file-warnings-behaviour* + (:warn (warn + (compatfmt "~@<COMPILE-FILE warned while performing ~A.~@:>") + (operation-description o c))) + (:error (error 'compile-warned :component c :operation o)) + (:ignore nil)))))) +(defmethod perform ((o compile-op) (c cl-source-file)) + (perform-lisp-compilation o c)) +(defmethod output-files ((o compile-op) (c cl-source-file)) + (declare (ignorable o)) + (let* ((i (first (input-files o c))) + (f (compile-file-pathname + i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) + #+mkcl (o (compile-file-pathname i :fasl-p nil))) ;; object file + #+ecl (if (use-ecl-byte-compiler-p) + (list f) + (list f (compile-file-pathname i :type :object))) + #+mkcl (list f o) + #-(or ecl mkcl) (list f))) +(defmethod component-depends-on ((o compile-op) (c component)) + (declare (ignorable o)) + `((prepare-op ,c) ,@(call-next-method))) +(defmethod perform ((o compile-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod output-files ((o compile-op) (c static-file)) + (declare (ignorable o c)) + nil) + +;;; load-op +(defmethod operation-description ((o load-op) (c cl-source-file)) + (declare (ignorable o)) + (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c)) +(defmethod operation-description ((o load-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") c)) +(defmethod operation-description ((o load-op) component) + (declare (ignorable o)) + (format nil (compatfmt "~@<loading ~3i~_~A~@:>") + component)) +(defmethod perform-with-restarts ((o load-op) (c cl-source-file)) + (loop + (restart-case + (return (call-next-method)) + (try-recompiling () + :report (lambda (s) + (format s "Recompile ~a and try loading it again" + (component-name c))) + (perform (find-operation o 'compile-op) c))))) +(defun perform-lisp-load-fasl (o c) + (load (first (input-files o c)))) +(defmethod perform ((o load-op) (c cl-source-file)) + (perform-lisp-load-fasl o c)) +(defmethod perform ((o load-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod component-depends-on ((o load-op) (c component)) + (declare (ignorable o)) + `((prepare-op ,c) ,@(call-next-method))) +(defmethod component-depends-on ((o load-op) (c source-file)) + (declare (ignorable o)) + `((compile-op ,c) ,@(call-next-method))) + + +;;;; prepare-source-op, load-source-op + +;;; prepare-source-op +(defmethod operation-description ((o prepare-source-op) (c component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c)) +(defmethod component-depends-on ((o prepare-source-op) (c source-file)) + (declare (ignorable o)) + `((load-source-op ,@(component-sibling-dependencies c)) ,@(call-next-method))) +(defmethod input-files ((o prepare-source-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod input-files ((o prepare-source-op) (s system)) + (declare (ignorable o)) + (aif (system-source-file s) (list it))) +(defmethod perform ((o prepare-source-op) (c component)) + (declare (ignorable o c)) + nil) + +;;; load-source-op +(defmethod operation-description ((o load-source-op) c) + (declare (ignorable o)) + (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c)) +(defmethod operation-description ((o load-source-op) (c parent-component)) + (declare (ignorable o)) + (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c)) +(defmethod component-depends-on ((o load-source-op) (c component)) + (declare (ignorable o)) + `((prepare-source-op ,c) ,@(call-next-method))) +(defun perform-lisp-load-source (o c) + (call-with-around-compile-hook + c #'(lambda () (load (first (input-files o c)) + #-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c))))) +(defmethod perform ((o load-source-op) (c cl-source-file)) + (perform-lisp-load-source o c)) +(defmethod perform ((o load-source-op) (c static-file)) + (declare (ignorable o c)) + nil) +(defmethod output-files ((o load-source-op) (c component)) + (declare (ignorable o c)) + nil) + + +;;;; test-op +(defmethod perform ((o test-op) (c component)) + (declare (ignorable o c)) + nil) +(defmethod operation-done-p ((o test-op) (c system)) + "Testing a system is _never_ done." + (declare (ignorable o c)) + nil) +(defmethod component-depends-on ((o test-op) (c system)) + (declare (ignorable o)) + `((load-op ,c) ,@(call-next-method))) + diff --git a/lisp-build.lisp b/lisp-build.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f07b334c662f6fbec18b164fe3bb73b2e396fa77 --- /dev/null +++ b/lisp-build.lisp @@ -0,0 +1,137 @@ +;;;; ------------------------------------------------------------------------- +;;;; Support to build (compile and load) Lisp files + +(defpackage :asdf/lisp-build + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os) + (:export + #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* + #:*compile-file-function* #:compile-file* #:compile-file-pathname* + #+(or ecl mkcl) #:compile-file-keeping-object + #:lispize-pathname #:fasl-type #:call-around-hook + #:combine-fasls)) +(in-package :asdf/lisp-build) + +(defvar *compile-file-warnings-behaviour* + (or #+clisp :ignore :warn) + "How should ASDF react if it encounters a warning when compiling a file? +Valid values are :error, :warn, and :ignore.") + +(defvar *compile-file-failure-behaviour* + (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) + "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) +when compiling a file? 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 *compile-file-function* 'compile-file* + "Function used to compile lisp files.") + +(defun* lispize-pathname (input-file) + (make-pathname :type "lisp" :defaults input-file)) + +(defun* call-around-hook (hook function) + (funcall (if hook (ensure-function hook) 'funcall) function)) + +(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-overwriting-target 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)))) + +(defun* fasl-type (&rest keys) + "pathname TYPE for lisp FASt Loading files" + (declare (ignorable keys)) + #-ecl (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+ecl (pathname-type (apply 'compile-file-pathname "foo.lisp" keys))) + +(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 'fasl-type keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) + (funcall (find-symbol* :apply-output-translations :asdf/output-translations) + (apply 'compile-file-pathname input-file + (if output-file keys (remove-keyword :output-file keys)))))) + +;;; 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. +;;; +#+(or ecl mkcl) +(progn + (setf *compile-file-function* 'compile-file-keeping-object) + + (defun* compile-file-keeping-object (input-file &rest keys &key output-file &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 + :output-file (compile-file-pathname + output-file . #+ecl (:type :object) #+mkcl (:fasl-p nil)) keys) + (values (and object-file + (compiler::build-fasl + output-file #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)) + object-file) + flags1 + flags2))))) + +(defun* combine-fasls (inputs output) + #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) + (declare (ignore inputs output)) + #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) + (error "~S is not supported on ~A" 'combine-fasls (implementation-type)) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) + #+lispworks + (let (fasls) + (unwind-protect + (progn + (loop :for i :in inputs + :for n :from 1 + :for f = (add-pathname-suffix + output (format nil "-FASL~D" n)) + :do #-lispworks-personal-edition (lispworks:copy-file i f) + #+lispworks-personal-edition (concatenate-files (list i) f) + (push f fasls)) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) + (eval `(scm:defsystem :fasls-to-concatenate + (:default-pathname ,(pathname-directory-pathname output)) + :members + ,(loop :for f :in (reverse fasls) + :collect `(,(namestring f) :load-only t)))) + (scm:concatenate-system output :fasls-to-concatenate)) + (loop :for f :in fasls :do (ignore-errors (delete-file f))) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) + + diff --git a/operate.lisp b/operate.lisp new file mode 100644 index 0000000000000000000000000000000000000000..cfaed627df61aef9ac7b3a19d9d031604fe21553 --- /dev/null +++ b/operate.lisp @@ -0,0 +1,166 @@ +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations +(defpackage :asdf/operate + (:use :common-lisp :asdf/implementation :asdf/utility :asdf/upgrade + :asdf/component :asdf/system :asdf/operation :asdf/action + :asdf/lisp-build :asdf/lisp-action #:asdf/plan + :asdf/find-system :asdf/find-component) + (:export + #:operate #:oos #:*systems-being-operated* + #:load-system #:load-systems #:compile-system #:test-system #:require-system + #:*load-system-operation* #:module-provide-asdf + #:component-loaded-p #:already-loaded-systems + #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*)) +(in-package :asdf/operate) + +(defgeneric* operate (operation-class system &key &allow-other-keys)) + +(defun* cleanup-upgraded-asdf () + (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) + (funcall (find-symbol* 'load-system :asdf) :asdf))) ;; load ASDF a second time, the right way. + +(defun* restart-upgraded-asdf () + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil))))) + +(pushnew 'cleanup-upgraded-asdf *post-upgrade-cleanup-hook*) +(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*) + + +;;;; Operate itself + +(defvar *systems-being-operated* nil + "A boolean indicating that some systems are being operated on") + +(defmethod operate :around (operation-class system + &key verbose + (on-warnings *compile-file-warnings-behaviour*) + (on-failure *compile-file-failure-behaviour*) &allow-other-keys) + (declare (ignorable operation-class system)) + (with-system-definitions () + (let* ((*asdf-verbose* verbose) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure)) + (call-next-method)))) + +(defmethod operate (operation-class system &rest args &key version &allow-other-keys) + "Operate does three things: + +1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. +2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). +3. It then calls TRAVERSE with the operation and system as arguments + +The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code. +If a VERSION argument is supplied, then operate also ensures that the system found +satisfies it using the VERSION-SATISFIES method. + +Note that dependencies may cause the operation to invoke other operations on the system +or its components: the new operations will be created with the same initargs as the original one. + +The :FORCE or :FORCE-NOT argument to OPERATE can be: + T to force the inside of the specified system to be rebuilt (resp. not), + without recursively forcing the other systems we depend on. + :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). + (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list +:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced." + (let* ((system (etypecase system + (system system) + ((or string symbol) (find-system system)))) + ;; I'd like to remove-keys :force :force-not :verbose, but swank.asd relies on :force (!). + (op (apply 'make-operation operation-class args)) + (systems-being-operated *systems-being-operated*) + (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))) + (check-type system system) + (setf (gethash (coerce-name system) *systems-being-operated*) system) + (flet ((upgrade () + ;; If we needed to upgrade ASDF to achieve our goal, + ;; then do it specially as the first thing, + ;; which will invalidate all existing systems; + ;; afterwards, try again with the new OPERATE function, + ;; which on some implementations may be a new symbol. + (unless (gethash "asdf" *systems-being-operated*) + (upgrade-asdf) + (return-from operate + (apply (find-symbol* 'operate :asdf) operation-class system args))))) + (when systems-being-operated ;; Upgrade if loading a system from another one. + (upgrade)) + (unless (version-satisfies system version) + (error 'missing-component-of-version :requires system :version version)) + (let ((plan (apply 'traverse op system args))) + (when (plan-operates-on-p plan '("asdf")) + (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time. + (perform-plan plan) + (values op plan))))) + +(defun* oos (operation-class system &rest args + &key force force-not verbose version &allow-other-keys) + (declare (ignore force force-not verbose version)) + (apply 'operate operation-class system args)) + +(setf (documentation 'oos 'function) + (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" + (documentation 'operate 'function))) + + +;;;; Common operations + +(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.") + +(defun* load-system (system &rest keys &key force force-not verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate *load-system-operation* system keys) + t) + +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + +(defun* compile-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'compile-op system args) + t) + +(defun* test-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'test-op system args) + t) + + +;;;; require-system, and hooking it into CL:REQUIRE when possible, +;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL + +(defun* component-loaded-p (c) + (action-already-done-p nil (make-instance 'load-op) (find-component c ()))) + +(defun* already-loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + +(defun* require-system (s &rest keys &key &allow-other-keys) + (apply 'load-system s :force-not (already-loaded-systems) keys)) + +(defun* module-provide-asdf (name) + (handler-bind + ((style-warning #'muffle-warning) + #-genera + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream)) + (system (find-system (string-downcase name) nil))) + (when system + (require-system system :verbose nil) + t)))) + diff --git a/operation.lisp b/operation.lisp new file mode 100644 index 0000000000000000000000000000000000000000..37287c3a5222f3715fc91b3206155a053c43f9a8 --- /dev/null +++ b/operation.lisp @@ -0,0 +1,52 @@ +;;;; ------------------------------------------------------------------------- +;;;; Operations + +(defpackage :asdf/operation + (:use :common-lisp :asdf/utility :asdf/upgrade) + (:export + #:operation + #:operation-original-initargs ;; backward-compatibility only. DO NOT USE. + #:make-operation + #:find-operation)) + +(in-package :asdf/operation) + +;;; Operation Classes + +(with-upgrade (:when (find-class 'operation nil)) + (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) + (declare (ignorable o slot-names initargs)) (values))) + +(defclass operation () + ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) + :initform nil :initarg :original-initargs :accessor operation-original-initargs))) + +(defmethod initialize-instance :after ((o operation) &rest initargs + &key force force-not system verbose &allow-other-keys) + (declare (ignorable force force-not system verbose)) + (unless (slot-boundp o 'original-initargs) + (setf (operation-original-initargs o) initargs))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity nil) + (ignore-errors + (format stream "~{~S~^ ~}" (operation-original-initargs o))))) + +;;; make-operation, find-operation + +(defparameter *operations* (make-hash-table :test 'equal)) +(defun* make-operation (operation-class &rest initargs) + (let ((key (cons operation-class initargs))) + (multiple-value-bind (operation foundp) (gethash key *operations*) + (if foundp operation + (setf (gethash key *operations*) + (apply 'make-instance operation-class initargs)))))) + +(defgeneric* find-operation (context spec) + (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) +(defmethod find-operation (context (spec operation)) + (declare (ignorable context)) + spec) +(defmethod find-operation (context (spec symbol)) + (apply 'make-operation spec (operation-original-initargs context))) +(defmethod operation-original-initargs ((context null)) context) diff --git a/os.lisp b/os.lisp new file mode 100644 index 0000000000000000000000000000000000000000..a9664f6413abf39ed33ddfb726554ca9fa718397 --- /dev/null +++ b/os.lisp @@ -0,0 +1,233 @@ +;;;; --------------------------------------------------------------------------- +;;;; Access to the Operating System +(defpackage :asdf/os + (:use :cl :asdf/package :asdf/implementation :asdf/utility :asdf/pathname) + (:export + #:featurep #:os-unix-p #:os-windows-p ;; features + #:read-file-forms ;; simple filesystem manipulation + #:copy-stream-to-stream #:concatenate-files ;; simple stream copy + #:getenv ;; environment variables, and parsing them + #:inter-directory-separator #:split-pathnames* + #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:implementation-identifier ;; implementation identifier + #:implementation-type #:operating-system #:architecture #:lisp-version-string + #:hostname #:user-homedir #:lisp-implementation-directory)) +(in-package :asdf/os) + +;;; Features +(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)))) + +;;; Simple filesystem manipulation +(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))) + +;; Simple stream copy +(defun* copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) + "Copy the contents of the INPUT stream into the OUTPUT stream, +using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver + (with-open-stream (input input) + (loop + :for buffer = (make-array (list buffer-size) :element-type element-type) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return))))) + +(defun* concatenate-files (inputs output) + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + + +;;;; Environment variables: getting them, and parsing them. + +(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* inter-directory-separator () + (if (os-unix-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)) + + +;;;; implementation-identifier +;; +;; produce a string to identify current implementation. +;; Initially stolen from SLIME's SWANK, completely rewritten since. +;; We're back to runtime checking, for the sake of e.g. ABCL. + +(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))))) + + +;;;; Other system information + +(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)) + +(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* lisp-implementation-directory (&key truename) + (let ((dir + (ignore-errors + #+clozure (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:")) + #+(or ecl mkcl) #p"SYS:" + #+sbcl (aif (find-symbol* :sbcl-homedir-pathname :sb-int) + (funcall it) + (getenv-pathname "SBCL_HOME" :want-directory t))))) + (if (and dir truename) + (let ((*default-pathname-defaults* #p"")) (truename dir)) + dir))) + diff --git a/output-translations.lisp b/output-translations.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9895b116fbca1ebfa339ded4461b3c59179672c0 --- /dev/null +++ b/output-translations.lisp @@ -0,0 +1,318 @@ +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations + +(defpackage :asdf/output-translations + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/configuration :asdf/action) + (:export + #:invalid-output-translation + #:output-translations #:output-translations-initialized-p + #:initialize-output-translations #:clear-output-translations + #:disable-output-translations #:ensure-output-translations + #:apply-output-translations + #:validate-output-translations-directive #:validate-output-translations-form + #:validate-output-translations-file #:validate-output-translations-directory + #:parse-output-translations-string #:wrapping-output-translations + #:user-output-translations-pathname #:system-output-translations-pathname + #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname + #:environment-output-translations #:process-output-translations + #:compute-output-translations + )) +(in-package :asdf/output-translations) + +(define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) + +(defvar *output-translations* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a sorted list of mappings. +Each mapping is a pair of a source pathname and destination pathname, +and the order is by decreasing length of namestring of the source pathname.") + +(defun* output-translations () + (car *output-translations*)) + +(defun* set-output-translations (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) + new-value) +(defsetf output-translations set-output-translations) ; works with gcl 2.6 + +(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)) + +(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 "~@<Environment string isn't: ~3i~_~S~@:>") string)) + ((eql (char string 0) #\") + (parse-output-translations-string (read-from-string string) :location location)) + ((eql (char string 0) #\() + (validate-output-translations-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with source = nil + :with separator = (inter-directory-separator) + :for i = (or (position separator string :start start) end) :do + (let ((s (subseq string start i))) + (cond + (source + (push (list source (if (equal "" s) nil s)) directives) + (setf source nil)) + ((equal "" s) + (when inherit + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") + string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) + +(defparameter *default-output-translations* + '(environment-output-translations + user-output-translations-pathname + user-output-translations-directory-pathname + system-output-translations-pathname + system-output-translations-directory-pathname)) + +(defun* wrapping-output-translations () + `(:output-translations + ;; Some implementations have precompiled ASDF systems, + ;; so we must disable translations for implementation paths. + #+(or #|clozure|# ecl mkcl sbcl) + ,@(let ((h (lisp-implementation-directory :truename t))) (when h `(((,h ,*wild-inferiors*) ())))) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; We enable the user cache by default, and here is the place we do: + :enable-user-cache)) + +(defparameter *output-translations-file* (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)) + +(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))))))))))) + +(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 #-gcl<2.7 pathname #+gcl<2.7 t) &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* compute-output-translations (&optional parameter) + "read the configuration, return it" + (remove-duplicates + (while-collecting (c) + (inherit-output-translations + `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) + :test 'equal :from-end t)) + +(defvar *output-translations-parameter* nil) + +(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*)) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) + +(defun* disable-output-translations () + "Initialize output translations in a way that maps every file to itself, +effectively disabling the output translation facility." + (initialize-output-translations + '(:output-translations :disable-cache :ignore-inherited-configuration))) + +;; checks an initial variable to see whether the state is initialized +;; or cleared. In the former case, return current configuration; in +;; the latter, initialize. ASDF will call this function at the start +;; of (asdf:find-system). +(defun* ensure-output-translations () + (if (output-translations-initialized-p) + (output-translations) + (initialize-output-translations))) + +(defun* apply-output-translations (path) + #+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)) + +#+abcl +(defun* translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (flet ((normalize-device (pathname) + (if (find :windows *features*) + pathname + (make-pathname :defaults pathname :device :unspecific)))) + (let* ((jar + (pathname (first (pathname-device source)))) + (target-root-directory-namestring + (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device jar)))) + (relative-source + (relativize-pathname-directory source)) + (relative-jar + (relativize-pathname-directory (ensure-directory-pathname jar))) + (target-root-directory + (normalize-device + (pathname-directory-pathname + (parse-namestring target-root-directory-namestring)))) + (target-root + (merge-pathnames* relative-jar target-root-directory)) + (target + (merge-pathnames* relative-source target-root))) + (normalize-device (apply-output-translations target))))) + +(pushnew 'clear-output-translations *clear-configuration-hook*) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000000000000000000000000000000000000..06f7a2ae075112df3dd8246400acf29276138e15 --- /dev/null +++ b/package.lisp @@ -0,0 +1,170 @@ +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. +;; +;; See https://bugs.launchpad.net/asdf/+bug/485687 +;; +;; CAUTION: we must handle the first few packages specially for hot-upgrade. +;; asdf/package will be frozen as of 2.27 +;; to forever export the same exact symbols. +;; Any other symbol must be import-from'ed +;; and reexported in a different package +;; (alternatively the package may be dropped & replaced by one with a new name). + +(defpackage :asdf/package + (:use :common-lisp) + (:export + #:find-symbol* #:define-package)) + +(in-package :asdf/package) + +;;;; General purpose package utilities + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun find-symbol* (name package-name &optional (error t)) + "Find a symbol in a package of given string'ified NAME; +unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax +by letting you supply a symbol or keyword for the name; +also works well when the package is not present. +If optional ERROR argument is NIL, return NIL instead of an error +when the symbol is not found." + (let ((package (find-package package-name))) + (if package + (let ((symbol (find-symbol (string name) package))) + (or symbol + (when error + (error "There is no symbol ~A in package ~A" name package-name)))) + (when error + (error "There is no package ~A" package-name))))) + (defun intern* (name package) + (intern (string name) package)) + (defun remove-symbol (symbol package) + (let ((sym (find-symbol* symbol package))) + (when sym + #-cormanlisp (unexport sym package) + (unintern sym package) + sym))) + (defun present-symbol-p (symbol package) + (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) + (defun 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))) + (defun ensure-package-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))) + (defun ensure-package-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))))) + (defun unlink-package (package) + (let ((u (find-package package))) + (when u + (ensure-package-unintern u (present-symbols u)) + (loop :for p :in (package-used-by-list u) :do + (unuse-package u p)) + (delete-package u)))) + (defun ensure-package-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-package-use p use) + p) + (t + (make-package name :nicknames nicknames :use use)))))) + (defun ensure-package-shadow (package symbols) + (shadow symbols package)) + (defun ensure-package-fmakunbound (package symbols) + (loop :for name :in symbols + :for sym = (find-symbol* name package) + :when sym :do (fmakunbound sym))) + (defun ensure-package-fmakunbound-setf (package symbols) + (loop :for name :in symbols + :for sym = (find-symbol* name package) + :when sym :do #-gcl (fmakunbound `(setf ,sym)))) + (defun ensure-package-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))))) + (defun ensure-package (name &key + nicknames use reuse unintern + shadow export fmakunbound fmakunbound-setf) + reuse + (let* ((p (ensure-package-exists name nicknames use))) + #-ecl (ensure-package-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL + #-ecl (ensure-package-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf + (ensure-package-unintern p unintern) + (ensure-package-shadow p shadow) + (ensure-package-export p export) + p)) + (defun do-define-package (package clauses) + package clauses +#| + (let ((h (make-hash-table :test 'equal))) + (labels ((ensure-imported (n) + (let* ((s (string n)) + (x (gethash s h))) + (unless x (setf (gethash s h) t)) + x)) + (import-from (package) + (loop :for s :being :each :external-symbol :in package + :for n = (symbol-name s) + :unless (ensure-imported n) + :collect n))) + ;; First, mark the symbols explicitly imported by the user + (loop :for (kw . ()) :in clauses + :when (member kw '(:import-from :shadowing-import-from)) :do + (map () #'ensure-imported (cddr clauses))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow :unintern ',unintern + :fmakunbound ',fmakunbound :fmakunbound-setf ',fmakunbound-setf))) + `(defpackage ,package (:use) + ,@(loop :for p :in mixed-packages + :collect `(:import-from ,p ,@(import-from p))) + ,@clauses + (:export ,@(loop :for s :being :the :hash-keys :of h :collect s))))))) +|# + )) + +(defmacro define-package (package &rest clauses) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (do-define-package ',package ',clauses))) diff --git a/pathname.lisp b/pathname.lisp new file mode 100644 index 0000000000000000000000000000000000000000..72acca94621e79fddf43da621abdb390341adb01 --- /dev/null +++ b/pathname.lisp @@ -0,0 +1,756 @@ +(defpackage :asdf/pathname + (:use :common-lisp :asdf/utility) + #+gcl<2.7 (:shadowing-import-from :system :*load-pathname*) ;; GCL 2.6 sucks + (:export + #:*resolve-symlinks* + ;; Making and merging pathnames, portably + #:normalize-pathname-directory-component #:denormalize-pathname-directory-component + #:merge-pathname-directory-components #:make-pathname* + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* + ;; Directories + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + ;; Absolute vs relative pathnames + #:absolute-pathname-p #:ensure-pathname-absolute + #:relativize-directory-component #:relativize-pathname-directory + ;; Parsing filenames and lists thereof + #:component-name-to-pathname-components + #:split-name-type #:coerce-pathname #:subpathname #:subpathname* #:ensure-pathname* + #:hidden-file-p + ;; Resolving symlinks somewhat + #:truenamize #:resolve-symlinks #:resolve-symlinks* + ;; Wildcard pathnames + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden + ;; Pathname host and its root + #:pathname-root #:directory-sperator-for-host + #:directorize-pathname-host-device + ;; probe filesystem + #:probe-file* #:safe-file-write-date + #:subdirectories #:directory-files #:directory* + #:filter-logical-directory-results #:collect-sub*directories + ;; Simple filesystem operations + #:ensure-all-directories-exist + #:rename-file-overwriting-target + #:delete-file-if-exists + ;; Translate a pathname + #:translate-pathname* + ;; temporary + #:add-pathname-suffix #:tmpize-pathname + #:call-with-staging-pathname #:with-staging-pathname + ;; basic pathnames + #:load-pathname #:default-directory + ;; Windows shortcut support + #:read-null-terminated-string #:read-little-endian + #:parse-file-location-info #:parse-windows-shortcut)) +(in-package :asdf/pathname) + +;;; User-visible parameters +(defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. + +Defaults to T.") + + +;;; The hell of portably making and merging pathnames! + +(defun* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" + #+gcl<2.7 (setf directory (substitute :back :parent directory)) + (cond + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. + ((stringp directory) `(:absolute ,directory)) + #+gcl<2.7 + ((and (consp directory) (eq :root (first directory))) + `(:absolute ,@(rest directory))) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + #+gcl<2.7 + ((consp directory) + `(:relative ,@directory)) + (t + (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) + +(defun* denormalize-pathname-directory-component (directory-component) + #-gcl<2.7 directory-component + #+gcl<2.7 + (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) + directory-component))) + (cond + ((and (consp d) (eq :relative (first d))) (rest d)) + ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) + (t d)))) + +(defun* merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. + (let ((directory (normalize-pathname-directory-component specified))) + (ecase (first directory) + ((nil) defaults) + (:absolute specified) + (:relative + (let ((defdir (normalize-pathname-directory-component defaults)) + (reldir (cdr directory))) + (cond + ((null defdir) + directory) + ((not (eq :back (first reldir))) + (append defdir reldir)) + (t + (loop :with defabs = (first defdir) + :with defrev = (reverse (rest defdir)) + :while (and (eq :back (car reldir)) + (or (and (eq :absolute defabs) (null defrev)) + (stringp (car defrev)))) + :do (pop reldir) (pop defrev) + :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) + +(defun* make-pathname* (&rest keys &key (directory nil directoryp) + host device name type version defaults) + (declare (ignore host device name type version defaults)) + (apply 'make-pathname + (append (when directoryp + `(:directory ,(denormalize-pathname-directory-component directory))) + keys))) + +(defun* make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname* + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) + +(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE both come from the DEFAULTS, whereas +if the SPECIFIED pathname does have an absolute directory, +then the HOST and DEVICE both come from the SPECIFIED. +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)))))) + + +;;; Directories +(defun* pathname-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) + +(defun* pathname-parent-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname* :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) + +(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 "~@<Invalid pathname designator ~S~@:>") pathspec)) + ((wild-pathname-p pathspec) + (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec)) + ((directory-pathname-p pathspec) + pathspec) + (t + (make-pathname* :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list (file-namestring pathspec))) + :name nil :type nil :version nil :defaults pathspec)))) + + +;;; Wildcard pathnames +(defparameter *wild* (or #+cormanlisp "*" :wild)) +(defparameter *wild-file* + (make-pathname :directory nil :name *wild* :type *wild* + :version (or #-(or abcl xcl) *wild*))) +(defparameter *wild-directory* + (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "*" *wild*)) + :name nil :type nil :version nil)) +(defparameter *wild-inferiors* + (make-pathname* :directory `(:relative ,(or #+gcl<2.7 "**" :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)) + + +;;; Probing the filesystem +(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))) + #+gcl<2.7 + '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename (subpathname (ensure-directory-pathname p) ".")))))) + '(ignore-errors (truename p))))))) + +(defun* safe-file-write-date (pathname) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls compute-action-stamp which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (and pathname (probe-file* pathname) (ignore-errors (file-write-date 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* 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* subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames* + #-(or abcl allegro cmu lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (fs:directory-list directory)) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmu sbcl scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) d + #+genera (ensure-directory-pathname (first x)) + #+(or cmu lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) + +(defun* collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) + + + +;;; Parsing filenames and lists thereof +(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 "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s)) + (let* ((components (split-string s :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char s) #\/) + (progn + (when force-relative + (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s)) + (values :absolute (cdr components))) + (values :relative nil)) + (values :relative components)) + (setf components (remove-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* 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* 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* 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* absolute-pathname-p (pathspec) + (and (typep pathspec '(or pathname string)) + (eq :absolute (car (normalize-pathname-directory-component + (pathname-directory (pathname pathspec))))))) + +(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* hidden-file-p (pathname) + (equal (first-char (pathname-name pathname)) #\.)) + + +;;; Pathname host and its root +(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)))) + +#-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))) + + +;;; Resolving symlinks somewhat +(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)) + + +;;; absolute vs relative +(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* relativize-directory-component (directory-component) + (let ((directory (normalize-pathname-directory-component directory-component))) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory)))) + +(defun* relativize-pathname-directory (pathspec) + (let ((p (pathname pathspec))) + (make-pathname* + :directory (relativize-directory-component (pathname-directory p)) + :defaults p))) + + +;;; Simple filesystem operations +(defun* ensure-all-directories-exist (pathnames) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) + +(defun* rename-file-overwriting-target (source target) + #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic + (posix:copy-file source target :method :rename) + #-clisp + (rename-file source target + #+clozure :if-exists #+clozure :rename-and-delete)) + +(defun* delete-file-if-exists (x) + (when (and x (probe-file* x)) + (delete-file x))) + +;;; Translate a pathname +(defun* translate-pathname* (path absolute-source destination &optional root source) + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (error "Invalid destination")) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) + +;;; Temporary pathnames +(defun* add-pathname-suffix (pathname suffix) + (make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname)) + +(defun* tmpize-pathname (x) + (add-pathname-suffix x "-ASDF-TMP")) + +(defun* call-with-staging-pathname (pathname fun) + "Calls fun with a staging pathname, and atomically +renames the staging pathname to the pathname in the end. +Note: this protects only against failure of the program, +not against concurrent attempts. +For the latter case, we ought pick random suffix and atomically open it." + (let* ((pathname (pathname pathname)) + (staging (tmpize-pathname pathname))) + (unwind-protect + (multiple-value-prog1 + (funcall fun staging) + (rename-file-overwriting-target staging pathname)) + (when (probe-file* staging) + (delete-file staging))))) + +(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) + +;;; Basic pathnames +(defun* load-pathname () + (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) + +(defun* default-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 + +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(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 (c) + (declare (ignore c)) + nil))))) diff --git a/plan.lisp b/plan.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c5bd9ccefcab6e6c91f4b47532689a7d9b9d8d99 --- /dev/null +++ b/plan.lisp @@ -0,0 +1,329 @@ +;;;; ------------------------------------------------------------------------- +;;;; Plan + +(cl:defpackage :asdf/plan + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os + :asdf/component :asdf/system :asdf/find-system :asdf/find-component + :asdf/operation :asdf/action) + #+gcl<2.7 (:shadowing-import-from :asdf/implementation #:type-of) + (:export + #:component-operation-time #:mark-operation-done + #:plan-traversal #:sequential-plan + #:planned-action-status #:plan-action-status #:action-already-done-p + #:circular-dependency #:circular-dependency-actions + #:node-for #:needed-in-image-p + #:plan-record-dependency #:visiting-action-p + #:normalize-forced-systems #:action-forced-p #:action-forced-not-p + #:visit-dependencies #:compute-action-stamp #:traverse-action + #:call-while-visiting-action #:while-visiting-action + #:traverse-sequentially #:traverse + #:perform-plan #:plan-operates-on-p)) + +(cl:in-package :asdf/plan) + +;;;; Planned action status + +(defgeneric* plan-action-status (plan operation component) + (:documentation "Returns the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + +(defgeneric* (setf plan-action-status) (new-status plan operation component) + (:documentation "Sets the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + +(defclass planned-action-status (action-status) + ((planned-p + :initarg :planned-p :reader action-planned-p + :documentation "a boolean, true iff the action was included in the plan.") + (index + :initarg :index :reader action-index + :documentation "an integer, counting all traversed actions in traversal order.")) + (:documentation "Status of an action in a plan")) + +(defmethod print-object ((status planned-action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (stamp done-p planned-p) status + (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p)))) + +;; TODO: eliminate NODE-FOR, use CONS. +;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. +;; However, see also component-operation-time and mark-operation-done +(defun* node-for (o c) (cons (type-of o) c)) + +(defun* action-already-done-p (plan operation component) + (action-done-p (plan-action-status plan operation component))) + +(defmethod plan-action-status ((plan null) (o operation) (c component)) + (declare (ignorable plan)) + (multiple-value-bind (stamp done-p) (component-operation-time o c) + (make-instance 'action-status :stamp stamp :done-p done-p))) + +(defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) + (declare (ignorable plan)) + (let ((to (type-of o)) + (times (component-operation-times c))) + (if (action-done-p new-status) + (remhash to times) + (setf (gethash to times) (action-stamp new-status)))) + new-status) + + +;;;; forcing + +(defgeneric* action-forced-p (plan operation component)) +(defgeneric* action-forced-not-p (plan operation component)) + +(defun* normalize-forced-systems (x system) + (etypecase x + ((member nil :all) x) + (cons (list-to-hash-set (mapcar #'coerce-name x))) + ((eql t) (list-to-hash-set (list (coerce-name system)))))) + +(defun* action-override-p (plan operation component override-accessor) + (declare (ignorable operation)) + (let* ((override (funcall override-accessor plan))) + (and override + (if (typep override 'hash-table) + (gethash (coerce-name (component-system (find-component () component))) override) + t)))) + +(defmethod action-forced-p (plan operation component) + (and (action-override-p plan operation component 'plan-forced) + (not (builtin-system-p (component-system component))))) +(defmethod action-forced-not-p (plan operation component) + (and (action-override-p plan operation component 'plan-forced-not) + (not (action-forced-p plan operation component)))) + + +;;;; action-valid-p + +(defgeneric action-valid-p (plan operation component) + (:documentation "Is this action valid to include amongst dependencies?")) +(defmethod action-valid-p (plan operation (c component)) + (declare (ignorable plan operation)) + (aif (component-if-feature c) (featurep it) t)) +(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil) +(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil) + + +;;;; Is the action needed in this image? + +(defgeneric* needed-in-image-p (operation component) + (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful, + or could it just as well have been done in another Lisp image?")) + +(defmethod needed-in-image-p ((o operation) (c component)) + ;; We presume that actions that modify the filesystem don't need be run + ;; in the current image if they have already been done in another, + ;; and can be run in another process (e.g. a fork), + ;; whereas those that don't are meant to side-effect the current image and can't. + (not (output-files o c))) + + +;;;; Visiting dependencies of an action and computing action stamps + +(defun* visit-dependencies (plan operation component fun &aux stamp) + (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) + :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature + :do (loop :with dep-o = (find-operation operation dep-o-spec) + :for dep-c-spec :in dep-c-specs + :for dep-c = (resolve-dependency-spec component dep-c-spec) + :when (action-valid-p plan dep-o dep-c) + :do (latest-stamp-f stamp (funcall fun dep-o dep-c)))) + stamp) + +(defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) + ;; In a distant future, safe-file-write-date and component-operation-time + ;; shall also be parametrized by the plan, or by a second model object. + (let* ((stamp-lookup #'(lambda (o c) (aif (plan-action-status plan o c) (action-stamp it) t))) + (out-files (output-files o c)) + (in-files (input-files o c)) + ;; Three kinds of actions: + (out-op (and out-files t)) ; those that create files on the filesystem + ;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing + ;; When was the thing last actually done? (Now, or ask.) + (op-time (or just-done (component-operation-time o c))) + ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) + (dep-stamp (visit-dependencies plan o c stamp-lookup)) + ;; Time stamps from the files at hand, and whether any is missing + (out-stamps (mapcar #'safe-file-write-date out-files)) + (in-stamps (mapcar #'safe-file-write-date in-files)) + (missing-in + (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) + (missing-out + (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) + (all-present (not (or missing-in missing-out))) + ;; Has any input changed since we last generated the files? + (earliest-out (stamps-earliest out-stamps)) + (latest-in (stamps-latest (cons dep-stamp in-stamps))) + (up-to-date-p (stamp<= latest-in earliest-out)) + ;; If everything is up to date, the latest of inputs and outputs is our stamp + (done-stamp (stamps-latest (cons latest-in out-stamps)))) + ;; Warn if some files are missing: + ;; either our model is wrong or some other process is messing with our files. + (when (and just-done (not all-present)) + (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ + ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" + (operation-description o c) + missing-in (length missing-in) (and missing-in missing-out) + missing-out (length missing-out))) + ;; Note that we use stamp<= instead of stamp< to play nice with generated files. + ;; Any race condition is intrinsic to the limited timestamp resolution. + (if (or just-done ;; The done-stamp is valid: if we're just done, or + ;; if all filesystem effects are up-to-date and there's no invalidating reason. + (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) + (values done-stamp ;; return the hard-earned timestamp + (or just-done + (or out-op ;; a file-creating op is done when all files are up to date + ;; a image-effecting a placeholder op is done when it was actually run, + (and op-time (eql op-time done-stamp))))) ;; with the matching stamp + ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet + (values t nil)))) + + +;;;; Generic support for plan-traversal + +(defgeneric* plan-record-dependency (plan operation component)) + +(defgeneric call-while-visiting-action (plan operation component function) + (:documentation "Detect circular dependencies")) + +(defclass plan-traversal () + ((forced :initform nil :initarg :force :accessor plan-forced) + (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) + (total-action-count :initform 0 :accessor plan-total-action-count) + (planned-action-count :initform 0 :accessor plan-planned-action-count) + (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) + (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) + (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) + (visiting-action-list :initform () :accessor plan-visiting-action-list))) + +(defmethod initialize-instance :after ((plan plan-traversal) + &key (force () fp) (force-not () fnp) system &allow-other-keys) + (with-slots (forced forced-not) plan + (when fp (setf forced (normalize-forced-systems force system))) + (when fnp (setf forced-not (normalize-forced-systems force-not system))))) + +(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) + (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) + +(defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) + (or (and (action-forced-not-p plan o c) (plan-action-status nil o c)) + (values (gethash (node-for o c) (plan-visited-actions plan))))) + +(defmethod action-valid-p ((plan plan-traversal) (o operation) (s system)) + (and (not (action-forced-not-p plan o s)) (call-next-method))) + +(defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) + (with-accessors ((action-set plan-visiting-action-set) + (action-list plan-visiting-action-list)) plan + (let ((action (cons operation component))) + (aif (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal)) + (progn + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil))))))) + + +;;;; Actual traversal: traverse-action + +(define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") + (circular-dependency-actions c))))) + +(defmacro while-visiting-action ((p o c) &body body) + `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))) + +(defgeneric* traverse-action (plan operation component needed-in-image-p)) + +(defmethod traverse-action (plan operation component needed-in-image-p) + (block nil + (unless (action-valid-p plan operation component) (return nil)) + (plan-record-dependency plan operation component) + (let* ((aniip (needed-in-image-p operation component)) + (eniip (and aniip needed-in-image-p)) + (status (plan-action-status plan operation component))) + (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) + ;; Already visited with sufficient need-in-image level: just return the stamp. + (return (action-stamp status))) + (labels ((visit-action (niip) + (visit-dependencies plan operation component + #'(lambda (o c) (traverse-action plan o c niip))) + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan operation component) + (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) + (cond + ((and add-to-plan-p (not niip)) ;; if we need to do it, + (visit-action t)) ;; then we need to do it in the image! + (t + (setf (plan-action-status plan operation component) + (make-instance + 'planned-action-status + :stamp stamp + :done-p (and done-p (not add-to-plan-p)) + :planned-p add-to-plan-p + :index (if status (action-index status) (incf (plan-total-action-count plan))))) + (when add-to-plan-p + (incf (plan-planned-action-count plan)) + (unless aniip + (incf (plan-planned-output-action-count plan)))) + stamp)))))) + (while-visiting-action (plan operation component) ; maintain context, handle circularity. + (visit-action eniip)))))) + + +;;;; Sequential plans (the default) + +(defclass sequential-plan (plan-traversal) + ((actions-r :initform nil :accessor plan-actions-r))) + +(defmethod plan-record-dependency ((plan sequential-plan) + (operation operation) (component component)) + (declare (ignorable plan operation component)) + (values)) + +(defmethod (setf plan-action-status) :after + (new-status (p sequential-plan) (o operation) (c component)) + (when (action-planned-p new-status) + (push (cons o c) (plan-actions-r p)))) + +(defun* traverse-sequentially (operation component &rest keys &key &allow-other-keys) + (let ((plan (apply 'make-instance 'sequential-plan :system (component-system component) keys))) + (traverse-action plan operation component t) + (reverse (plan-actions-r plan)))) + + +;;;; high-level interface: traverse, perform-plan, plan-operates-on-p + +(defgeneric* traverse (operation component &key &allow-other-keys) + (:documentation +"Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) +(defgeneric* perform-plan (plan &key)) +(defgeneric* plan-operates-on-p (plan component)) + +(defmethod traverse ((o operation) (c component) &rest keys &key &allow-other-keys) + (apply 'traverse-sequentially o c keys)) + +(defmethod perform-plan ((steps list) &key) + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () + (loop :for (op . component) :in steps :do + (perform-with-restarts op component))))) + +(defmethod plan-operates-on-p ((plan list) (component-path list)) + (find component-path (mapcar 'cdr plan) + :test 'equal :key 'component-find-path)) + diff --git a/source-registry.lisp b/source-registry.lisp new file mode 100644 index 0000000000000000000000000000000000000000..928384b897a7653d4bf3e682ceb99533e7ce7434 --- /dev/null +++ b/source-registry.lisp @@ -0,0 +1,314 @@ +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 + +(defpackage :asdf/source-registry + (:use :common-lisp :asdf/implementation :asdf/configuration :asdf/utility :asdf/pathname :asdf/os + :asdf/find-system) + (:export + #:invalid-source-registry + #:source-registry #:source-registry-initialized-p + #:initialize-source-registry #:clear-source-registry #:*source-registry* + #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter* + #:*default-source-registry-exclusions* #:*source-registry-exclusions* + #:*wild-asd* #:directory-asd-files #:register-asd-directory + #:collect-asds-in-directory #:collect-sub*directories-asd-files + #:validate-source-registry-directive #:validate-source-registry-form + #:validate-source-registry-file #:validate-source-registry-directory + #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry + #:user-source-registry #:system-source-registry + #:user-source-registry-directory #:system-source-registry-directory + #:environment-source-registry #:process-source-registry + #:compute-source-registry #:flatten-source-registry + #:sysdef-source-registry-search + )) +(in-package :asdf/source-registry) + +(define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) + +;; Using ack 1.2 exclusions +(defvar *default-source-registry-exclusions* + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_sgbak" "autom4te.cache" "cover_db" "_build" + "debian")) ;; debian often builds stuff under the debian directory... BAD. + +(defvar *source-registry-exclusions* *default-source-registry-exclusions*) + +(defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") + +(defun* source-registry-initialized-p () + (typep *source-registry* 'hash-table)) + +(defun* clear-source-registry () + "Undoes any initialization of the source registry. +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* directory-asd-files (directory) + (directory-files directory *wild-asd*)) + +(defun* collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) + +(defun* collect-sub*directories-asd-files + (directory &key (exclude *default-source-registry-exclusions*) collect) + (collect-sub*directories + directory + (constantly t) + #'(lambda (x) (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 "~@<Environment string isn't: ~3i~_~S~@:>") string)) + ((find (char string 0) "\"(") + (validate-source-registry-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with separator = (inter-directory-separator) + :for pos = (position separator string :start start) :do + (let ((s (subseq string start (or pos end)))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) + (cond + (pos + (setf start (1+ pos))) + (t + (unless inherit + (push '(:ignore-inherited-configuration) directives)) + (return `(:source-registry ,@(nreverse directives)))))))))) + +(defun* register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect))) + +(defparameter *default-source-registries* + '(environment-source-registry + user-source-registry + user-source-registry-directory + 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)) + +(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) + +(defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) +(defmethod process-source-registry ((pathname #-gcl<2.7 pathname #+gcl<2.7 t) &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* 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 "~@<In source-registry entry ~A~@[/~*~] ~ + found several entries for ~A - picking ~S over ~S~:>") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values)) + +(defvar *source-registry-parameter* nil) + +(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) + (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*))) + +(pushnew 'clear-source-registry *clear-configuration-hook*) diff --git a/system.lisp b/system.lisp new file mode 100644 index 0000000000000000000000000000000000000000..d5115b5d97859b2547b2c5815cccc73e75931cc3 --- /dev/null +++ b/system.lisp @@ -0,0 +1,141 @@ +;;;; ------------------------------------------------------------------------- +;;;; Systems + +(defpackage :asdf/system + (:use :common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/upgrade + :asdf/component) + (:export + #:child-component #:parent-component #:module #:system + #:component-children-by-name #:component-children #:compute-children-by-name + #:module-default-component-class + #:system-source-file #:system-source-directory #:system-relative-pathname + #:reset-system #:builtin-system-p + #:system-description #:system-long-description + #:system-author #:system-maintainer #:system-licence #:system-license + #:find-system #:probe-asd ;; forward-reference, defined in find-system + #:%set-system-source-file ;; For internal use only. DO NOT USE. + #:module-components ;; backward-compatibility. DO NOT USE. + #:system-defsystem-depends-on)) +(in-package :asdf/system) + +(defgeneric* find-system (system &optional error-p)) +(declaim (ftype (function (t t) t) probe-asd)) + +;;;; Component hierarchy within a system +;; The tree typically but not necessarily follows the filesystem hierarchy. + +(defclass child-component (component) ()) + +(defclass parent-component (component) + ((children + :initform nil + :initarg :components + :reader module-components ; backward-compatibility + :accessor component-children) + (children-by-name + :reader module-components-by-name ; backward-compatibility + :accessor component-children-by-name) + (default-component-class + :initform nil + :initarg :default-component-class + :accessor module-default-component-class))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun* compute-children-by-name (parent &key only-if-needed-p) + (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) + (let ((hash (make-hash-table :test 'equal))) + (setf (component-children-by-name parent) hash) + (loop :for c :in (component-children parent) + :for name = (component-name c) + :for previous = (gethash name hash) + :do (when previous (error 'duplicate-names :name name)) + (setf (gethash name hash) c)) + hash)))) + +(with-upgrade (:when (find-class 'module nil)) + (defmethod reinitialize-instance :after ((m module) &rest initargs &key) + (declare (ignorable m initargs)) (values)) + (defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable m added deleted plist)) + (when (and (member 'children added) (member 'components deleted)) + (setf (slot-value m 'children) + ;; old ECLs provide an alist instead of a plist(!) + (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist))) + (getf plist 'components))) + (compute-children-by-name m)) + (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)))))) + +(defclass module (child-component parent-component) + ()) + + +;;;; The system class itself + +(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. + ((asdf/component::name) (source-file) #|(children) (children-by-names)|#)) + +(defclass system (module proto-system) + ;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component. + (;; {,long-}description is now inherited from component, but we add the legacy accessors + (asdf/component::description :accessor system-description) + (asdf/component::long-description :accessor system-long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence + :accessor system-license :initarg :license) + (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) + +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + + +;;;; Pathnames + +(defmethod component-pathname ((system system)) + (if (or (slot-boundp system 'asdf/component::relative-pathname) + (slot-boundp system 'asdf/component::absolute-pathname) + (slot-value system 'source-file)) + (call-next-method) + (default-directory))) + +(defgeneric* system-source-file (system) + (:documentation "Return the source file in which system is defined.")) +(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)) + (slot-value system 'source-file)) +(defmethod system-source-file ((system-name string)) + (system-source-file (find-system system-name))) +(defmethod system-source-file ((system-name symbol)) + (system-source-file (find-system system-name))) + +(defun* system-source-directory (system-designator) + "Return a pathname object corresponding to the +directory in which the system specification (.asd file) is +located." + (pathname-directory-pathname (system-source-file system-designator))) + +(defun* system-relative-pathname (system name &key type) + (subpathname (system-source-directory system) name :type type)) + + +;;;; Beware of builtin systems +(defgeneric* builtin-system-p (system)) +(defmethod builtin-system-p ((s system)) + (let* ((system (find-system s nil)) + (sysdir (and system (component-pathname system))) + (impdir (lisp-implementation-directory :truename t))) + (and sysdir impdir (pathname-match-p (truename sysdir) (wilden impdir)) t))) + diff --git a/test/test-around-compile.asd b/test/test-around-compile.asd deleted file mode 100644 index 4ec5270d502c243a341375b6d19449e3671718e0..0000000000000000000000000000000000000000 --- a/test/test-around-compile.asd +++ /dev/null @@ -1,13 +0,0 @@ -;;; -*- Lisp -*- -(in-package :asdf) - -(defun call-in-base-2 (thunk) - (let ((*read-base* 2)) - (funcall thunk))) - -;;(trace call-in-base-2 compile-file load trace around-compile-hook) - -(defsystem test-around-compile - :around-compile call-in-base-2 - :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. - :components ((:file "test"))) diff --git a/test/test-around-compile.script b/test/test-around-compile.script index efd5d7f966880018f1c92a5c186e335501df62dd..deae5a48b60db38099b97a703cb72a9338c3d610 100644 --- a/test/test-around-compile.script +++ b/test/test-around-compile.script @@ -2,7 +2,16 @@ (load "script-support.lisp") (load-asdf) +(defun call-in-base-2 (thunk) + (let ((*read-base* 2)) + (funcall thunk))) + +(trace call-in-base-2 compile-file load asdf::around-compile-hook) + (quit-on-error - (setf *central-registry* '(*default-pathname-defaults*)) - (load-system 'test-around-compile :force t) - (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2 + (defsystem test-around-compile + :around-compile call-in-base-2 + :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that. + :components ((:file "test"))) + (load-system 'test-around-compile :force t) + (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2 diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index aff22cc4e540d00654927f55a7bdd8e4bb3f53a6..f3145e27111f9a058b0e9a02b5aa506565dcedd0 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -22,7 +22,7 @@ (DBG "trlc1 6" name mode) (assert (eq mode :external) nil "Mode of ~s was not external" name) (let ((restart (find-restart name c))) - (DBG "trlc1 7" restart) + (DBG "trlc1 7" name restart) (assert restart) (when restart (invoke-restart restart))))))) (DBG "trlc1 3") diff --git a/upgrade.lisp b/upgrade.lisp new file mode 100644 index 0000000000000000000000000000000000000000..22feaa7b9c1176e83a9cbc4b652421a9cc5e569a --- /dev/null +++ b/upgrade.lisp @@ -0,0 +1,92 @@ +;;;; ------------------------------------------------------------------------- +;;;; Handle upgrade as forward- and backward-compatibly as possible +;; See https://bugs.launchpad.net/asdf/+bug/485687 + +(defpackage :asdf/upgrade + (:use :common-lisp :asdf/package :asdf/implementation :asdf/utility) + (:export + #:upgrade-asdf #:asdf-upgrade-error #:with-upgrade + #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* + #:asdf-version #:*upgraded-p*)) +(in-package :asdf/upgrade) + +;;; Special magic to detect if this is an upgrade + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil) + (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.62") + (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* + "~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%" + existing-version asdf-version)) + (setf *asdf-version* asdf-version + *upgraded-p* (if existing-version + (cons existing-version *upgraded-p*) + *upgraded-p*))))) + +;;;; User interface + +(defmacro with-upgrade ((&key (upgraded-p '*upgraded-p*) when) &body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (when (and ,upgraded-p ,@(when when `(,when))) + (handler-bind ((style-warning #'muffle-warning)) + (eval '(progn ,@body)))))) + +(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* asdf-upgrade-error () + ;; Important notice for whom it concerns. The crux of the matter is that + ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. + (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ + Otherwise, when you upgrade ASDF, you must do it before you operate on any system.~%")) + + +;;; Self-upgrade functions + +(defvar *post-upgrade-cleanup-hook* ()) +(defvar *post-upgrade-restart-hook* ()) + +(defun* post-upgrade-cleanup (old-version) + (let ((new-version (asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-compatible-p new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-compatible-p 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))) + (dolist (h (reverse *post-upgrade-cleanup-hook*)) + (funcall (ensure-function h))) + (dolist (h *post-upgrade-restart-hook*) + (funcall (ensure-function h))) + t))) + +(defun* upgrade-asdf () + "Try to upgrade of ASDF. If a different version was used, return T. + We need do that before we operate on anything that depends on ASDF." + (let ((version (asdf-version))) + (handler-bind (((or style-warning warning) #'muffle-warning)) + (funcall (find-symbol* 'load-system :asdf) :asdf :verbose nil)) + (post-upgrade-cleanup version))) + diff --git a/utility.lisp b/utility.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1a39025210c4833b147fb21176e8bd4453568bee --- /dev/null +++ b/utility.lisp @@ -0,0 +1,199 @@ +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities for ASDF + +(defpackage :asdf/utility + (:use :common-lisp :asdf/package :asdf/implementation) + (:export + #:find-symbol* ;; reexport from asdf/package + #:strcat #:compatfmt ;; reexport from asdf/implementation + #:defun* #:defgeneric* ;; defining macros + #:aif #:it ;; basic flow control + #:while-collecting #:appendf #:length=n-p ;; lists + #:remove-keys #:remove-keyword ;; keyword argument lists + #:first-char #:last-char #:split-string #:string-suffix-p ;; strings + #:find-class* ;; CLOS + #:stamp< #:stamp<= #:earlier-stamp #:stamps-earliest #:earliest-stamp ;; stamps + #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f + #:list-to-hash-set ;; hash-table + #:ensure-function ;; functions + #:parse-version #:version-compatible-p ;; version + )) +(in-package :asdf/utility) + +;;; *-defining macros + +(macrolet + ((defdef (def* def) + `(defmacro ,def* (name formals &rest rest) + `(progn + #+(or ecl gcl) + ,(when (and #+gcl<2.7 (symbolp name)) + `(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)) + +;;; Flow control +(defmacro aif (test then &optional else) + "Anaphoric version of IF, On Lisp style" + `(let ((it ,test)) (if it ,then ,else))) + +;;; List manipulation +(defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." + (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) + ,@body + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) + +(define-modify-macro appendf (&rest args) + append "Append onto list") ;; only to be used on short lists. + +(defun* length=n-p (x n) ;is it that (= (length x) n) ? + (check-type n (integer 0 *)) + (loop + :for l = x :then (cdr l) + :for i :downfrom n :do + (cond + ((zerop i) (return (null l))) + ((not (consp l)) (return nil))))) + +;;; Keyword argument lists +(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))) + +;;; Strings +(defun* first-char (s) + (and (stringp s) (plusp (length s)) (char s 0))) + +(defun* last-char (s) + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + +(defun* split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. +If MAX is specified, then no more than max(1,MAX) components will be returned, +starting the separation from the end, e.g. when called with arguments + \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." + (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* 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)))) + +;;; CLOS +(defun* find-class* (x &optional (errorp t) environment) + (etypecase x + ((or standard-class built-in-class) x) + #+gcl<2.7 (keyword nil) + (symbol (find-class x errorp environment)))) + +;;; stamps: real or boolean where NIL=-infinity, T=+infinity +(defun* stamp< (x y) + (etypecase x + (null (and y t)) + ((eql t) nil) + (real (etypecase y + (null nil) + ((eql t) t) + (real (< x y)))))) +;;(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) +;;(defun* stamp*< (&rest list) (stamps< list)) +(defun* stamp<= (x y) (not (stamp< y x))) +(defun* earlier-stamp (x y) (if (stamp< x y) x y)) +(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) +(defun* earliest-stamp (&rest list) (stamps-earliest list)) +(defun* later-stamp (x y) (if (stamp< x y) y x)) +(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) +(defun* latest-stamp (&rest list) (stamps-latest list)) +(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp) + +;;; Hash-tables +(defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) + (dolist (x list h) (setf (gethash x h) t))) + +;;; Functions +(defun* ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or boolean keyword character number) (constantly fun)) + ((or function symbol) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + + +;;; Version handling +(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 ".")))) + +(defun* version-compatible-p (provided-version required-version) + "Is the provided version a compatible substitution for the required-version? +If major versions differ, it's not compatible. +If they are equal, then any later version is compatible, +with later being determined by a lexicographical comparison of minor numbers." + (let ((x (parse-version version 'warn)) + (y (parse-version base-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 x y (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) +