pax_global_header00006660000000000000000000000064122316444340014515gustar00rootroot0000000000000052 comment=10fa87ab70d7db14b45ad822558382fe3dad4540 cl-asdf-3.0.3/000077500000000000000000000000001223164443400130315ustar00rootroot00000000000000cl-asdf-3.0.3/.gitattributes000066400000000000000000000000161223164443400157210ustar00rootroot00000000000000* export-substcl-asdf-3.0.3/.gitignore000066400000000000000000000011431223164443400150200ustar00rootroot00000000000000? ?? build asdf.lisp doc/asdf/ doc/asdf.aux doc/asdf.cp doc/asdf.cps doc/asdf.fn doc/asdf.fns doc/asdf.html doc/asdf.info doc/asdf.ky doc/asdf.log doc/asdf.pdf doc/asdf.pg doc/asdf.toc doc/asdf.tp doc/asdf.vr doc/asdf.vrs doc/asdf.t2d/ LICENSE tmp/ *.dribble *.fas[bcl] *.fas *.lib *.[oahcisS] *.*fsl *.x86f *.bak *.data *.ufasl *.vbin *.~*~ *.sse2f test/try-reloading-dependency.asd test/fileMissing.lisp test/hello-world-example build-stamp debian/cl-asdf.debhelper.log debian/cl-asdf.postinst.debhelper debian/cl-asdf.prerm.debhelper debian/cl-asdf.substvars debian/cl-asdf/ debian/files .pc /.DS_Store cl-asdf-3.0.3/Makefile000066400000000000000000000167651223164443400145100ustar00rootroot00000000000000system := "asdf" webhome_private := common-lisp.net:/project/asdf/public_html/ webhome_public := "http://common-lisp.net/project/asdf/" clnet_home := "/project/asdf/public_html/" sourceDirectory := $(shell pwd) #### Common Lisp implementations available for testing. ## export ASDF_TEST_LISPS to override the default list of such implementations, ## or specify a lisps= argument at the make command-line ifdef ASDF_TEST_LISPS lisps ?= ${ASDF_TEST_LISPS} else lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern xcl gcl endif ## NOT SUPPORTED BY OUR AUTOMATED TESTS: ## cormancl genera lispworks-personal-edition mkcl rmcl ## Some are manually tested once in a while. ## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen. ## grep for #+/#- features in the test/ directory to see plenty of disabled tests. ifdef ASDF_TEST_SYSTEMS s ?= ${ASDF_TEST_SYSTEMS} endif ifdef ASDF_DEVEL_SOURCE_REGISTRY export CL_SOURCE_REGISTRY = ${ASDF_DEVEL_SOURCE_REGISTRY} endif l ?= sbcl ABCL ?= abcl ALLEGRO ?= alisp ALLEGROMODERN ?= mlisp CCL ?= ccl CLISP ?= clisp CMUCL ?= cmucl ECL ?= ecl GCL ?= gcl LISPWORKS ?= lispworks MKCL ?= mkcl SBCL ?= sbcl SCL ?= scl XCL ?= xcl # website, tag, install header_lisp := header.lisp driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/run-program.lisp uiop/lisp-build.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp defsystem_lisp := upgrade.lisp component.lisp system.lisp cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp output-translations.lisp backward-interface.lisp source-registry.lisp interface.lisp user.lisp footer.lisp all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) # Making ASDF itself should be our first, default, target: build/asdf.lisp: $(all_lisp) mkdir -p build cat $(all_lisp) > $@ # This quickly locates such mistakes as unbalanced parentheses: load: build/asdf.lisp ./test/run-tests.sh -t $l $(all_lisp) install: archive bump: bump-version bump-version: build/asdf.lisp ./bin/asdf-builder bump-version ${v} driver-files: @echo $(driver_lisp) defsystem-files: @echo $(defsystem_lisp) archive: build/asdf.lisp ./bin/asdf-builder make-and-publish-archive ### Count lines separately for asdf-driver and asdf itself: wc: @wc $(driver_lisp) | sort -n ; echo ; \ wc $(header_lisp) $(defsystem_lisp) | sort -n ; \ echo ; \ wc $(header_lisp) $(driver_lisp) $(defsystem_lisp) | tail -n 1 push: git status git push --tags cl.net release master git push --tags github release master git fetch git status doc: ${MAKE} -C doc website: ${MAKE} -C doc website clean_dirs = $(sourceDirectory) clean_extensions = fasl dfsl cfsl fasl fas lib dx32fsl lx64fsl lx32fsl ufasl o bak x86f vbin amd64f sparcf sparc64f hpf hp64f clean: @for dir in $(clean_dirs); do \ if test -d $$dir; then \ echo Cleaning $$dir; \ for ext in $(clean_extensions); do \ find $$dir \( -name "*.$$ext" \) \ -and -not -path \""*/.git/*"\" \ -and -not -path \""*/_darcs/*"\" \ -and -not -path \""*/tags/*"\" -print -delete; \ done; \ fi; \ done rm -rf build/ LICENSE test/try-reloading-dependency.asd test/hello-world-example asdf.lisp rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap ${MAKE} -C doc clean mrproper: git clean -xfd test-upgrade: build/asdf.lisp ./test/run-tests.sh -u ${l} u: test-upgrade test-clean-load: build/asdf.lisp ./test/run-tests.sh -c ${l} # test-glob has been replaced by t, and lisp by l, easier to type test-lisp: build/asdf.lisp @cd test; ./run-tests.sh ${l} ${t} t: test-lisp test: test-lisp test-clean-load test-load-systems doc test-load-systems: build/asdf.lisp ./test/run-tests.sh -l ${l} ${s} test-all-lisps: ${MAKE} test-load-systems @for lisp in ${lisps} ; do \ ${MAKE} test-lisp test-upgrade test-clean-load l=$$lisp || exit 1 ; \ done # test upgrade is a very long run... This does just the regression tests test-all-no-upgrade: @for lisp in ${lisps} ; do \ ${MAKE} test-lisp test-clean-load l=$$lisp || exit 1 ; \ done test-all-upgrade: @for lisp in ${lisps} ; do \ ${MAKE} test-upgrade l=$$lisp || exit 1 ; \ done test-all: doc test-all-lisps test-all-no-stop: -make doc ; for l in ${lisps} ; do make t l=$$l ; make u l=$$l ; done ; true extract: extract-all-tagged-asdf extract-all-tagged-asdf: build/asdf.lisp ./test/run-tests.sh -H # Note that the debian git at git://git.debian.org/git/pkg-common-lisp/cl-asdf.git is stale, # as we currently build directly from upstream at git://common-lisp.net/projects/asdf/asdf.git debian-package: mrproper : $${RELEASE:="$$(git tag -l '3.[0-9].[0-9]' | tail -n 1)"} ; echo building package version $$RELEASE ; \ git-buildpackage --git-debian-branch=release --git-upstream-branch=release --git-upstream-tag=$$RELEASE --git-tag --git-retag --git-ignore-branch debian-package-from-master: mrproper : $${RELEASE:="$$(git tag -l '3.[0-9].[0-9]' | tail -n 1)"} ; echo building package version $$RELEASE ; \ git-buildpackage --git-debian-branch=master --git-upstream-branch=master --git-upstream-tag=$$RELEASE --git-tag --git-retag --git-ignore-branch # Replace SBCL's ASDF with the current one. -- NOT recommended now that SBCL has ASDF2. # for casual users, just use (asdf:load-system :asdf) replace-sbcl-asdf: build/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: build/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 # It's not 1.37, it's 1.85! 1.37 is for the README. # Delete wrongful tags from local repository fix-local-git-tags: for i in ${WRONGFUL_TAGS} ; do git tag -d $$i ; done # Delete wrongful tags from remote repository fix-remote-git-tags: for i in ${WRONGFUL_TAGS} ; do git push $${REMOTE:-cl.net} :refs/tags/$$i ; done release-push: git checkout master git merge release git checkout release git merge master git checkout master TODO: exit 2 release: TODO test-all test-on-other-machines-too debian-changelog debian-package send-mail-to-mailing-lists .PHONY: install archive push doc website clean mrproper \ test-forward-references test test-lisp test-upgrade test-forward-references \ test-all test-all-lisps test-all-no-upgrade \ debian-package release \ replace-sbcl-asdf replace-ccl-asdf \ fix-local-git-tags fix-remote-git-tags wc wc-driver wc-asdf # RELEASE or PUSH checklist: # make test-all # make test-load-systems s=fare-all # make bump v=3.0 # edit debian/changelog # RELEASE only... # git commit # git tag 3.0 # for example ... # git push # git push origin 3.0 # for example... # everything from here for RELEASE only # make debian-package # make release-push archive website debian-package # dput mentors ../*.changes # send debian mentors request # send announcement to asdf-announce, asdf-devel, etc. # ## Users don't release as above, only maintainers do. ## Users, all you need to do is: make ## Vendors, you may want to test your implementation with: make test l=sbcl cl-asdf-3.0.3/README000066400000000000000000000014571223164443400137200ustar00rootroot00000000000000ASDF: another system definition facility ======================================== If you cloned our git repository, bootstrap a copy of build/asdf.lisp with: make To use ASDF, read our manual: http://common-lisp.net/project/asdf/asdf.html The first few sections, Loading ASDF, Configuring ASDF and Using ASDF, will get you started as a simple user. If you want to define your own systems, further read the section Defining systems with defsystem. ASDF 3 now includes an extensive runtime support library: UIOP, the Utilities for Implementation- and OS- Portability. Its documentation unhappily lies mainly in the source code and docstrings. More information and additional links can be found on ASDF's home page at: http://common-lisp.net/project/asdf/ Last updated Thursday, April 10th, 2013. cl-asdf-3.0.3/TODO000066400000000000000000000123211223164443400135200ustar00rootroot00000000000000* Find out why ABCL fails the timestamp propagation test. * Fix bugs on http://bugs.launchpad.net/asdf/+bugs * fix directory-files to not return directories on CCL, etc. Add tests. * use cl-test-grid to see if asdf-user can :use most (all?) of UIOP. Unhappily, on SBCL, sb-grovel uses asdf and sb-ext, which causes a clash with run-program. Or has this been changed long enough ago? Can it be special-cased? * have a mode to explain WHY a component needs to be recompiled. * have a better defsystem form verifier - see lp#1007335 * have a function verify-strict-asd that can verify a asd is pure lp#541562 Then if it passes, use load-strict-asd. If not, optionally issue a warning. Start migrating people toward that. * have with-input-file use the encodings mechanism? * have a single test .asd that tests as many features as possible, use it for upgrade test. * implement deferred warnings support on lispworks * work with cl-test-grid to eliminate deferred warnings from quicklisp libraries * fix upgrade on clisp, cmucl, abcl (if still broken) ** Extract minimal test case, build a battery of automated tests * Bug found by fe[nl]ix: infinite loop if the definitions in an asd file are not in strict defsystem-depends-on dependency order. ** At least document the issue. ** Real solution: defer parsing and evaluation of defsystem forms. * Learn to use cl-grid-test, to make sure ASDF changes don't break stuff, and that breakage gets fixed quickly. * Include some ABL test for stassats's thing: (asdf:enable-asdf-binary-locations-compatibility :centralize-lisp-binaries t :default-toplevel-directory *fasl-dir*) * Make load-op a generic operation that selects the proper strategy for each system, module or file, according to component properties and user-configuration: compile the lisp file then load the fasl (load-fasl-op on a cl-source-file), load the lisp file without compiling (load-source-op), compile all files for the system, link them and load the result (load-fasl-op on the system), compile all files for the system *and* its dependencies, link and load (monolithic-load-fasl-op), concatenate all files for the system, then load the result (load-concatenated-source-op), concatenate all files for the system, then link them and load the result (load-compiled-concatenated-op), concatenate all files for the system *and* its dependencies, link and load (monolithic-load-compiled-concatenated-op). * operation cleanup? ** Kill backward-compat functions after all clients have moved on. ** Kill original-initargs -- BEWARE, it currently has clients! * Get rid of component-properties ** directly use component-properties: *** yaclml.asd => misguided :features for version comparison *** amazon-ecs-20110418-git/amazon-ecs.asd => :website property *** hemlock.asd => bad implementation of latin1 encodings ** .asd use :properties *** arnesi, arnesi+ => :features, misguided for version comparison and pseudo #+features *** lkcas, thopter => :long-name *** cl-irc cliki-bot rss cl-syslog com.informatimago.clext com.informatimago.clisp com.informatimago.clmisc com.informatimago.common-lisp.arithmetic om.informatimago.common-lisp.bank com.informatimago.common-lisp.cesarum com.informatimago.common-lisp com.informatimago.common-lisp.csv com.informatimago.common-lisp.cxx com.informatimago.common-lisp.data-encoding com.informatimago.common-lisp.diagram com.informatimago.common-lisp.ed com.informatimago.common-lisp.graphviz com.informatimago.common-lisp.heap com.informatimago.common-lisp.html-base com.informatimago.common-lisp.html-generator com.informatimago.common-lisp.html-parser com.informatimago.common-lisp.http com.informatimago.common-lisp.interactive com.informatimago.common-lisp.invoice com.informatimago.common-lisp.lisp com.informatimago.common-lisp.lisp.ibcl com.informatimago.common-lisp.lisp.stepper com.informatimago.common-lisp.lisp-reader com.informatimago.common-lisp.lisp-sexp com.informatimago.common-lisp.lisp-text com.informatimago.common-lisp.parser com.informatimago.common-lisp.picture com.informatimago.common-lisp.regexp com.informatimago.common-lisp.rfc2822 com.informatimago.common-lisp.rfc3548 com.informatimago.common-lisp.telnet com.informatimago.common-lisp.unix linc com.informatimago.lispdoc com.informatimago.lua com.informatimago.cocoa-playground com.informatimago.objcl com.informatimago.rdp com.informatimago.rdp.basic com.informatimago.rdp.basic.example com.informatimago.rdp.example com.informatimago.susv3 com.informatimago.common-lisp.tools.make-depends com.informatimago.xcode spartns xlunit => (uninterned!) #:author-email #:date (#:albert #:output-dirs) (#:albert #:formats) (#:albert #:docbook #:template) (#:albert #:docbook #:bgcolor) (#:albert #:docbook #:textcolor) (#:albert #:docbook #:dtd) *** portableaserve => ("system" "author" "email") ("albert" "presentation" "output-dir") ("albert" "presentation" "formats") ("albert" "docbook" "dtd") ("albert" "docbook" "template") *** com.clearly-useful.generic-collection-interface => :com.clearly-useful *** metatilities => :ait-timeout :system-applicable-p *** ucw ucw-core => version cl-asdf-3.0.3/action.lisp000066400000000000000000000353001223164443400152000ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Actions (asdf/package:define-package :asdf/action (:nicknames :asdf-action) (:recycle :asdf/action :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation) (:export #:action #:define-convenience-action-methods #:explain #:action-description #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:component-depends-on #:input-files #:output-files #:output-file #:operation-done-p #:action-status #:action-stamp #:action-done-p #:component-operation-time #:mark-operation-done #:compute-action-stamp #:perform #:perform-with-restarts #:retry #:accept #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan #:action-path #:find-action #:stamp #:done-p)) (in-package :asdf/action) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype action () '(cons operation component))) ;; a step to be performed while building (with-upgradability () (defgeneric traverse-actions (actions &key &allow-other-keys)) (defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) (defgeneric required-components (component &key &allow-other-keys))) ;;;; Reified representation for storage or debugging. Note: dropping original-initargs (with-upgradability () (defun action-path (action) (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c)))) (defun find-action (path) (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c))))) ;;;; Convenience methods (with-upgradability () (defmacro define-convenience-action-methods (function formals &key if-no-operation if-no-component operation-initargs) (let* ((rest (gensym "REST")) (found (gensym "FOUND")) (keyp (equal (last formals) '(&key))) (formals-no-key (if keyp (butlast formals) formals)) (len (length formals-no-key)) (operation 'operation) (component 'component) (opix (position operation formals)) (coix (position component formals)) (prefix (subseq formals 0 opix)) (suffix (subseq formals (1+ coix) len)) (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) (assert (and (integerp opix) (integerp coix) (= coix (1+ opix)))) (flet ((next-method (o c) (if keyp `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) `(,function ,@prefix ,o ,c ,@suffix)))) `(progn (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args) (if ,operation ,(next-method (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. `(apply 'make-operation ,operation :original-initargs ,rest ,rest) `(make-operation ,operation)) `(or (find-component () ,component) ,if-no-component)) ,if-no-operation)) (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args) (if (typep ,component 'component) (error "No defined method for ~S on ~/asdf-action:format-action/" ',function (cons ,operation ,component)) (if-let (,found (find-component () ,component)) ,(next-method operation found) ,if-no-component)))))))) ;;;; self-description (with-upgradability () (defgeneric action-description (operation component) (:documentation "returns a phrase that describes performing this operation on this component, e.g. \"loading /a/b/c\". You can put together sentences using this phrase.")) (defmethod action-description (operation component) (format nil (compatfmt "~@<~A on ~A~@:>") (type-of operation) component)) (defgeneric* (explain) (operation component)) (defmethod explain ((o operation) (c component)) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))) (define-convenience-action-methods explain (operation component)) (defun format-action (stream action &optional colon-p at-sign-p) (assert (null colon-p)) (assert (null at-sign-p)) (destructuring-bind (operation . component) action (princ (action-description operation component) stream)))) ;;;; Dependencies (with-upgradability () (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies (:documentation "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: ( *), where is an operation designator with respect to FIND-OPERATION in the context of the OPERATION argument, and each is a component designator with respect to FIND-COMPONENT in the context of the COMPONENT argument, and means that the component depends on having been performed on each ; or (FEATURE ), which means that the component depends on the expression satisfying FEATUREP. (This is DEPRECATED -- use :IF-FEATURE instead.) Methods specialized on subclasses of existing component types should usually append the results of CALL-NEXT-METHOD to the list.")) (define-convenience-action-methods component-depends-on (operation component)) (defmethod component-depends-on :around ((o operation) (c component)) (do-asdf-cache `(component-depends-on ,o ,c) (call-next-method))) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies ;;;; upward-operation, downward-operation ;; These together handle actions that propagate along the component hierarchy. ;; Downward operations like load-op or compile-op propagate down the hierarchy: ;; operation on a parent depends-on operation on its children. ;; By default, an operation propagates itself, but it may propagate another one instead. (with-upgradability () (defclass downward-operation (operation) ((downward-operation :initform nil :initarg :downward-operation :reader downward-operation :allocation :class))) (defmethod component-depends-on ((o downward-operation) (c parent-component)) `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method))) ;; Upward operations like prepare-op propagate up the component hierarchy: ;; operation on a child depends-on operation on its parent. ;; By default, an operation propagates itself, but it may propagate another one instead. (defclass upward-operation (operation) ((upward-operation :initform nil :initarg :downward-operation :reader upward-operation :allocation :class))) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF4: remove that. (defmethod component-depends-on ((o upward-operation) (c child-component)) `(,@(if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))) ,@(call-next-method))) ;; Sibling operations propagate to siblings in the component hierarchy: ;; operation on a child depends-on operation on its parent. ;; By default, an operation propagates itself, but it may propagate another one instead. (defclass sideway-operation (operation) ((sideway-operation :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class))) (defmethod component-depends-on ((o sideway-operation) (c component)) `((,(or (sideway-operation o) o) ,@(loop :for dep :in (component-sideway-dependencies c) :collect (resolve-dependency-spec c dep))) ,@(call-next-method))) ;; Selfward operations propagate to themselves a sub-operation: ;; they depend on some other operation being acted on the same component. (defclass selfward-operation (operation) ((selfward-operation :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class))) (defmethod component-depends-on ((o selfward-operation) (c component)) `(,@(loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)) ,@(call-next-method)))) ;;;; Inputs, Outputs, and invisible dependencies (with-upgradability () (defgeneric* (output-files) (operation component)) (defgeneric* (input-files) (operation component)) (defgeneric* (operation-done-p) (operation component) (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again")) (define-convenience-action-methods output-files (operation component)) (define-convenience-action-methods input-files (operation component)) (define-convenience-action-methods operation-done-p (operation component)) (defmethod operation-done-p ((o operation) (c component)) (declare (ignorable o c)) t) (defmethod output-files :around (operation component) "Translate output files, unless asked not to. Memoize the result." operation component ;; hush genera, not convinced by declare ignorable(!) (do-asdf-cache `(output-files ,operation ,component) (values (multiple-value-bind (pathnames fixedp) (call-next-method) ;; 1- Make sure we have absolute pathnames (let* ((directory (pathname-directory-pathname (component-pathname (find-component () component)))) (absolute-pathnames (loop :for pathname :in pathnames :collect (ensure-absolute-pathname pathname directory)))) ;; 2- Translate those pathnames as required (if fixedp absolute-pathnames (mapcar *output-translation-function* absolute-pathnames)))) t))) (defmethod output-files ((o operation) (c component)) (declare (ignorable o c)) nil) (defun output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" (let ((files (output-files operation component))) (assert (length=n-p files 1)) (first files))) (defmethod input-files :around (operation component) "memoize input files." (do-asdf-cache `(input-files ,operation ,component) (call-next-method))) (defmethod input-files ((o operation) (c component)) (declare (ignorable o c)) nil) (defmethod input-files ((o selfward-operation) (c component)) `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) :append (or (output-files dep-o c) (input-files dep-o c))) (if-let ((pathname (component-pathname c))) (and (file-pathname-p pathname) (list pathname)))) ,@(call-next-method)))) ;;;; Done performing (with-upgradability () (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp (define-convenience-action-methods component-operation-time (operation component)) (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp) (defgeneric compute-action-stamp (plan operation component &key just-done) (:documentation "Has this action been successfully done already, and at what known timestamp has it been done at or will it be done at? Takes two keywords JUST-DONE and PLAN: JUST-DONE is a boolean that is true if the action was just successfully performed, at which point we want compute the actual stamp and warn if files are missing; otherwise we are making plans, anticipating the effects of the action. PLAN is a plan object modelling future effects of actions, or NIL to denote what actually happened. Returns two values: * a STAMP saying when it was done or will be done, or T if the action has involves files that need to be recomputed. * a boolean DONE-P that indicates whether the action has actually been done, and both its output-files and its in-image side-effects are up to date.")) (defclass action-status () ((stamp :initarg :stamp :reader action-stamp :documentation "STAMP associated with the ACTION if it has been completed already in some previous image, or T if it needs to be done.") (done-p :initarg :done-p :reader action-done-p :documentation "a boolean, true iff the action was already done (before any planned action).")) (:documentation "Status of an action")) (defmethod print-object ((status action-status) stream) (print-unreadable-object (status stream :type t) (with-slots (stamp done-p) status (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) (defmethod component-operation-time ((o operation) (c component)) (gethash (type-of o) (component-operation-times c))) (defmethod mark-operation-done ((o operation) (c component)) (setf (gethash (type-of o) (component-operation-times c)) (compute-action-stamp nil o c :just-done t)))) ;;;; Perform (with-upgradability () (defgeneric* (perform-with-restarts) (operation component)) (defgeneric* (perform) (operation component)) (define-convenience-action-methods perform (operation component)) (defmethod perform :before ((o operation) (c component)) (ensure-all-directories-exist (output-files o c))) (defmethod perform :after ((o operation) (c component)) (mark-operation-done o c)) (defmethod perform ((o operation) (c parent-component)) (declare (ignorable o c)) nil) (defmethod perform ((o operation) (c source-file)) (sysdef-error (compatfmt "~@") (class-of o) (class-of c))) (defmethod perform-with-restarts (operation component) ;; TOO verbose, especially as the default. Add your own :before method ;; to perform-with-restart or perform if you want that: #|(explain operation component)|# (perform operation component)) (defmethod perform-with-restarts :around (operation component) (loop (restart-case (return (call-next-method)) (retry () :report (lambda (s) (format s (compatfmt "~@") (action-description operation component)))) (accept () :report (lambda (s) (format s (compatfmt "~@") (action-description operation component))) (mark-operation-done operation component) (return)))))) ;;; Generic build operation (with-upgradability () (defmethod component-depends-on ((o build-op) (c component)) `((,(or (component-build-operation c) 'load-op) ,c)))) cl-asdf-3.0.3/asdf.asd000066400000000000000000000075731223164443400144530ustar00rootroot00000000000000;;; -*- mode: lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software available under an MIT-style license. ;;; ;;; ;;; ;;; Copyright (c) 2001-2013 Daniel Barlow and contributors ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :asdf) #+asdf3 (defsystem :asdf/header ;; Note that it's polite to sort the defsystem forms in dependency order, ;; and compulsory to sort them in defsystem-depends-on order. :version (:read-file-form "version.lisp-expr") :around-compile call-without-redefinition-warnings ;; we need be the same as uiop :encoding :utf-8 :components ((:file "header"))) #+asdf3 (defsystem :asdf/driver :depends-on (:uiop)) #+asdf3 (defsystem :asdf/defsystem :licence "MIT" :description "The defsystem part of ASDF" :long-name "Another System Definition Facility" :description "The portable defsystem for Common Lisp" :long-description "ASDF/DEFSYSTEM is the de facto standard DEFSYSTEM facility for Common Lisp, a successor to Dan Barlow's ASDF and Francois-Rene Rideau's ASDF2. For bootstrap purposes, it comes bundled with UIOP in a single file, asdf.lisp." :homepage "http://common-lisp.net/projects/asdf/" :bug-tracker "https://launchpad.net/asdf/" :mailto "asdf-devel@common-lisp.net" :source-control (:git "git://common-lisp.net/projects/asdf/asdf.git") :version (:read-file-form "version.lisp-expr") :build-operation monolithic-concatenate-source-op :build-pathname "build/asdf" ;; our target :around-compile call-without-redefinition-warnings ;; we need be the same as asdf-driver :depends-on (:asdf/header :asdf/driver) :encoding :utf-8 :components ((:file "upgrade") (:file "component" :depends-on ("upgrade")) (:file "system" :depends-on ("component")) (:file "cache" :depends-on ("upgrade")) (:file "find-system" :depends-on ("system" "cache")) (:file "find-component" :depends-on ("find-system")) (:file "operation" :depends-on ("upgrade")) (:file "action" :depends-on ("find-component" "operation" "cache")) (:file "lisp-action" :depends-on ("action")) (:file "plan" :depends-on ("lisp-action" "cache")) (:file "operate" :depends-on ("plan")) (:file "output-translations" :depends-on ("operate")) (:file "source-registry" :depends-on ("find-system")) (:file "backward-internals" :depends-on ("lisp-action" "operate")) (:file "defsystem" :depends-on ("backward-internals" "cache")) (:file "bundle" :depends-on ("lisp-action")) (:file "concatenate-source" :depends-on ("bundle")) (:file "backward-interface" :depends-on ("operate" "output-translations")) (:file "interface" :depends-on ("defsystem" "concatenate-source" "backward-interface" "backward-internals" "output-translations" "source-registry")) (:file "user" :depends-on ("interface")) (:file "footer" :depends-on ("user")))) (defsystem :asdf :author ("Daniel Barlow") :maintainer ("Francois-Rene Rideau") :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." :version "3.0.3" ;; to be automatically updated by make bump-version :depends-on () #+asdf3 :encoding #+asdf3 :utf-8 ;; For most purposes, asdf itself specially counts as a builtin system. ;; If you want to link it or do something forbidden to builtin systems, ;; specify separate dependencies on UIOP (aka asdf-driver) and asdf/defsystem. #+asdf3 :builtin-system-p #+asdf3 t :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf3 (prepare-op (monolithic-concatenate-source-op :asdf/defsystem)))) cl-asdf-3.0.3/backward-interface.lisp000066400000000000000000000204721223164443400174430ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces (asdf/package:define-package :asdf/backward-interface (:recycle :asdf/backward-interface :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations) (:export #:*asdf-verbose* #:operation-error #:compile-error #:compile-failed #:compile-warned #:error-component #:error-operation #:traverse #:component-load-dependencies #:enable-asdf-binary-locations-compatibility #:operation-forced #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings #:component-property #:run-shell-command #:system-definition-pathname)) (in-package :asdf/backward-interface) (with-upgradability () (define-condition operation-error (error) ;; Bad, backward-compatible name ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") (type-of c) (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defun component-load-dependencies (component) ;; Old deprecated name for the same thing. Please update your software. (component-sideway-dependencies component)) (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) (defgeneric operation-on-warnings (operation)) (defgeneric operation-on-failure (operation)) #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation)) #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation)) (defmethod operation-on-warnings ((o operation)) (declare (ignorable o)) *compile-file-warnings-behaviour*) (defmethod operation-on-failure ((o operation)) (declare (ignorable o)) *compile-file-failure-behaviour*) (defmethod (setf operation-on-warnings) (x (o operation)) (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) (defmethod (setf operation-on-failure) (x (o operation)) (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) (defun system-definition-pathname (x) ;; As of 2.014.8, we mean to make this function obsolete, ;; but that won't happen until all clients have been updated. ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. It used to expose ASDF internals with subtle differences with respect to user expectations, that have been refactored away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a mostly compatible replacement that we're supporting, or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME if that's whay you mean." ;;) (system-source-file x)) (defgeneric* (traverse) (operation component &key &allow-other-keys) (:documentation "Generate and return a plan for performing OPERATION on COMPONENT. The plan returned is a list of dotted-pairs. Each pair is the CONS of ASDF operation object and a COMPONENT object. The pairs will be processed in order by OPERATE.")) (define-convenience-action-methods traverse (operation component &key)) (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) (plan-actions (apply 'make-plan plan-class o c keys)))) ;;;; ASDF-Binary-Locations compatibility ;; This remains supported for legacy user, but not recommended for new users. (with-upgradability () (defun enable-asdf-binary-locations-compatibility (&key (centralize-lisp-binaries nil) (default-toplevel-directory (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (include-per-user-information nil) (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) (source-to-target-mappings nil) (file-types `(,(compile-file-type) "build-report" #+ecl (compile-file-type :type :object) #+mkcl (compile-file-type :fasl-p nil) #+clisp "lib" #+sbcl "cfasl" #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) #+(or clisp ecl mkcl) (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) (let* ((patterns (if map-all-source-files (list *wild-file*) (loop :for type :in file-types :collect (make-pathname :type type :defaults *wild-file*)))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory ,@(when include-per-user-information (cdr (pathname-directory (user-homedir-pathname)))) :implementation ,*wild-inferiors*) `(:root ,*wild-inferiors* :implementation)))) (initialize-output-translations `(:output-translations ,@source-to-target-mappings #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) ,@(loop :for pattern :in patterns :collect `((:root ,*wild-inferiors* ,pattern) (,@destination-directory ,pattern))) (t t) :ignore-inherited-configuration)))) (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) (declare (ignorable operation-class system args)) (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. In case you insist on preserving your previous A-B-L configuration, but do not know how to achieve the same effect with A-O-T, you may use function ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; call that function where you would otherwise have loaded and configured A-B-L.")))) ;;; run-shell-command ;; WARNING! The function below is not just deprecated but also dysfunctional. ;; Please use asdf/run-program:run-program instead. (with-upgradability () (defun run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and synchronously execute the result using a Bourne-compatible shell, with output to *VERBOSE-OUT*. Returns the shell's exit code. PLEASE DO NOT USE. Deprecated function, for backward-compatibility only. Please use UIOP:RUN-PROGRAM instead." (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command) (let ((exit-code (ignore-errors (nth-value 2 (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))) (typecase exit-code ((integer 0 255) exit-code) (t 255)))))) (with-upgradability () (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. ;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. (with-upgradability () (defgeneric component-property (component property)) (defgeneric (setf component-property) (new-value component property)) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a (setf (cdr a) new-value) (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties))))) new-value)) cl-asdf-3.0.3/backward-internals.lisp000066400000000000000000000077321223164443400175060ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;; Internal hacks for backward-compatibility (asdf/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/component :asdf/operation :asdf/find-system :asdf/action :asdf/lisp-action) (:export ;; for internal use #:load-sysdef #:make-temporary-package #:%refresh-component-inline-methods #:%resolve-if-component-dep-fails #:make-sub-operation #:load-sysdef #:make-temporary-package)) (in-package :asdf/backward-internals) ;;;; Backward compatibility with "inline methods" (with-upgradability () (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) (defun %remove-component-inline-methods (component) (dolist (name +asdf-methods+) (map () ;; this is inefficient as most of the stored ;; methods will not be for this particular gf ;; But this is hardly performance-critical #'(lambda (m) (remove-method (symbol-function name) m)) (component-inline-methods component))) (component-inline-methods component) nil) (defun %define-component-inline-methods (ret rest) (loop* :for (key value) :on rest :by #'cddr :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) :when name :do (destructuring-bind (op &rest body) value (loop :for arg = (pop body) :while (atom arg) :collect arg :into qualifiers :finally (destructuring-bind (o c) arg (pushnew (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body)) (component-inline-methods ret))))))) (defun %refresh-component-inline-methods (component rest) ;; clear methods, then add the new ones (%remove-component-inline-methods component) (%define-component-inline-methods component rest))) ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute ;; and the companion asdf:feature pseudo-dependency. ;; This won't recurse into dependencies to accumulate feature conditions. ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL ;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. (with-upgradability () (defun %resolve-if-component-dep-fails (if-component-dep-fails component) (asdf-message "The system definition for ~S uses deprecated ~ ASDF option :IF-COMPONENT-DEP-DAILS. ~ Starting with ASDF 3, please use :IF-FEATURE instead" (coerce-name (component-system component))) ;; This only supports the pattern of use of the "feature" seen in the wild (check-type component parent-component) (check-type if-component-dep-fails (member :fail :ignore :try-next)) (unless (eq if-component-dep-fails :fail) (loop :with o = (make-operation 'compile-op) :for c :in (component-children component) :do (loop* :for (feature? feature) :in (component-depends-on o c) :when (eq feature? 'feature) :do (setf (component-if-feature c) feature)))))) (when-upgrading (:when (fboundp 'make-sub-operation)) (defun make-sub-operation (c o dep-c dep-o) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) ;;;; load-sysdef (with-upgradability () (defun load-sysdef (name pathname) (load-asd pathname :name name)) (defun make-temporary-package () ;; For loading a .asd file, we dont't make a temporary package anymore, ;; but use ASDF-USER. I'd like to have this function do this, ;; but since whoever uses it is likely to delete-package the result afterwards, ;; this would be a bad idea, so preserve the old behavior. (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) cl-asdf-3.0.3/bin/000077500000000000000000000000001223164443400136015ustar00rootroot00000000000000cl-asdf-3.0.3/bin/asdf-builder000077500000000000000000000266501223164443400161010ustar00rootroot00000000000000":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*- ;;;;; Really runs on any decent Common Lisp implementation (setf *load-verbose* nil *load-print* nil *compile-verbose* nil *compile-print* nil) (format t "Loading your implementation's ASDF... ~%") (ignore-errors (funcall 'require :asdf)) (format t "~:[No ~;~]ASDF~:*~@[ ~A~] was provided~%" (when (find-package :asdf) (or (symbol-value (or (find-symbol (string :*asdf-version*) :asdf) (find-symbol (string :*asdf-revision*) :asdf))) (string :1.x)))) #-asdf2 (load (merge-pathnames "../build/asdf.lisp" *load-pathname*)) #-asdf2 (error "Not ASDF2, you lose!") (in-package :asdf) (defparameter *provided-version* (asdf-version)) (format t "Initializing the source registry... ~%") (initialize-source-registry) (format t "Upgrading to the latest ASDF... ~%") (load-system :asdf) (let ((ver (asdf-version))) (if (equal ver *provided-version*) (format t "Congratulations to your implementation for being up to date!~%") (format t "Upgraded to ASDF ~A~%" ver))) (format t "Now loading some dependencies... ~%") (load-systems :cl-ppcre :fare-utils :inferior-shell) (format t "There we are!~%") (restore-image) (defpackage :asdf-builder (:use :cl :uiop :asdf/operate :asdf :fare-utils :inferior-shell)) (in-package :asdf-builder) (uiop-debug) (defun build-asdf () "Make sure asdf.lisp is built" (load-system :asdf) (values)) ;;; ASDF directory (defvar *asdf-dir* (ensure-pathname (system-relative-pathname :asdf ()) :want-physical t :want-absolute t :want-existing t :truename t)) (defparameter /asdf-dir/ (native-namestring *asdf-dir*)) (defun apath (x &rest keys) (apply 'subpathname *asdf-dir* x keys)) ;;; UIOP directory (defvar *uiop-dir* (subpathname *asdf-dir* "uiop/")) (defparameter /uiop-dir/ (native-namestring *uiop-dir*)) (defun upath (x &rest keys) (apply 'subpathname *uiop-dir* x keys)) ;;; build directory (defparameter *build-dir* (ensure-pathname "build/" :defaults *asdf-dir* :want-relative t :ensure-absolute t :ensure-subpath t)) (defparameter /build-dir/ (native-namestring *build-dir*)) (defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys)) (defparameter *version* (safe-read-file-form (subpathname *asdf-dir* "version.lisp-expr"))) (defun enough-namestring! (base pathname) (let ((e (enough-namestring base pathname))) (assert (relative-pathname-p e)) e)) (defun enough-namestrings (base pathnames) (loop :with b = (ensure-pathname base :want-absolute t :want-directory t) :for p :in pathnames :collect (enough-namestring! p b))) (defun system-source-files (system) (let* ((sys (find-system system)) (dir (ensure-pathname (system-source-directory sys) :want-absolute t :want-directory t)) (components (asdf::required-components sys :other-systems nil :goal-operation 'load-op :keep-operation 'load-op :keep-component 'file-component)) (pathnames (mapcar 'component-pathname components))) (enough-namestrings dir pathnames))) (defun tarname (name) (strcat name ".tar.gz")) (defun make-tarball-under-build (name base files) (check-type name string) (ensure-pathname base :want-absolute t :want-existing t :want-directory t) (dolist (f files) (check-type f string)) (let* ((/base/ (native-namestring (ensure-pathname base :want-absolute t :want-directory t :want-existing t :truename t))) (destination (ensure-pathname name :defaults *build-dir* :want-relative t :ensure-absolute t :ensure-subpath t :ensure-directory t)) (/destination/ (native-namestring destination)) (/tarball/ (native-namestring (ensure-pathname (tarname name) :defaults *build-dir* :want-relative t :ensure-absolute t :ensure-subpath t :want-file t :ensure-directories-exist t))) (/files/ (mapcar 'native-namestring files))) (assert (< 6 (length (pathname-directory destination)))) (when (probe-file* destination) (error "Destination ~S already exists, not taking chances - you can delete it yourself." destination)) (ensure-directories-exist destination) (run (format nil "cd ~S && cp -pHux --parents ~{~S ~} ~S" /base/ /files/ /destination/) :show t) (run (format nil "tar zcfC ~S ~S ~S/" /tarball/ /build-dir/ name) :show t) (delete-directory-tree destination :validate (lambda (x) (equal (native-namestring x) /destination/))) (values))) (defun driver-files () (list* "README" "uiop.asd" "asdf-driver.asd" (system-source-files :uiop))) (defun driver-name () (format nil "uiop-~A" *version*)) (defun make-driver-tarball () (make-tarball-under-build (driver-name) *uiop-dir* (driver-files))) (defun asdf-defsystem-files () (list* "asdf.asd" "build/asdf.lisp" "version.lisp-expr" "header.lisp" (system-source-files :asdf/defsystem))) (defun asdf-defsystem-name () (format nil "asdf-defsystem-~A" *version*)) (defun make-asdf-defsystem-tarball () (build-asdf) (make-tarball-under-build (asdf-defsystem-name) *asdf-dir* (asdf-defsystem-files))) (defun asdf-git-name () (format nil "asdf-~A" *version*)) (defun make-git-tarball () (build-asdf) (run (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)" /asdf-dir/ (asdf-git-name)) :show t) (values)) (defun asdf-lisp-name () (format nil "asdf-~A.lisp" *version*)) (defun make-asdf-lisp () (build-asdf) (concatenate-files (list (apath "build/asdf.lisp")) (bpath (asdf-lisp-name)))) (defun make-archive () (make-driver-tarball) (make-asdf-defsystem-tarball) (make-git-tarball) (make-asdf-lisp) (values)) (defvar *clnet* "common-lisp.net") (defvar *clnet-asdf-public* "/project/asdf/public_html/") (defun publish-archive () (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name))))) (run (format nil "cd ~S && rsync ~{~S ~}~S common-lisp.net:/project/asdf/public_html/archives/" /build-dir/ tarballs (asdf-lisp-name)) :show t)) (format t "~&To download the tarballs, point your browser at:~% http://common-lisp.net/project/asdf/archives/ ~%") (values)) (defun link-archive () (run (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S" (tarname (driver-name)) (strcat *clnet-asdf-public* "archives/uiop.tar.gz") (tarname (asdf-defsystem-name)) (strcat *clnet-asdf-public* "archives/asdf-defsystem.tar.gz") (tarname (asdf-git-name)) (strcat *clnet-asdf-public* "archives/asdf.tar.gz") (asdf-lisp-name) (strcat *clnet-asdf-public* "archives/asdf.lisp")) :show t :host *clnet*) (values)) (defun make-and-publish-archive () (make-archive) (publish-archive) (link-archive)) (defparameter *versioned-files* '(("version.lisp-expr" "\"" "\"") ("asdf.asd" " :version \"" "\" ;; to be automatically updated by make bump-version") ("header.lisp" "This is ASDF " ": Another System Definition Facility.") ("upgrade.lisp" " (asdf-version \"" "\")"))) (defparameter *version-file* (apath "version.lisp-expr")) (defparameter *old-version* nil) (defparameter *new-version* nil) (defun next-version (v) (let ((pv (parse-version v 'error))) (assert (first pv)) (assert (second pv)) (unless (third pv) (appendf pv (list 0))) (unless (fourth pv) (appendf pv (list 0))) (incf (car (last pv))) (unparse-version pv))) (defun version-from-file () (safe-read-file-form *version-file*)) (defun versions-from-args (&optional v1 v2) (labels ((check (old new) (parse-version old 'error) (parse-version new 'error) (values old new))) (cond ((and v1 v2) (check v1 v2)) (v1 (check (version-from-file) v1)) (t (let ((old (version-from-file))) (check old (next-version old))))))) (deftype byte-vector () '(array (unsigned-byte 8) (*))) (defun maybe-replace-file (file transformer &key (reader 'read-file-string) (writer nil) (comparator 'equalp) (external-format *utf-8-external-format*)) (format t "Transforming file ~A... " (file-namestring file)) (let* ((old-contents (funcall reader file)) (new-contents (funcall transformer old-contents))) (if (funcall comparator old-contents new-contents) (format t "no changes needed!~%") (let ((written-contents (if writer (with-output (s ()) (funcall writer s new-contents)) new-contents))) (check-type written-contents (or string (byte-vector))) (clobber-file-with-vector file written-contents :external-format external-format) (format t "done.~%"))))) (defun version-transformer (new-version file prefix suffix &optional dont-warn) (let* ((qprefix (cl-ppcre:quote-meta-chars prefix)) (versionrx "([0-9]+(\\.[0-9]+)+)") (qsuffix (cl-ppcre:quote-meta-chars suffix)) (regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")")) (replacement (constantly (strcat prefix new-version suffix)))) (lambda (text) (multiple-value-bind (new-text foundp) (cl-ppcre:regex-replace regex text replacement) (unless (or foundp dont-warn) (warn "Missing version in ~A" (file-namestring file))) (values new-text foundp))))) (defun transform-file (new-version file prefix suffix) (maybe-replace-file (apath file) (version-transformer new-version file prefix suffix))) (defun transform-files (new-version) (loop :for f :in *versioned-files* :do (apply 'transform-file new-version f))) (defun test-transform-file (new-version file prefix suffix) (let ((lines (read-file-lines (apath file)))) (dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil)) (multiple-value-bind (new-text foundp) (funcall (version-transformer new-version file prefix suffix t) l) (when foundp (format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%" l new-text) (return t)))))) (defun test-transform (new-version) (apply 'test-transform-file new-version (first *versioned-files*))) (defun bump-version (&optional v1 v2) (multiple-value-bind (old-version new-version) (versions-from-args v1 v2) (a "Bumping ASDF version from " old-version " to " new-version) (transform-files new-version) (a "Rebuilding ASDF with bumped version") (build-asdf))) (defun git-version () (first (run '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines :show t))) ;;;; Main entry point (defun main (args) (block nil (unless args (format t "No command provided~%") (return)) (if-let (sym (find-symbol* (string-upcase (first args)) :asdf-builder nil)) (let ((results (multiple-value-list (apply sym (rest args))))) (when results (format t "~&Results:~%~{ ~S~%~}" results))) (format t "Command ~A not found~%" (first args))))) (main *command-line-arguments*) cl-asdf-3.0.3/build.xcvb000066400000000000000000000004351223164443400150160ustar00rootroot00000000000000#+xcvb (module (:fullname "/asdf" :author ("Daniel Barlow and contributors") :licence "MIT" ;; MIT-style license. See asdf.lisp :description "ASDF" :long-description "Another System Definition Facility." :depends-on ("asdf") :supersedes-asdf ("asdf") :build-image nil)) cl-asdf-3.0.3/bundle.lisp000066400000000000000000000525041223164443400152010ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; ASDF-Bundle (asdf/package:define-package :asdf/bundle (:recycle :asdf/bundle :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) (:export #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:lib-op #:monolithic-lib-op #:dll-op #:monolithic-dll-op #:binary-op #:monolithic-binary-op #:program-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p #+ecl #:make-build #:register-pre-built-system #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (with-upgradability () (defclass bundle-op (operation) ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) (defclass bundle-compile-op (bundle-op basic-compile-op) () (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) ;; create a single fasl for the entire library (defclass basic-fasl-op (bundle-compile-op) ((bundle-type :initform :fasl))) (defclass prepare-fasl-op (sideway-operation) ((sideway-operation :initform 'load-fasl-op))) (defclass fasl-op (basic-fasl-op selfward-operation) ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op)))) (defclass load-fasl-op (basic-load-op selfward-operation) ((selfward-operation :initform '(prepare-op fasl-op)))) ;; NB: since the monolithic-op's can't be sideway-operation's, ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's, ;; we'd have to have the monolithic-op not inherit from the main op, ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above. (defclass no-ld-flags-op (operation) ()) (defclass lib-op (bundle-compile-op no-ld-flags-op) ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it." #-(or ecl mkcl) "just compile the system")) (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op) ((bundle-type :initform :dll)) (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) (defclass binary-op (basic-compile-op selfward-operation) ((selfward-operation :initform '(fasl-op lib-op))) (:documentation "produce fasl and asd files for the system")) (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies (defclass monolithic-bundle-op (monolithic-op bundle-op) ((prologue-code :accessor monolithic-op-prologue-code) (epilogue-code :accessor monolithic-op-epilogue-code))) (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op) () (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems")) (defclass monolithic-binary-op (monolithic-op binary-op) ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))) (:documentation "produce fasl and asd files for combined system and dependencies.")) (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op no-ld-flags-op) ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies." #-(or ecl mkcl) "Compile a system and its dependencies.")) (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op) ((bundle-type :initform :dll)) (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op) #-(or mkcl ecl) (monolithic-bundle-op selfward-operation) ((bundle-type :initform :program) #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op)) (:documentation "create an executable file from the system and its dependencies")) (defun bundle-pathname-type (bundle-type) (etypecase bundle-type ((eql :no-output-file) nil) ;; should we error out instead? ((or null string) bundle-type) ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") #+ecl ((member :binary :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) ((eql :binary) "image") ((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) (defun bundle-output-files (o c) (when (input-files o c) (let ((bundle-type (bundle-type o))) (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. (let ((name (or (component-build-pathname c) (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) (type (bundle-pathname-type bundle-type))) (values (list (subpathname (component-pathname c) name :type type)) (eq (type-of o) (component-build-operation c)))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) #-(or ecl mkcl) (defmethod perform ((o program-op) (c system)) (let ((output-file (output-file o c))) (setf *image-entry-point* (ensure-function (component-entry-point c))) (dump-image output-file :executable t))) (defclass compiled-file (file-component) ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) (defclass precompiled-system (system) ((build-pathname :initarg :fasl))) (defclass prebuilt-system (system) ((build-pathname :initarg :static-library :initarg :lib :accessor prebuilt-system-static-library)))) ;;; ;;; BUNDLE-OP ;;; ;;; This operation takes all components from one or more systems and ;;; creates a single output file, which may be ;;; a FASL, a statically linked library, a shared library, etc. ;;; The different targets are defined by specialization. ;;; (with-upgradability () (defun operation-monolithic-p (op) (typep op 'monolithic-op)) (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key (name-suffix nil name-suffix-p) &allow-other-keys) (declare (ignorable initargs name-suffix)) (unless name-suffix-p (setf (slot-value instance 'name-suffix) (unless (typep instance 'program-op) (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames (when (typep instance 'monolithic-bundle-op) (destructuring-bind (&rest original-initargs &key lisp-files prologue-code epilogue-code &allow-other-keys) (operation-original-initargs instance) (setf (operation-original-initargs instance) (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) (monolithic-op-prologue-code instance) prologue-code (monolithic-op-epilogue-code instance) epilogue-code) #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) (setf (bundle-op-build-args instance) (remove-plist-keys '(:type :monolithic :name-suffix) (operation-original-initargs instance)))) (defmethod bundle-op-build-args :around ((o no-ld-flags-op)) (declare (ignorable o)) (let ((args (call-next-method))) (remf args :ld-flags) args)) (defun bundlable-file-p (pathname) (let ((type (pathname-type pathname))) (declare (ignorable type)) (or #+ecl (or (equalp type (compile-file-type :type :object)) (equalp type (compile-file-type :type :static-library))) #+mkcl (equalp type (compile-file-type :fasl-p nil)) #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) (defgeneric* (trivial-system-p) (component)) (defun user-system-p (s) (and (typep s 'system) (not (builtin-system-p s)) (not (trivial-system-p s))))) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype user-system () '(and system (satisfies user-system-p)))) ;;; ;;; First we handle monolithic bundles. ;;; These are standalone systems which contain everything, ;;; including other ASDF systems required by the current one. ;;; A PROGRAM is always monolithic. ;;; ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () (defmethod component-depends-on ((o bundle-compile-op) (c system)) `(,(if (operation-monolithic-p o) `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op ,@(required-components c :other-systems t :component-type 'system :goal-operation (find-operation o 'load-op) :keep-operation 'compile-op)) `(compile-op ,@(required-components c :other-systems nil :component-type '(not system) :goal-operation (find-operation o 'load-op) :keep-operation 'compile-op))) ,@(call-next-method))) (defmethod component-depends-on :around ((o bundle-op) (c component)) (declare (ignorable o c)) (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) `((,op ,c)) (call-next-method))) (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) ;; This file selects output files from direct dependencies; ;; your component-depends-on method better gathered the correct dependencies in the correct order. (while-collecting (collect) (map-direct-dependencies o c #'(lambda (sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c) :when (funcall test f) :do (collect f)))))) (defmethod input-files ((o bundle-compile-op) (c system)) (unless (eq (bundle-type o) :no-output-file) (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) (defun select-bundle-operation (type &optional monolithic) (ecase type ((:binary) (if monolithic 'monolithic-binary-op 'binary-op)) ((:dll :shared-library) (if monolithic 'monolithic-dll-op 'dll-op)) ((:lib :static-library) (if monolithic 'monolithic-lib-op 'lib-op)) ((:fasl) (if monolithic 'monolithic-fasl-op 'fasl-op)) ((:program) 'program-op))) (defun make-build (system &rest args &key (monolithic nil) (type :fasl) (move-here nil move-here-p) &allow-other-keys) (let* ((operation-name (select-bundle-operation type monolithic)) (move-here-path (if (and move-here (typep move-here '(or pathname string))) (pathname move-here) (system-relative-pathname system "asdf-output/"))) (operation (apply #'operate operation-name system (remove-plist-keys '(:monolithic :type :move-here) args))) (system (find-system system)) (files (and system (output-files operation system)))) (if (or move-here (and (null move-here-p) (member operation-name '(:program :binary)))) (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) :for f :in files :for new-f = (make-pathname :name (pathname-name f) :type (pathname-type f) :defaults dest-path) :do (rename-file-overwriting-target f new-f) :collect new-f) files)))) ;;; ;;; LOAD-FASL-OP ;;; ;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. ;;; (with-upgradability () (defmethod component-depends-on ((o load-fasl-op) (c system)) (declare (ignorable o)) `((,o ,@(loop :for dep :in (component-sideway-dependencies c) :collect (resolve-dependency-spec c dep))) (,(if (user-system-p c) 'fasl-op 'load-op) ,c) ,@(call-next-method))) (defmethod input-files ((o load-fasl-op) (c system)) (when (user-system-p c) (output-files (find-operation o 'fasl-op) c))) (defmethod perform ((o load-fasl-op) c) (declare (ignorable o c)) nil) (defmethod perform ((o load-fasl-op) (c system)) (when (input-files o c) (perform-lisp-load-fasl o c))) (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) (mark-operation-done (find-operation o 'load-op) c))) ;;; ;;; PRECOMPILED FILES ;;; ;;; This component can be used to distribute ASDF systems in precompiled form. ;;; Only useful when the dependencies have also been precompiled. ;;; (with-upgradability () (defmethod trivial-system-p ((s system)) (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) (defmethod output-files (o (c compiled-file)) (declare (ignorable o c)) nil) (defmethod input-files (o (c compiled-file)) (declare (ignorable o)) (component-pathname c)) (defmethod perform ((o load-op) (c compiled-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-source-op) (c compiled-file)) (perform (find-operation o 'load-op) c)) (defmethod perform ((o load-fasl-op) (c compiled-file)) (perform (find-operation o 'load-op) c)) (defmethod perform ((o operation) (c compiled-file)) (declare (ignorable o c)) nil)) ;;; ;;; Pre-built systems ;;; (with-upgradability () (defmethod trivial-system-p ((s prebuilt-system)) (declare (ignorable s)) t) (defmethod perform ((o lib-op) (c prebuilt-system)) (declare (ignorable o c)) nil) (defmethod component-depends-on ((o lib-op) (c prebuilt-system)) (declare (ignorable o c)) nil) (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) (declare (ignorable o)) nil)) ;;; ;;; PREBUILT SYSTEM CREATOR ;;; (with-upgradability () (defmethod output-files ((o binary-op) (s system)) (list (make-pathname :name (component-name s) :type "asd" :defaults (component-pathname s)))) (defmethod perform ((o binary-op) (s system)) (let* ((inputs (input-files o s)) (fasl (first inputs)) (library (second inputs)) (asd (first (output-files o s))) (name (if (and fasl asd) (pathname-name asd) (return-from perform))) (dependencies (if (operation-monolithic-p o) (remove-if-not 'builtin-system-p (required-components s :component-type 'system :keep-operation 'load-op)) (while-collecting (x) ;; resolve the sideway-dependencies of s (map-direct-dependencies 'load-op s #'(lambda (o c) (when (and (typep o 'load-op) (typep c 'system)) (x c))))))) (depends-on (mapcar 'coerce-name dependencies))) (when (pathname-equal asd (system-source-file s)) (cerror "overwrite the asd file" "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations." (cons o s) asd)) (with-open-file (s asd :direction :output :if-exists :supersede :if-does-not-exist :create) (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" (operation-monolithic-p o) name) (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" (lisp-implementation-type) (lisp-implementation-version) (software-type) (machine-type) (software-version)) (let ((*package* (find-package :asdf-user))) (pprint `(defsystem ,name :class prebuilt-system :depends-on ,depends-on :components ((:compiled-file ,(pathname-name fasl))) ,@(when library `(:lib ,(file-namestring library)))) s) (terpri s))))) #-(or ecl mkcl) (defmethod perform ((o bundle-compile-op) (c system)) (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) (output-files (output-files o c)) (output-file (first output-files))) (assert (eq (not input-files) (not output-files))) (when input-files (when non-fasl-files (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" (implementation-type) non-fasl-files)) (when (and (typep o 'monolithic-bundle-op) (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) (error "prologue-code and epilogue-code are not supported on ~A" (implementation-type))) (with-staging-pathname (output-file) (combine-fasls fasl-files output-file))))) (defmethod input-files ((o load-op) (s precompiled-system)) (declare (ignorable o)) (bundle-output-files (find-operation o 'fasl-op) s)) (defmethod perform ((o load-op) (s precompiled-system)) (perform-lisp-load-fasl o s)) (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) (declare (ignorable o)) `((load-op ,s) ,@(call-next-method)))) #| ;; Example use: (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) (asdf:load-system :precompiled-asdf-utils) |# #+(or ecl mkcl) (with-upgradability () (defun uiop-library-file () (or (and (find-system :uiop nil) (system-source-directory :uiop) (progn (operate 'lib-op :uiop) (output-file 'lib-op :uiop))) (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib)))) (defmethod input-files :around ((o program-op) (c system)) (let ((files (call-next-method)) (plan (traverse-sub-actions o c :plan-class 'sequential-plan))) (unless (or (and (find-system :uiop nil) (system-source-directory :uiop) (plan-operates-on-p plan '("uiop"))) (and (system-source-directory :asdf) (plan-operates-on-p plan '("asdf")))) (pushnew (uiop-library-file) files :test 'pathname-equal)) files)) (defun register-pre-built-system (name) (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) #+ecl (with-upgradability () (defmethod perform ((o bundle-compile-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) (bundle (first output)) (kind (bundle-type o))) (when output (create-image bundle (append object-files (bundle-op-lisp-files o)) :kind kind :entry-point (component-entry-point c) :prologue-code (when (typep o 'monolithic-bundle-op) (monolithic-op-prologue-code o)) :epilogue-code (when (typep o 'monolithic-bundle-op) (monolithic-op-epilogue-code o)) :build-args (bundle-op-build-args o)))))) #+mkcl (with-upgradability () (defmethod perform ((o lib-op) (s system)) (apply #'compiler::build-static-library (output-file o c) :lisp-object-files (input-files o s) (bundle-op-build-args o))) (defmethod perform ((o basic-fasl-op) (s system)) (apply #'compiler::build-bundle (output-file o c) ;; second??? :lisp-object-files (input-files o s) (bundle-op-build-args o))) (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) (declare (ignore force verbose version)) (apply #'operate 'binary-op system args))) cl-asdf-3.0.3/cache.lisp000066400000000000000000000046471223164443400150000ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Stamp cache (asdf/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) (in-package :asdf/cache) ;;; This stamp cache is useful for: ;; * consistency of stamps used within a single run ;; * fewer accesses to the filesystem ;; * the ability to test with fake timestamps, without touching files (with-upgradability () (defvar *asdf-cache* nil) (defun set-asdf-cache-entry (key value-list) (apply 'values (if *asdf-cache* (setf (gethash key *asdf-cache*) value-list) value-list))) (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) (if foundp (apply 'values results) (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) (call-function thunk))) (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () ,@body))) (defun call-with-asdf-cache (thunk &key override) (if (and *asdf-cache* (not override)) (funcall thunk) (let ((*asdf-cache* (make-hash-table :test 'equal))) (funcall thunk)))) (defmacro with-asdf-cache ((&key override) &body body) `(call-with-asdf-cache #'(lambda () ,@body) :override ,override)) (defun normalize-namestring (pathname) (let ((resolved (resolve-symlinks* (ensure-absolute-pathname (physicalize-pathname pathname) 'get-pathname-defaults)))) (with-pathname-defaults () (namestring resolved)))) (defun compute-file-stamp (normalized-namestring) (with-pathname-defaults () (safe-file-write-date normalized-namestring))) (defun register-file-stamp (file &optional (stamp nil stampp)) (let* ((namestring (normalize-namestring file)) (stamp (if stampp stamp (compute-file-stamp namestring)))) (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) (defun get-file-stamp (file) (let ((namestring (normalize-namestring file))) (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) cl-asdf-3.0.3/component.lisp000066400000000000000000000347531223164443400157400ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Components (asdf/package:define-package :asdf/component (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:component #:component-find-path #:component-name #:component-pathname #:component-relative-pathname #:component-parent #:component-system #:component-parent-pathname #:child-component #:parent-component #:module #:file-component #:source-file #:c-source-file #:java-source-file #:static-file #:doc-file #:html-file #:file-type #:source-file-type #:source-file-explicit-type ;; backward-compatibility #:component-in-order-to #:component-sideway-dependencies #:component-if-feature #:around-compile-hook #:component-description #:component-long-description #:component-version #:version-satisfies #:component-inline-methods ;; backward-compatibility only. DO NOT USE! #:component-operation-times ;; For internal use only. ;; portable ASDF encoding and implementation-specific external-format #:component-external-format #:component-encoding #:component-children-by-name #:component-children #:compute-children-by-name #:component-build-operation #:module-default-component-class #:module-components ;; backward-compatibility. DO NOT USE. #:sub-components ;; conditions #:system-definition-error ;; top level, moved here because this is the earliest place for it. #:duplicate-names ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes #:name #:version #:description #:long-description #:author #:maintainer #:licence #:components-by-name #:components #:children #:children-by-name #:default-component-class #:author #:maintainer #:licence #:source-file #:defsystem-depends-on #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods #:relative-pathname #:absolute-pathname #:operation-times #:around-compile #:%encoding #:properties #:component-properties #:parent)) (in-package :asdf/component) (with-upgradability () (defgeneric component-name (component) (:documentation "Name of the COMPONENT, unique relative to its parent")) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) (defgeneric component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) (defgeneric (component-relative-pathname) (component) (:documentation "Returns a pathname for the component argument intended to be interpreted relative to the pathname of that component's parent. Despite the function's name, the return value may be an absolute pathname, because an absolute pathname may be interpreted relative to another pathname in a degenerate way.")) (defgeneric component-external-format (component)) (defgeneric component-encoding (component)) (defgeneric version-satisfies (component version)) (defgeneric component-version (component)) (defgeneric (setf component-version) (new-version component)) (defgeneric component-parent (component)) (defmethod component-parent ((component null)) (declare (ignorable component)) nil) ;; Backward compatible way of computing the FILE-TYPE of a component. ;; TODO: find users, have them stop using that, remove it for ASDF4. (defgeneric (source-file-type) (component system)) (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function ;; over print-object; this is always conditions::%print-condition for ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) (format s (compatfmt "~@") (duplicate-names-name c)))))) (when-upgrading (:when (find-class 'component nil)) (defmethod reinitialize-instance :after ((c component) &rest initargs &key) (declare (ignorable c initargs)) (values))) (with-upgradability () (defclass component () ((name :accessor component-name :initarg :name :type string :documentation "Component name: designator for a string composed of portable pathname characters") ;; We might want to constrain version with ;; :type (and string (satisfies parse-version)) ;; but we cannot until we fix all systems that don't use it correctly! (version :accessor component-version :initarg :version :initform nil) (description :accessor component-description :initarg :description :initform nil) (long-description :accessor component-long-description :initarg :long-description :initform nil) (sideway-dependencies :accessor component-sideway-dependencies :initform nil) (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) ;; In the ASDF object model, dependencies exist between *actions*, ;; where an action is a pair of an operation and a component. ;; Dependencies are represented as alists of operations ;; to a list where each entry is a pair of an operation and a list of component specifiers. ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) ;; and do-first things that modify the current image (such as loading a fasl). ;; These are now unified because we now correctly propagate timestamps between dependencies. ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017, ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains. ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated. (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES. ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. ;; There is no initform and no direct accessor for this specified pathname, ;; so we only access the information through appropriate methods, after it has been processed. ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4. (relative-pathname :initarg :pathname) ;; The absolute-pathname is computed based on relative-pathname and parent pathname. ;; The slot is but a cache used by component-pathname. (absolute-pathname) (operation-times :initform (make-hash-table) :accessor component-operation-times) (around-compile :initarg :around-compile) ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE! (properties :accessor component-properties :initarg :properties :initform nil) (%encoding :accessor %component-encoding :initform nil :initarg :encoding) ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. (parent :initarg :parent :initform nil :reader component-parent) (build-operation :initarg :build-operation :initform nil :reader component-build-operation))) (defun component-find-path (component) (check-type component (or null component)) (reverse (loop :for c = component :then (component-parent c) :while c :collect (component-name c)))) (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity nil) (format stream "~{~S~^ ~}" (component-find-path c)))) (defmethod component-system ((component component)) (if-let (system (component-parent component)) (component-system system) component))) ;;;; Component hierarchy within a system ;; The tree typically but not necessarily follows the filesystem hierarchy. (with-upgradability () (defclass child-component (component) ()) (defclass file-component (child-component) ((type :accessor file-type :initarg :type))) ; no default (defclass source-file (file-component) ((type :accessor source-file-explicit-type ;; backward-compatibility :initform nil))) ;; NB: many systems have come to rely on this default. (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) ((type :initform "java"))) (defclass static-file (source-file) ((type :initform nil))) (defclass doc-file (static-file) ()) (defclass html-file (doc-file) ((type :initform "html"))) (defclass parent-component (component) ((children :initform nil :initarg :components :reader module-components ; backward-compatibility :accessor component-children) (children-by-name :reader module-components-by-name ; backward-compatibility :accessor component-children-by-name) (default-component-class :initform nil :initarg :default-component-class :accessor module-default-component-class)))) (with-upgradability () (defun compute-children-by-name (parent &key only-if-needed-p) (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) (let ((hash (make-hash-table :test 'equal))) (setf (component-children-by-name parent) hash) (loop :for c :in (component-children parent) :for name = (component-name c) :for previous = (gethash name hash) :do (when previous (error 'duplicate-names :name name)) (setf (gethash name hash) c)) hash)))) (when-upgrading (:when (find-class 'module nil)) (defmethod reinitialize-instance :after ((m module) &rest initargs &key) (declare (ignorable m initargs)) (values)) (defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable m added deleted plist)) (when (and (member 'children added) (member 'components deleted)) (setf (slot-value m 'children) ;; old ECLs provide an alist instead of a plist(!) (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist))) (getf plist 'components))) (compute-children-by-name m)))) (with-upgradability () (defclass module (child-component parent-component) (#+clisp (components)))) ;; backward compatibility during upgrade only ;;;; component pathnames (with-upgradability () (defgeneric* (component-parent-pathname) (component)) (defmethod component-parent-pathname (component) (component-pathname (component-parent component))) (defmethod component-pathname ((component component)) (if (slot-boundp component 'absolute-pathname) (slot-value component 'absolute-pathname) (let ((pathname (merge-pathnames* (component-relative-pathname component) (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error (compatfmt "~@") pathname (component-find-path component))) (setf (slot-value component 'absolute-pathname) pathname) pathname))) (defmethod component-relative-pathname ((component component)) ;; source-file-type is backward-compatibility with ASDF1; ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE. ;; TODO: track who uses it, and have them not use it anymore. (parse-unix-namestring (or (and (slot-boundp component 'relative-pathname) (slot-value component 'relative-pathname)) (component-name component)) :want-relative t :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) (defmethod source-file-type ((component parent-component) system) (declare (ignorable component system)) :directory) (defmethod source-file-type ((component file-component) system) (declare (ignorable system)) (file-type component))) ;;;; Encodings (with-upgradability () (defmethod component-encoding ((c component)) (or (loop :for x = c :then (component-parent x) :while x :thereis (%component-encoding x)) (detect-encoding (component-pathname c)))) (defmethod component-external-format ((c component)) (encoding-external-format (component-encoding c)))) ;;;; around-compile-hook (with-upgradability () (defgeneric around-compile-hook (component)) (defmethod around-compile-hook ((c component)) (cond ((slot-boundp c 'around-compile) (slot-value c 'around-compile)) ((component-parent c) (around-compile-hook (component-parent c)))))) ;;;; version-satisfies (with-upgradability () (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (when version (warn "Requested version ~S but component ~S has no version" version c)) (return-from version-satisfies t)) (version-satisfies (component-version c) version)) (defmethod version-satisfies ((cver string) version) (version<= version cver))) ;;; all sub-components (of a given type) (with-upgradability () (defun sub-components (component &key (type t)) (while-collecting (c) (labels ((recurse (x) (when (if-let (it (component-if-feature x)) (featurep it) t) (when (typep x type) (c x)) (when (typep x 'parent-component) (map () #'recurse (component-children x)))))) (recurse component))))) cl-asdf-3.0.3/concatenate-source.lisp000066400000000000000000000107531223164443400175120ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Concatenate-source (asdf/package:define-package :asdf/concatenate-source (:recycle :asdf/concatenate-source :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/defsystem :asdf/action :asdf/lisp-action :asdf/bundle) (:export #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op #:load-compiled-concatenated-source-op #:monolithic-concatenate-source-op #:monolithic-load-concatenated-source-op #:monolithic-compile-concatenated-source-op #:monolithic-load-compiled-concatenated-source-op)) (in-package :asdf/concatenate-source) ;;; ;;; Concatenate sources ;;; (with-upgradability () (defclass basic-concatenate-source-op (bundle-op) ((bundle-type :initform "lisp"))) (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) (defclass concatenate-source-op (basic-concatenate-source-op) ()) (defclass load-concatenated-source-op (basic-load-concatenated-source-op) ((selfward-operation :initform '(prepare-op concatenate-source-op)))) (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) ((selfward-operation :initform '(prepare-op concatenate-source-op)))) (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) ((selfward-operation :initform '(prepare-op compile-concatenated-source-op)))) (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ()) (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) ((selfward-operation :initform 'monolithic-concatenate-source-op))) (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) ((selfward-operation :initform 'monolithic-concatenate-source-op))) (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) ((selfward-operation :initform 'monolithic-compile-concatenated-source-op))) (defmethod input-files ((operation basic-concatenate-source-op) (s system)) (loop :with encoding = (or (component-encoding s) *default-encoding*) :with other-encodings = '() :with around-compile = (around-compile-hook s) :with other-around-compile = '() :for c :in (required-components s :goal-operation 'compile-op :keep-operation 'compile-op :other-systems (operation-monolithic-p operation)) :append (when (typep c 'cl-source-file) (let ((e (component-encoding c))) (unless (equal e encoding) (let ((a (assoc e other-encodings))) (if a (push (component-find-path c) (cdr a)) (push (list a (component-find-path c)) other-encodings))))) (unless (equal around-compile (around-compile-hook c)) (push (component-find-path c) other-around-compile)) (input-files (make-operation 'compile-op) c)) :into inputs :finally (when other-encodings (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}" operation encoding (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) other-encodings))) (when other-around-compile (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" operation around-compile other-around-compile)) (return inputs))) (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) (lisp-compilation-output-files o s)) (defmethod perform ((o basic-concatenate-source-op) (s system)) (let ((inputs (input-files o s)) (output (output-file o s))) (concatenate-files inputs output))) (defmethod perform ((o basic-load-concatenated-source-op) (s system)) (perform-lisp-load-source o s)) (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) (perform-lisp-compilation o s)) (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) (perform-lisp-load-fasl o s))) cl-asdf-3.0.3/contrib/000077500000000000000000000000001223164443400144715ustar00rootroot00000000000000cl-asdf-3.0.3/contrib/debug.lisp000077700000000000000000000000001223164443400232512../uiop/contrib/debug.lispustar00rootroot00000000000000cl-asdf-3.0.3/contrib/detect-multiply-used-files.lisp000066400000000000000000000021571223164443400225520ustar00rootroot00000000000000(uiop:define-package :detect-multiply-used-files (:use :asdf :uiop :common-lisp) (:export #:find-fishy-components #:register-component-files #:*file-components*)) (in-package :detect-multiply-used-files) (defparameter *file-components* (make-hash-table :test 'equal)) (defun register-component-files (component) (let ((c (find-component () component))) (if-let (p (component-pathname c)) (pushnew (component-find-path c) (gethash (namestring p) *file-components*))) (when (typep c 'parent-component) (dolist (cc (component-children c)) (register-component-files cc))))) (defun table-keys (table) (loop :for s :being :the :hash-keys :of table :collect s)) (defun find-fishy-components () (clrhash *file-components*) (map () 'register-component-files (table-keys asdf::*defined-systems*)) (loop :for p :in (sort (table-keys *file-components*) 'string<) :for l = (gethash p *file-components*) :when (and (file-pathname-p p) (not (length=n-p l 1))) :do (format t "~&~S =>~{ ~S~}~%" p l))) #| ;; Use it like that: (detect-multiply-used-files:find-fishy-components) |# cl-asdf-3.0.3/contrib/wild-modules.lisp000066400000000000000000000025441223164443400177740ustar00rootroot00000000000000(in-package :asdf) (defclass wild-module (module) ((component-class :accessor wild-module-component-class :initform 'static-file :initarg :component-class) (component-options :accessor wild-module-component-options :initform nil :initarg :component-options))) (defmethod (setf component-children) (new-value (module wild-module)) (when new-value (sysdef-error "Cannot explicitly set wild-module ~A's children components. Please ~ use a wild pathname instead." module))) (defmethod reinitialize-instance :after ((self wild-module) &key) (let ((pathname (component-pathname self))) (unless (and pathname (wild-pathname-p pathname)) (sysdef-error "Wild-module ~A specified with non-wild pathname ~A." self pathname)) (setf (slot-value self 'components) (let* ((files (directory pathname)) (class (wild-module-component-class self)) (options (wild-module-component-options self))) (mapcar (lambda (file) (apply #'make-instance class :name (namestring file) :pathname file :parent self options)) files))) (compute-children-by-name self) (values))) (export 'wild-module) cl-asdf-3.0.3/debian/000077500000000000000000000000001223164443400142535ustar00rootroot00000000000000cl-asdf-3.0.3/debian/README.Debian000066400000000000000000000016161223164443400163200ustar00rootroot00000000000000Debian Package cl-asdf ---------------------- This package was originally created for Debian by Kevin M. Rosenberg in Aug 2002. It is now being kept up to date by Francois-Rene Rideau, who also maintains the upstream ASDF project at http://common-lisp.net/project/asdf/ To load ASDF into your Lisp system, you can give the command (load "/usr/share/common-lisp/source/asdf/asdf.lisp") although in many implementations, you can just use (require :asdf) Additionally, there is an optional module that you can load with the command (load "/usr/share/common-lisp/source/asdf/wild-modules.lisp") This package is built from the git repository at git://git.debian.org/git/pkg-common-lisp/cl-asdf.git This repository should be mostly identical to the release branch at git://common-lisp.net/projects/asdf/asdf.git -- Francois-Rene Rideau , Wed, 14 Jul 2010 13:49:26 -0400 cl-asdf-3.0.3/debian/README.building000066400000000000000000000035311223164443400167310ustar00rootroot00000000000000As upstream maintainer, I do all development in master, and sometimes update release. * use git from the upstream repo git clone ssh://common-lisp.net/project/asdf/git/asdf.git * checkout the release branch git checkout release * do dark magic to create a release, merging with master. git merge master * Don't forget to renumber the version, if needed ./bin/bump-version.sh 2.xx * Commit any relevant files, if needed git add ... git add -u git commit * do the releasing: git tag 2.xx ; make archive-copy ; make website ; make push * edit debian files, then: git commit * create debian package: make debian-package * if unsatisfied, edit debian files some more then git commit --amend then goto previous point. If ever debian diverges from upstream, you should adapt accordingly. The below notes are obsolete, but might give you ideas how to do it. ------>8------>8------>8------>8------>8------>8------>8------>8------>8------ NB: old instructions, not currently valid since all debian development currently happens in the upstream git. To build this package you need to get the git repository: git clone git://git.debian.org/git/pkg-common-lisp/cl-asdf.git Get the upstream branch too: cd cl-asdf git checkout -t -b upstream remotes/origin/upstream Then you need to setup the following remotes: git remote add upstream git://common-lisp.net/projects/asdf/asdf.git To update the package from upstream do: git checkout upstream git pull upstream release:upstream git whatchanged #git tag upstream/ # not necessary anymore, now that we use the same as upstream. git checkout master git pull . upstream To build: git-buildpackage -uc -us please check your package with: lintian --verbose --info --display-info --md5sums *.changes Then commit any changes and either send me the diff or push this to somewhere were I can fetch it. cl-asdf-3.0.3/debian/changelog000066400000000000000000001671371223164443400161440ustar00rootroot00000000000000cl-asdf (2:3.0.3-1) unstable; urgency=low New release: * Run-program much improved, with a slight backward incompatibility. See the new documentation about it. * Portability enhanced, with more robust Windows support, plus patches for CCL, CLISP, LispWorks, XCL. * UIOP improved, with a README, more docstrings, a few new functions (println, writeln, stripln, ensure-gethash, vomit-output-stream), and bugfixes (to ensure-function, with-temporary-file, split-string). * Debian installations that don't export XDG_DATA_DIRS will benefit from the fix to split-string, as the bug was basically disabling the default source-registry entry for /usr/share/common-lisp/source// Closes: #723977 * Minor tweaks to the defsystem, mostly to print more information in some situations, less in other situations, but also to better handle systems with secondary names like foo/bar, a fix for user functions in output-translation, and to :version (:read-file-...) * Documentation somewhat updated. -- Francois-Rene Rideau Tue, 22 Oct 2013 22:30:12 -0500 cl-asdf (2:3.0.2.4-1) unstable; urgency=low UIOP:DIRECTORY* fixed to NOT follow symbolic links on LispWorks. Fix handling of :at key in :read-file-form. Fix package issue for system-definition-error (lp #1206173). Some docstring updates. Also documentation updates. -- Francois-Rene Rideau Tue, 03 Sep 2013 12:17:21 -0500 cl-asdf (2:3.0.2-1) unstable; urgency=low Improve support for CMUCL, ABCL, restore MCL support. TRAVERSE is deprecated (moved to BACKWARD-INTERFACE), use MAKE-PLAN instead. Added DLL-OP and MONOLITHIC-DLL-OP for ECL. -- Robert P. Goldman Tue, 02 Jul 2013 12:05:57 -0500 cl-asdf (2:3.0.1.3-1) unstable; urgency=low Add some backward-compatibility to the debian package, with a symlink from asdf.lisp to build/asdf.lisp. -- Francois-Rene Rideau Sun, 02 Jun 2013 00:56:50 +0200 cl-asdf (2:3.0.1.2-1) unstable; urgency=low ASDF 3.0.1.2 fixes issues with the debian package itself. It also includes fixes to run-program and run-shell-command. -- Francois-Rene Rideau Mon, 27 May 2013 22:44:50 -0400 cl-asdf (2:3.0.1-1) unstable; urgency=low ASDF 3.0.1 is an emergency release for better compatibility with Quicklisp. * version-satisfies now uses uiop:version<= for comparison, and does not check for a same major version number, like version-compatible-p does, which was the undocumented behavior since ASDF 1. -- Francois-Rene Rideau Mon, 16 May 2013 19:20:28 -0400 cl-asdf (2:3.0.0-1) unstable; urgency=low ASDF 3.0.0 is the first official release of ASDF 3; ASDF 2.27 to 2.33 were pre-releases. Since 2.33, the following changes were done: * Portability: have *uninteresting-conditions* be empty by default. Move stuff to *usual-uninteresting-conditions*, unused by default. Will make the SBCL team happy. Also, fix tests on ABCL. Fix regression of program-op on ECL, by implicitly linking in UIOP or ASDF. * UIOP: improvements to slurp-input-stream and thus run-program, notably accepting T as alias for *standard-output*, for better backward-compatibility of the deprecated run-shell-command. New macro with-output-file. * POIU support enhanced with various tweaks. * Build cleanup so make and concatenate-source-op create the same asdf.lisp -- Francois-Rene Rideau Mon, 15 May 2013 23:57:22 -0400 cl-asdf (2:2.33-1) unstable; urgency=low ASDF 2.33 is a set of cleanups since 2.32. Since previous release 2.32, it includes the following changes: * Portability tweaks for ABCL, Allegro, CCL, CLISP, ECL, LispWorks, SBCL. * deferred-warning received yet more improvements for CCL. * upgrade is made more robust in many cases, notably for ECL, SBCL, or when using UIOP with an old ASDF<=2.26. * Packages have been tweaked to pass more tests, notably wrt what symbols are exported. * Image lifecycle support is improved, thanks to deploying ASDF3 for QRes. More options for dump-image on CCL; handle reentrance in restore-image. * delete-directory-tree, delete-empty-directory, copy-file, directory-exists-p, file-exists-p were added to UIOP, also better strcat, with reduce/strcat, base-string-p, etc. * Recompilation avoided for things already done by defsystem-depends-on. * monolithic-fasl-op was fixed in cases when the main system has components. * fasl-op and monolithic-fasl-op now work on ABCL trunk and upcoming 1.2.0, and will eventually replace the ABCL-JAR contrib. * *uninteresting-conditions* was added as a common list of conditions shared between the compile-time and load-time muffled conditions. -- Francois-Rene Rideau Thu, 04 Apr 2013 01:54:26 -0400 cl-asdf (2:2.32-1) unstable; urgency=low ASDF 2.31 is yet another bug fix release in preparation of an upcoming ASDF 3. Since previous release 2.31, it includes the following changes: * deferred-warning checks are now disabled by default, to enhance backward compatibility with ASDF 2.26 and earlier. In the future, we will enable them by default, but not until we implement a smoother transition plan. * UIOP is the new official name for ASDF-DRIVER. "Utilities for Implementation- and OS- Portability". Old names remain as package and system nicknames: . ASDF/DRIVER ASDF-DRIVER ASDF-UTILS * require-system so systems may depend on implementation-provided modules. * auto-upgrade attempt in operate *before* the implicit find-system. * class specification for components can now be a string to be read as a symbol. * feature conditional dependencies are now debugged and tested: . :depends-on ("some-system" (:feature :foo "other-system)) we only recommend them for dependencies between systems; within systems, we recommend you use feature-conditional components with . :if-feature :foo and we only provide limited support for the deprecated legacy way of using feature-conditionals with a module having :if-component-dep-fails :ignore while its components specify things like: . :in-order-to ((compile-op (feature :foo))) * read-from-file for :version specification is made more useful by using the ASDF-USER package rather than CL (into which interning is forbidden) to read the files. -- Francois-Rene Rideau Tue, 05 Mar 2013 19:35:43 -0500 cl-asdf (2:2.31-1) unstable; urgency=low ASDF 2.31 is another bug fix release in preparation of an upcoming ASDF 3. Since previous release 2.30, it includes the following changes: * *default-encoding* is now UTF-8. As tested with cl-test-grid, This is a boon for most programs, that will compile in a more predictable way in a wider range of settings. A handful of unmaintained outliers still need to be fixed. * Downgrade is now explicitly avoided. ASDF will issue a warning if your system is misconfigured in a way that specifies downgrade, but will then ignore the specified ASDF downgrade. * version specifications, when invalid, will lead only to a warning for now; a future ASDF3 may restore the behavior of ASDF 2.27, that raises an errors when there is a bad :version specification, but for now, backward compatibility prevails. * ECL support received several bug fixes. * precompiled-system support was notably fixed, enabling single-fasl deployment of SBCL contribs. -- Francois-Rene Rideau Mon, 25 Feb 2013 19:02:14 -0500 cl-asdf (2:2.30-1) unstable; urgency=low ASDF 2.30 is another bug fix release in preparation of an upcoming ASDF 3. Since previous release 2.29, it includes: * syntax around loading .asd files made more backward-compatible, by *not* (for now) binding *readtable* and *print-pprint-dispatch* to standard values, because it breaks some indelicate libraries. We intend to reinstate these bindings at some point in the future, but only after more implementations enforce the immutability of these standard values like SBCL does, and after fixed libraries have been released. This notably unbreaks iolib 0.7.3 (for readtable) and defdoc (for the pprint-dispatch table). * portability fixes for CCL and CMUCL. On CCL, punt on package upgrade, and on reify-simple-sexp. On CMUCL, fix raw-print-backtrace and hostname. * exported symbols cleaned up somewhat. -- Francois-Rene Rideau Fri, 20 Feb 2013 17:53:32 -0500 cl-asdf (2:2.29-1) unstable; urgency=low ASDF 2.29 is a bug fix release in preparation of an upcoming ASDF 3. Since previous release 2.28, it includes: * deferred-warnings support for Allegro, CMUCL, SCL; fixes to the CCL support. * Upgrade fixes regarding fallback system versions; making it possible (via massive use of eval-when) to compile ASDF without loading it first. * Compatibility with private use of :D package nickname by not claiming it for package ASDF/DRIVER anymore. Also explicitly handle NIL in safe-file-write-date, in case the implementation doesn't issue a file-error in that case; make UTF-8 the default encoding for with-input-file. Be portable to #+(and sbcl (not sb-eval)). * Bugfixes to old bugs: inline-methods can now be unqualified (lp#485393), defsystem-depends-on accepts arbitrary specs, not just names (lp#1027521). -- Francois-Rene Rideau Fri, 16 Feb 2013 15:07:24 +0100 cl-asdf (2:2.28-1) unstable; urgency=low ASDF 2.28 is a quick patch to ASDF 2.27 to make it work better with systems that specify a relative pathname, then at runtime (e.g. in tests) use merge-pathnames or merge-pathnames* against it expecting a directory. -- Francois-Rene Rideau Fri, 01 Feb 2013 17:07:53 -0500 cl-asdf (2:2.27-1) unstable; urgency=low ASDF 2.27 is actually an almost complete rewrite of ASDF, and should be considered a pre-release for an upcoming ASDF 3. It nevertheless maintains backward compatibility with the current practice, and is tested against the software in Quicklisp. * ASDF-BUNDLE was merged into ASDF. This notably means fewer headaches for users of ECL; it also means a new load-fasl-op feature for all users of a modern CL, making it easier to deliver software as a single fasl. After release, I plan to offer a patch so SBCL use that for its contrib's. All remnants of asdf-bundle's predecessor asdf-ecl were removed. * DECADES-OLD bugs of notable significance were fixed: (a) changes in dependencies now trigger a rebuild across systems, and https://bugs.launchpad.net/asdf/+bug/479522 (b) timestamps are now correctly propagated (they weren't at all!) https://bugs.launchpad.net/asdf/+bug/1087609 Fixing them required a complete rewrite of ASDF's dependency tracking. In olden days, some have argued for not rebuilding systems that :depend-on a modified one as a "feature". It really isn't. On the other hand, it is now possible to explicitly prevent a system from being rebuilt, using an actual feature, :force-not, which was released in 2.21 in April 2012. * PREPARE-OP was introduced to fix a conceptual bug in the ASDF object model. It corresponds to "loading the dependencies of a component and its parents" and is explicitly depends-on'ed by LOAD-OP and COMPILE-OP of the component, instead of their implicitly depending on it via the TRAVERSE algorithm, which implicit dependency proved fatal in cases revealed by the above bugs. It propagates upward in the component hierarchy, rather than downward, like the TRAVERSE algorithm used to systematically propagate dependencies. * TRAVERSE was gutted out and factored into reusable higher-order functions and objects, which not only fixes the above conceptual bug, but makes for semantics that are simpler to implement, possible to understand, easier to extend, and less limited in expressivity. TRAVERSE doesn't automatically propagate operations downward the component hierarchy anymore; propagation is now implemented through methods on COMPONENT-DEPENDS-ON. * COMPONENT-DEPENDS-ON is now more powerful: it can express dependencies on arbitrary operation objects (i.e. operations of the same class can have different options) acting on arbitrary component objects (i.e. not necessarily siblings of the current component). The ASDF object model can now express arbitrary build graphs, with no more special magic for children components vs other dependencies. * COMPONENT-DO-FIRST is no more. It used to specify some dependencies that were skipped if no re-build was triggered based on local timestamps; except that ASDF 1 didn't let the users control it, and ASDF 2 only let you control it since 2.017 or so. In ASDF 3, COMPONENT-DEPENDS-ON is used for all dependencies, and all are consulted to correctly propagate timestamps. However actions meant for in-image side-effects are included only if needed, and might be visited twice by TRAVERSE, first without the needed-in-image-p flag, another time with. You can use :IN-ORDER-TO everywhere you used to use :DO-FIRST, if ever. * FORCE and FORCE-NOT now correctly distinguish T from :ALL in addition to a list of system name specifiers, as per the original specification (which was never implemented in ASDF 1). Additionally, builtin systems (such as SB-BSD-SOCKETS on SBCL) cannot be forced (which doesn't work on SBCL). * IF-FEATURE is a new attribute of components that accepts an arbitrary feature expression such as (:and :sbcl (:or :x86 :x86-64)), which when defined is a precondition to the component being enabled; when the expression is false, the component is disabled, and dependencies to it are removed. It replaces the misguided :if-component-dep-fails attribute of modules and the accompanying :feature feature, which were dropped. They were not very expressive, clunky to use, and relied on baking conceptually dubious non-local behavior in the old TRAVERSE algorithm, which belied the object model and defeated other features. Unhappily, this breaks backwards compatibility for the few who used it, namely sb-grovel, nibbles and ironclad. A minimal compatibility layer is included that allows ASDF 3 or later to load the SB-GROVEL of old versions of SBCL; but it won't suffice to load an old version of nibbles or ironclad; please upgrade them a recent version that was updated to support ASDF 3. * CONCATENATE-SOURCE-OP is a new operation that builds a single Lisp file from all the source files in a system, which allows you to develop in a structured way with many compact files, yet deliver a large single file. Other related operations allow you to load that source file, or compile and load it, or do the same while including all other system dependencies. ASDF was broken up into lots of small files, to be delivered that way. * FOO/BAR/BAZ names will be recognized by defsystem as having to be located in a file called foo.asd. This is backward compatible in the case where you somehow arranged to load foo.asd before to use the other subsystems, except now ASDF can find the subsystems by name without the main system definition having been loaded. See uses of function PRIMARY-SYSTEM-NAME. * BUILD-OP is a generic operation that can do the "right thing" for each system, without users having to maintain the knowledge of what the right thing is for each system they may indirectly depend on. * Convenience methods were added to most exported generic functions, so you can (input-files 'compile-op '(system1 "file1")) instead of (input-files (make-instance 'compile-op) (find-component 'system1 "file1")) This notably makes it much easier to interact with ASDF at the REPL and debug your system definitions or ASDF extensions (or modifications). * Packages were introduced as ASDF was broken up into small files. Each file now has its own package, importing and exporting functionality, following the style made popular by faslpath and quick-build. ASDF does not yet include builtin support for quick-build or faslpath systems and dependencies, however. Possibly in ASDF 2.28. * ASDF-DRIVER is a separately-usable library for Common Lisp runtime support. It is transcluded in asdf.lisp (i.e. when delivering ASDF as a separate bootstrap file, the contents of ASDF-DRIVER have been included in it), but can also be used as a separate ASDF system on top of an old ASDF (within limits: CLISP and XCL still need a recent ASDF). The package ASDF/DRIVER (with short nickname :D) re-exports all the functions that ASDF needed to run portably. * Pathnames are a notable part of ASDF-DRIVER, required to deal portably with pathnames despite the many bugs and variations from platform to platform. See notably in pathname.lisp, MERGE-PATHNAMES*, SUBPATHNAME, PARSE-UNIX-NAMESTRING, PARSE-NATIVE-NAMESTRING, ENSURE-PATHNAME, and many many more. * Pathname use by ASDF was also improved in countless small ways, closing more buglets that appeared in as many corner cases. For instance, system pathname defaulting was improved, and systems not associated with a file will now have NIL as their pathname, which will otherwise be correctly treated. Many things that would vary depending on implementation will work better. Also, although we cannot strongly enough disrecommend the use of so-called "logical pathnames", especially where portability matters in any way, we support them better than ever within the limitations of the implementation. * Image lifecycle support is included in ASDF-DRIVER (and thus ASDF); this standardizes things like access to *COMMAND-LINE-ARGUMENTS*, declaring an entry-point to a program, hook functions and/or a prelude to run before to start the main entry, and a postlude and/or hook functions to run before to dump an image, dumping or creating an image, etc. * PROGRAM-OP allows you to create standalone executables on implementations that support it: CLISP, Clozure CL, CMUCL ECL, LispWorks, SBCL, SCL. A hello-world-example system shows demonstrates how to use it. * Run-program is a replacement for the old run-shell-command. Unlike run-shell-command, it is portable to Windows as well as Unix, it can avoid going through a shell and will sensibly escape arguments when it does go through a shell, and it has a usable interface to either capture program output or run the program interactively. This supersedes run-program/ previously available from xcvb-driver, including several improvements and portability fixes. * Conditions can be selectively muffled around compilation thanks to the an around-compile hook and the *UNINTERESTING-COMPILER-CONDITIONS* parameter, and around loading with *UNINTERESTING-LOADER-CONDITIONS* which is _appended_ to the former during loading. This supersedes the functionality previously available from xcvb-driver and its thin wrapper asdf-condition-control, which was retired. * Deferred warnings for yet undefined functions, that in a single-session build are usually signaled at the end of a compilation unit, will be saved and reassembled to make each system a compilation unit of its own, even when compilation of file happens across multiple sessions; only CCL and SBCL support this feature at this time. I welcome patches for other compilers, for which ASDF will _not_ wrap an implicit WITH-COMPILATION-UNIT around its operate method anymore. * COMPILE-FILE* was beefed up to support all these features and more, and the Right Thing(tm) on all implementations, including support for their various extensions. * Internals have been refactored, and some sorry features were excised. The semantics of OPERATION-DONE-P is simplified and now well-specified. FIND-COMPONENT will pass component objects through, and a corresponding FIND-OPERATION replaces MAKE-SUB-OPERATION. Many internal accessors were renamed, after checking on Quicklisp that no one was using them. * Portability updates were done for each and every implementation. Working support for GCL 2.6 was restored, with notable limitations including lack of support for output-translations or logical-pathnames. * TRUENAME resolution can be reliably turned off in all cases where ASDF was using them by setting the variable *RESOLVE-SYMLINKS* to NIL. This is useful if your operating system makes that operation slow, or if your build system uses symlinks to content-addressed storage in which case TRUENAME just does the wrong thing. * PERFORMANCE of ASDF3 is somewhat slower (about 70%) than ASDF2 when *RESOLVE-SYMLINKS* is true, and slightly faster when it is false; but underneath ASDF3 does much more work than ASDF2. * VERSION strings can now be specified as having to be fetched from a file using a (:read-file-form ) specification, that can use an optional :at keyword argument to specify a form or subform other than the first form in the file, as per the utility asdf-driver:access-at. For instance, if your file specials.lisp is a defpackage, an in-package and a defparameter of the version, then you could use: (:read-file-form "specials.lisp" :at (2 2)) This makes it easier for developers to manage versioning of one or multiple systems with a single master version location. * COMPONENT-PROPERTY and the :PROPERTIES initarg of defsystem are deprecated; though they are still supported for now, we intend to retire them in a hypothetical future ASDF 4. To replace them, we recommend you instead define a subclass of asdf:system, with new slots and/or initargs, and use them with the :defsystem-depends-on and :class options of defsystem. We looked at usage of in Quicklisp systems, and added to asdf:system these slots corresponding to the general-purpose metadata we saw: :homepage :bug-tracker :mailto :long-name * Self-Upgrade of ASDF will happen automatically as the first thing before any attempt to build anything, as it was determined that doing it in the midst of a build breaks everything, and it is not otherwise possible to reliably detect in advance whether ASDF may be needed in such midst. If you don't want an ASDF upgrade, just don't configure your source-registry to include any copy of ASDF. * DEFINE-PACKAGE is provided as a replacement to DEFPACKAGE that supports hot upgrade of software where some packages have changed. It also provides new forms :MIX and :REEXPORT which can be quite practical. * ASDF-USER is now the shared package in which all .asd files are loaded. There will be no more temporary packages created around the loading of each .asd file. This shouldn't change much for users: you should probably still define your own private package whenever you define new classes, functions, or variables, to avoid namespace conflict; except now, when you don't, you can still access your defined symbols after the file is loaded. ASDF is not the right place to fix Common Lisp namespace issues, and these temporary packages were never a successful fix anyway; indeed, users were still required to define their own package as soon as they wanted to define variables, functions and classes in the system file. * ASDF3 was added to the *features* so you can detect the presence of this massively updated ASDF and its new features with #+asdf3. * Documentation received some updates, though by no means comparable to the complete rewrite of the code base. * Tests were updated, notably including support for bundles, encodings, run-program, and more. They were successfully run on abcl allegro allegromodern ccl clisp cmucl ecl ecl_bytecodes lispworks sbcl scl xcl Manual tests were run on gcl2.6 genera lispworks-personal-edition. Untested remain cormancl mkcl rmcl. The internal test system itself was massively improved. * ASDF-DEBUG is a simple utility to make your favorite debugging primitives available in the package you're debugging. See contrib/debug.lisp and the asdf/utility:*asdf-debug-utility* variable. * ASDF-UTILS is now but an empty shell that depends-on ASDF-DRIVER. The ASDF-DRIVER package has the ASDF-UTILS nickname, and exports all the functionality that used to be in ASDF-UTILS, and much more, minus a few misdesigned things from ASDF1 that you ought not to have been using, and for which there are non-broken replacements. ASDF-UTILS was distributed separately from ASDF; ASDF-DRIVER is available both as part of ASDF 3 and later and separately. * POIU was updated. This extension is still distributed separately from ASDF. It is now much simplified and made correct by construction by reusing the new TRAVERSE infrastructure of ASDF and now being able to assume the ASDF object model is a complete description of dependencies. On SBCL it will handle deferred warnings from background compilations. Where forking is not supported or not possible because of threads, it will gracefully fall back to serial compilation. * INFERIOR-SHELL (distributed separately) was updated to use asdf-driver instead of xcvb-driver. It notably provides a richer interface to the RUN-PROGRAM functionality. * SLIME support for ASDF was significantly enhanced. It is distributed with SLIME, separately from ASDF. See latest slime checkin from 2013-01-29. It requires ASDF 2.014.6 or later (as used by 2011 quicklisp releases). We recommend that you should include slime-asdf in your slime-setup and that in your ~/.swank.lisp you should include: (in-package :swank) (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*) -- Francois-Rene Rideau Fri, 01 Feb 2013 13:27:12 -0500 cl-asdf (2:2.26-1) unstable; urgency=low * Package change: removed the old ASDF-UTILITIES package nickname for ASDF. Please use the separate ASDF-UTILS system and package for utilities. * compile-file-pathname* bug fix for :output-file nil. Fixes lp#1067617. * get-folder-path factored out of various functions, thanks Martin Simmons. * Lispworks: enable sys:get-folder-path on Personal Edition for Windows. * ECL: add proper wrapping-source-registry -- Francois-Rene Rideau Thu, 30 Oct 2012 08:09:06 +0900 cl-asdf (2:2.25-1) unstable; urgency=low * Lispworks: avoid professional edition functions in personal edition. * CormanLisp: improve support a little bit. * Exports: don't export utilities anymore. Please use asdf-utils. -- Francois-Rene Rideau Thu, 27 Sep 2012 18:35:21 -0400 cl-asdf (2:2.24-1) unstable; urgency=low * ACL: handle SMP vs non-SMP builds in Allegro 9.0 * MKCL: add support for ManKai Common Lisp * ECL: merge improvements from ECL git. Refactor ECL support somewhat. * Remove broken-fasl-support: first, cormanlisp is supposed to have fixed it; second, cormanlisp is dead; third, one can now (setf *load-system-operation* 'load-source-op) instead while using asdf:load-system. * renaming ends-with to string-suffix-p to avoid conflict with alexandria. * Refactor load-system to use *load-system-operation*, and change require-system and module-provide-asdf to use that. Also note: * We recommend you use asdf-utils to access the utilities in asdf. Some time next year, we may stop exporting the utilities from asdf itself. * To avoid conflicts between alexandria, fare-utils, xcvb-driver, asdf-utils, etc., you can use xcvb-utils that solves the conflicts. Or you can use fare-utils:define-package-mix that will help you automatically resolve them. -- Francois-Rene Rideau Sat, 25 Aug 2012 08:05:21 -0400 cl-asdf (2:2.23-1) unstable; urgency=low * add new :compile-check argument to compile-file* and around-compile-hook. This allows for consistency check of .fasl output before the file can possibly be seen by other builds (i.e. no race condition). * export more utilities for dealing with pathnames from environment. -- Francois-Rene Rideau Tue, 17 Jul 2012 11:03:32 -0400 cl-asdf (2:2.22-1) unstable; urgency=low * require is now mapped to the recently defined require-system, not to load-system anymore. * more sensible inheritance semantics for default-component-class, which can be either a class or a class name. * accept wildcards in directory-files for physical pathnames. lp#1000842 -- Francois-Rene Rideau Tue, 12 Jun 2012 11:22:33 -0400 cl-asdf (2:2.21-1) unstable; urgency=low * New features: * Most importantly, encodings. ASDF now lets you specify an :encoding for a system, module or component, that is used when loading or compiling Lisp files. See the documentation. By default, the only useful value is :utf-8, and we recommend you use UTF-8 everywhere. We intend to make UTF-8 the default in the future (current default is the legacy behavior of using whichever implicit default your underlying implementation is currently configured to use). An extension asdf-encodings is available that supports more encodings, including autodetection of encoding from either emacs-style declaration -*- Mode: Lisp ; coding: utf-8 -*- or content. * require-system works like load-system, but won't try to load or update systems that have already been loaded, as listed by loaded-systems. More generally, you can specify a list of systems as :force-not argument to load-system and the specified systems won't be loaded or updated. * You can specify :force-not and a list of systems when loading a system, * You can now specify :hostname in your asdf-output-translations, so you can easily share a home directory via the network yet split its fasl cache between several subtly different machines. * Bug Fixes: * lp#982285. since 2.014.4, the default source-registry was skipping anything from /usr or XDG_DATA_DIRS, because of a missing test in getenv-absolute-pathnames. Fixed in .15. * In 2.019.9 aka 2.20, ECL support was broken by using a function in the wrong package (defined in cl-user). Fixed in .1. * logical-pathname support was somewhat broken since 2.017.6, due to the way most implementations fail to read physical namestrings when *default-pathname-defaults* is a logical-pathname. Fixed, together with other logical-pathname issues, and a test case was added to the test suite to ensure no further regression. Works great modulo quirks around implementation bugs on CLISP and Allegro. * Make upgrading ASDF more robust on CMUCL, LispWorks, SBCL. * Minor tweaks: * Use :unspecific in pathname components on more implementations. * export and/or document more utilities. * add a few missing compatfmt for Genera. -- Francois-Rene Rideau Sat, 28 Apr 2012 23:55:23 -0400 cl-asdf (2:2.20-1) unstable; urgency=low * Portability: support the new CCL fasl numbering API * Bug fixes: handle various configuration corner cases better (thanks to Sergey Katrevich and Rupert Warwick). * Feature: Robert Goldman fixed and documented WEAKLY-DEPENDS-ON. -- Francois-Rene Rideau Fri, 13 Jan 2012 14:40:12 -0500 cl-asdf (2:2.019-1) unstable; urgency=low * UI: Create and use a load-systems abstraction, in view of using it in a system-granular parallelizing backend. (.15) * Usability: when a system can't be found, there's now a restart to retry finding a system after reinitializing the source-registry (.10). * Feature: :around-compile now accepts lambda expressions, and also strings, so you can specify future wrappers that can't even be read yet. (.11, .12). * Filesystem: recursing through logical pathnames in LispWorks (.2, .3), on SBCL as on CMUCL, have asdf:subdirectories follow symlinks (.8., .9) * Configuration: modify user-configuration-directories and system-configuration-directories to return all valid directory names even when they don't exist yet so you may create them (.6), also output name of non-existing configuration file when opening them for writing (.7), * Internals: strcat (.5), split locate-systems from find-systems (.6) * Portability: Debugged CormanLisp support (.1). Fix type declaration for SCL (.17). * Bug fix: don't drop pathname components without a / at the end when reading a path using GETENV (.18). (Bug from 2.017.27) Closes: #647544. * Bug fix: don't redefine reinitialize-instance in ways that break its contract and its clients (such as asdf-dependency-grovel). Use change-class to reset slots (.16), but not to 'standard-object, which breaks ecl, rather to a proto-system class (.19), and not using keys with breaks genera (.21). (Bug from 2.017.3) * Bug fix: buglet in maybe-add-tree (.4) * Upgrade: unintern internals of signature changed in 2.017.12 (.13), have *system-definition-search-functions* not be a defparameter, but a defvar with a fixup (.14), clear *systems-being-defined* when upgrading asdf but re-find them immediately because they may be needed as part of a higher operation (.14). Unintern some more functions that have changed signature (.20). -- Francois-Rene Rideau Sun, 27 Nov 2011 16:09:42 -0500 cl-asdf (2:2.018-1) unstable; urgency=low Bugs: * Solved a bug due to ASDF reusing components even when the ASDF definition has changed wildly, leading to bad behavior in incremental compilation and sometimes total failure of compilation of a new version. (Thanks to Xach for reporting and RPGoldman for fixing.) * Fix an issue with ASDF doing the wrong thing in case of a clock skew, thanks to Andreas Fuchs. * Simplification of the internals of perform-with-restarts and traverse's do-dep, that should fix some corner cases and make it easier to extend or further fix. There scarily doesn't remain any unedited code from Dan Barlow's original ASDF, though much of the interface design is preserved. * Upgrade code slightly simplified, with a particular fix for CLISP; it is now tested on all supported implementations, not just SBCL. * Improvements to tests and documentation. Portability: * Many implementation specific improvements for ECL: merge with the ECL upstream version, support for the bytecode compiler. * Because it is required at least on ABCL, made the Unix vs Windows detection a runtime rather than compile-time distinction No more asdf-unix or asdf-windows feature, but (asdf::os-unix-p) and (asdf::os-windows-p) functions (not exported for now). Also recognize darwin as Unix ECL. * Also small improvements for SCL. Features: * Bind *default-pathname-defaults* around load-sysdef, to increase chances of successful pathname parsing in defsystem. * Fixed run-shell-command on allegro/unix and clisp, documented the function, noted how it mightn't do what you think on Windows, marked it as obsolete, promoted as an official replacement my new xcvb-driver:run-program/process-output-stream * New :around-compile hook so you can control the syntax, optimization, and warning level, rename packages and balance compile-time side-effects, etc., around the compilation of files in your own modules. * Now exporting function subpathname, to portably make subpathnames. -- Francois-Rene Rideau Sat, 29 Oct 2011 12:46:22 -0400 cl-asdf (2:2.017-1) unstable; urgency=low Promoting 2.016.3 as 2.017. Since 2.016, we have the following improvements: * ABCL: jar translation happier with recent compile-file-pathname* change. * CCL: see truenamize change below. * GCL: vain partially reverted attempts at making GCL 2.6 and 2.7 fail less. * LispWorks: use probe-file for probe-file* * RMCL: location strings are now POSIX namestrings. You can thus share configuration files and environment variables between RMCL and other Lisp implementations on same host. Use #p"" syntax when you insist on using MacOS 9 style MCL pathnames. * truenamize: happier when e.g. the *default-pathname-defaults* is #p"", which is the case notably on CCL. * Logical pathnames: now preserved by the source-registry's tree directive. * Upgrade: instead of unintern'ing symbols, use fmakunbound; however, treat compilation of asdf specially, by always making sure it is loaded as source before it is compiled, so that compilation is never an upgrade and never calls fmakunbound, thus ensuring functions in the continuation of compilation are always fbound. * Obsolete: dropped support for *system-cache* and get-uid. * Internals: refactored resolve-relative-location-component. * Documentation: update wrt to the location DSL. -- Francois-Rene Rideau Tue, 26 Jul 2011 12:52:49 -0400 cl-asdf (2:2.016-1) unstable; urgency=low Promoting 2.015.12 as 2.016. Since 2.015, we have the following improvements: * Portability: fixes for ECL, RMCL, CLISP. Improvements to Windows configuration. * Fix to load-source-op (broken in 2.014.13). * Avoid infinite loops in defsystem in cases of bad interference between quicklisp and your source-registry. * Small fixes regarding upgrade, compile-file* :output-file. * Make defsystem-depends-on much more useful by allowing a system thus depended on to define the class of the system depending on it. * Some documentation updates. Notably, for the sake of CLISP, (require "asdf") is the new canonical way to load ASDF, instead of (require :asdf). Sigh. * Better tests, notably wrt hot upgrade. -- Francois-Rene Rideau Tue, 07 Jun 2011 17:46:15 -0400 cl-asdf (2:2.015-1) unstable; urgency=low Promoting 2.014.17 as 2.015. Since 2.014, we have the following improvements: * Portability: support cormanlisp, xcl; fixes for cmucl, ecl; tweaks for abcl, allegro, clisp, genera, lispworks. * Feature: un-cerror and actually fix the :force '(sys1 sys2 sys3) feature, introduced in 2002 and never working before. * Feature: classes asdf:cl-source-file.cl and asdf:cl-source-file.lsp for people who use these file type extensions. * Semantic change: the source-registry eagerly gathers a list of .asd, rather than querying the filesystem over and over again. * API change: exposing function asdf:search-for-system-definition as looking through asdf:*system-definition-search-functions* for either pathnames *or* (new feature) system objects. Should make quicklisp happier. * Better support for asdf upgrading itself, with new function asdf:upgrade-asdf that knows to invalidate old systems when necessary, and is magically invoked before to build any system that :depends-on asdf. Make upgrade smoother some cases that were previously broken. * More robust handling of version strings. * Declaring function asdf:system-definition-pathname obsolete, but still supporting it for now, as an alias for asdf:system-source-file. * Various refactorings of internals. Splitting a function asdf::perform-plan out of the default asdf:operate method. asdf::register-system now takes only one argument. * Tests to prevent the regressions experienced during this development cycle * Tried and reverted: attempts to make asdf more verbose when it's verbose, but not verbose by default. -- Francois-Rene Rideau Tue, 07 Jun 2011 17:38:50 -0400 cl-asdf (2:2.014.3-1) unstable; urgency=low * yet another debian package attempt * update to 2.014.3, workaround for ABCL make-pathname bug (same as on XCL). -- Francois-Rene Rideau Mon, 04 Apr 2011 23:27:30 -0400 cl-asdf (2:2.014.2-1) unstable; urgency=low * yet another attempt at a debian package. * update to 2.014.2, adds XCL support. -- Francois-Rene Rideau Thu, 31 Mar 2011 14:08:09 -0400 cl-asdf (2:2.014.1-1) unstable; urgency=low * new attempt for a debian package. * while I'm at it, update to 2.014.1 which will make CMUCL happy. -- Francois-Rene Rideau Tue, 29 Mar 2011 18:19:19 -0400 cl-asdf (2:2.014-3) unstable; urgency=low * another attempt with my new GPG key -- Francois-Rene Rideau Sun, 27 Mar 2011 19:33:43 -0400 cl-asdf (2:2.014-2) unstable; urgency=low * tweak Makefile for debian packaging. -- Francois-Rene Rideau Sun, 27 Mar 2011 17:17:15 -0400 cl-asdf (2:2.014-1) unstable; urgency=low * Blessing 2.013.7 as 2.014. * Fixed bug preventing upgrade from 2.000 to 2.008 (test added) * Better support for URL pathnames on SCL (test added) * Robustified defsystem-depends-on * Cosmetic changes: * better more portably readable error messages. * remove forward references, again (test added) * canonicalize system names earlier (slight robustness improvement) -- Francois-Rene Rideau Sun, 27 Mar 2011 16:45:58 -0400 cl-asdf (2:2.013.3-1) unstable; urgency=low * Packaging 2.013.3 because 2.013 had important issues. * Fix important upgradability issue with 2.013 (unable to upgrade from versions 2.00[0-8] that have a separate ASDF-UTILITIES) * Fix minor verbosity issue (forward reference makes sbcl noisy when loading asdf.lisp directly as does quicklisp.) * Also, enhance support for SCL. -- Francois-Rene Rideau Mon, 21 Mar 2011 16:24:27 -0400 cl-asdf (2:2.013-1) unstable; urgency=low * Blessing 2.012.12: many small improvements since 2.012. * Fixes and cleanups for CLISP, ECL, SBCL. * Added support for two legacy platforms: (R)MCL, Genera * Cleanup features: now using #+asdf-unix and #+asdf-window * Many cleanups and improvements regarding our portable pathname layer * Fixes a regression in source-registry scanning from 2.011.4 * Remember *source-registry-parameter* and *output-translations-parameter* * Export and document coerce-pathname (f.k.a merge-component-name-type) * allow description and long-description for all components * Several documentation updates -- Francois-Rene Rideau Sat, 19 Mar 2011 20:01:34 -0400 cl-asdf (2:2.012-1) unstable; urgency=low * Blessing 2.011.9: more fixes to corner cases. * Added :here directive to pathname DSL, robustified ECL support, fixed infinite loop when filesystem clock is in the future, extended the AOT DSL and made it more futureproof, fixed how clear-system interacts with map-systems, fixed use of directory under old SBCLs, fixed run-shell-command status and version string under clisp, fixed error messages. * Synchronized version of asdf.asd and asdf.lisp, automatically. -- Francois-Rene Rideau Mon, 03 Jan 2011 06:59:17 +0100 cl-asdf (2:2.011-1) unstable; urgency=low * Mostly same as 2.010.9: several minor tweaks and bug fixes since 2.010. * Will be happier: users of implementations ACL, GCL; users of libraries CL-Launch, XCVB; future former users of ASDF-Binary-Locations; people with missing dependencies (in lieu of error-in-error); people extending ASDF (notably Stelian Ionescu), who'd like to use keywords to name component classes. -- Francois-Rene Rideau Sun, 28 Nov 2010 13:21:34 -0500 cl-asdf (2:2.010-1) unstable; urgency=low * same as 2.146 -- Francois-Rene Rideau Thu, 28 Oct 2010 15:58:36 -0700 cl-asdf (2:2.009-1) unstable; urgency=low * new upstream release 2.009, identical to 2.134 from master. -- Francois-Rene Rideau Wed, 06 Oct 2010 13:26:36 -0400 cl-asdf (2:2.008-1) unstable; urgency=low * new upstream: removes unwanted exports, plays nicer with sbcl, cmucl, old clisp. -- Francois-Rene Rideau Fri, 10 Sep 2010 17:16:06 -0400 cl-asdf (2:2.007-1) unstable; urgency=low * new upstream, fixes lp#623992 introduced in 2.006, allows upgrade on SBCL. -- Francois-Rene Rideau Wed, 25 Aug 2010 23:22:13 -0400 cl-asdf (2:2.006-1) unstable; urgency=low * new upstream, with bug fixes and API changes. -- Francois-Rene Rideau Tue, 24 Aug 2010 18:43:48 -0400 cl-asdf (2:2.005-1) unstable; urgency=low * New upstream. * Don't use dh-lisp -- Francois-Rene Rideau Tue, 17 Aug 2010 13:57:04 -0400 cl-asdf (2:2.004-1) unstable; urgency=low * Imported new upstream, try not to diverge from it. * Remove cl-cclan which was removed from the upstream repository. * Updated Debian configuration and documentation. -- Francois-Rene Rideau Wed, 14 Jul 2010 14:06:50 -0400 cl-asdf (2:1.704-1) unstable; urgency=low * Imported new upstream. * We now have a makefile for Documentation, use it * Add debian/source/format for the stupid quilt mess -- Peter Van Eynde Mon, 19 Apr 2010 21:37:48 +0200 cl-asdf (2:1.627-1) unstable; urgency=low * New upstream release. * Added dh_installinfo for info files. (Closes: #560290) * Incorporated run-shell-command patch for LispWorks. Thanks tianchun! (Closes: #457919) * Added info that this version breaks clc * Fix conflict with clc * Small patch to make :implementation-type work for clc -- Peter Van Eynde Thu, 25 Feb 2010 18:36:16 +0100 cl-asdf (2:1.502-1) unstable; urgency=low * new upstream, back to version numbers. * added /etc/common-lisp/source-registry.conf.d/ directory * Added README's to documentation * it's debian/*.dirs not debian/*.dir\! * Updated standard version, no real changes * Added lintian overrides for cl-cclan -- Peter Van Eynde Mon, 01 Feb 2010 07:31:06 +0100 cl-asdf (1:20091221-1) unstable; urgency=low * New upstream, version 1.374 -- Peter Van Eynde Thu, 31 Dec 2009 08:36:15 +0100 cl-asdf (1:20090819-3) unstable; urgency=low * Fixed the loop construct again. (Closes: #546205) -- Peter Van Eynde Sat, 12 Sep 2009 10:08:23 +0100 cl-asdf (1:20090819-2) unstable; urgency=low * Fix the loop contruct. This makes ecl fail. (Closes: #545768) -- Peter Van Eynde Thu, 10 Sep 2009 14:20:11 +0100 cl-asdf (1:20090819-1) unstable; urgency=low * New upstream, New homepage and new upstream repository. * changed section to lisp * now using debhelper v7 * added debian/README.building * remove cvs2cl from dependencies * remove upstream ChangeLog * added dummy watch file * added ${misc:Depends} to cl-asdf Depends * Updated Standards-Version no real changes * fixed Section of cl-asdf.doc-base -- Peter Van Eynde Tue, 01 Sep 2009 08:20:28 +0100 cl-asdf (1.111-1) unstable; urgency=low * New upstream release. * Updated standard version without real changes * Corrected Vcs-Bzr field * Move to using dh-lisp * Fixed Vcs-Git field * Changed to group maintanance * recreated upstream changelog with git2cl * Changed directory, so we depend on a newer clc -- Peter Van Eynde Sat, 09 Feb 2008 10:07:21 +0100 cl-asdf (1.109-2) unstable; urgency=low * stop trying to dump the package, use the package name instead. (Closes: #436129) -- Peter Van Eynde Thu, 27 Sep 2007 05:42:20 +0200 cl-asdf (1.109-1) unstable; urgency=low * New upstream. Major changes: + main change is the addition of system-relative-pathname function. This takes a system name and a partial pathname and combines them to return a new pathname _relative_ to the system. This is exported and lightly documented. + this patch also updates preference-file-for-system/operation in an effort to prevent it from being confused by *default-pathname-defaults* that include a specific name and type. + Removes inline component methods more carefully (and, I believe, correctly!). Helps keep LispWorks happy. + Reworked asdf tests to make them more robust and perhaps more flexible too. * Now use texlive to build. -- Peter Van Eynde Sun, 16 Sep 2007 14:45:57 +0200 cl-asdf (1.107-1) unstable; urgency=low * New upstream release, adding the system-relative-pathname function. -- Peter Van Eynde Sun, 08 Apr 2007 23:05:18 +0200 cl-asdf (1.106-1) experimental; urgency=low * New upstream. Major changes: + Minor patch in class-for-type that evaluates only *package* at read time rather than (package-name *package*); this keeps case sensitive Lisps happy all the time and keeps case insensitive lisps happily insensitive. + A patch from Richard Kreuter that allows pathname defaulting to work better with *load-truename* and *default-pathname-defaults*; this makes it easier to work with defsystems in the REPL. -- Peter Van Eynde Wed, 14 Mar 2007 09:18:25 +0100 cl-asdf (1.104-1) experimental; urgency=low * Added XS-X-Vcs-Darcs header * modified S-X-Vcs-Darcs to XS-Vcs-Darcs field * New upstream. Major changes: + add a better docstring for component-depends-on (via #lisp and Robert Goldman) + ASDF now sends output to *standard-output* (thanks to Richard M. Kreuter). + Slightly better SBCL_HOME treatement for SBCL. * upload to experimental during the freeze -- Peter Van Eynde Tue, 6 Feb 2007 08:21:06 +0100 cl-asdf (1.101-1) unstable; urgency=low * New upstream version. -- Peter Van Eynde Wed, 20 Sep 2006 07:08:57 +0200 cl-asdf (1.99-3) unstable; urgency=low * Added tetex-bin to Build-Depends-Indep (Closes: #379532) -- Peter Van Eynde Mon, 24 Jul 2006 19:34:49 +0200 cl-asdf (1.99-2) unstable; urgency=low * Move asdf.info files from sbcl to this package. * move texinfo to BuildDependsIndep * we build something build-indep -- Peter Van Eynde Fri, 30 Jun 2006 23:18:40 +0200 icl-asdf (1.99-1) unstable; urgency=low * New upstream. -- Peter Van Eynde Mon, 19 Jun 2006 05:28:12 +0200 cil-asdf (1.97-1) unstable; urgency=low * New upstream release * Moved debhelper to build-depeneds * increased standards-version without real changes. -- Peter Van Eynde Sat, 20 May 2006 19:28:58 +0200 cl-asdf (1.89-1) unstable; urgency=low * Noticed that I actually increased the version with the CVS commit * Updated the standards version * Remove the prepare build stuff, build through darcs * Improve duplicate names test: use equal instead of equalp. From a comment from Faré. * Remove CVS cruft * Seperate CVS version of asdf.lisp from version of package. The tag is not the version of the package -- Peter Van Eynde Thu, 22 Sep 2005 12:52:31 +0200 cl-asdf (1.86-5) unstable; urgency=low * Fixed duplicate components patch to better handle reloading defsystem files. Now works again with McClim. Closes: #310640 * Corrected dependencies. * Added postinst rebuild of all clc-enabled lisps so the new version actually gets loaded. -- Peter Van Eynde Wed, 25 May 2005 08:22:17 +0200 cl-asdf (1.86-4) unstable; urgency=low * My release script stripped the patch. So this should really contain the patch. Damn. -- Peter Van Eynde Tue, 10 May 2005 14:17:51 +0200 cl-asdf (1.86-3) unstable; urgency=low * Now checks if components names are unique Closes: #304972, #304970 * Fix dependency on common-lisp-controller Closes: #308385 -- Peter Van Eynde Tue, 10 May 2005 07:50:25 +0200 cl-asdf (1.86-2) unstable; urgency=low * New maintainer. (Closes: #297349: O: cl-asdf -- Another System Definition Facility) * Adopted by Peter Van Eynde -- Peter Van Eynde Tue, 1 Mar 2005 10:11:55 +0100 cl-asdf (1.86-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Wed, 4 Aug 2004 21:19:16 -0600 cl-asdf (1.84-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Wed, 12 May 2004 12:43:58 -0600 cl-asdf (1.81-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Tue, 30 Dec 2003 12:12:38 -0700 cl-asdf (1.80-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Fri, 5 Dec 2003 14:55:43 -0700 cl-asdf (1.79-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Tue, 11 Nov 2003 16:12:07 -0700 cl-asdf (1.78-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Thu, 9 Oct 2003 16:46:38 -0600 cl-asdf (1.77.2-1) unstable; urgency=low * Don't export asdf:wild-module as can cause a full warning when reloading asdf -- Kevin M. Rosenberg Mon, 11 Aug 2003 21:55:16 -0600 cl-asdf (1.77.1-1) unstable; urgency=low * cclan.lisp: conditionalize for sbcl (closes: 201822) -- Kevin M. Rosenberg Thu, 17 Jul 2003 23:30:57 -0600 cl-asdf (1.77-1) unstable; urgency=low * New upstream * Add automated [cvs2cl] ChangeLog -- Kevin M. Rosenberg Thu, 17 Jul 2003 10:27:27 -0600 cl-asdf (1.76) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Thu, 10 Jul 2003 16:42:48 -0600 cl-asdf (1.75) unstable; urgency=low * New upstream * Use compat rather than DH_COMPAT -- Kevin M. Rosenberg Thu, 5 Jun 2003 00:15:11 -0600 cl-asdf (1.73b) unstable; urgency=low * Update README * export two variables -- Kevin M. Rosenberg Wed, 28 May 2003 11:19:40 -0600 cl-asdf (1.73) unstable; urgency=low * Update README to mention asdf::*compile-file-warnings-behaviour* (closes:194957) -- Kevin M. Rosenberg Tue, 27 May 2003 16:00:36 -0600 cl-asdf (1.72) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Tue, 20 May 2003 14:07:10 -0600 cl-asdf (1.71) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Tue, 13 May 2003 09:33:51 -0600 cl-asdf (1.70) unstable; urgency=low * Add another check in check-component-values. * Signal a generalized instance of SYSTEM-DEFINITION-ERROR from check-component-values -- Kevin M. Rosenberg Tue, 6 May 2003 09:32:16 -0600 cl-asdf (1.69) unstable; urgency=low * Add check-component-values function with partial checking of components -- Kevin M. Rosenberg Tue, 6 May 2003 08:26:11 -0600 cl-asdf (1.68) unstable; urgency=low * New upstream with 'asdf:test-op -- Kevin M. Rosenberg Wed, 19 Mar 2003 10:16:01 -0700 cl-asdf (1.66) unstable; urgency=low * New upstream version, added changes to dependent system compilations with :force option. -- Kevin M. Rosenberg Mon, 17 Mar 2003 12:50:00 -0700 cl-asdf (1.62) unstable; urgency=low * New upstream, fixes a sbcl-specific directory name -- Kevin M. Rosenberg Fri, 7 Mar 2003 09:23:11 -0700 cl-asdf (1.61-1) unstable; urgency=low * New upstream, fixes 'load-source-op -- Kevin M. Rosenberg Tue, 4 Mar 2003 09:48:40 -0700 cl-asdf (1.60-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Mon, 3 Mar 2003 12:40:27 -0700 cl-asdf (1.59-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Fri, 14 Feb 2003 09:24:59 -0700 cl-asdf (1.58-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Sun, 9 Feb 2003 11:55:03 -0700 cl-asdf (1.57-1) unstable; urgency=low * New upstream -- Kevin M. Rosenberg Tue, 4 Feb 2003 10:23:03 -0700 cl-asdf (1.55-1) unstable; urgency=low * New upstream.version (closes: 172074) -- Kevin M. Rosenberg Mon, 9 Dec 2002 10:23:21 -0700 cl-asdf (1.54-1) unstable; urgency=low * New upstream. -- Kevin M. Rosenberg Fri, 8 Nov 2002 07:30:41 -0700 cl-asdf (1.49-1) unstable; urgency=low * Remove clc-reregister-all-impl from postinst -- Kevin M. Rosenberg Sat, 5 Oct 2002 09:38:18 -0600 cl-asdf (1.49) unstable; urgency=low * New upstream release, fixes run-shell-command for allegro. Code refactoring for run-shell-code. * Support new CLC reregister command -- Kevin M. Rosenberg Wed, 25 Sep 2002 23:57:23 -0600 cl-asdf (1.47) unstable; urgency=low * Return numeric exit status for openmcl's run-shell-command -- Kevin M. Rosenberg Fri, 20 Sep 2002 10:22:36 -0600 cl-asdf (1.46) unstable; urgency=low * New upstream version, adds run-shell-command for openmcl -- Kevin M. Rosenberg Fri, 20 Sep 2002 10:11:48 -0600 cl-asdf (1.45) unstable; urgency=low * Changes to improve clisp support -- Kevin M. Rosenberg Fri, 20 Sep 2002 07:12:21 -0600 cl-asdf (1.44.1-1) unstable; urgency=low * Make cclan.asd a symlink, remove :pathname keyword -- Kevin M. Rosenberg Wed, 18 Sep 2002 00:19:26 -0600 cl-asdf (1.44-1) unstable; urgency=low * New upstream version -- Kevin M. Rosenberg Tue, 17 Sep 2002 12:24:27 -0600 cl-asdf (1.43-1) unstable; urgency=low * New upstream version -- Kevin M. Rosenberg Tue, 17 Sep 2002 10:34:57 -0600 cl-asdf (1.42-2) unstable; urgency=low * Add reregister-common-lisp-implementations call when installing cl-asdf. -- Kevin M. Rosenberg Mon, 16 Sep 2002 08:31:13 -0600 cl-asdf (1.42-1) unstable; urgency=low * Remove Depends on lisp-compiler for cl-asdf (fixes problem with circular dependencies) -- Kevin M. Rosenberg Sat, 14 Sep 2002 11:59:58 -0600 cl-asdf (1.42) unstable; urgency=low * New upstream. -- Kevin M. Rosenberg Fri, 13 Sep 2002 08:40:58 -0600 cl-asdf (1.41) unstable; urgency=low * Same release as 1.40, but with proper version number. -- Kevin M. Rosenberg Fri, 13 Sep 2002 08:38:30 -0600 cl-asdf (1.40) unstable; urgency=low * New upstream version. -- Kevin M. Rosenberg Fri, 13 Sep 2002 07:31:27 -0600 cl-asdf (1.39) unstable; urgency=low * New upstream version. -- Kevin M. Rosenberg Wed, 11 Sep 2002 19:21:32 -0600 cl-asdf (1.38) unstable; urgency=low * New upstream version * Re-add register and unregister clc-source for cclan -- Kevin M. Rosenberg Wed, 11 Sep 2002 13:39:51 -0600 cl-asdf (1.35-1) unstable; urgency=low * Comment call to register and unregister clc-source until new version of clc is released. (closes: 158697) -- Kevin M. Rosenberg Wed, 28 Aug 2002 18:58:59 -0600 cl-asdf (1.35) unstable; urgency=high * New upstream version, fixes important bugs. -- Kevin M. Rosenberg Wed, 28 Aug 2002 09:36:58 -0600 cl-asdf (1.34) unstable; urgency=low * New upstream version. -- Kevin M. Rosenberg Wed, 28 Aug 2002 07:18:57 -0600 cl-asdf (0.0+cvs.2002.08.26-1) unstable; urgency=low * Add Common Lisp Controller registration functions for cl-cclan -- Kevin M. Rosenberg Mon, 26 Aug 2002 04:21:32 -0600 cl-asdf (0.0+cvs.2002.08.26) unstable; urgency=low * New upstream version -- Kevin M. Rosenberg Mon, 26 Aug 2002 01:23:48 -0600 cl-asdf (0.0+cvs.2002.08.22) unstable; urgency=low * Add new binary package: cl-cclan -- Kevin M. Rosenberg Thu, 22 Aug 2002 12:43:21 -0600 cl-asdf (0.0+cvs.2002.08.18) unstable; urgency=low * New upstream version * Expand description in control file. * Change version numbering scheme since upstream has native debian directory -- Kevin M. Rosenberg Sat, 17 Aug 2002 14:25:33 -0600 cl-asdf (0.0+cvs.2002.08.15-1) unstable; urgency=low * Initial Release (closes: 157009) -- Kevin M. Rosenberg Fri, 16 Aug 2002 23:14:49 -0600 cl-asdf-3.0.3/debian/cl-asdf.dirs000066400000000000000000000005051223164443400164470ustar00rootroot00000000000000/usr/share/common-lisp/source/cl-asdf/ /usr/share/common-lisp/source/cl-asdf/build/ /usr/share/common-lisp/source/cl-asdf/uiop/ /usr/share/common-lisp/source/cl-asdf/uiop/contrib/ /usr/share/common-lisp/source/cl-asdf/contrib/ /usr/share/doc/cl-asdf/ /usr/share/doc/cl-asdf/examples/ /etc/common-lisp/source-registry.conf.d/ cl-asdf-3.0.3/debian/cl-asdf.doc-base000066400000000000000000000004411223164443400171620ustar00rootroot00000000000000Document: asdf Title: ASDF User Manual Author: Danual Barlow Abstract: This manual describes the usage of ASDF Section: Programming Format: HTML Index: /usr/share/doc/cl-asdf/asdf/index.html Files: /usr/share/doc/cl-asdf/asdf/*.html Format: PDF Files: /usr/share/doc/cl-asdf/asdf.pdf.gz cl-asdf-3.0.3/debian/cl-asdf.docs000066400000000000000000000000351223164443400164340ustar00rootroot00000000000000doc/asdf.pdf doc/asdf README cl-asdf-3.0.3/debian/cl-asdf.examples000066400000000000000000000000071223164443400173210ustar00rootroot00000000000000test/* cl-asdf-3.0.3/debian/cl-asdf.info000066400000000000000000000000161223164443400164360ustar00rootroot00000000000000doc/asdf.info cl-asdf-3.0.3/debian/cl-asdf.install000066400000000000000000000001511223164443400171510ustar00rootroot00000000000000uiop/ *.lisp build/ contrib/ asdf.asd build.xcvb version.lisp-expr usr/share/common-lisp/source/cl-asdf/ cl-asdf-3.0.3/debian/cl-asdf.postinst000066400000000000000000000032331223164443400173720ustar00rootroot00000000000000#!/bin/bash # postinst script for common-lisp-controller # # see: dh_installdeb(1) set -e # summary of how this script can be called: # * `configure' # * `abort-upgrade' # * `abort-remove' `in-favour' # # * `abort-deconfigure' `in-favour' # `removing' # # for details, see /usr/share/doc/packaging-manual/ # # quoting from the policy: # Any necessary prompting should almost always be confined to the # post-installation script, and should be protected with a conditional # so that unnecessary prompting doesn't happen if a package's # installation fails and the `postinst' is called with `abort-upgrade', # `abort-remove' or `abort-deconfigure'. . /usr/share/debconf/confmodule case "$1" in configure) # We need to rebuild the images for compiler in /usr/lib/common-lisp/bin/*.sh ; do if [ -f "$compiler" -a -r "$compiler" ] ; then i=${compiler##*/} i=${i%.sh} if [ -x "$compiler" ] ; then echo Reinstalling for $i echo Recompiling Common Lisp Controller for $i bash "$compiler" install-clc || true echo echo Done rebuilding fi fi done ;; abort-upgrade|abort-remove|abort-deconfigure) ;; *) echo "postinst called with unknown argument \`$1'" >&2 exit 0 ;; esac # dh_installdeb will replace this with shell code automatically # generated by other debhelper scripts. #DEBHELPER# exit 0 cl-asdf-3.0.3/debian/compat000066400000000000000000000000021223164443400154510ustar00rootroot000000000000007 cl-asdf-3.0.3/debian/control000066400000000000000000000023231223164443400156560ustar00rootroot00000000000000Source: cl-asdf Section: lisp Priority: optional Maintainer: Debian Common Lisp Team Uploaders: Peter Van Eynde , Milan Zamazal , Christoph Egger , Julien Danjou , Robert P. Goldman Build-Depends: debhelper (>> 7) Build-Depends-Indep: texinfo, texlive-extra-utils, texlive, texlive-generic-recommended Standards-Version: 3.9.3 Homepage: http://common-lisp.net/project/asdf/ Vcs-Git: git://common-lisp.net/projects/asdf/asdf.git Package: cl-asdf Architecture: all Recommends: common-lisp-controller, sbcl | lisp-compiler Replaces: sbcl-common (<= 1:0.9.13.0-2) Breaks: sbcl-common (<= 1:0.9.13.0-2), common-lisp-controller (<< 7.3) Depends: ${misc:Depends} Description: Another System Definition Facility asdf provides a "make" type functions for Common Lisp software. It drives compilation and dynamic loading for complex Lisp systems with multiple modules and files, and is the de facto standard used by free software written in Common Lisp. . Most Common Lisp implementations already provide asdf via (require "asdf"), but not all of them provide an up-to-date version. cl-asdf-3.0.3/debian/copyright000066400000000000000000000033371223164443400162140ustar00rootroot00000000000000This package was debianized by Kevin M. Rosenberg on Fri, 16 Aug 2002 23:14:49 -0600. It was downloaded from SourceForge CVS server with the below commands: cvs -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan login (no password: just press Enter) cvs -z3 -d:pserver:anonymous@cvs.cclan.sourceforge.net:/cvsroot/cclan \ co asdf The debian related changes and files are licensed according to the GPL-v2, see /usr/share/common-licenses/GPL-2 Upstream Authors: Dan Barlow & Contributors Copyright: (This is the MIT / X Consortium license as taken from http://www.opensource.org/licenses/mit-license.html) Copyright (c) 2001-2007 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. cl-asdf-3.0.3/debian/rules000077500000000000000000000017501223164443400153360ustar00rootroot00000000000000#!/usr/bin/make -f # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 build: build-stamp build-stamp: dh_testdir make make -C doc all ln -sf build/asdf.lisp . touch build-stamp build-arch: build-indep: build clean: dh_testdir dh_testroot rm -f build-stamp make -C doc veryclean dh_clean # Build architecture-dependent files here. binary-arch: build # We have nothing to do by default. # Build architecture-independent files here. binary-indep: build dh_testdir -i dh_testroot -i dh_prep -i chmod +x test/run-tests.sh dh_installdirs -i dh_install -i #dh_lisp -i dh_installdocs -i dh_installinfo -i dh_installexamples -i dh_installchangelogs dh_link --verbose -i dh_strip -i dh_compress -i dh_fixperms -i dh_installdeb -i dh_shlibdeps -i dh_gencontrol -i dh_md5sums -i dh_builddeb -i source diff: @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary cl-asdf-3.0.3/debian/source/000077500000000000000000000000001223164443400155535ustar00rootroot00000000000000cl-asdf-3.0.3/debian/source/format000066400000000000000000000000141223164443400167610ustar00rootroot000000000000003.0 (quilt) cl-asdf-3.0.3/debian/watch000066400000000000000000000000431223164443400153010ustar00rootroot00000000000000# upstream uses git which we track cl-asdf-3.0.3/defsystem.lisp000066400000000000000000000302131223164443400157240ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Defsystem (asdf/package:define-package :asdf/defsystem (:recycle :asdf/defsystem :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/cache :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate :asdf/backward-internals) (:export #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form #:non-toplevel-system #:non-system-system #:sysdef-error-component #:check-component-input)) (in-package :asdf/defsystem) ;;; Pathname (with-upgradability () (defun determine-system-directory (pathname) ;; The defsystem macro calls this function to determine ;; the pathname of a system as follows: ;; 1. if the pathname argument is an pathname object (NOT a namestring), ;; that is already an absolute pathname, return it. ;; 2. otherwise, the directory containing the LOAD-PATHNAME ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and ;; if it is indeed available and an absolute pathname, then ;; the PATHNAME argument is normalized to a relative pathname ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) ;; and merged into that DIRECTORY as per SUBPATHNAME. ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, ;; and may be from within the EVAL-WHEN of a file compilation. ;; If no absolute pathname was found, we return NIL. (check-type pathname (or null string pathname)) (pathname-directory-pathname (resolve-symlinks* (ensure-absolute-pathname (parse-unix-namestring pathname :type :directory) #'(lambda () (ensure-absolute-pathname (load-pathname) 'get-pathname-defaults nil)) nil))))) ;;; Component class (with-upgradability () (defvar *default-component-class* 'cl-source-file) (defun class-for-type (parent type) (or (loop :for symbol :in (list type (find-symbol* type *package* nil) (find-symbol* type :asdf/interface nil) (and (stringp type) (safe-read-from-string type :package :asdf/interface))) :for class = (and symbol (symbolp symbol) (find-class* symbol nil)) :when (and class (#-cormanlisp subtypep #+cormanlisp cl::subclassp class (find-class* 'component))) :return class) (and (eq type :file) (find-class* (or (loop :for p = parent :then (component-parent p) :while p :thereis (module-default-component-class p)) *default-component-class*) nil)) (sysdef-error "don't recognize component type ~A" type)))) ;;; Check inputs (with-upgradability () (define-condition non-system-system (system-definition-error) ((name :initarg :name :reader non-system-system-name) (class-name :initarg :class-name :reader non-system-system-class-name)) (:report (lambda (c s) (format s (compatfmt "~@") (non-system-system-name c) (non-system-system-class-name c) 'system)))) (define-condition non-toplevel-system (system-definition-error) ((parent :initarg :parent :reader non-toplevel-system-parent) (name :initarg :name :reader non-toplevel-system-name)) (:report (lambda (c s) (format s (compatfmt "~@") (non-toplevel-system-parent c) (non-toplevel-system-name c))))) (defun sysdef-error-component (msg type name value) (sysdef-error (strcat msg (compatfmt "~&~@")) type name value)) (defun check-component-input (type name weakly-depends-on depends-on components) "A partial test of the values of a component." (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." type name depends-on)) (unless (listp weakly-depends-on) (sysdef-error-component ":weakly-depends-on must be a list." type name weakly-depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." type name components))) (defun* (normalize-version) (form &key pathname component parent) (labels ((invalid (&optional (continuation "using NIL instead")) (warn (compatfmt "~@") form component parent pathname continuation)) (invalid-parse (control &rest args) (unless (builtin-system-p (find-component parent component)) (apply 'warn control args) (invalid)))) (if-let (v (typecase form ((or string null) form) (real (invalid "Substituting a string") (format nil "~D" form)) ;; 1.0 becomes "1.0" (cons (case (first form) ((:read-file-form) (destructuring-bind (subpath &key (at 0)) (rest form) (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user))) ((:read-file-line) (destructuring-bind (subpath &key (at 0)) (rest form) (safe-read-file-line (subpathname pathname subpath) :at at))) (otherwise (invalid)))) (t (invalid)))) (if-let (pv (parse-version v #'invalid-parse)) (unparse-version pv) (invalid)))))) ;;; Main parsing function (with-upgradability () (defun* (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key (builtin-system-p () bspp) ;; the following list of keywords is reproduced below in the ;; remove-plist-keys form. important to keep them in sync components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial do-first if-component-dep-fails version ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) (check-component-input type name weakly-depends-on depends-on components) (when (and parent (find-component parent name) (not ;; ignore the same object when rereading the defsystem (typep (find-component parent name) (class-for-type parent type)))) (error 'duplicate-names :name name)) (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) (let* ((name (coerce-name name)) (args `(:name ,name :pathname ,pathname ,@(when parent `(:parent ,parent)) ,@(remove-plist-keys '(:components :pathname :if-component-dep-fails :version :perform :explain :output-files :operation-done-p :weakly-depends-on :depends-on :serial) rest))) (component (find-component parent name)) (class (class-for-type parent type))) (when (and parent (subtypep class 'system)) (error 'non-toplevel-system :parent parent :name name)) (if component ; preserve identity (apply 'reinitialize-instance component args) (setf component (apply 'make-instance class args))) (component-pathname component) ; eagerly compute the absolute pathname (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous (when (and (typep component 'system) (not bspp)) (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) (setf version (normalize-version version :component name :parent parent :pathname sysfile))) ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. ;; A better fix is required. (setf (slot-value component 'version) version) (when (typep component 'parent-component) (setf (component-children component) (loop :with previous-component = nil :for c-form :in components :for c = (parse-component-form component c-form :previous-serial-component previous-component) :for name = (component-name c) :collect c :when serial :do (setf previous-component name))) (compute-children-by-name component)) (when previous-serial-component (push previous-serial-component depends-on)) (when weakly-depends-on ;; ASDF4: deprecate this feature and remove it. (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) ;; Used by POIU. ASDF4: rename to component-depends-on? (setf (component-sideway-dependencies component) depends-on) (%refresh-component-inline-methods component rest) (when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails component)) component))) (defun register-system-definition (name &rest options &key pathname (class 'system) (source-file () sfp) defsystem-depends-on &allow-other-keys) ;; The system must be registered before we parse the body, ;; otherwise we recur when trying to find an existing system ;; of the same name to reuse options (e.g. pathname) from. ;; To avoid infinite recursion in cases where you defsystem a system ;; that is registered to a different location to find-system, ;; we also need to remember it in a special variable *systems-being-defined*. (with-system-definitions () (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) (registered (system-registered-p name)) (registered! (if registered (rplaca registered (get-file-stamp source-file)) (register-system (make-instance 'system :name name :source-file source-file)))) (system (reset-system (cdr registered!) :name name :source-file source-file)) (component-options (remove-plist-key :class options)) (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect (resolve-dependency-spec nil spec)))) (setf (gethash name *systems-being-defined*) system) (load-systems* defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. (let ((class (class-for-type nil class))) (unless (subtypep class 'system) (error 'non-system-system :name name :class-name (class-name class))) (unless (eq (type-of system) class) (change-class system class))) (parse-component-form nil (list* :module name :pathname (determine-system-directory pathname) component-options))))) (defmacro defsystem (name &body options) `(apply 'register-system-definition ',name ',options))) cl-asdf-3.0.3/doc/000077500000000000000000000000001223164443400135765ustar00rootroot00000000000000cl-asdf-3.0.3/doc/.htaccess000066400000000000000000000001211223164443400153660ustar00rootroot00000000000000Redirect /project/asdf/manual.html http://common-lisp.net/project/asdf/asdf.html cl-asdf-3.0.3/doc/Makefile000066400000000000000000000015471223164443400152450ustar00rootroot00000000000000#user=frideau ifeq (${user},) userat := else userat := ${user}@ endif website:=${userat}common-lisp.net:/project/asdf/public_html/ output = asdf.html asdf asdf.pdf asdf.info webfiles = index.html .htaccess style.css cclan.png lisp-logo120x80.png favicon.ico ${output} intermediate = asdf.cps asdf.log asdf.vr asdf.aux asdf.fn asdf.toc asdf.vrs \ asdf.cp asdf.fns asdf.ky asdf.pg asdf.tp all: asdf.html asdf.info asdf.pdf manual-html manual-html: asdf.texinfo makeinfo --html asdf.texinfo asdf.html: asdf.texinfo makeinfo --html --no-split --no-headers -o asdf.html asdf.texinfo asdf.info: asdf.texinfo makeinfo asdf.texinfo asdf.pdf: asdf.texinfo texi2pdf asdf.texinfo website: all rsync -av ${webfiles} ${website} .PHONY: clean veryclean manual-html clean: rm -f ${intermediate} veryclean: clean rm -f asdf.html asdf.pdf asdf.info rm -rf asdf/ asdf.t2d/ cl-asdf-3.0.3/doc/asdf.texinfo000066400000000000000000005551001223164443400161170ustar00rootroot00000000000000\input texinfo @c -*- texinfo -*- @c %**start of header @setfilename asdf.info @settitle ASDF Manual @c %**end of header @c We use @&key, etc to escape & from TeX in lambda lists -- @c so we need to define them for info as well. @macro AallowOtherKeys &allow-other-keys @end macro @macro Aoptional &optional @end macro @macro Arest &rest @end macro @macro Akey &key @end macro @macro Abody &body @end macro @c for install-info @dircategory Software development @direntry * asdf: (asdf). Another System Definition Facility (for Common Lisp) @end direntry @copying This manual describes ASDF, a system definition facility for Common Lisp programs and libraries. You can find the latest version of this manual at @url{http://common-lisp.net/project/asdf/asdf.html}. ASDF Copyright @copyright{} 2001-2013 Daniel Barlow and contributors. This manual Copyright @copyright{} 2001-2013 Daniel Barlow and contributors. This manual revised @copyright{} 2009-2013 Robert P. Goldman and Francois-Rene Rideau. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ``Software''), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. @end copying @titlepage @title ASDF: Another System Definition Facility @c The following two commands start the copyright page. @page @vskip 0pt plus 1filll @insertcopying @end titlepage @c Output the table of contents at the beginning. @contents @c ------------------- @ifnottex @node Top, Introduction, (dir), (dir) @top asdf: another system definition facility @insertcopying @menu * Introduction:: * Loading ASDF:: * Configuring ASDF:: * Using ASDF:: * Defining systems with defsystem:: * The object model of ASDF:: * Controlling where ASDF searches for systems:: * Controlling where ASDF saves compiled files:: * Error handling:: * Miscellaneous additional functionality:: * Getting the latest version:: * FAQ:: * TODO list:: * Inspiration:: * Concept Index:: * Function and Class Index:: * Variable Index:: @c @detailmenu @c --- The Detailed Node Listing --- @c Defining systems with defsystem @c * The defsystem form:: @c * A more involved example:: @c * The defsystem grammar:: @c * Other code in .asd files:: @c The object model of ASDF @c * Operations:: @c * Components:: @c * Functions:: @c Operations @c * Predefined operations of ASDF:: @c * Creating new operations:: @c Components @c * Common attributes of components:: @c * Pre-defined subclasses of component:: @c * Creating new component types:: @c properties @c * Pre-defined subclasses of component:: @c * Creating new component types:: @c @end detailmenu @end menu @end ifnottex @c ------------------- @node Introduction, Loading ASDF, Top, Top @comment node-name, next, previous, up @chapter Introduction @cindex ASDF-related features @vindex *features* @cindex Testing for ASDF @cindex ASDF versions @cindex :asdf @cindex :asdf2 @cindex :asdf3 ASDF is Another System Definition Facility: a tool for specifying how systems of Common Lisp software are comprised of components (sub-systems and files), and how to operate on these components in the right order so that they can be compiled, loaded, tested, etc. ASDF presents three faces: one for users of Common Lisp software who want to reuse other people's code, one for writers of Common Lisp software who want to specify how to build their systems, one for implementers of Common Lisp extensions who want to extend the build system. @xref{Using ASDF,,Loading a system}, to learn how to use ASDF to load a system. @xref{Defining systems with defsystem}, to learn how to define a system of your own. @xref{The object model of ASDF}, for a description of the ASDF internals and how to extend ASDF. @emph{Nota Bene}: We have released ASDF 2.000 on May 31st 2010, and ASDF 3.0 on January 31st 2013. Releases of ASDF 2 and later have since then been included in all actively maintained CL implementations that used to bundle ASDF 1, plus some implementations that didn't use to, and has been made to work with all actively used CL implementations and a few more. @xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 or ASDF 3 on the fly. For this reason, we have stopped supporting ASDF 1 and ASDF 2. If you are using ASDF 1 or ASDF 2 and are experiencing any kind of issues or limitations, we recommend you upgrade to ASDF 3 --- and we explain how to do that. @xref{Loading ASDF}. Also note that ASDF is not to be confused with ASDF-Install. ASDF-Install is not part of ASDF, but a separate piece of software. ASDF-Install is also unmaintained and obsolete. We recommend you use Quicklisp instead, which works great and is being actively maintained. If you want to download software from version control instead of tarballs, so you may more easily modify it, we recommend clbuild. @node Loading ASDF, Configuring ASDF, Introduction, Top @comment node-name, next, previous, up @chapter Loading ASDF @vindex *central-registry* @cindex link farm @findex load-system @findex require-system @findex compile-system @findex test-system @cindex system directory designator @findex operate @findex oos @c @menu @c * Installing ASDF:: @c @end menu @section Loading a pre-installed ASDF Most recent Lisp implementations include a copy of ASDF 2, and soon ASDF 3. You can usually load this copy using Common Lisp's @code{require} function: @lisp (require "asdf") @end lisp As of the writing of this manual, the following implementations provide ASDF 2 this way: abcl allegro ccl clisp cmucl ecl lispworks mkcl sbcl xcl. The following implementation doesn't provide it yet but will in an upcoming release: scl. The following implementations are obsolete, not actively maintained, and most probably will never bundle it: cormanlisp gcl genera mcl. If the implementation you are using doesn't provide ASDF 2 or ASDF 3, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. If that implementation is still actively maintained, you may also send a bug report to your Lisp vendor and complain about their failing to provide ASDF. NB: all implementations except clisp also accept @code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}. For portability's sake, you probably want to use @code{(require "asdf")}. @section Checking whether ASDF is loaded To check whether ASDF is properly loaded in your current Lisp image, you can run this form: @lisp (asdf:asdf-version) @end lisp If it returns a string, that is the version of ASDF that is currently installed. If it raises an error, then either ASDF is not loaded, or you are using an old version of ASDF. You can check whether an old version is loaded by checking if the ASDF package is present. The form below will allow you to programmatically determine whether a recent version is loaded, an old version is loaded, or none at all: @lisp (when (find-package :asdf) (let ((ver (symbol-value (or (find-symbol (string :*asdf-version*) :asdf) (find-symbol (string :*asdf-revision*) :asdf))))) (etypecase ver (string ver) (cons (with-output-to-string (s) (loop for (n . m) on ver do (princ n s) (when m (princ "." s))))) (null "1.0")))) @end lisp If it returns @code{nil} then ASDF is not installed. Otherwise it should return a string. If it returns @code{"1.0"}, then it can actually be any version before 1.77 or so, or some buggy variant of 1.x. If you are experiencing problems with ASDF, please try upgrading to the latest released version, using the method below, before you contact us and raise an issue. @section Upgrading ASDF If your implementation provides ASDF 3 or later, you only need to @code{(require "asdf")}: ASDF will automatically look whether an updated version of itself is available amongst the regularly configured systems, before it compiles anything else. See @pxref{Configuring ASDF} below. If your implementation does provide ASDF 2 or later, but not ASDF 3 or later, and you want to upgrade to a more recent version, you need to install and configure your ASDF as above, and additionally, you need to explicitly tell ASDF to load itself, right after you require your implementation's old ASDF 2: @lisp (require "asdf") (asdf:load-system :asdf) @end lisp If on the other hand, your implementation only provides an old ASDF, you will require a special configuration step and an old-style loading. Take special attention to not omit the trailing directory separator @code{/} at the end of your pathname: @lisp (require "asdf") (push #p"@var{/path/to/new/asdf/}" asdf:*central-registry*) (asdf:oos 'asdf:load-op :asdf) @end lisp Note that ASDF 1 won't redirect its output files, or at least won't do it according to your usual ASDF 2 configuration. You therefore need write access on the directory where you install the new ASDF, and make sure you're not using it for multiple mutually incompatible implementations. At worst, you may have to have multiple copies of the new ASDF, e.g. one per implementation installation, to avoid clashes. Note that to our knowledge all implementations that provide ASDF provide ASDF 2 in their latest release, so you may want to upgrade your implementation rather than go through that hoop. Finally, if you are using an unmaintained implementation that does not provide ASDF at all, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below. Note that there are some limitations to upgrading ASDF: @itemize @item Previously loaded ASDF extension becomes invalid, and will need to be reloaded. This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc. Since it isn't possible to automatically detect what extensions are present that need to be invalidated, ASDF will actually invalidate all previously loaded systems when it is loaded on top of a different ASDF version, starting with ASDF 2.014.8 (as far as releases go, 2.015); and it will automatically attempt this self-upgrade as its very first step starting with ASDF 3. @item For this an many other reasons, it important reason to load, configure and upgrade ASDF (if needed) as one of the very first things done by your build and startup scripts. Until all implementations provide ASDF 3 or later, it is safer if you upgrade ASDF and its extensions as a special step at the very beginning of whatever script you are running, before you start using ASDF to load anything else; even afterwards, it is still a good idea, to avoid having to load and reload code twice as it gets invalidated. @item Until all implementations provide ASDF 3 or later, it is unsafe to upgrade ASDF as part of loading a system that depends on a more recent version of ASDF, since the new one might shadow the old one while the old one is running, and the running old one will be confused when extensions are loaded into the new one. In the meantime, we recommend that your systems should @emph{not} specify @code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "2.010"))}, but instead that they check that a recent enough ASDF is installed, with such code as: @example (unless (or #+asdf2 (asdf:version-satisfies (asdf:asdf-version) *required-asdf-version*)) (error "FOO requires ASDF ~A or later." *required-asdf-version*)) @end example @item Until all implementations provide ASDF 3 or later, it is unsafe for a system to transitively depend on ASDF and not directly depend on ASDF; if any of the system you use either depends-on asdf, system-depends-on asdf, or transitively does, you should also do as well. @end itemize @section Loading an otherwise installed ASDF If your implementation doesn't include ASDF, if for some reason the upgrade somehow fails, does not or cannot apply to your case, you will have to install the file @file{asdf.lisp} somewhere and load it with: @lisp (load "/path/to/your/installed/asdf.lisp") @end lisp The single file @file{asdf.lisp} is all you normally need to use ASDF. You can extract this file from latest release tarball on the @url{http://common-lisp.net/project/asdf/,ASDF website}. If you are daring and willing to report bugs, you can get the latest and greatest version of ASDF from its git repository. @xref{Getting the latest version}. For maximum convenience you might want to have ASDF loaded whenever you start your Lisp implementation, for example by loading it from the startup script or dumping a custom core --- check your Lisp implementation's manual for details. @node Configuring ASDF, Using ASDF, Loading ASDF, Top @comment node-name, next, previous, up @chapter Configuring ASDF @section Configuring ASDF to find your systems So it may compile and load your systems, ASDF must be configured to find the @file{.asd} files that contain system definitions. Since ASDF 2, the preferred way to configure where ASDF finds your systems is the @code{source-registry} facility, fully described in its own chapter of this manual. @xref{Controlling where ASDF searches for systems}. The default location for a user to install Common Lisp software is under @file{~/.local/share/common-lisp/source/}. If you install software there (it can be a symlink), you don't need further configuration. If you're installing software yourself at a location that isn't standard, you have to tell ASDF where you installed it. See below. If you're using some tool to install software (e.g. Quicklisp), the authors of that tool should already have configured ASDF. The simplest way to add a path to your search path, say @file{/home/luser/.asd-link-farm/} is to create the directory @file{~/.config/common-lisp/source-registry.conf.d/} and there create a file with any name of your choice, and with the type @file{conf}, for instance @file{42-asd-link-farm.conf} containing the line: @kbd{(:directory "/home/luser/.asd-link-farm/")} If you want all the subdirectories under @file{/home/luser/lisp/} to be recursively scanned for @file{.asd} files, instead use: @kbd{(:tree "/home/luser/lisp/")} Note that your Operating System distribution or your system administrator may already have configured system-managed libraries for you. The required @file{.conf} extension allows you to have disabled files or editor backups (ending in @file{~}), and works portably (for instance, it is a pain to allow both empty and non-empty extension on CLISP). Excluded are files the name of which start with a @file{.} character. It is customary to start the filename with two digits that specify the order in which the directories will be scanned. ASDF will automatically read your configuration the first time you try to find a system. You can reset the source-registry configuration with: @lisp (asdf:clear-source-registry) @end lisp And you probably should do so before you dump your Lisp image, if the configuration may change between the machine where you save it at the time you save it and the machine you resume it at the time you resume it. Actually, you should use @code{(asdf:clear-configuration)} before you dump your Lisp image, which includes the above. @section Configuring ASDF to find your systems --- old style The old way to configure ASDF to find your systems is by @code{push}ing directory pathnames onto the variable @code{asdf:*central-registry*}. You must configure this variable between the time you load ASDF and the time you first try to use it. Loading and configuring ASDF presumably happen as part of some initialization script that builds or starts your Common Lisp software system. (For instance, some SBCL users used to put it in their @file{~/.sbclrc}.) The @code{asdf:*central-registry*} is empty by default in ASDF 2 or ASDF 3, but is still supported for compatibility with ASDF 1. When used, it takes precedence over the above source-registry@footnote{ It is possible to further customize the system definition file search. That's considered advanced use, and covered later: search forward for @code{*system-definition-search-functions*}. @xref{Defining systems with defsystem}.}. For instance, if you wanted ASDF to find the @file{.asd} file @file{/home/me/src/foo/foo.asd} your initialization script could after it loads ASDF with @code{(require "asdf")} configure it with: @lisp (push "/home/me/src/foo/" asdf:*central-registry*) @end lisp Note the trailing slash: when searching for a system, ASDF will evaluate each entry of the central registry and coerce the result to a pathname@footnote{ ASDF will indeed call @code{eval} on each entry. It will also skip entries that evaluate to @code{nil}. Strings and pathname objects are self-evaluating, in which case the @code{eval} step does nothing; but you may push arbitrary SEXP onto the central registry, that will be evaluated to compute e.g. things that depend on the value of shell variables or the identity of the user. The variable @code{asdf:*central-registry*} is thus a list of ``system directory designators''. A @dfn{system directory designator} is a form which will be evaluated whenever a system is to be found, and must evaluate to a directory to look in. By ``directory'' here, we mean ``designator for a pathname with a supplied DIRECTORY component''. } at which point the presence of the trailing directory name separator is necessary to tell Lisp that you're discussing a directory rather than a file. Typically, however, there are a lot of @file{.asd} files, and a common idiom was to have to put a bunch of @emph{symbolic links} to @file{.asd} files in a common directory and push @emph{that} directory (the ``link farm'') to the @code{asdf:*central-registry*} instead of pushing each of the many involved directories to the @code{asdf:*central-registry*}. ASDF knows how to follow such @emph{symlinks} to the actual file location when resolving the paths of system components (on Windows, you can use Windows shortcuts instead of POSIX symlinks; if you try aliases under MacOS, we are curious to hear about your experience). For example, if @code{#p"/home/me/cl/systems/"} (note the trailing slash) is a member of @code{*central-registry*}, you could set up the system @var{foo} for loading with asdf with the following commands at the shell: @example $ cd /home/me/cl/systems/ $ ln -s ~/src/foo/foo.asd . @end example This old style for configuring ASDF is not recommended for new users, but it is supported for old users, and for users who want to programmatically control what directories are added to the ASDF search path. @section Configuring where ASDF stores object files @findex clear-output-translations ASDF lets you configure where object files will be stored. Sensible defaults are provided and you shouldn't normally have to worry about it. This allows the same source code repository may be shared between several versions of several Common Lisp implementations, between several users using different compilation options and without write privileges on shared source directories, etc. This also allows to keep source directories uncluttered by plenty of object files. Starting with ASDF 2, the @code{asdf-output-translations} facility was added to ASDF itself, that controls where object files will be stored. This facility is fully described in a chapter of this manual, @ref{Controlling where ASDF saves compiled files}. The simplest way to add a translation to your search path, say from @file{/foo/bar/baz/quux/} to @file{/where/i/want/my/fasls/} is to create the directory @file{~/.config/common-lisp/asdf-output-translations.conf.d/} and there create a file with any name of your choice and the type @file{conf}, for instance @file{42-bazquux.conf} containing the line: @kbd{("/foo/bar/baz/quux/" "/where/i/want/my/fasls/")} To disable output translations for source under a given directory, say @file{/toto/tata/} you can create a file @file{40-disable-toto.conf} with the line: @kbd{("/toto/tata/")} To wholly disable output translations for all directories, you can create a file @file{00-disable.conf} with the line: @kbd{(t t)} Note that your Operating System distribution or your system administrator may already have configured translations for you. In absence of any configuration, the default is to redirect everything under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}. @xref{Controlling where ASDF searches for systems}, for full details. The required @file{.conf} extension allows you to have disabled files or editor backups (ending in @file{~}), and works portably (for instance, it is a pain to allow both empty and non-empty extension on CLISP). Excluded are files the name of which start with a @file{.} character. It is customary to start the filename with two digits that specify the order in which the directories will be scanned. ASDF will automatically read your configuration the first time you try to find a system. You can reset the source-registry configuration with: @lisp (asdf:clear-output-translations) @end lisp And you probably should do so before you dump your Lisp image, if the configuration may change between the machine where you save it at the time you save it and the machine you resume it at the time you resume it. (Once again, you should use @code{(asdf:clear-configuration)} before you dump your Lisp image, which includes the above.) Finally note that before ASDF 2, other ASDF add-ons offered the same functionality, each in subtly different and incompatible ways: ASDF-Binary-Locations, cl-launch, common-lisp-controller. ASDF-Binary-Locations is now not needed anymore and should not be used. cl-launch 3.000 and common-lisp-controller 7.2 have been updated to just delegate this functionality to ASDF. @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top @comment node-name, next, previous, up @section Resetting Configuration When you dump and restore an image, or when you tweak your configuration, you may want to reset the ASDF configuration. For that you may use the following function: @defun clear-configuration undoes any ASDF configuration, regarding source-registry or output-translations. @end defun If you use SBCL, CMUCL or SCL, you may use this snippet so that the ASDF configuration be cleared automatically as you dump an image: @example #+(or cmu sbcl scl) (pushnew 'clear-configuration #+(or cmu scl) ext:*before-save-initializations* #+sbcl sb-ext:*save-hooks*) @end example For compatibility with all Lisp implementations, however, you might want instead your build script to explicitly call @code{(asdf:clear-configuration)} at an appropriate moment before dumping. @chapter Using ASDF @section Loading a system The system @var{foo} is loaded (and compiled, if necessary) by evaluating the following Lisp form: @example (asdf:load-system :@var{foo}) @end example On some implementations (namely recent versions of ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL and XCL), ASDF hooks into the @code{CL:REQUIRE} facility and you can just use: @example (require :@var{foo}) @end example In older versions of ASDF, you needed to use @code{(asdf:oos 'asdf:load-op :@var{foo})}. If your ASDF is too old to provide @code{asdf:load-system} though we recommend that you upgrade to ASDF 3. @xref{Loading ASDF,,Loading an otherwise installed ASDF}. Note the name of a system is specified as a string or a symbol, typically a keyword. If a symbol (including a keyword), its name is taken and lowercased. The name must be a suitable value for the @code{:name} initarg to @code{make-pathname} in whatever filesystem the system is to be found. The lower-casing-symbols behaviour is unconventional, but was selected after some consideration. Observations suggest that the type of systems we want to support either have lowercase as customary case (unix, mac, windows) or silently convert lowercase to uppercase (lpns), so this makes more sense than attempting to use @code{:case :common}, which is reported not to work on some implementations @section Other Operations ASDF provides three commands for the most common system operations: @code{load-system}, @code{compile-system} or @code{test-system}. It also provides @code{require-system}, a version of @code{load-system} that skips trying to update systems that are already loaded. Because ASDF is an extensible system for defining @emph{operations} on @emph{components}, it also provides a generic function @code{operate} (which is usually abbreviated by @code{oos}). You'll use @code{oos} whenever you want to do something beyond compiling, loading and testing. Output from ASDF and ASDF extensions are supposed to be sent to the CL stream @code{*standard-output*}, and so rebinding that stream around calls to @code{asdf:operate} should redirect all output from ASDF operations. Reminder: before ASDF can operate on a system, however, it must be able to find and load that system's definition. @xref{Configuring ASDF,,Configuring ASDF to find your systems}. @findex already-loaded-systems For the advanced users, note that @code{require-system} calls @code{load-system} with keyword arguments @code{:force-not (already-loaded-systems)}. @code{already-loaded-systems} returns a list of the names of loaded systems. @code{load-system} applies @code{operate} with the operation from @code{*load-system-operation*}, which by default is @code{load-op}, the system, and any provided keyword arguments. @section Summary To use ASDF: @itemize @item Load ASDF itself into your Lisp image, either through @code{(require "asdf")} or else through @code{(load "/path/to/asdf.lisp")}. @item Make sure ASDF can find system definitions thanks to proper source-registry configuration. @item Load a system with @code{(asdf:load-system :my-system)} or use some other operation on some system of your choice. @end itemize @section Moving on That's all you need to know to use ASDF to load systems written by others. The rest of this manual deals with writing system definitions for Common Lisp software you write yourself, including how to extend ASDF to define new operation and component types. @node Defining systems with defsystem, The object model of ASDF, Using ASDF, Top @comment node-name, next, previous, up @chapter Defining systems with defsystem This chapter describes how to use asdf to define systems and develop software. @menu * The defsystem form:: * A more involved example:: * The defsystem grammar:: * Other code in .asd files:: @end menu @node The defsystem form, A more involved example, Defining systems with defsystem, Defining systems with defsystem @comment node-name, next, previous, up @section The defsystem form Systems can be constructed programmatically by instantiating components using @code{make-instance}. Most of the time, however, it is much more practical to use a static @code{defsystem} form. This section begins with an example of a system definition, then gives the full grammar of @code{defsystem}. Let's look at a simple system. This is a complete file that would usually be saved as @file{hello-lisp.asd}: @lisp (in-package :asdf) (defsystem "hello-lisp" :description "hello-lisp: a sample Lisp system." :version "0.2.1" :author "Joe User " :licence "Public Domain" :components ((:file "packages") (:file "macros" :depends-on ("packages")) (:file "hello" :depends-on ("macros")))) @end lisp Some notes about this example: @itemize @item The file starts with an @code{in-package} form to use package @code{asdf}. You could instead start your definition by using a qualified name @code{asdf:defsystem}. @item If in addition to simply using @code{defsystem}, you are going to define functions, create ASDF extension, globally bind symbols, etc., it is recommended that to avoid namespace pollution between systems, you should create your own package for that purpose, for instance replacing the above @code{(in-package :asdf)} with: @lisp (defpackage :foo-system (:use :cl :asdf)) (in-package :foo-system) @end lisp @item The @code{defsystem} form defines a system named @code{hello-lisp} that contains three source files: @file{packages}, @file{macros} and @file{hello}. @item The file @file{macros} depends on @file{packages} (presumably because the package it's in is defined in @file{packages}), and the file @file{hello} depends on @file{macros} (and hence, transitively on @file{packages}). This means that ASDF will compile and load @file{packages} and @file{macros} before starting the compilation of file @file{hello}. @item The files are located in the same directory as the file with the system definition. ASDF resolves symbolic links (or Windows shortcuts) before loading the system definition file and stores its location in the resulting system@footnote{ It is possible, though almost never necessary, to override this behaviour.}. This is a good thing because the user can move the system sources without having to edit the system definition. @c FIXME: Should have cross-reference to "Version specifiers" in the @c defsystem grammar, but the cross-referencing is so broken by @c insufficient node breakdown that I have not put one in. @item Make sure you know how the @code{:version} numbers will be parsed! They are parsed as period-separated lists of integers. I.e., in the example, @code{0.2.1} is to be interpreted, roughly speaking, as @code{(0 2 1)}. In particular, version @code{0.2.1} is interpreted the same as @code{0.0002.1} and is strictly version-less-than version @code{0.20.1}, even though the two are the same when interpreted as decimal fractions. Instead of a string representing the version, the @code{:version} argument can be an expression that is resolved to such a string using the following trivial domain-specific language: in addition to being a literal string, it can be an expression of the form @code{(:read-file-form :at )}, which will be resolved by reading a form in the specified pathname (read as a subpathname of the current system if relative or a unix-namestring). You may use a @code{uiop:access-at} specifier with the (optional) @code{:at} keyword, by default the specifier is @code{0}, meaning the first form is returned. @cindex :version @end itemize @node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem @comment node-name, next, previous, up @section A more involved example Let's illustrate some more involved uses of @code{defsystem} via a slightly convoluted example: @lisp (defsystem "foo" :version "1.0.0" :components ((:module "mod" :components ((:file "bar") (:file"baz") (:file "quux")) :perform (compile-op :after (op c) (do-something c)) :explain (compile-op :after (op c) (explain-something c))) (:file "blah"))) @end lisp The @code{:module} component named @code{"mod"} is a collection of three files, which will be located in a subdirectory of the main code directory named @file{mod} (this location can be overridden; see the discussion of the @code{:pathname} option in @ref{The defsystem grammar}). The method-form tokens provide a shorthand for defining methods on particular components. This part @lisp :perform (compile-op :after (op c) (do-something c)) :explain (compile-op :after (op c) (explain-something c)) @end lisp has the effect of @lisp (defmethod perform :after ((op compile-op) (c (eql ...))) (do-something c)) (defmethod explain :after ((op compile-op) (c (eql ...))) (explain-something c)) @end lisp where @code{...} is the component in question. In this case @code{...} would expand to something like @lisp (find-component "foo" "mod") @end lisp For more details on the syntax of such forms, see @ref{The defsystem grammar}. For more details on what these methods do, @pxref{Operations} in @ref{The object model of ASDF}. @c The following plunge into the weeds is not appropriate in this @c location. [2010/10/03:rpg] @c note that although this also supports @code{:before} methods, @c they may not do what you want them to --- @c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))} @c will run after all the dependencies and sub-components have been processed, @c but before the component in question has been compiled. @node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem @comment node-name, next, previous, up @section The defsystem grammar @c FIXME: @var typesetting not consistently used here. We should either expand @c its use to everywhere, or we should kill it everywhere. @example system-definition := ( defsystem system-designator @var{system-option}* ) system-option := :defsystem-depends-on system-list | :weakly-depends-on @var{system-list} | :class class-name (see discussion below) | module-option | option module-option := :components component-list | :serial [ t | nil ] option := | :pathname pathname-specifier | :default-component-class class-name | :perform method-form | :explain method-form | :output-files method-form | :operation-done-p method-form | :if-feature feature-expression | :depends-on ( @var{dependency-def}* ) | :in-order-to ( @var{dependency}+ ) system-list := ( @var{simple-component-name}* ) component-list := ( @var{component-def}* ) component-def := ( component-type simple-component-name @var{option}* ) component-type := :module | :file | :static-file | other-component-type other-component-type := symbol-by-name (@pxref{The defsystem grammar,,Component types}) # This is used in :depends-on, as opposed to ``dependency,'' # which is used in :in-order-to dependency-def := simple-component-name | (feature @var{feature-name}) | ( :version simple-component-name version-specifier) # ``dependency'' is used in :in-order-to, as opposed to # ``dependency-def'' dependency := (dependent-op @var{requirement}+) requirement := (required-op @var{required-component}+) | (:feature @var{feature-name}) dependent-op := operation-name required-op := operation-name simple-component-name := string | symbol pathname-specifier := pathname | string | symbol method-form := (operation-name qual lambda-list @Arest body) qual := method qualifier component-dep-fail-option := :fail | :try-next | :ignore feature-expression := keyword | (:and @var{feature-expression}*) | (:or @var{feature-expression}*) | (:not @var{feature-expression}) @end example @subsection Component names Component names (@code{simple-component-name}) may be either strings or symbols. @subsection Component types Component type names, even if expressed as keywords, will be looked up by name in the current package and in the asdf package, if not found in the current package. So a component type @code{my-component-type}, in the current package @code{my-system-asd} can be specified as @code{:my-component-type}, or @code{my-component-type}. @code{system} and its subclasses are @emph{not} allowed as component types for such children components. @subsection System class names A system class name will be looked up in the same way as a Component type (see above), except that only @code{system} and its subclasses are allowed. Typically, one will not need to specify a system class name, unless using a non-standard system class defined in some ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON}, see below. For such class names in the ASDF package, we recommend that the @code{:class} option be specified using a keyword symbol, such as @example :class :MY-NEW-SYSTEM-SUBCLASS @end example This practice will ensure that package name conflicts are avoided. Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into the current package @emph{before} it has been exported from the ASDF extension loaded by @code{:defsystem-depends-on}, causing a name conflict in the current package. @subsection Defsystem depends on @cindex :defsystem-depends-on The @code{:defsystem-depends-on} option to @code{defsystem} allows the programmer to specify another ASDF-defined system or set of systems that must be loaded @emph{before} the system definition is processed. Typically this is used to load an ASDF extension that is used in the system definition. @subsection Weakly depends on @cindex :weakly-depends-on We do @emph{NOT} recommend you use this feature. If you are tempted to write a system @var{foo} that weakly-depends-on a system @var{bar}, we recommend that you should instead write system @var{foo} in a parametric way, and offer some special variable and/or some hook to specialize its behavior; then you should write a system @var{foo+bar} that does the hooking of things together. The (deprecated) @code{:weakly-depends-on} option to @code{defsystem} allows the programmer to specify another ASDF-defined system or set of systems that ASDF should @emph{try} to load, but need not load in order to be successful. Typically this is used if there are a number of systems that, if present, could provide additional functionality, but which are not necessary for basic function. Currently, although it is specified to be an option only to @code{defsystem}, this option is accepted at any component, but it probably only makes sense at the @code{defsystem} level. Programmers are cautioned not to use this component option except at the @code{defsystem} level, as this anomalous behavior may be removed without warning. Finally, you might look into the @code{asdf-system-connections} extension, that will let you define additional code to be loaded when two systems are simultaneously loaded. It may or may not be considered good style, but at least it can be used in a way that has deterministic behavior independent of load order, unlike @code{weakly-depends-on}. @subsection Pathname specifiers @cindex pathname specifiers A pathname specifier (@code{pathname-specifier}) may be a pathname, a string or a symbol. When no pathname specifier is given for a component, which is the usual case, the component name itself is used. If a string is given, which is the usual case, the string will be interpreted as a Unix-style pathname where @code{/} characters will be interpreted as directory separators. Usually, Unix-style relative pathnames are used (i.e. not starting with @code{/}, as opposed to absolute pathnames); they are relative to the path of the parent component. Finally, depending on the @code{component-type}, the pathname may be interpreted as either a file or a directory, and if it's a file, a file type may be added corresponding to the @code{component-type}, or else it will be extracted from the string itself (if applicable). For instance, the @code{component-type} @code{:module} wants a directory pathname, and so a string @code{"foo/bar"} will be interpreted as the pathname @file{#p"foo/bar/"}. On the other hand, the @code{component-type} @code{:file} wants a file of type @code{lisp}, and so a string @code{"foo/bar"} will be interpreted as the pathname @file{#p"foo/bar.lisp"}, and a string @code{"foo/bar.quux"} will be interpreted as the pathname @file{#p"foo/bar.quux.lisp"}. Finally, the @code{component-type} @code{:static-file} wants a file without specifying a type, and so a string @code{"foo/bar"} will be interpreted as the pathname @file{#p"foo/bar"}, and a string @code{"foo/bar.quux"} will be interpreted as the pathname @file{#p"foo/bar.quux"}. ASDF does not interpret the string @code{".."} to designate the parent directory. This string will be passed through to the underlying operating system for interpretation. We @emph{believe} that this will work on all platforms where ASDF is deployed, but do not guarantee this behavior. A pathname object with a relative directory component of @code{:up} or @code{:back} is the only guaranteed way to specify a parent directory. If a symbol is given, it will be translated into a string, and downcased in the process. The downcasing of symbols is unconventional, but was selected after some consideration. Observations suggest that the type of systems we want to support either have lowercase as customary case (Unix, Mac, windows) or silently convert lowercase to uppercase (lpns), so this makes more sense than attempting to use @code{:case :common} as argument to @code{make-pathname}, which is reported not to work on some implementations. Pathname objects may be given to override the path for a component. Such objects are typically specified using reader macros such as @code{#p} or @code{#.(make-pathname ...)}. Note however, that @code{#p...} is a shorthand for @code{#.(parse-namestring ...)} and that the behavior of @code{parse-namestring} is completely non-portable, unless you are using Common Lisp @code{logical-pathname}s, which themselves involve other non-portable behavior (@pxref{The defsystem grammar,,Using logical pathnames}, below). Pathnames made with @code{#.(make-pathname ...)} can usually be done more easily with the string syntax above. The only case that you really need a pathname object is to override the component-type default file type for a given component. Therefore, pathname objects should only rarely be used. Unhappily, ASDF 1 didn't properly support parsing component names as strings specifying paths with directories, and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. An alternative to @code{#.} read-time evaluation is to use @code{(eval `(defsystem ... ,pathname ...))}. Note that when specifying pathname objects, ASDF does not do any special interpretation of the pathname influenced by the component type, unlike the procedure for pathname-specifying strings. On the one hand, you have to be careful to provide a pathname that correctly fulfills whatever constraints are required from that component type (e.g. naming a directory or a file with appropriate type); on the other hand, you can circumvent the file type that would otherwise be forced upon you if you were specifying a string. @subsection Version specifiers @cindex version specifiers @cindex :version Version specifiers are strings to be parsed as period-separated lists of integers. I.e., in the example, @code{"0.2.1"} is to be interpreted, roughly speaking, as @code{(0 2 1)}. In particular, version @code{"0.2.1"} is interpreted the same as @code{"0.0002.1"}, though the latter is not canonical and may lead to a warning being issued. Also, @code{"1.3"} and @code{"1.4"} are both strictly @code{uiop:version<} to @code{"1.30"}, quite unlike what would have happened had the version strings been interpreted as decimal fractions. System definers are encouraged to use version identifiers of the form @var{x}.@var{y}.@var{z} for major version, minor version and patch level, where significant API incompatibilities are signaled by an increased major number. @xref{Common attributes of components}. @subsection Using logical pathnames @cindex logical pathnames We do not generally recommend the use of logical pathnames, especially not so to newcomers to Common Lisp. However, we do support the use of logical pathnames by old timers, when such is their preference. To use logical pathnames, you will have to provide a pathname object as a @code{:pathname} specifier to components that use it, using such syntax as @code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}. You only have to specify such logical pathname for your system or some top-level component. Sub-components' relative pathnames, specified using the string syntax for names, will be properly merged with the pathnames of their parents. The specification of a logical pathname host however is @emph{not} otherwise directly supported in the ASDF syntax for pathname specifiers as strings. The @code{asdf-output-translation} layer will avoid trying to resolve and translate logical pathnames. The advantage of this is that you can define yourself what translations you want to use with the logical pathname facility. The disadvantage is that if you do not define such translations, any system that uses logical pathnames will behave differently under asdf-output-translations than other systems you use. If you wish to use logical pathnames you will have to configure the translations yourself before they may be used. ASDF currently provides no specific support for defining logical pathname translations. Note that the reasons we do not recommend logical pathnames are that (1) there is no portable way to set up logical pathnames before they are used, (2) logical pathnames are limited to only portably use a single character case, digits and hyphens. While you can solve the first issue on your own, describing how to do it on each of fifteen implementations supported by ASDF is more than we can document. As for the second issue, mind that the limitation is notably enforced on SBCL, and that you therefore can't portably violate the limitations but must instead define some encoding of your own and add individual mappings to name physical pathnames that do not fit the restrictions. This can notably be a problem when your Lisp files are part of a larger project in which it is common to name files or directories in a way that includes the version numbers of supported protocols, or in which files are shared with software written in different programming languages where conventions include the use of underscores, dots or CamelCase in pathnames. @subsection Serial dependencies @cindex serial dependencies If the @code{:serial t} option is specified for a module, ASDF will add dependencies for each child component, on all the children textually preceding it. This is done as if by @code{:depends-on}. @lisp :serial t :components ((:file "a") (:file "b") (:file "c")) @end lisp is equivalent to @lisp :components ((:file "a") (:file "b" :depends-on ("a")) (:file "c" :depends-on ("a" "b"))) @end lisp @subsection Source location The @code{:pathname} option is optional in all cases for systems defined via @code{defsystem}, and in the usual case the user is recommended not to supply it. Instead, ASDF follows a hairy set of rules that are designed so that @enumerate @item @code{find-system} will load a system from disk and have its pathname default to the right place. @item This pathname information will not be overwritten with @code{*default-pathname-defaults*} (which could be somewhere else altogether) if the user loads up the @file{.asd} file into his editor and interactively re-evaluates that form. @end enumerate If a system is being loaded for the first time, its top-level pathname will be set to: @itemize @item The host/device/directory parts of @code{*load-truename*}, if it is bound. @item @code{*default-pathname-defaults*}, otherwise. @end itemize If a system is being redefined, the top-level pathname will be @itemize @item changed, if explicitly supplied or obtained from @code{*load-truename*} (so that an updated source location is reflected in the system definition) @item changed if it had previously been set from @code{*default-pathname-defaults*} @item left as before, if it had previously been set from @code{*load-truename*} and @code{*load-truename*} is currently unbound (so that a developer can evaluate a @code{defsystem} form from within an editor without clobbering its source location) @end itemize @subsection if-feature option This option allows you to specify a feature expression to be evaluated as if by @code{#+} to conditionally include a component in your build. If the expression is false, the component is dropped as well as any dependency pointing to it. As compared to using @code{#+} which is expanded at read-time, this allows you to have an object in your component hierarchy that can be used for manipulations beside building your project. This option was added in ASDF 3. @subsection if-component-dep-fails option This option was removed in ASDF 3. Its semantics was limited in purpose and dubious to explain, and its implementation was breaking a hole into the ASDF object model. Please use the @code{if-feature} option instead. @node Other code in .asd files, , The defsystem grammar, Defining systems with defsystem @section Other code in .asd files Files containing @code{defsystem} forms are regular Lisp files that are executed by @code{load}. Consequently, you can put whatever Lisp code you like into these files. However, it is recommended to keep such forms to a minimal, and to instead define @code{defsystem} extensions that you use with @code{:defsystem-depends-on}. If however, you might insist on including code in the @code{.asd} file itself, e.g., to examine and adjust the compile-time environment, possibly adding appropriate features to @code{*features*}. If so, here are some conventions we recommend you follow, so that users can control certain details of execution of the Lisp in @file{.asd} files: @itemize @item Any informative output (other than warnings and errors, which are the condition system's to dispose of) should be sent to the standard CL stream @code{*standard-output*}, so that users can easily control the disposition of output from ASDF operations. @end itemize @node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top @comment node-name, next, previous, up @chapter The object model of ASDF ASDF is designed in an object-oriented way from the ground up. Both a system's structure and the operations that can be performed on systems follow a extensible protocol. This allows the addition of behaviours: for example, @code{cffi} adds support of special FFI description files to interface with C libraries and of wrapper files to embed C code in Lisp; @code{abcl-jar} supports creating Java JAR archives in ABCL; and @code{poiu} supports for compiling code in parallel using background processes. This chapter deals with @code{component}s and @code{operation}s. A @code{component} represents an individual source file or a group of source files, and the things that get transformed into. A @code{system} is a component at the top level of the component hierarchy. A @code{source-file} is a component representing a single source-file and the successive output files into which it is transformed. A @code{module} is an intermediate component itself grouping several other components, themselves source-files or further modules. An @code{Operation} represents a transformation that can be performed on a component, turning them from source files to intermediate results to final outputs. A pair of an @code{operation} and a @code{component} is called an @code{action}. An @code{action} represents a particular build step to be @code{perform}ed, after all its dependencies have been fulfilled. In the ASDF model, actions depend on other actions. The term @emph{action} itself was used by Kent Pitman in his old article, but was only used by ASDF hackers starting with the ASDF 2; but the concept is ubiquitous since the very beginning of ASDF 1, though previously implicit. Then, there are many @emph{functions} available to users, extenders and implementers of ASDF to use, define or implement the activities that are part of building your software. Though they manipulate @code{action}s, most of these functions do not take as an argument a reified pair (a @code{cons} cell) of an operation and a component; instead, they usually take two separate arguments, which allows to take advantage of the power CLOS-style multiple dispatch for fun and profit. There are many @emph{hooks} in which to add functionality, by customizing the behavior of existing @emph{functions}. Last but not least is the notion of @emph{dependency} between two actions. The structure of dependencies between actions is a directed @emph{dependency graph}. ASDF is invoked by being told to @emph{operate} with some @emph{operation} on some toplevel @emph{system}; it will then @emph{traverse} the graph and build a @emph{plan} that follows its structure. To be successfully buildable, this graph of actions but be acyclic. If, as a user, extender or implementer of ASDF, you fail to keep the dependency graph without cycles, ASDF will fail loudly as it eventually finds one. To clearly distinguish the direction of dependencies, ASDF 3 uses the words @emph{requiring} and @emph{required} as applied to an action depending on the other: the requiring action @code{depends-on} the completion of all required actions before it may itself be @code{perform}ed. Using the @code{defsystem} syntax, users may easily express direct dependencies along the graph of the object hierarchy: between a component and its parent, its children, and its siblings. By defining custom CLOS methods, you can express more elaborate dependencies as you wish. Most common operations, such as @code{load-op}, @code{compile-op} or @code{load-source-op} are automatically propagate ``downward'' the component hierarchy and are ``covariant'' with it: to act the operation on the parent module, you must first act it on all the children components, with the action on the parent being parent of the action on each child. Other operations, such as @code{prepare-op} and @code{prepare-source-op} (introduced in ASDF 3) are automatically propagated ``upward'' the component hierarchy and are ``contravariant'' with it: to perform the operation of preparing for compilation of a child component, you must perform the operation of preparing for compilation of its parent component, and so on, ensuring that all the parent's dependencies are (compiled and) loaded before the child component may be compiled and loaded. Yet other operations, such as @code{test-op} or @code{load-fasl-op} remain at the system level, and are not propagated along the hierarchy, but instead do something global on the system. @menu * Operations:: * Components:: * Functions:: @end menu @node Operations, Components, The object model of ASDF, The object model of ASDF @comment node-name, next, previous, up @section Operations @cindex operation An @dfn{operation} object of the appropriate type is instantiated whenever the user wants to do something with a system like @itemize @item compile all its files @item load the files into a running lisp environment @item copy its source files somewhere else @end itemize Operations can be invoked directly, or examined to see what their effects would be without performing them. There are a bunch of methods specialised on operation and component type that actually do the grunt work. The operation object contains whatever state is relevant for this purpose (perhaps a list of visited nodes, for example) but primarily is a nice thing to specialise operation methods on and easier than having them all be @code{EQL} methods. Operations are invoked on systems via @code{operate}. @anchor{operate} @deffn {Generic function} @code{operate} @var{operation} @var{system} @Arest @var{initargs} @Akey @code{force} @code{force-not} @code{verbose} @AallowOtherKeys @deffnx {Generic function} @code{oos} @var{operation} @var{system} @Arest @var{initargs} @Akey @AallowOtherKeys @code{operate} invokes @var{operation} on @var{system}. @code{oos} is a synonym for @code{operate}. @var{operation} is a symbol that is passed, along with the supplied @var{initargs}, to @code{make-instance} to create the operation object. @var{system} is a system designator. The @var{initargs} are passed to the @code{make-instance} call when creating the operation object. Note that dependencies may cause the operation to invoke other operations on the system or its components: the new operations will be created with the same @var{initargs} as the original one. If @var{force} is @code{:all}, then all systems are forced to be recompiled even if not modified since last compilation. If @var{force} is @code{t}, then only the system being loaded is forced to be recompiled even if not modified since last compilation, but other systems are not affected. If @var{force} is a list, then it specifies a list of systems that are forced to be recompiled even if not modified since last compilation. If @var{force-not} is @code{:all}, then all systems are forced not to be recompiled even if modified since last compilation. If @var{force-not} is @code{t}, then only the system being loaded is forced not to be recompiled even if modified since last compilation, but other systems are not affected. If @var{force-not} is a list, then it specifies a list of systems that are forced not to be recompiled even if modified since last compilation. @var{force} takes precedences over @var{force-not}; both of them apply to systems that are dependencies and were already compiled. To see what @code{operate} would do, you can use: @example (asdf:traverse operation-class system-name) @end example @end deffn @menu * Predefined operations of ASDF:: * Creating new operations:: @end menu @node Predefined operations of ASDF, Creating new operations, Operations, Operations @comment node-name, next, previous, up @subsection Predefined operations of ASDF All the operations described in this section are in the @code{asdf} package. They are invoked via the @code{operate} generic function. @lisp (asdf:operate 'asdf:@var{operation-name} :@var{system-name} @{@var{operation-options ...}@}) @end lisp @deffn Operation @code{compile-op} This operation compiles the specified component. A @code{cl-source-file} will be @code{compile-file}'d. All the children and dependencies of a system or module will be recursively compiled by @code{compile-op}. @code{compile-op} depends on @code{prepare-op} which itself depends on a @code{load-op} of all of a component's dependencies, as well as of its parent's dependencies. When @code{operate} is called on @code{compile-op}, all these dependencies will be loaded as well as compiled; yet, some parts of the system main remain unloaded, because nothing depends on them. Use @code{load-op} to load a system. @end deffn @deffn Operation @code{load-op} This operation loads the compiled code for a specified component. A @code{cl-source-file} will have its compiled fasl @code{load}ed, which fasl is the output of @code{compile-op} that @code{load-op} depends on. All the children and dependencies of a system or module will be recursively loaded by @code{load-op}. @code{load-op} depends on @code{prepare-op} which itself depends on a @code{load-op} of all of a component's dependencies, as well as of its parent's dependencies. @end deffn @deffn Operation @code{prepare-op} This operation ensures that the dependencies of a component and its recursive parents are loaded (as per @code{load-op}), as a prerequisite before @code{compile-op} and @code{load-op} operations may be performed on a given component. @end deffn @deffn Operation @code{load-source-op}, @code{prepare-source-op} @code{load-source-op} will load the source for the files in a module rather than they compiled fasl output. It has a @code{prepare-source-op} analog to @code{prepare-op}, that ensures the dependencies are themselves loaded via @code{load-source-op}. There is no provision in ASDF for ensuring that some components are always loaded as source, while others are always compiled. While this idea often comes up in discussions, it actually doesn't play well with either the linking model of ECL or with various bundle operations (see below), and is eventually not workable; also the dependency model of ASDF would have to be modified incompatibly to allow for such trick. If your code doesn't compile cleanly, fix it. If compilation makes it slow, use @code{declaim} or @code{eval-when} to adjust your compiler settings, or eschew compilation by @code{eval}uating a quoted source form at load-time. @end deffn @anchor{test-op} @deffn Operation @code{test-op} This operation will perform some tests on the module. The default method will do nothing. The default dependency is to require @code{load-op} to be performed on the module first. The default @code{operation-done-p} is that the operation is @emph{never} done --- we assume that if you invoke the @code{test-op}, you want to test the system, even if you have already done so. The results of this operation are not defined by ASDF. It has proven difficult to define how the test operation should signal its results to the user in a way that is compatible with all of the various test libraries and test techniques in use in the community. People typically define @code{test-op} methods like thus: @example (defmethod perform ((o asdf:test-op) (s (eql (asdf:find-system @var{:my-system})))) (asdf:load-system @var{:my-system-test}) (funcall (read-from-string "my-system-test:test-suite"))) @end example Using @code{load-system} in the perform method rather than an @code{:in-order-to} dependency, is sometimes necessary for backward compatibility with ASDF 2 and older, to avoid circular dependencies that could arise because of the way these old versions propagate dependencies. If you don't care for compatibility with ASDF 2, you could use the following options in your @code{defsystem} form: @example :in-order-to ((test-op (load-op :my-system-test))) :perform (test-op (o c) (symbol-call :my-system-test :test-suite)) @end example @end deffn @deffn Operation @code{fasl-op}, @code{monolithic-fasl-op}, @code{load-fasl-op}, @code{binary-op}, @code{monolithic-binary-op}, @code{lib-op}, @code{monolithic-lib-op}, @code{dll-op}, @code{monolithic-dll-op}, @code{program-op} These are ``bundle'' operations, that can create a single-file ``bundle'' for all the contents of each system in an application, or for the entire application. @code{fasl-op} will create a single fasl file for each of the systems needed, grouping all its many fasls in one, so you can deliver each system as a single fasl. @code{monolithic-fasl-op} will create a single fasl file for target system and all its dependencies, so you can deliver your entire application as a single fasl. @code{load-fasl-op} will load the output of @code{fasl-op} (though if it the output is not up-to-date, it will load the intermediate fasls indeed as part of building it); this matters a lot on ECL, where the dynamic linking involved in loading tens of individual fasls can be noticeably more expensive than loading a single one. Once you have created a fasl with @code{fasl-op}, you can use @code{precompiled-system} to deliver it in a way that is compatible with clients having dependencies on your system, whether it is distributed as source or as a single binary; the @file{.asd} file to be delivered with the fasl will look like this: @example (defsystem :mysystem :class :precompiled-system :fasl (some expression that will evaluate to a pathname)) @end example Or you can use @code{binary-op} to let ASDF create such a system for you as well as the @code{fasl-op} output, or @code{monolithic-binary-op}. This allows you to deliver code for your systems or applications as a single file. Of course, if you want to test the result in the current image, @emph{before} you try to use any newly created @file{.asd} files, you should not forget to @code{(asdf:clear-configuration)} or at least @code{(asdf:clear-source-registry)}, so it re-populates the source-registry from the filesystem. The @code{program-op} operation will create an executable program from the specified system and its dependencies. You can use UIOP for its pre-image-dump hooks, its post-image-restore hooks, and its access to command-line arguments. And you can specify an entry point @code{my-app:main} by specifying in your @code{defsystem} the option @code{:entry-point "my-app:main"}. Depending on your implementation, running @code{(asdf:operate 'asdf:program-op :my-app)} may quit the current Lisp image upon completion. See the example in @file{test/hello-world-example.asd} and @file{test/hello.lisp}, as built and tested by @file{test/test-program.script} and @file{test/make-hello-world.lisp}. There is also @code{lib-op} for building a linkable @file{.a} file (Windows: @file{.lib}) from all linkable object dependencies (FFI files, and on ECL, Lisp files too), and its monolithic equivalent @code{monolithic-lib-op}. And there is also @code{dll-op} (respectively its monolithic equivalent @code{monolithic-lib-op}) for building a linkable @file{.so} file (Windows: @file{.dll}, MacOS X: @file{.dynlib}) to create a single dynamic library for all the extra FFI code to be linked into each of your systems (respectively your entire application). All these ``bundle'' operations are available since ASDF 3 on all actively supported Lisp implementations, but may be unavailable on unmaintained legacy implementations. This functionality was previously available for select implementations, as part of a separate system @code{asdf-bundle}, itself descended from the ECL-only @code{asdf-ecl}. The pathname of the output of bundle operations is subject to output-translation as usual, unless the operation is equal to the @code{:build-operation} argument to @code{defsystem}. This behavior is not very satisfactory and may change in the future. Maybe you have suggestions on how to better configure it? @end deffn @deffn Operation @code{concatenate-source-op}, @code{monolithic-concatenate-source-op}, @code{load-concatenated-source-op}, @code{compile-concatenated-source-op}, @code{load-compiled-concatenated-source-op}, @code{monolithic-load-concatenated-source-op}, @code{monolithic-compile-concatenated-source-op}, @code{monolithic-load-compiled-concatenated-source-op} These operation, as their respective names indicate, consist in concatenating all @code{cl-source-file} source files in a system (or in a system and all its dependencies, if monolithic), in the order defined by dependencies, then loading the result, or compiling then loading the result. These operations are useful to deliver a system or application as a single source file, and for testing that said file loads properly, or compiles then loads properly. ASDF itself is notably delivered as a single source file this way using @code{monolithic-concatenate-source-op}, transcluding a prelude and the @code{uiop} library before the @code{asdf/defsystem} system itself. @end deffn @node Creating new operations, , Predefined operations of ASDF, Operations @comment node-name, next, previous, up @subsection Creating new operations ASDF was designed to be extensible in an object-oriented fashion. To teach ASDF new tricks, a programmer can implement the behaviour he wants by creating a subclass of @code{operation}. ASDF's pre-defined operations are in no way ``privileged'', but it is requested that developers never use the @code{asdf} package for operations they develop themselves. The rationale for this rule is that we don't want to establish a ``global asdf operation name registry'', but also want to avoid name clashes. Your operation @emph{must} usually provide methods for one or more of the following generic functions: @itemize @item @code{perform} Unless your operation, like @code{prepare-op}, is for dependency propagation only, the most important function for which to define a method is usually @code{perform}, which will be called to perform the operation on a specified component, after all dependencies have been performed. The @code{perform} method must call @code{output-files} (see below) to find out where to put its files, because the user is allowed to override the method or tweak the output-translation mechanism. Perform should only use the primary value returned by @code{output-files}. If one and only one output file is expected, it can call @code{output-file} that checks that this is the case and returns the first and only list element. @item @code{output-files} If your perform method has any output, you must define a method for this function. for ASDF to determine where the outputs of performing operation lie. Your method may return two values, a list of pathnames, and a boolean. If the boolean is @code{nil} (or you fail to return multiple values), then enclosing @code{:around} methods may translate these pathnames, e.g. to ensure object files are somehow stored in some implementation-dependent cache. If the boolean is @code{t} then the pathnames are marked not be translated by the enclosing @code{:around} method. @item @code{component-depends-on} If the action of performing the operation on a component has dependencies, you must define a method on @code{component-depends-on}. Your method will take as specialized arguments an operation and a component which together identify an action, and return a list of entries describing actions that this action depends on. The format of entries is described below. It is @emph{strongly} advised that you should always append the results of @code{(call-next-method)} to the results of your method, or ``interesting'' failures will likely occur, unless you're a true specialist of ASDF internals. It is unhappily too late to compatibly use the @code{append} method combination, but conceptually that's the protocol that is being manually implemented. Each entry returned by @code{component-depends-on} is itself a list. The first element of an entry is an operation designator: either an operation object designating itself, or a symbol that names an operation class (that ASDF will instantiate using @code{make-operation}). For instance, @code{load-op}, @code{compile-op} and @code{prepare-op} are common such names, denoting the respective operations. The rest of each entry is a list of component designators: either a component object designating itself, or an identifier to be used with @code{find-component}. @code{find-component} will be called with the current component's parent as parent, and the identifier as second argument. The identifier is typically a string, a symbol (to be downcased as per @code{coerce-name}), or a list of strings or symbols. In particular, the empty list @code{nil} denotes the parent itself. @end itemize An operation @emph{may} provide methods for the following generic functions: @itemize @item @code{input-files} A method for this function is often not needed, since ASDF has a pretty clever default @code{input-files} mechanism. You only need create a method if there are multiple ultimate input files, and/or the bottom one doesn't depend on the @code{component-pathname} of the component. @item @code{operation-done-p} You only need to define a method on that function if you can detect conditions that invalidate previous runs of the operation, even though no filesystem timestamp has changed, in which case you return @code{nil} (the default is @code{t}). For instance, the method for @code{test-op} always returns @code{nil}, so that tests are always run afresh. Of course, the @code{test-op} for your system could depend on a deterministically repeatable @code{test-report-op}, and just read the results from the report files, in which case you could have this method return @code{t}. @end itemize Operations that print output should send that output to the standard CL stream @code{*standard-output*}, as the Lisp compiler and loader do. @node Components, Functions, Operations, The object model of ASDF @comment node-name, next, previous, up @section Components @cindex component @cindex system @cindex system designator @cindex component designator @vindex *system-definition-search-functions* A @dfn{component} represents a source file or (recursively) a collection of components. A @dfn{system} is (roughly speaking) a top-level component that can be found via @code{find-system}. A @dfn{system designator} is a system itself, or a string or symbol that behaves just like any other component name (including with regard to the case conversion rules for component names). A @dfn{component designator}, relative to a base component, is either a component itself, or a string or symbol, or a list of designators. @defun find-system system-designator @Aoptional (error-p t) Given a system designator, @code{find-system} finds and returns a system. If no system is found, an error of type @code{missing-component} is thrown, or @code{nil} is returned if @code{error-p} is false. To find and update systems, @code{find-system} funcalls each element in the @code{*system-definition-search-functions*} list, expecting a pathname to be returned, or a system object, from which a pathname may be extracted, and that will be registered. The resulting pathname (if any) is loaded if one of the following conditions is true: @itemize @item there is no system of that name in memory @item the pathname is different from that which was previously loaded @item the file's @code{last-modified} time exceeds the @code{last-modified} time of the system in memory @end itemize When system definitions are loaded from @file{.asd} files, a new scratch package is created for them to load into, so that different systems do not overwrite each others operations. The user may also wish to (and is recommended to) include @code{defpackage} and @code{in-package} forms in his system definition files, however, so that they can be loaded manually if need be. The default value of @code{*system-definition-search-functions*} is a list of two functions. The first function looks in each of the directories given by evaluating members of @code{*central-registry*} for a file whose name is the name of the system and whose type is @file{asd}. The first such file is returned, whether or not it turns out to actually define the appropriate system. The second function does something similar, for the directories specified in the @code{source-registry}. Hence, it is strongly advised to define a system @var{foo} in the corresponding file @var{foo.asd}. @end defun @defun find-component base path Given a @var{base} component (or designator for such), and a @var{path}, find the component designated by the @var{path} starting from the @var{base}. If @var{path} is a component object, it designates itself, independently from the base. If @var{path} is a string, or symbol denoting a string via @code{coerce-name}, then @var{base} is resolved to a component object, which must be a system or module, and the designated component is the child named by the @var{path}. If @var{path} is a @code{cons} cell, @code{find-component} with the base and the @code{car} of the @var{path}, and the resulting object is used as the base for a tail call to @code{find-component} with the @code{car} of the @var{path}. If @var{base} is a component object, it designates itself. If @var{base} is null, then @var{path} is used as the base, with @code{nil} as the path. If @var{base} is a string, or symbol denoting a string via @code{coerce-name}, it designates a system as per @code{find-system}. If @var{base} is a @code{cons} cell, it designates the component found by @code{find-component} with its @code{car} as base and @code{cdr} as path. @end defun @menu * Common attributes of components:: * Pre-defined subclasses of component:: * Creating new component types:: @end menu @node Common attributes of components, Pre-defined subclasses of component, Components, Components @comment node-name, next, previous, up @subsection Common attributes of components All components, regardless of type, have the following attributes. All attributes except @code{name} are optional. @subsubsection Name A component name is a string or a symbol. If a symbol, its name is taken and lowercased. Unless overridden by a @code{:pathname} attribute, the name will be interpreted as a pathname specifier according to a Unix-style syntax. @xref{The defsystem grammar,,Pathname specifiers}. @subsubsection Version identifier @findex version-satisfies @cindex :version This optional attribute specifies a version for the current component. The version should typically be a string of integers separated by dots, for example @samp{1.0.11}. For more information on version specifiers, see @ref{The defsystem grammar}. A version may then be queried by the generic function @code{version-satisfies}, to see if @code{:version} dependencies are satisfied, and when specifying dependencies, a constraint of minimal version to satisfy can be specified using e.g. @code{(:version "mydepname" "1.0.11")}. Note that in the wild, we typically see version numbering only on components of type @code{system}. Presumably it is much less useful within a given system, wherein the library author is responsible to keep the various files in synch. @subsubsection Required features Traditionally defsystem users have used @code{#+} reader conditionals to include or exclude specific per-implementation files. This means that any single implementation cannot read the entire system, which becomes a problem if it doesn't wish to compile it, but instead for example to create an archive file containing all the sources, as it will omit to process the system-dependent sources for other systems. Each component in an asdf system may therefore specify using @code{:if-feature} a feature expression using the same syntax as @code{#+} does, such that any reference to the component will be ignored during compilation, loading and/or linking if the expression evaluates to false. Since the expression is read by the normal reader, you must explicitly prefix your symbols with @code{:} so they be read as keywords; this is as contrasted with the @code{#+} syntax that implicitly reads symbols in the keyword package by default. For instance, @code{:if-feature (:and :x86 (:or :sbcl :cmu :scl))} specifies that the given component is only to be compiled and loaded when the implementation is SBCL, CMUCL or Scieneer CL on an x86 machine. You can not write it as @code{:if-feature (and x86 (or sbcl cmu scl))} since the symbols would presumably fail to be read as keywords. @subsubsection Dependencies This attribute specifies dependencies of the component on its siblings. It is optional but often necessary. There is an excitingly complicated relationship between the initarg and the method that you use to ask about dependencies Dependencies are between (operation component) pairs. In your initargs for the component, you can say @lisp :in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) (load-op (load-op "foo"))) @end lisp This means the following things: @itemize @item before performing compile-op on this component, we must perform load-op on @var{a} and @var{b}, and compile-op on @var{c}, @item before performing @code{load-op}, we have to load @var{foo} @end itemize The syntax is approximately @verbatim (this-op @{(other-op required-components)@}+) simple-component-name := string | symbol required-components := simple-component-name | (required-components required-components) component-name := simple-component-name | (:version simple-component-name minimum-version-object) @end verbatim Side note: This is on a par with what ACL defsystem does. mk-defsystem is less general: it has an implied dependency @verbatim for all source file x, (load x) depends on (compile x) @end verbatim and using a @code{:depends-on} argument to say that @var{b} depends on @var{a} @emph{actually} means that @verbatim (compile b) depends on (load a) @end verbatim This is insufficient for e.g. the McCLIM system, which requires that all the files are loaded before any of them can be compiled ] End side note In ASDF, the dependency information for a given component and operation can be queried using @code{(component-depends-on operation component)}, which returns a list @lisp ((load-op "a") (load-op "b") (compile-op "c") ...) @end lisp @code{component-depends-on} can be subclassed for more specific component/operation types: these need to @code{(call-next-method)} and append the answer to their dependency, unless they have a good reason for completely overriding the default dependencies. If it weren't for CLISP, we'd be using @code{LIST} method combination to do this transparently. But, we need to support CLISP. If you have the time for some CLISP hacking, I'm sure they'd welcome your fixes. @c Doesn't CLISP now support LIST method combination? A minimal version can be specified for a component you depend on (typically another system), by specifying @code{(:version "other-system" "1.2.3")} instead of simply @code{"other-system"} as the dependency. See the discussion of the semantics of @code{:version} in the defsystem grammar. @c FIXME: Should have cross-reference to "Version specifiers" in the @c defsystem grammar, but the cross-referencing is so broken by @c insufficient node breakdown that I have not put one in. @subsubsection pathname This attribute is optional and if absent (which is the usual case), the component name will be used. @xref{The defsystem grammar,,Pathname specifiers}, for an explanation of how this attribute is interpreted. Note that the @code{defsystem} macro (used to create a ``top-level'' system) does additional processing to set the filesystem location of the top component in that system. This is detailed elsewhere. @xref{Defining systems with defsystem}. @subsubsection properties This attribute is optional. Packaging systems often require information about files or systems in addition to that specified by ASDF's pre-defined component attributes. Programs that create vendor packages out of ASDF systems therefore have to create ``placeholder'' information to satisfy these systems. Sometimes the creator of an ASDF system may know the additional information and wish to provide it directly. @code{(component-property component property-name)} and associated @code{setf} method will allow the programmatic update of this information. Property names are compared as if by @code{EQL}, so use symbols or keywords or something. @menu * Pre-defined subclasses of component:: * Creating new component types:: @end menu @node Pre-defined subclasses of component, Creating new component types, Common attributes of components, Components @comment node-name, next, previous, up @subsection Pre-defined subclasses of component @deffn Component source-file A source file is any file that the system does not know how to generate from other components of the system. Note that this is not necessarily the same thing as ``a file containing data that is typically fed to a compiler''. If a file is generated by some pre-processor stage (e.g. a @file{.h} file from @file{.h.in} by autoconf) then it is not, by this definition, a source file. Conversely, we might have a graphic file that cannot be automatically regenerated, or a proprietary shared library that we received as a binary: these do count as source files for our purposes. Subclasses of source-file exist for various languages. @emph{FIXME: describe these.} @end deffn @deffn Component module A module is a collection of sub-components. A module component has the following extra initargs: @itemize @item @code{:components} the components contained in this module @item @code{:default-component-class} All children components which don't specify their class explicitly are inferred to be of this type. @item @code{:if-component-dep-fails} This attribute was removed in ASDF 3. Do not use it. Use @code{:if-feature} instead. @item @code{:serial} When this attribute is set, each subcomponent of this component is assumed to depend on all subcomponents before it in the list given to @code{:components}, i.e. all of them are loaded before a compile or load operation is performed on it. @end itemize The default operation knows how to traverse a module, so most operations will not need to provide methods specialised on modules. @code{module} may be subclassed to represent components such as foreign-language linked libraries or archive files. @end deffn @deffn Component system @code{system} is a subclass of @code{module}. A system is a module with a few extra attributes for documentation purposes; these are given elsewhere. @xref{The defsystem grammar}. Users can create new classes for their systems: the default @code{defsystem} macro takes a @code{:class} keyword argument. @end deffn @node Creating new component types, , Pre-defined subclasses of component, Components @comment node-name, next, previous, up @subsection Creating new component types New component types are defined by subclassing one of the existing component classes and specializing methods on the new component class. @emph{FIXME: this should perhaps be explained more throughly, not only by example ...} As an example, suppose we have some implementation-dependent functionality that we want to isolate in one subdirectory per Lisp implementation our system supports. We create a subclass of @code{cl-source-file}: @lisp (defclass unportable-cl-source-file (cl-source-file) ()) @end lisp Function @code{asdf:implementation-type} (exported since 2.014.14) gives us the name of the subdirectory. All that's left is to define how to calculate the pathname of an @code{unportable-cl-source-file}. @lisp (defmethod component-pathname ((component unportable-cl-source-file)) (merge-pathnames* (parse-unix-namestring (format nil "~(~A~)/" (asdf:implementation-type))) (call-next-method))) @end lisp The new component type is used in a @code{defsystem} form in this way: @lisp (defsystem :foo :components ((:file "packages") ... (:unportable-cl-source-file "threads" :depends-on ("packages" ...)) ... ) @end lisp @node Functions, , Components, The object model of ASDF @comment node-name, next, previous, up @section Functions @findex version-satisfies @deffn version-satisfies @var{version} @var{version-spec} Does @var{version} satisfy the @var{version-spec}. A generic function. ASDF provides built-in methods for @var{version} being a @code{component} or @code{string}. @var{version-spec} should be a string. If it's a component, its version is extracted as a string before further processing. A version string satisfies the version-spec if after parsing, the former is no older than the latter. Therefore @code{"1.9.1"}, @code{"1.9.2"} and @code{"1.10"} all satisfy @code{"1.9.1"}, but @code{"1.8.4"} or @code{"1.9"} do not. For more information about how @code{version-satisfies} parses and interprets version strings and specifications, @pxref{The defsystem grammar} (version specifiers) and @ref{Common attributes of components}. Note that in versions of ASDF prior to 3.0.1, including the entire ASDF 1 and ASDF 2 series, @code{version-satisfies} would also require that the version and the version-spec have the same major version number (the first integer in the list); if the major version differed, the version would be considered as not matching the spec. But that feature was not documented, therefore presumably not relied upon, whereas it was a nuisance to several users. Starting with ASDF 3.0.1, @code{version-satisfies} does not treat the major version number specially, and returns T simply if the first argument designates a version that isn't older than the one specified as a second argument. If needs be, the @code{(:version ...)} syntax for specifying dependencies could be in the future extended to specify an exclusive upper bound for compatible versions as well as an inclusive lower bound. @end deffn @node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top @comment node-name, next, previous, up @chapter Controlling where ASDF searches for systems @section Configurations Configurations specify paths where to find system files. @enumerate @item The search registry may use some hardcoded wrapping registry specification. This allows some implementations (notably SBCL) to specify where to find some special implementation-provided systems that need to precisely match the version of the implementation itself. @item An application may explicitly initialize the source-registry configuration using the configuration API (@pxref{Controlling where ASDF searches for systems,Configuration API,Configuration API}, below) in which case this takes precedence. It may itself compute this configuration from the command-line, from a script, from its own configuration file, etc. @item The source registry will be configured from the environment variable @code{CL_SOURCE_REGISTRY} if it exists. @item The source registry will be configured from user configuration file @file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf} (which defaults to @file{~/.config/common-lisp/source-registry.conf}) if it exists. @item The source registry will be configured from user configuration directory @file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/} (which defaults to @file{~/.config/common-lisp/source-registry.conf.d/}) if it exists. @item The source registry will be configured from system configuration file @file{/etc/common-lisp/source-registry.conf} if it exists/ @item The source registry will be configured from system configuration directory @file{/etc/common-lisp/source-registry.conf.d/} if it exists. @item The source registry will be configured from a default configuration. This configuration may allow for implementation-specific systems to be found, for systems to be found the current directory (at the time that the configuration is initialized) as well as @code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and @code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}. For instance, SBCL will include directories for its contribs when it can find them; it will look for them where SBCL was installed, or at the location specified by the @code{SBCL_HOME} environment variable. @end enumerate Each of these configurations is specified as an s-expression in a trivial domain-specific language (defined below). Additionally, a more shell-friendly syntax is available for the environment variable (defined yet below). Each of these configurations is only used if the previous configuration explicitly or implicitly specifies that it includes its inherited configuration. Additionally, some implementation-specific directories may be automatically prepended to whatever directories are specified in configuration files, no matter if the last one inherits or not. @section Truenames and other dangers One great innovation of the original ASDF was its ability to leverage @code{CL:TRUENAME} to locate where your source code was and where to build it, allowing for symlink farms as a simple but effective configuration mechanism that is easy to control programmatically. ASDF 3 still supports this configuration style, and it is enabled by default; however we recommend you instead use our source-registry configuration mechanism described below, because it is easier to setup in a portable way across users and implementations. Addtionally, some people dislike truename, either because it is very slow on their system, or because they are using content-addressed storage where the truename of a file is related to a digest of its individual contents, and not to other files in the same intended project. For these people, ASDF 3 allows to eschew the @code{TRUENAME} mechanism, by setting the variable @var{asdf:*resolve-symlinks*} to @code{nil}. PS: Yes, if you haven't read Vernor Vinge's short but great classic ``True Names... and Other Dangers'' then you're in for a treat. @section XDG base directory Note that we purport to respect the XDG base directory specification as to where configuration files are located, where data files are located, where output file caches are located. Mentions of XDG variables refer to that document. @url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} This specification allows the user to specify some environment variables to customize how applications behave to his preferences. On Windows platforms, when not using Cygwin, instead of the XDG base directory specification, we try to use folder configuration from the registry regarding @code{Common AppData} and similar directories. Since support for querying the Windows registry is not possible to do in reasonable amounts of portable Common Lisp code, ASDF 3 relies on the environment variables that Windows usually exports. @section Backward Compatibility For backward compatibility as well as to provide a practical backdoor for hackers, ASDF will first search for @code{.asd} files in the directories specified in @code{asdf:*central-registry*} before it searches in the source registry above. @xref{Configuring ASDF,,Configuring ASDF to find your systems --- old style}. By default, @code{asdf:*central-registry*} will be empty. This old mechanism will therefore not affect you if you don't use it, but will take precedence over the new mechanism if you do use it. @section Configuration DSL Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration: @c FIXME: This is too wide for happy compilation into pdf. @example ;; A configuration is a single SEXP starting with keyword :source-registry ;; followed by a list of directives. CONFIGURATION := (:source-registry DIRECTIVE ...) ;; A directive is one of the following: DIRECTIVE := ;; INHERITANCE DIRECTIVE: ;; Your configuration expression MUST contain ;; exactly one of either of these: :inherit-configuration | ; splices inherited configuration (often specified last) :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) ;; forward compatibility directive (since ASDF 2.011.4), useful when ;; you want to use new configuration features but have to bootstrap a ;; the newer required ASDF from an older release that doesn't sport said features: :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out ;; add a single directory to be scanned (no recursion) (:directory DIRECTORY-PATHNAME-DESIGNATOR) | ;; add a directory hierarchy, recursing but excluding specified patterns (:tree DIRECTORY-PATHNAME-DESIGNATOR) | ;; override the defaults for exclusion patterns (:exclude EXCLUSION-PATTERN ...) | ;; augment the defaults for exclusion patterns (:also-exclude EXCLUSION-PATTERN ...) | ;; Note that the scope of a an exclude pattern specification is ;; the rest of the current configuration expression or file. ;; splice the parsed contents of another config file (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | ;; This directive specifies that some default must be spliced. :default-registry REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name PATHNAME-DESIGNATOR := NIL | ;; Special: skip this entry. ABSOLUTE-COMPONENT-DESIGNATOR ;; see pathname DSL EXCLUSION-PATTERN := a string without wildcards, that will be matched exactly against the name of a any subdirectory in the directory component of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} @end example Pathnames are designated using another DSL, shared with the output-translations configuration DSL below. The DSL is resolved by the function @code{asdf::resolve-location}, to be documented and exported at some point in the future. @example ABSOLUTE-COMPONENT-DESIGNATOR := (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | STRING | ;; namestring (better be absolute or bust, directory assumed where applicable). ;; In output-translations, directory is assumed and **/*.*.* added if it's last. ;; On MCL, a MacOSX-style POSIX namestring (for MacOS9 style, use #p"..."); ;; Note that none of the above applies to strings used in *central-registry*, ;; which doesn't use this DSL: they are processed as normal namestrings. ;; however, you can compute what you put in the *central-registry* ;; based on the results of say (asdf::resolve-location "/Users/fare/cl/cl-foo/") PATHNAME | ;; pathname (better be an absolute path, or bust) ;; In output-translations, unless followed by relative components, ;; it better have appropriate wildcards, as in **/*.*.* :HOME | ;; designates the user-homedir-pathname ~/ :USER-CACHE | ;; designates the default location for the user cache :HERE | ;; designates the location of the configuration file ;; (or *default-pathname-defaults*, if invoked interactively) :ROOT ;; magic, for output-translations source only: paths that are relative ;; to the root of the source host and device ;; Not valid anymore: :SYSTEM-CACHE (was a security hazard) RELATIVE-COMPONENT-DESIGNATOR := (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | STRING | ;; relative directory pathname as interpreted by parse-unix-namestring. ;; In output translations, if last component, **/*.*.* is added PATHNAME | ;; pathname; unless last component, directory is assumed. :IMPLEMENTATION | ;; directory based on implementation, e.g. sbcl-1.0.45-linux-x64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :DEFAULT-DIRECTORY | ;; a relativized version of the default directory :*/ | ;; any direct subdirectory (since ASDF 2.011.4) :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4) :*.*.* | ;; any file (since ASDF 2.011.4) ;; Not supported (anymore): :UID and :USERNAME @end example For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf}, which is the default place ASDF looks for this configuration, once contained: @example (:source-registry (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" :inherit-configuration) @end example @section Configuration Directories Configuration directories consist in files each containing a list of directives without any enclosing @code{(:source-registry ...)} form. The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included at the @emph{end} of the list. This allows for packaging software that has file granularity (e.g. Debian's @code{dpkg} or some future version of @code{clbuild}) to easily include configuration information about distributed software. The convention is that, for sorting purposes, the names of files in such a directory begin with two digits that determine the order in which these entries will be read. Also, the type of these files is conventionally @code{"conf"} and as a limitation to some implementations (e.g. GNU clisp), the type cannot be @code{nil}. Directories may be included by specifying a directory pathname or namestring in an @code{:include} directive, e.g.: @example (:include "/foo/bar/") @end example Hence, to achieve the same effect as my example @file{~/.config/common-lisp/source-registry.conf} above, I could simply create a file @file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf} alone in its directory with the following contents: @example (:tree "/home/fare/cl/") @end example @subsection The :here directive The @code{:here} directive is an absolute pathname designator that refers to the directory containing the configuration file currently being processed. The @code{:here} directive is intended to simplify the delivery of complex CL systems, and for easy configuration of projects shared through revision control systems, in accordance with our design principle that each participant should be able to provide all and only the information available to him or her. Consider a person X who has set up the source code repository for a complex project with a master directory @file{dir/}. Ordinarily, one might simply have the user add a directive that would look something like this: @example (:tree "path/to/dir") @end example But what if X knows that there are very large subtrees under dir that are filled with, e.g., Java source code, image files for icons, etc.? All of the asdf system definitions are contained in the subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and these are the only directories that should be searched. In this case, X can put into @file{dir/} a file @file{asdf.conf} that contains the following: @example (:source-registry (:tree (:here "src/lisp/")) (:tree (:here "extlib/lisp")) (:directory (:here "outlier/"))) @end example Then when someone else (call her Y) checks out a copy of this repository, she need only add @example (:include "/path/to/my/checkout/directory/asdf.conf") @end example to one of her previously-existing asdf source location configuration files, or invoke @code{initialize-source-registry} with a configuration form containing that s-expression. ASDF will find the .conf file that X has provided, and then set up source locations within the working directory according to X's (relative) instructions. @section Shell-friendly syntax for configuration When considering environment variable @code{CL_SOURCE_REGISTRY} ASDF will skip to next configuration if it's an empty string. It will @code{READ} the string as a SEXP in the DSL if it begins with a paren @code{(} and it will be interpreted much like @code{TEXINPUTS} list of paths, where * paths are separated by a @code{:} (colon) on Unix platforms (including cygwin), by a @code{;} (semicolon) on other platforms (mainly, Windows). * each entry is a directory to add to the search path. * if the entry ends with a double slash @code{//} then it instead indicates a tree in the subdirectories of which to recurse. * if the entry is the empty string (which may only appear once), then it indicates that the inherited configuration should be spliced there. @section Search Algorithm @vindex *default-source-registry-exclusions* In case that isn't clear, the semantics of the configuration is that when searching for a system of a given name, directives are processed in order. When looking in a directory, if the system is found, the search succeeds, otherwise it continues. When looking in a tree, if one system is found, the search succeeds. If multiple systems are found, the consequences are unspecified: the search may succeed with any of the found systems, or an error may be raised. ASDF currently returns the first system found, XCVB currently raised an error. If none is found, the search continues. Exclude statements specify patterns of subdirectories the systems from which to ignore. Typically you don't want to use copies of files kept by such version control systems as Darcs. Exclude statements are not propagated to further included or inherited configuration files or expressions; instead the defaults are reset around every configuration statement to the default defaults from @code{asdf::*default-source-registry-exclusions*}. Include statements cause the search to recurse with the path specifications from the file specified. An inherit-configuration statement cause the search to recurse with the path specifications from the next configuration (@pxref{Controlling where ASDF searches for systems,,Configurations} above). @section Caching Results The implementation is allowed to either eagerly compute the information from the configurations and file system, or to lazily re-compute it every time, or to cache any part of it as it goes. To explicitly flush any information cached by the system, use the API below. @section Configuration API The specified functions are exported from your build system's package. Thus for ASDF the corresponding functions are in package ASDF, and for XCVB the corresponding functions are in package XCVB. @defun initialize-source-registry @Aoptional PARAMETER will read the configuration and initialize all internal variables. You may extend or override configuration from the environment and configuration files with the given @var{PARAMETER}, which can be @code{nil} (no configuration override), or a SEXP (in the SEXP DSL), a string (as in the string DSL), a pathname (of a file or directory with configuration), or a symbol (fbound to function that when called returns one of the above). @end defun @defun clear-source-registry undoes any source registry configuration and clears any cache for the search algorithm. You might want to call this function (or better, @code{clear-configuration}) before you dump an image that would be resumed with a different configuration, and return an empty configuration. Note that this does not include clearing information about systems defined in the current image, only about where to look for systems not yet defined. @end defun @defun ensure-source-registry @Aoptional PARAMETER checks whether a source registry has been initialized. If not, initialize it with the given @var{PARAMETER}. @end defun Every time you use ASDF's @code{find-system}, or anything that uses it (such as @code{operate}, @code{load-system}, etc.), @code{ensure-source-registry} is called with parameter @code{nil}, which the first time around causes your configuration to be read. If you change a configuration file, you need to explicitly @code{initialize-source-registry} again, or maybe simply to @code{clear-source-registry} (or @code{clear-configuration}) which will cause the initialization to happen next time around. @section Status This mechanism is vastly successful, and we have declared that @code{asdf:*central-registry*} is not recommended anymore, though we will continue to support it. All hooks into implementation-specific search mechanisms have been integrated in the @code{wrapping-source-registry} that everyone uses implicitly. @section Rejected ideas Alternatives I considered and rejected included: @enumerate @item Keep @code{asdf:*central-registry*} as the master with its current semantics, and somehow the configuration parser expands the new configuration language into a expanded series of directories of subdirectories to lookup, pre-recursing through specified hierarchies. This is kludgy, and leaves little space of future cleanups and extensions. @item Keep @code{asdf:*central-registry*} remains the master but extend its semantics in completely new ways, so that new kinds of entries may be implemented as a recursive search, etc. This seems somewhat backwards. @item Completely remove @code{asdf:*central-registry*} and break backwards compatibility. Hopefully this will happen in a few years after everyone migrate to a better ASDF and/or to XCVB, but it would be very bad to do it now. @item Replace @code{asdf:*central-registry*} by a symbol-macro with appropriate magic when you dereference it or setf it. Only the new variable with new semantics is handled by the new search procedure. Complex and still introduces subtle semantic issues. @end enumerate I've been suggested the below features, but have rejected them, for the sake of keeping ASDF no more complex than strictly necessary. @itemize @item More syntactic sugar: synonyms for the configuration directives, such as @code{(:add-directory X)} for @code{(:directory X)}, or @code{(:add-directory-hierarchy X)} or @code{(:add-directory X :recurse t)} for @code{(:tree X)}. @item The possibility to register individual files instead of directories. @item Integrate Xach Beane's tilde expander into the parser, or something similar that is shell-friendly or shell-compatible. I'd rather keep ASDF minimal. But maybe this precisely keeps it minimal by removing the need for evaluated entries that ASDF has? i.e. uses of @code{USER-HOMEDIR-PATHNAME} and @code{$SBCL_HOME} Hopefully, these are already superseded by the @code{:default-registry} @item Using the shell-unfriendly syntax @code{/**} instead of @code{//} to specify recursion down a filesystem tree in the environment variable. It isn't that Lisp friendly either. @end itemize @section TODO @itemize @item Add examples @end itemize @section Credits for the source-registry Thanks a lot to Stelian Ionescu for the initial idea. Thanks to Rommel Martinez for the initial implementation attempt. All bad design ideas and implementation bugs are to mine, not theirs. But so are good design ideas and elegant implementation tricks. --- Francois-Rene Rideau @email{fare@@tunes.org}, Mon, 22 Feb 2010 00:07:33 -0500 @node Controlling where ASDF saves compiled files, Error handling, Controlling where ASDF searches for systems, Top @comment node-name, next, previous, up @chapter Controlling where ASDF saves compiled files @cindex asdf-output-translations @vindex ASDF_OUTPUT_TRANSLATIONS Each Common Lisp implementation has its own format for compiled files (fasls for short, short for ``fast loading''). If you use multiple implementations (or multiple versions of the same implementation), you'll soon find your source directories littered with various @file{fasl}s, @file{dfsl}s, @file{cfsl}s and so on. Worse yet, some implementations use the same file extension while changing formats from version to version (or platform to platform) which means that you'll have to recompile binaries as you switch from one implementation to the next. Since ASDF 2, ASDF includes the @code{asdf-output-translations} facility to mitigate the problem. @section Configurations Configurations specify mappings from input locations to output locations. Once again we rely on the XDG base directory specification for configuration. @xref{Controlling where ASDF searches for systems,,XDG base directory}. @enumerate @item Some hardcoded wrapping output translations configuration may be used. This allows special output translations (or usually, invariant directories) to be specified corresponding to the similar special entries in the source registry. @item An application may explicitly initialize the output-translations configuration using the Configuration API in which case this takes precedence. (@pxref{Controlling where ASDF saves compiled files,,Configuration API}.) It may itself compute this configuration from the command-line, from a script, from its own configuration file, etc. @item The source registry will be configured from the environment variable @code{ASDF_OUTPUT_TRANSLATIONS} if it exists. @item The source registry will be configured from user configuration file @file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf} (which defaults to @file{~/.config/common-lisp/asdf-output-translations.conf}) if it exists. @item The source registry will be configured from user configuration directory @file{$XDG_CONFIG_DIRS/common-lisp/asdf-output-translations.conf.d/} (which defaults to @file{~/.config/common-lisp/asdf-output-translations.conf.d/}) if it exists. @item The source registry will be configured from system configuration file @file{/etc/common-lisp/asdf-output-translations.conf} if it exists. @item The source registry will be configured from system configuration directory @file{/etc/common-lisp/asdf-output-translations.conf.d/} if it exists. @end enumerate Each of these configurations is specified as a SEXP in a trival domain-specific language (defined below). Additionally, a more shell-friendly syntax is available for the environment variable (defined yet below). Each of these configurations is only used if the previous configuration explicitly or implicitly specifies that it includes its inherited configuration. Note that by default, a per-user cache is used for output files. This allows the seamless use of shared installations of software between several users, and takes files out of the way of the developers when they browse source code, at the expense of taking a small toll when developers have to clean up output files and find they need to get familiar with output-translations first. @section Backward Compatibility @cindex ASDF-BINARY-LOCATIONS compatibility We purposefully do NOT provide backward compatibility with earlier versions of @code{ASDF-Binary-Locations} (8 Sept 2009), @code{common-lisp-controller} (7.0) or @code{cl-launch} (2.35), each of which had similar general capabilities. The previous APIs of these programs were not designed for configuration by the end-user in an easy way with configuration files. Recent versions of same packages use the new @code{asdf-output-translations} API as defined below: @code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000). @code{ASDF-Binary-Locations} is fully superseded and not to be used anymore. This incompatibility shouldn't inconvenience many people. Indeed, few people use and customize these packages; these few people are experts who can trivially adapt to the new configuration. Most people are not experts, could not properly configure these features (except inasmuch as the default configuration of @code{common-lisp-controller} and/or @code{cl-launch} might have been doing the right thing for some users), and yet will experience software that ``just works'', as configured by the system distributor, or by default. Nevertheless, if you are a fan of @code{ASDF-Binary-Locations}, we provide a limited emulation mode: @defun enable-asdf-binary-locations-compatibility @Akey centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings This function will initialize the new @code{asdf-output-translations} facility in a way that emulates the behavior of the old @code{ASDF-Binary-Locations} facility. Where you would previously set global variables @var{*centralize-lisp-binaries*}, @var{*default-toplevel-directory*}, @var{*include-per-user-information*}, @var{*map-all-source-files*} or @var{*source-to-target-mappings*} you will now have to pass the same values as keyword arguments to this function. Note however that as an extension the @code{:source-to-target-mappings} keyword argument will accept any valid pathname designator for @code{asdf-output-translations} instead of just strings and pathnames. @end defun If you insist, you can also keep using the old @code{ASDF-Binary-Locations} (the one available as an extension to load of top of ASDF, not the one built into a few old versions of ASDF), but first you must disable @code{asdf-output-translations} with @code{(asdf:disable-output-translations)}, or you might experience ``interesting'' issues. Also, note that output translation is enabled by default. To disable it, use @code{(asdf:disable-output-translations)}. @section Configuration DSL Here is the grammar of the SEXP DSL for @code{asdf-output-translations} configuration: @verbatim ;; A configuration is single SEXP starting with keyword :source-registry ;; followed by a list of directives. CONFIGURATION := (:output-translations DIRECTIVE ...) ;; A directive is one of the following: DIRECTIVE := ;; INHERITANCE DIRECTIVE: ;; Your configuration expression MUST contain ;; exactly one of either of these: :inherit-configuration | ; splices inherited configuration (often specified last) :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere) ;; forward compatibility directive (since ASDF 2.011.4), useful when ;; you want to use new configuration features but have to bootstrap a ;; the newer required ASDF from an older release that doesn't sport said features: :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out ;; include a configuration file or directory (:include PATHNAME-DESIGNATOR) | ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ or something. :enable-user-cache | ;; Disable global cache. Map / to / :disable-cache | ;; add a single directory to be scanned (no recursion) (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR) ;; use a function to return the translation of a directory designator (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION)) DIRECTORY-DESIGNATOR := NIL | ;; As source: skip this entry. As destination: same as source T | ;; as source matches anything, as destination leaves pathname unmapped. ABSOLUTE-COMPONENT-DESIGNATOR ;; same as in the source-registry language TRANSLATION-FUNCTION := SYMBOL | ;; symbol of a function that takes two arguments, ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR LAMBDA ;; A form which evalutates to a function taking two arguments consisting of ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR @end verbatim Relative components better be either relative or subdirectories of the path before them, or bust. The last component, if not a pathname, is notionally completed by @file{/**/*.*}. You can specify more fine-grained patterns by using a pathname object as the last component e.g. @file{#p"some/path/**/foo*/bar-*.fasl"} You may use @code{#+features} to customize the configuration file. The second designator of a mapping may be @code{nil}, indicating that files are not mapped to anything but themselves (same as if the second designator was the same as the first). When the first designator is @code{t}, the mapping always matches. When the first designator starts with @code{:root}, the mapping matches any host and device. In either of these cases, if the second designator isn't @code{t} and doesn't start with @code{:root}, then strings indicating the host and pathname are somehow copied in the beginning of the directory component of the source pathname before it is translated. When the second designator is @code{t}, the mapping is the identity. When the second designator starts with @code{:root}, the mapping preserves the host and device of the original pathname. Notably, this allows you to map files to a subdirectory of the whichever directory the file is in. Though the syntax is not quite as easy to use as we'd like, you can have an (source destination) mapping entry such as follows in your configuration file, or you may use @code{enable-asdf-binary-locations-compatibility} with @code{:centralize-lisp-binaries nil} which will do the same thing internally for you: @verbatim #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors))) (wild-file (make-pathname :name :wild :version :wild :type :wild))) `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root (:root ,wild-subdir :implementation ,wild-file))) @end verbatim Starting with ASDF 2.011.4, you can use the simpler: @code{`(:root (:root :**/ :implementation :*.*.*))} @code{:include} statements cause the search to recurse with the path specifications from the file specified. If the @code{translate-pathname} mechanism cannot achieve a desired translation, the user may provide a function which provides the required algorithim. Such a translation function is specified by supplying a list as the second @code{directory-designator} the first element of which is the keyword @code{:function}, and the second element of which is either a symbol which designates a function or a lambda expression. The function designated by the second argument must take two arguments, the first being the pathname of the source file, the second being the wildcard that was matched. The result of the function invocation should be the translated pathname. An @code{:inherit-configuration} statement cause the search to recurse with the path specifications from the next configuration. @xref{Controlling where ASDF saves compiled files,,Configurations}, above. @itemize @item @code{:enable-user-cache} is the same as @code{(t :user-cache)}. @item @code{:disable-cache} is the same as @code{(t t)}. @item @code{:user-cache} uses the contents of variable @code{asdf::*user-cache*} which by default is the same as using @code{(:home ".cache" "common-lisp" :implementation)}. @item @code{:system-cache} uses the contents of variable @code{asdf::*system-cache*} which by default is the same as using @code{("/var/cache/common-lisp" :uid :implementation-type)} (on Unix and cygwin), or something semi-sensible on Windows. @end itemize @section Configuration Directories Configuration directories consist in files each contains a list of directives without any enclosing @code{(:output-translations ...)} form. The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included at the @emph{end} of the list. This allows for packaging software that has file granularity (e.g. Debian's @command{dpkg} or some future version of @command{clbuild}) to easily include configuration information about software being distributed. The convention is that, for sorting purposes, the names of files in such a directory begin with two digits that determine the order in which these entries will be read. Also, the type of these files is conventionally @code{"conf"} and as a limitation of some implementations, the type cannot be @code{nil}. Directories may be included by specifying a directory pathname or namestring in an @code{:include} directive, e.g.: @verbatim (:include "/foo/bar/") @end verbatim @section Shell-friendly syntax for configuration When considering environment variable @code{ASDF_OUTPUT_TRANSLATIONS} ASDF will skip to next configuration if it's an empty string. It will @code{READ} the string as an SEXP in the DSL if it begins with a paren @code{(} and it will be interpreted as a list of directories. Directories should come by pairs, indicating a mapping directive. Entries are separated by a @code{:} (colon) on Unix platforms (including cygwin), by a @code{;} (semicolon) on other platforms (mainly, Windows). The magic empty entry, if it comes in what would otherwise be the first entry in a pair, indicates the splicing of inherited configuration. If it comes as the second entry in a pair, it indicates that the directory specified first is to be left untranslated (which has the same effect as if the directory had been repeated). @section Semantics of Output Translations From the specified configuration, a list of mappings is extracted in a straightforward way: mappings are collected in order, recursing through included or inherited configuration as specified. To this list is prepended some implementation-specific mappings, and is appended a global default. The list is then compiled to a mapping table as follows: for each entry, in order, resolve the first designated directory into an actual directory pathname for source locations. If no mapping was specified yet for that location, resolve the second designated directory to an output location directory add a mapping to the table mapping the source location to the output location, and add another mapping from the output location to itself (unless a mapping already exists for the output location). Based on the table, a mapping function is defined, mapping source pathnames to output pathnames: given a source pathname, locate the longest matching prefix in the source column of the mapping table. Replace that prefix by the corresponding output column in the same row of the table, and return the result. If no match is found, return the source pathname. (A global default mapping the filesystem root to itself may ensure that there will always be a match, with same fall-through semantics). @section Caching Results The implementation is allowed to either eagerly compute the information from the configurations and file system, or to lazily re-compute it every time, or to cache any part of it as it goes. To explicitly flush any information cached by the system, use the API below. @section Output location API The specified functions are exported from package ASDF. @defun initialize-output-translations @Aoptional PARAMETER will read the configuration and initialize all internal variables. You may extend or override configuration from the environment and configuration files with the given @var{PARAMETER}, which can be @code{nil} (no configuration override), or a SEXP (in the SEXP DSL), a string (as in the string DSL), a pathname (of a file or directory with configuration), or a symbol (fbound to function that when called returns one of the above). @end defun @defun disable-output-translations will initialize output translations in a way that maps every pathname to itself, effectively disabling the output translation facility. @end defun @defun clear-output-translations undoes any output translation configuration and clears any cache for the mapping algorithm. You might want to call this function (or better, @code{clear-configuration}) before you dump an image that would be resumed with a different configuration, and return an empty configuration. Note that this does not include clearing information about systems defined in the current image, only about where to look for systems not yet defined. @end defun @defun ensure-output-translations @Aoptional PARAMETER checks whether output translations have been initialized. If not, initialize them with the given @var{PARAMETER}. This function will be called before any attempt to operate on a system. @end defun @defun apply-output-translations PATHNAME Applies the configured output location translations to @var{PATHNAME} (calls @code{ensure-output-translations} for the translations). @end defun Every time you use ASDF's @code{output-files}, or anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.), @code{ensure-output-translations} is called with parameter @code{nil}, which the first time around causes your configuration to be read. If you change a configuration file, you need to explicitly @code{initialize-output-translations} again, or maybe @code{clear-output-translations} (or @code{clear-configuration}), which will cause the initialization to happen next time around. @section Credits for output translations Thanks a lot to Bjorn Lindberg and Gary King for @code{ASDF-Binary-Locations}, and to Peter van Eynde for @code{Common Lisp Controller}. All bad design ideas and implementation bugs are to mine, not theirs. But so are good design ideas and elegant implementation tricks. --- Francois-Rene Rideau @email{fare@@tunes.org} @c @section Default locations @c @findex output-files-for-system-and-operation @c The default binary location for each Lisp implementation @c is a subdirectory of each source directory. @c To account for different Lisps, Operating Systems, Implementation versions, @c and so on, ASDF borrows code from SLIME @c to create reasonable custom directory names. @c Here are some examples: @c @itemize @c @item @c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86} @c @item @c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86} @c @item @c Franz Allegro, version 8.1, Modern (case sensitive) Common Lisp: @code{allegro-8.1m-macosx-x86} @c @end itemize @c By default, all output file pathnames will be relocated @c to some thus-named subdirectory of @file{~/.cache/common-lisp/}. @c See the document @file{README.asdf-output-translations} @c for a full specification on how to configure @code{asdf-output-translations}. @node Error handling, Miscellaneous additional functionality, Controlling where ASDF saves compiled files, Top @comment node-name, next, previous, up @chapter Error handling @findex SYSTEM-DEFINITION-ERROR @findex OPERATION-ERROR @section ASDF errors If ASDF detects an incorrect system definition, it will signal a generalised instance of @code{SYSTEM-DEFINITION-ERROR}. Operations may go wrong (for example when source files contain errors). These are signalled using generalised instances of @code{OPERATION-ERROR}. @section Compilation error and warning handling @vindex *compile-file-warnings-behaviour* @vindex *compile-file-errors-behavior* ASDF checks for warnings and errors when a file is compiled. The variables @var{*compile-file-warnings-behaviour*} and @var{*compile-file-errors-behavior*} control the handling of any such events. The valid values for these variables are @code{:error}, @code{:warn}, and @code{:ignore}. @node Miscellaneous additional functionality, Getting the latest version, Error handling, Top @comment node-name, next, previous, up @chapter Miscellaneous additional functionality ASDF includes several additional features that are generally useful for system definition and development. @section Controlling file compilation @cindex :around-compile @cindex around-compile keyword @cindex compile-check keyword @cindex :compile-check @findex compile-file* When declaring a component (system, module, file), you can specify a keyword argument @code{:around-compile function}. If left unspecified (and therefore unbound), the value will be inherited from the parent component if any, or with a default of @code{nil} if no value is specified in any transitive parent. The argument must be a either @code{nil}, a fbound symbol, a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk ...) ...)}) a function object (e.g. using @code{#.#'} but that's discouraged because it prevents the introspection done by e.g. asdf-dependency-grovel), or a string that when @code{read} yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. A non-nil value designates a function of one argument that will be called with a function that will invoke @code{compile-file*} with various arguments; the around-compile hook may supply additional keyword arguments to pass to that call to @code{compile-file*}. One notable argument that is heeded by @code{compile-file*} is @code{:compile-check}, a function called when the compilation was otherwise a success, with the same arguments as @code{compile-file}; the function shall return true if the compilation and its resulting compiled file respected all system-specific invariants, and false (@code{nil}) if it broke any of those invariants; it may issue warnings or errors before it returns @code{nil}. (NB: The ability to pass such extra flags is only available starting with ASDF 2.22.3.) This feature is notably exercised by asdf-finalizers. By using a string, you may reference a function, symbol and/or package that will only be created later during the build, but isn't yet present at the time the defsystem form is evaluated. However, if your entire system is using such a hook, you may have to explicitly override the hook with @code{nil} for all the modules and files that are compiled before the hook is defined. Using this hook, you may achieve such effects as: locally renaming packages, binding @var{*readtables*} and other syntax-controlling variables, handling warnings and other conditions, proclaiming consistent optimization settings, saving code coverage information, maintaining meta-data about compilation timings, setting gensym counters and PRNG seeds and other sources of non-determinism, overriding the source-location and/or timestamping systems, checking that some compile-time side-effects were properly balanced, etc. Note that there is no around-load hook. This is on purpose. Some implementations such as ECL, GCL or MKCL link object files, which allows for no such hook. Other implementations allow for concatenating FASL files, which doesn't allow for such a hook either. We aim to discourage something that's not portable, and has some dubious impact on performance and semantics even when it is possible. Things you might want to do with an around-load hook are better done around-compile, though it may at times require some creativity (see e.g. the @code{package-renaming} system). @section Controlling source file character encoding Starting with ASDF 2.21, components accept a @code{:encoding} option so authors may specify which character encoding should be used to read and evaluate their source code. When left unspecified, the encoding is inherited from the parent module or system; if no encoding is specified at any point, the default @code{:autodetect} is assumed. By default, only @code{:default}, @code{:utf-8} and @code{:autodetect} are accepted. @code{:autodetect}, the default, calls @code{*encoding-detection-hook*} which by default always returns @code{*default-encoding*} which itself defaults to @code{:default}. In other words, there now are plenty of extension hooks, but by default ASDF follows the backwards compatible behavior of using whichever @code{:default} encoding your implementation uses, which itself may or may not vary based on environment variables and other locale settings. In practice this means that only source code that only uses ASCII is guaranteed to be read the same on all implementations independently from any user setting. Additionally, for backward-compatibility with older versions of ASDF and/or with implementations that do not support unicode and its many encodings, you may want to use the reader conditionals @code{#+asdf-unicode #+asdf-unicode} to protect any @code{:encoding @emph{encoding}} statement as @code{:asdf-unicode} will be present in @code{*features*} only if you're using a recent ASDF on an implementation that supports unicode. We recommend that you avoid using unprotected @code{:encoding} specifications until after ASDF 2.21 or later becomes widespread, hopefully by the end of 2012. While it offers plenty of hooks for extension, and one such extension is being developed (see below), ASDF itself only recognizes one encoding beside @code{:default}, and that is @code{:utf-8}, which is the @emph{de facto} standard, already used by the vast majority of libraries that use more than ASCII. On implementations that do not support unicode, the feature @code{:asdf-unicode} is absent, and the @code{:default} external-format is used to read even source files declared as @code{:utf-8}. On these implementations, non-ASCII characters intended to be read as one CL character may thus end up being read as multiple CL characters. In most cases, this shouldn't affect the software's semantics: comments will be skipped just the same, strings with be read and printed with slightly different lengths, symbol names will be accordingly longer, but none of it should matter. But a few systems that actually depend on unicode characters may fail to work properly, or may work in a subtly different way. See for instance @code{lambda-reader}. We invite you to embrace UTF-8 as the encoding for non-ASCII characters starting today, even without any explicit specification in your @code{.asd} files. Indeed, on some implementations and configurations, UTF-8 is already the @code{:default}, and loading your code may cause errors if it is encoded in anything but UTF-8. Therefore, even with the legacy behavior, non-UTF-8 is guaranteed to break for some users, whereas UTF-8 is pretty much guaranteed not to break anywhere (provided you do @emph{not} use a BOM), although it might be read incorrectly on some implementations. In the future, we intend to make @code{:utf-8} the default value of @code{*default-encoding*}, to be enforced everywhere, so at least the code is guaranteed to be read correctly everywhere it can be. If you need non-standard character encodings for your source code, use the extension system @code{asdf-encodings}, by specifying @code{:defsystem-depends-on (:asdf-encodings)} in your @code{defsystem}. This extension system will register support for more encodings using the @code{*encoding-external-format-hook*} facility, so you can explicitly specify @code{:encoding :latin1} in your @code{.asd} file. Using the @code{*encoding-detection-hook*} it will also eventually implement some autodetection of a file's encoding from an emacs-style @code{-*- mode: lisp ; coding: latin1 -*-} declaration, or otherwise based on an analysis of octet patterns in the file. At this point, asdf-encoding only supports the encodings that are supported as part of your implementation. Since the list varies depending on implementations, we once again recommend you use @code{:utf-8} everywhere, which is the most portable (next is @code{:latin1}). If you're not using a version of Quicklisp that has it, you may get the source for @code{asdf-encodings} using git: @kbd{git clone git://common-lisp.net/projects/asdf/asdf-encodings.git} or @kbd{git clone ssh://common-lisp.net/project/asdf/git/asdf-encodings.git}. You can also browse the repository on @url{http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git}. In the future, we intend to change the default @code{*default-encoding*} to @code{:utf-8}, which is already the de facto standard for most libraries that use non-ASCII characters: utf-8 works everywhere and was backhandedly enforced by a lot of people using SBCL and utf-8 and sending reports to authors so they make their packages compatible. A survey showed only about a handful few libraries are incompatible with non-UTF-8, and then, only in comments, and we believe that authors will adopt UTF-8 when prompted. See the April 2012 discussion on the asdf-devel mailing-list. For backwards compatibility with users who insist on a non-UTF-8 encoding, but cannot immediately transition to using @code{asdf-encodings} (maybe because it isn't ready), it will still be possible to use the @code{:encoding :default} option in your @code{defsystem} form to restore the behavior of ASDF 2.20 and earlier. This shouldn't be required in libraries, because user pressure as mentioned above will already have pushed library authors towards using UTF-8; but authors of end-user programs might care. When you use @code{asdf-encodings}, any further loaded @code{.asd} file will use the autodetection algorithm to determine its encoding; yet if you depend on this detection happening, you may want to explicitly load @code{asdf-encodings} early in your build, for by the time you can use @code{:defsystem-depends-on}, it is already too late to load it. In practice, this means that the @code{*default-encoding*} is usually used for @code{.asd} files. Currently, this defaults to @code{:default} for backwards compatibility, and that means that you shouldn't rely on non-ASCII characters in a .asd file. Since component (path)names are the only real data in these files, and non-ASCII characters are not very portable for file names, this isn't too much of an issue. We still encourage you to use either plain ASCII or UTF-8 in @code{.asd} files, as we intend to make @code{:utf-8} the default encoding in the future. This might matter, for instance, in meta-data about author's names. @section Miscellaneous Functions These functions are exported by ASDF for your convenience. @defun system-relative-pathname system name @Akey type It's often handy to locate a file relative to some system. The @code{system-relative-pathname} function meets this need. It takes two mandatory arguments @var{system} and @var{name} and a keyword argument @var{type}: @var{system} is name of a system, whereas @var{name} and optionally @var{type} specify a relative pathname, interpreted like a component pathname specifier by @code{coerce-pathname}. @xref{The defsystem grammar,,Pathname specifiers}. It returns a pathname built from the location of the system's source directory and the relative pathname. For example: @lisp > (asdf:system-relative-pathname 'cl-ppcre "regex.data") #P"/repository/other/cl-ppcre/regex.data" @end lisp @end defun @defun system-source-directory system-designator ASDF does not provide a turnkey solution for locating data (or other miscellaneous) files that are distributed together with the source code of a system. Programmers can use @code{system-source-directory} to find such files. Returns a pathname object. The @var{system-designator} may be a string, symbol, or ASDF system object. @end defun @defun clear-system system-designator It is sometimes useful to force recompilation of a previously loaded system. In these cases, it may be useful to @code{(asdf:clear-system :foo)} to remove the system from the table of currently loaded systems; the next time the system @code{foo} or one that depends on it is re-loaded, @code{foo} will then be loaded again. Alternatively, you could touch @code{foo.asd} or remove the corresponding fasls from the output file cache. (It was once conceived that one should provide a list of systems the recompilation of which to force as the @code{:force} keyword argument to @code{load-system}; but this has never worked, and though the feature was fixed in ASDF 2.000, it remains @code{cerror}'ed out as nobody ever used it.) Note that this does not and cannot by itself undo the previous loading of the system. Common Lisp has no provision for such an operation, and its reliance on irreversible side-effects to global datastructures makes such a thing impossible in the general case. If the software being re-loaded is not conceived with hot upgrade in mind, this re-loading may cause many errors, warnings or subtle silent problems, as packages, generic function signatures, structures, types, macros, constants, etc. are being redefined incompatibly. It is up to the user to make sure that reloading is possible and has the desired effect. In some cases, extreme measures such as recursively deleting packages, unregistering symbols, defining methods on @code{update-instance-for-redefined-class} and much more are necessary for reloading to happen smoothly. ASDF itself goes through notable pains to make such a hot upgrade possible with respect to its own code, and what it does is ridiculously complex; look at the beginning of @file{asdf.lisp} to see what it does. @end defun @defun register-preloaded-system name @Arest keys A system with name @var{name}, created by @code{make-instance} with extra keys @var{keys} (e.g. @code{:version}), is registered as @emph{preloaded}. That is, its code has already been loaded into the current image, and if at some point some other system @code{:depends-on} it yet no source code is found, it is considered as already provided, and ASDF will not raise a @code{missing-component} error. This function is particularly useful if you distribute your code as fasls with either @code{fasl-op} or @code{monolithic-fasl-op}, and want to register systems so that dependencies will work uniformly whether you're using your software from source or from fasl. @end defun @defun run-shell-command control-string @Arest args This function is obsolete and present only for the sake of backwards-compatibility: ``If it's not backwards, it's not compatible''. We @emph{strongly} discourage its use. Its current behavior is only well-defined on Unix platforms (which include MacOS X and cygwin). On Windows, anything goes. The following documentation is only for the purpose of your migrating away from it in a way that preserves semantics. Instead we recommend the use @code{run-program}, described in the next section, and available as part of ASDF since ASDF 3. @code{run-shell-command} takes as arguments a format @code{control-string} and arguments to be passed to @code{format} after this control-string to produce a string. This string is a command that will be evaluated with a POSIX shell if possible; yet, on Windows, some implementations will use CMD.EXE, while others (like SBCL) will make an attempt at invoking a POSIX shell (and fail if it is not present). @end defun @section Some Utility Functions The below functions are not exported by ASDF itself, but by UIOP, available since ASDF 3. Some of them have precursors in ASDF 2, but we recommend you rely on ASDF 3 for active developments. UIOP provides many, many more utility functions, and we recommend you read its README and sources for more information. @defun parse-unix-namestring name @Akey type defaults dot-dot ensure-directory @AallowOtherKeys Coerce NAME into a PATHNAME using standard Unix syntax. Unix syntax is used whether or not the underlying system is Unix; on such non-Unix systems it is only usable but for relative pathnames; but especially to manipulate relative pathnames portably, it is of crucial to possess a portable pathname syntax independent of the underlying OS. This is what @code{parse-unix-namestring} provides, and why we use it in ASDF. When given a @code{pathname} object, just return it untouched. When given @code{nil}, just return @code{nil}. When given a non-null @code{symbol}, first downcase its name and treat it as a string. When given a @code{string}, portably decompose it into a pathname as below. @code{#\/} separates directory components. The last @code{#\/}-separated substring is interpreted as follows: 1- If @var{type} is @code{:directory} or @var{ensure-directory} is true, the string is made the last directory component, and its @code{name} and @code{type} are @code{nil}. if the string is empty, it's the empty pathname with all slots @code{nil}. 2- If @var{type} is @code{nil}, the substring is a file-namestring, and its @code{name} and @code{type} are separated by @code{split-name-type}. 3- If @var{type} is a string, it is the given @code{type}, and the whole string is the @code{name}. Directory components with an empty name the name @code{.} are removed. Any directory named @code{..} is read as @var{dot-dot}, which must be one of @code{:back} or @code{:up} and defaults to @code{:back}. @code{host}, @code{device} and @code{version} components are taken from @var{defaults}, which itself defaults to @code{*nil-pathname*}, also used if @var{defaults} is @code{nil}. No host or device can be specified in the string itself, which makes it unsuitable for absolute pathnames outside Unix. For relative pathnames, these components (and hence the defaults) won't matter if you use @code{merge-pathnames*} but will matter if you use @code{merge-pathnames}, which is an important reason to always use @code{merge-pathnames*}. Arbitrary keys are accepted, and the parse result is passed to @code{ensure-pathname} with those keys, removing @var{type}, @var{defaults} and @var{dot-dot}. When you're manipulating pathnames that are supposed to make sense portably even though the OS may not be Unixish, we recommend you use @code{:want-relative t} to throw an error if the pathname is absolute @end defun @defun merge-pathnames* specified @Aoptional defaults This function is a replacement for @code{merge-pathnames} that uses the host and device from the @var{defaults} rather than the @var{specified} pathname when the latter is a relative pathname. This allows ASDF and its users to create and use relative pathnames without having to know beforehand what are the host and device of the absolute pathnames they are relative to. @end defun @defun subpathname pathname subpath @Akey type This function takes a @var{pathname} and a @var{subpath} and a @var{type}. If @var{subpath} is already a @code{pathname} object (not namestring), and is an absolute pathname at that, it is returned unchanged; otherwise, @var{subpath} is turned into a relative pathname with given @var{type} as per @code{parse-unix-namestring} with @code{:want-relative t :type }@var{type}, then it is merged with the @code{pathname-directory-pathname} of @var{pathname}, as per @code{merge-pathnames*}. We strongly encourage the use of this function for portably resolving relative pathnames in your code base. @end defun @defun subpathname* pathname subpath @Akey type This function returns @code{nil} if the base @var{pathname} is @code{nil}, otherwise acts like @code{subpathname}. @end defun @defun run-program command @Akey ignore-error-status force-shell input output error-output if-input-does-not-exist if-output-exists if-error-output-exists element-type external-format @AallowOtherKeys @code{run-program} takes a @var{command} argument that is either a list of a program name or path and its arguments, or a string to be executed by a shell. It spawns the command, waits for it to return, verifies that it exited cleanly (unless told not too below), and optionally captures and processes its output. It accepts many keyword arguments to configure its behavior. @code{run-program} returns three values: the first for the output, the second for the error-output, and the third for the return value. (Beware that before ASDF 3.0.2.11, it didn't handle input or error-output, and returned only one value, the one for the output if any handler was specified, or else the exit code; please upgrade ASDF, or at least UIOP, to rely on the new enhanced behavior.) @var{output} is its most important argument; it specifies how the output is captured and processed. If it is @code{nil}, then the output is redirected to the null device, that will discard it. If it is @code{:interactive}, then it is inherited from the current process (beware: this may be different from your @var{*standard-output*}, and under SLIME will be on your @code{*inferior-lisp*} buffer). If it is @code{t}, output goes to your current @var{*standard-output*} stream. Otherwise, @var{output} should be a value that is a suitable first argument to @code{slurp-input-stream} (see below), or a list of such a value and keyword arguments. In this case, @code{run-program} will create a temporary stream for the program output; the program output, in that stream, will be processed by a call to @code{slurp-input-stream}, using @var{output} as the first argument (or if it's a list the first element of @var{output} and the rest as keywords). The primary value resulting from that call (or @code{nil} if no call was needed) will be the first value returned by @code{run-program}. E.g., using @code{:output :string} will have it return the entire output stream as a string. And using @code{:output '(:string :stripped t)} will have it return the same string stripped of any ending newline. @var{error-output} is similar to @var{output}, except that the resulting value is returned as the second value of @code{run-program}. @code{t} designates the @var{*error-output*}. Also @code{:output} means redirecting the error output to the output stream, in which case @code{nil} is returned. @var{input} is similar to @var{output}, except that @code{vomit-output-stream} is used, no value is returned, and @code{t} designates the @var{*standard-input*}. @code{element-type} and @code{external-format} are passed on to your Lisp implementation, when applicable, for creation of the output stream. One and only one of the stream slurping or vomiting may or may not happen in parallel in parallel with the subprocess, depending on options and implementation, and with priority being given to output processing. Other streams are completely produced or consumed before or after the subprocess is spawned, using temporary files. @code{force-shell} forces evaluation of the command through a shell, even if it was passed as a list rather than a string. If a shell is used, it is @file{/bin/sh} on Unix or @file{CMD.EXE} on Windows, except on implementations that (erroneously, IMNSHO) insist on consulting @code{$SHELL} like clisp. @code{ignore-error-status} causes @code{run-program} to not raise an error if the spawned program exits in error. Following POSIX convention, an error is anything but a normal exit with status code zero. By default, an error of type @code{subprocess-error} is raised in this case. @code{run-program} works on all platforms supported by ASDF, except Genera. See the source code for more documentation. @end defun @defun slurp-input-stream processor input-stream @Akey It's a generic function of two arguments, a target object and an input stream, and accepting keyword arguments. Predefined methods based on the target object are as follow: If the object is a function, the function is called with the stream as argument. If the object is a cons, its first element is applied to its rest appended by a list of the input stream. If the object is an output stream, the contents of the input stream are copied to it. If the @var{linewise} keyword argument is provided, copying happens line by line, and an optional @var{prefix} is printed before each line. Otherwise, copying happen based on a buffer of size @var{buffer-size}, using the specified @var{element-type}. If the object is @code{'string} or @code{:string}, the content is captured into a string. Accepted keywords include the @var{element-type} and a flag @var{stripped}, which when true causes any single line ending to be removed as per @code{uiop:stripln}. If the object is @code{:lines}, the content is captured as a list of strings, one per line, without line ending. If the @var{count} keyword argument is provided, it is a maximum count of lines to be read. If the object is @code{:line}, the content is capture as with @code{:lines} above, and then its sub-object is extracted with the @var{at} argument, which defaults to @code{0}, extracting the first line. A number will extract the corresponding line. See the documentation for @code{uiop:access-at}. If the object is @code{:forms}, the content is captured as a list of S-expressions, as read by the Lisp reader. If the @var{count} argument is provided, it is a maximum count of lines to be read. We recommend you control the syntax with such macro as @code{uiop:with-safe-io-syntax}. If the object is @code{:form}, the content is capture as with @code{:forms} above, and then its sub-object is extracted with the @var{at} argument, which defaults to @code{0}, extracting the first form. A number will extract the corresponding form. See the documentation for @code{uiop:access-at}. We recommend you control the syntax with such macro as @code{uiop:with-safe-io-syntax}. @end defun @node Getting the latest version, FAQ, Miscellaneous additional functionality, Top @comment node-name, next, previous, up @chapter Getting the latest version Decide which version you want. The @code{master} branch is where development happens; its @code{HEAD} is usually OK, including the latest fixes and portability tweaks, but an occasional regression may happen despite our (limited) test suite. The @code{release} branch is what cautious people should be using; it has usually been tested more, and releases are cut at a point where there isn't any known unresolved issue. You may get the ASDF source repository using git: @kbd{git clone git://common-lisp.net/projects/asdf/asdf.git} You will find the above referenced tags in this repository. You can also browse the repository on @url{http://common-lisp.net/gitweb?p=projects/asdf/asdf.git}. Discussion of ASDF development is conducted on the mailing list @kbd{asdf-devel@@common-lisp.net}. @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} @node FAQ, TODO list, Getting the latest version, Top @comment node-name, next, previous, up @chapter FAQ @section ``Where do I report a bug?'' ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. If you're unsure about whether something is a bug, or for general discussion, use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} @section ``What has changed between ASDF 1 and ASDF 2?'' @subsection What are ASDF 1 and ASDF 2? On May 31st 2010, we have released ASDF 2. ASDF 2 refers to release 2.000 and later. (Releases between 1.656 and 1.728 were development releases for ASDF 2.) ASDF 1 to any release earlier than 1.369 or so. If your ASDF doesn't sport a version, it's an old ASDF 1. ASDF 2 and its release candidates push @code{:asdf2} onto @code{*features*} so that if you are writing ASDF-dependent code you may check for this feature to see if the new API is present. @emph{All} versions of ASDF should have the @code{:asdf} feature. Additionally, all versions of ASDF 2 define a function @code{(asdf:asdf-version)} you may use to query the version; and the source code of recent versions of ASDF 2 features the version number prominently on the second line of its source code. If you are experiencing problems or limitations of any sort with ASDF 1, we recommend that you should upgrade to ASDF 2, or whatever is the latest release. @subsection ASDF can portably name files in subdirectories Common Lisp namestrings are not portable, except maybe for logical pathnamestrings, that themselves have various limitations and require a lot of setup that is itself ultimately non-portable. In ASDF 1, the only portable ways to refer to pathnames inside systems and components were very awkward, using @code{#.(make-pathname ...)} and @code{#.(merge-pathnames ...)}. Even the above were themselves were inadequate in the general case due to host and device issues, unless horribly complex patterns were used. Plenty of simple cases that looked portable actually weren't, leading to much confusion and greavance. ASDF 2 implements its own portable syntax for strings as pathname specifiers. Naming files within a system definition becomes easy and portable again. @xref{Miscellaneous additional functionality,asdf:system-relative-pathname}, @code{merge-pathnames*}, @code{coerce-pathname}. On the other hand, there are places where systems used to accept namestrings where you must now use an explicit pathname object: @code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} must now be written with the @code{#p} syntax: @code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} @xref{The defsystem grammar,,Pathname specifiers}. @subsection Output translations A popular feature added to ASDF was output pathname translation: @code{asdf-binary-locations}, @code{common-lisp-controller}, @code{cl-launch} and other hacks were all implementing it in ways both mutually incompatible and difficult to configure. Output pathname translation is essential to share source directories of portable systems across multiple implementations or variants thereof, or source directories of shared installations of systems across multiple users, or combinations of the above. In ASDF 2, a standard mechanism is provided for that, @code{asdf-output-translations}, with sensible defaults, adequate configuration languages, a coherent set of configuration files and hooks, and support for non-Unix platforms. @xref{Controlling where ASDF saves compiled files}. @subsection Source Registry Configuration Configuring ASDF used to require special magic to be applied just at the right moment, between the moment ASDF is loaded and the moment it is used, in a way that is specific to the user, the implementation he is using and the application he is building. This made for awkward configuration files and startup scripts that could not be shared between users, managed by administrators or packaged by distributions. ASDF 2 provides a well-documented way to configure ASDF, with sensible defaults, adequate configuration languages, and a coherent set of configuration files and hooks. We believe it's a vast improvement because it decouples application distribution from library distribution. The application writer can avoid thinking where the libraries are, and the library distributor (dpkg, clbuild, advanced user, etc.) can configure them once and for every application. Yet settings can be easily overridden where needed, so whoever needs control has exactly as much as required. At the same time, ASDF 2 remains compatible with the old magic you may have in your build scripts (using @code{*central-registry*} and @code{*system-definition-search-functions*}) to tailor the ASDF configuration to your build automation needs, and also allows for new magic, simpler and more powerful magic. @xref{Controlling where ASDF searches for systems}. @subsection Usual operations are made easier to the user In ASDF 1, you had to use the awkward syntax @code{(asdf:oos 'asdf:load-op :foo)} to load a system, and similarly for @code{compile-op}, @code{test-op}. In ASDF 2, you can use shortcuts for the usual operations: @code{(asdf:load-system :foo)}, and similarly for @code{compile-system}, @code{test-system}. @subsection Many bugs have been fixed The following issues and many others have been fixed: @itemize @item The infamous TRAVERSE function has been revamped completely between ASDF 1 and ASDF 2, with many bugs squashed. In particular, dependencies were not correctly propagated across modules but now are. It has been completely rewritten many times over between ASDF 2.000 and ASDF 3, with fundamental issues in the original model being fixed. Timestamps were not propagated at all, and now are. The internal model of how actions depend on each other is now both consistent and complete. The :version and the :force (system1 .. systemN) feature have been fixed. @item Performance has been notably improved for large systems (say with thousands of components) by using hash-tables instead of linear search, and linear-time list accumulation instead of quadratic-time recursive appends. @item Many features used to not be portable, especially where pathnames were involved. Windows support was notably quirky because of such non-portability. @item The internal test suite used to massively fail on many implementations. While still incomplete, it now fully passes on all implementations supported by the test suite, except for GCL (due to GCL bugs). @item Support was lacking for some implementations. ABCL and GCL were notably wholly broken. ECL extensions were not integrated with ASDF release. @item The documentation was grossly out of date. @end itemize @subsection ASDF itself is versioned Between new features, old bugs fixed, and new bugs introduced, there were various releases of ASDF in the wild, and no simple way to check which release had which feature set. People using or writing systems had to either make worst-case assumptions as to what features were available and worked, or take great pains to have the correct version of ASDF installed. With ASDF 2, we provide a new stable set of working features that everyone can rely on from now on. Use @code{#+asdf2} to detect presence of ASDF 2, @code{(asdf:version-satisfies (asdf:asdf-version) "2.345.67")} to check the availability of a version no earlier than required. @subsection ASDF can be upgraded When an old version of ASDF was loaded, it was very hard to upgrade ASDF in your current image without breaking everything. Instead you had to exit the Lisp process and somehow arrange to start a new one from a simpler image. Something that can't be done from within Lisp, making automation of it difficult, which compounded with difficulty in configuration, made the task quite hard. Yet as we saw before, the task would have been required to not have to live with the worst case or non-portable subset of ASDF features. With ASDF 2, it is easy to upgrade from ASDF 2 to later versions from within Lisp, and not too hard to upgrade from ASDF 1 to ASDF 2 from within Lisp. We support hot upgrade of ASDF and any breakage is a bug that we will do our best to fix. There are still limitations on upgrade, though, most notably the fact that after you upgrade ASDF, you must also reload or upgrade all ASDF extensions. @subsection Decoupled release cycle When vendors were releasing their Lisp implementations with ASDF, they had to basically never change version because neither upgrade nor downgrade was possible without breaking something for someone, and no obvious upgrade path was visible and recommendable. With ASDF 2, upgrade is possible, easy and can be recommended. This means that vendors can safely ship a recent version of ASDF, confident that if a user isn't fully satisfied, he can easily upgrade ASDF and deal with a supported recent version of it. This means that release cycles will be causally decoupled, the practical consequence of which will mean faster convergence towards the latest version for everyone. @subsection Pitfalls of the transition to ASDF 2 The main pitfalls in upgrading to ASDF 2 seem to be related to the output translation mechanism. @itemize @item Output translations is enabled by default. This may surprise some users, most of them in pleasant way (we hope), a few of them in an unpleasant way. It is trivial to disable output translations. @xref{FAQ,,``How can I wholly disable the compiler output cache?''}. @item Some systems in the large have been known not to play well with output translations. They were relatively easy to fix. Once again, it is also easy to disable output translations, or to override its configuration. @item The new ASDF output translations are incompatible with ASDF-Binary-Locations. They replace A-B-L, and there is compatibility mode to emulate your previous A-B-L configuration. See @code{enable-asdf-binary-locations-compatibility} in @pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. But thou shalt not load ABL on top of ASDF 2. @end itemize Other issues include the following: @itemize @item ASDF pathname designators are now specified in places where they were unspecified, and a few small adjustments have to be made to some non-portable defsystems. Notably, in the @code{:pathname} argument to a @code{defsystem} and its components, a logical pathname (or implementation-dependent hierarchical pathname) must now be specified with @code{#p} syntax where the namestring might have previously sufficed; moreover when evaluation is desired @code{#.} must be used, where it wasn't necessary in the toplevel @code{:pathname} argument (but necessary in other @code{:pathname} arguments). @item There is a slight performance bug, notably on SBCL, when initially searching for @file{asd} files, the implicit @code{(directory "/configured/path/**/*.asd")} for every configured path @code{(:tree "/configured/path/")} in your @code{source-registry} configuration can cause a slight pause. Try to @code{(time (asdf:initialize-source-registry))} to see how bad it is or isn't on your system. If you insist on not having this pause, you can avoid the pause by overriding the default source-registry configuration and not use any deep @code{:tree} entry but only @code{:directory} entries or shallow @code{:tree} entries. Or you can fix your implementation to not be quite that slow when recursing through directories. @emph{Update}: This performance bug fixed the hard way in 2.010. @item On Windows, only LispWorks supports proper default configuration pathnames based on the Windows registry. Other implementations make do with environment variables, that you may have to define yourself if you're using an older version of Windows. Windows support is somewhat less tested than Unix support. Please help report and fix bugs. @emph{Update}: As of ASDF 2.21, all implementations should now use the same proper default configuration pathnames and they should actually work, though they haven't all been tested. @item The mechanism by which one customizes a system so that Lisp files may use a different extension from the default @file{.lisp} has changed. Previously, the pathname for a component was lazily computed when operating on a system, and you would @code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo)))) (declare (ignorable component system)) "lis")}. Now, the pathname for a component is eagerly computed when defining the system, and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))} and use @code{:default-component-class cl-source-file.lis} as argument to @code{defsystem}, as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below. @findex source-file-type @end itemize @section Issues with installing the proper version of ASDF @subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?'' We recommend you upgrade ASDF. @xref{Loading ASDF,,Upgrading ASDF}. If this does not work, it is a bug, and you should report it. @xref{FAQ, report-bugs, Where do I report a bug}. In the meantime, you can load @file{asdf.lisp} directly. @xref{Loading ASDF,Loading an otherwise installed ASDF}. @subsection ``I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?'' Since ASDF 2, it should always be a good time to upgrade to a recent version of ASDF. You may consult with the maintainer for which specific version they recommend, but the latest @code{release} should be correct. We trust you to thoroughly test it with your implementation before you release it. If there are any issues with the current release, it's a bug that you should report upstream and that we will fix ASAP. As to how to include ASDF, we recommend the following: @itemize @item If ASDF isn't loaded yet, then @code{(require "asdf")} should load the version of ASDF that is bundled with your system. If possible so should @code{(require "ASDF")}. You may have it load some other version configured by the user, if you allow such configuration. @item If your system provides a mechanism to hook into @code{CL:REQUIRE}, then it would be nice to add ASDF to this hook the same way that ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it. Please send us appropriate code to this end. @item You may, like SBCL, have ASDF be implicitly used to require systems that are bundled with your Lisp distribution. If you do have a few magic systems that come with your implementation in a precompiled way such that one should only use the binary version that goes with your distribution, like SBCL does, then you should add them in the beginning of @code{wrapping-source-registry}. @item If you have magic systems as above, like SBCL does, then we explicitly ask you to @emph{NOT} distribute @file{asdf.asd} as part of those magic systems. You should still include the file @file{asdf.lisp} in your source distribution and precompile it in your binary distribution, but @file{asdf.asd} if included at all, should be secluded from the magic systems, in a separate file hierarchy. Alternatively, you may provide the system after renaming it and its @file{.asd} file to e.g. @code{asdf-ecl} and @file{asdf-ecl.asd}, or @code{sb-asdf} and @file{sb-asdf.asd}. Indeed, if you made @file{asdf.asd} a magic system, then users would no longer be able to upgrade ASDF using ASDF itself to some version of their preference that they maintain independently from your Lisp distribution. @item If you do not have any such magic systems, or have other non-magic systems that you want to bundle with your implementation, then you may add them to the @code{wrapping-source-registry}, and you are welcome to include @file{asdf.asd} amongst them. Non-magic systems should be at the back of the @code{wrapping-source-registry} while magic systems are at the front. @item Please send us upstream any patches you make to ASDF itself, so we can merge them back in for the benefit of your users when they upgrade to the upstream version. @end itemize @section Issues with configuring ASDF @subsection ``How can I customize where fasl files are stored?'' @xref{Controlling where ASDF saves compiled files}. Note that in the past there was an add-on to ASDF called @code{ASDF-binary-locations}, developed by Gary King. That add-on has been merged into ASDF proper, then superseded by the @code{asdf-output-translations} facility. Note that use of @code{asdf-output-translations} can interfere with one aspect of your systems --- if your system uses @code{*load-truename*} to find files (e.g., if you have some data files stored with your program), then the relocation that this ASDF customization performs is likely to interfere. Use @code{asdf:system-relative-pathname} to locate a file in the source directory of some system, and use @code{asdf:apply-output-translations} to locate a file whose pathname has been translated by the facility. @subsection ``How can I wholly disable the compiler output cache?'' To permanently disable the compiler output cache for all future runs of ASDF, you can: @example mkdir -p ~/.config/common-lisp/asdf-output-translations.conf.d/ echo ':disable-cache' > ~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf @end example This assumes that you didn't otherwise configure the ASDF files (if you did, edit them again), and don't somehow override the configuration at runtime with a shell variable (see below) or some other runtime command (e.g. some call to @code{asdf:initialize-output-translations}). To disable the compiler output cache in Lisp processes run by your current shell, try (assuming @code{bash} or @code{zsh}) (on Unix and cygwin only): @example export ASDF_OUTPUT_TRANSLATIONS=/: @end example To disable the compiler output cache just in the current Lisp process, use (after loading ASDF but before using it): @example (asdf:disable-output-translations) @end example @section Issues with using and extending ASDF to define systems @subsection ``How can I cater for unit-testing in my system?'' ASDF provides a predefined test operation, @code{test-op}. @xref{Predefined operations of ASDF, test-op}. The test operation, however, is largely left to the system definer to specify. @code{test-op} has been a topic of considerable discussion on the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, and on the @url{https://launchpad.net/asdf,launchpad bug-tracker}. Here are some guidelines: @itemize @item For a given system, @var{foo}, you will want to define a corresponding test system, such as @var{foo-test}. The reason that you will want this separate system is that ASDF does not out of the box supply components that are conditionally loaded. So if you want to have source files (with the test definitions) that will not be loaded except when testing, they should be put elsewhere. @item The @var{foo-test} system can be defined in an asd file of its own or together with @var{foo}. An aesthetic preference against cluttering up the filesystem with extra asd files should be balanced against the question of whether one might want to directly load @var{foo-test}. Typically one would not want to do this except in early stages of debugging. @item Record that testing is implemented by @var{foo-test}. For example: @example (defsystem @var{foo} :in-order-to ((test-op (test-op @var{foo-test}))) ....) (defsystem @var{foo-test} :depends-on (@var{foo} @var{my-test-library} ...) ....) @end example @end itemize This procedure will allow you to support users who do not wish to install your test framework. One oddity of ASDF is that @code{operate} (@pxref{Operations,operate}) does not return a value. So in current versions of ASDF there is no reliable programmatic means of determining whether or not a set of tests has passed, or which tests have failed. The user must simply read the console output. This limitation has been the subject of much discussion. @subsection ``How can I cater for documentation generation in my system?'' The ASDF developers are currently working to add a @code{doc-op} to the set of predefined ASDF operations. @xref{Predefined operations of ASDF}. See also @url{https://bugs.launchpad.net/asdf/+bug/479470}. @subsection ``How can I maintain non-Lisp (e.g. C) source files?'' See @code{cffi}'s @code{cffi-grovel}. @anchor{report-bugs} @subsection ``I want to put my module's files at the top level. How do I do this?'' By default, the files contained in an asdf module go in a subdirectory with the same name as the module. However, this can be overridden by adding a @code{:pathname ""} argument to the module description. For example, here is how it could be done in the spatial-trees ASDF system definition for ASDF 2: @example (asdf:defsystem :spatial-trees :components ((:module base :pathname "" :components ((:file "package") (:file "basedefs" :depends-on ("package")) (:file "rectangles" :depends-on ("package")))) (:module tree-impls :depends-on (base) :pathname "" :components ((:file "r-trees") (:file "greene-trees" :depends-on ("r-trees")) (:file "rstar-trees" :depends-on ("r-trees")) (:file "rplus-trees" :depends-on ("r-trees")) (:file "x-trees" :depends-on ("r-trees" "rstar-trees")))) (:module viz :depends-on (base) :pathname "" :components ((:static-file "spatial-tree-viz.lisp"))) (:module tests :depends-on (base) :pathname "" :components ((:static-file "spatial-tree-test.lisp"))) (:static-file "LICENCE") (:static-file "TODO"))) @end example All of the files in the @code{tree-impls} module are at the top level, instead of in a @file{tree-impls/} subdirectory. Note that the argument to @code{:pathname} can be either a pathname object or a string. A pathname object can be constructed with the @file{#p"foo/bar/"} syntax, but this is discouraged because the results of parsing a namestring are not portable. A pathname can only be portably constructed with such syntax as @code{#.(make-pathname :directory '(:relative "foo" "bar"))}, and similarly the current directory can only be portably specified as @code{#.(make-pathname :directory '(:relative))}. However, as of ASDF 2, you can portably use a string to denote a pathname. The string will be parsed as a @code{/}-separated path from the current directory, such that the empty string @code{""} denotes the current directory, and @code{"foo/bar"} (no trailing @code{/} required in the case of modules) portably denotes the same subdirectory as above. When files are specified, the last @code{/}-separated component is interpreted either as the name component of a pathname (if the component class specifies a pathname type), or as a name component plus optional dot-separated type component (if the component class doesn't specifies a pathname type). @subsection How do I create a system definition where all the source files have a .cl extension? Starting with ASDF 2.014.14, you may just pass the builtin class @code{cl-source-file.cl} as the @code{:default-component-class} argument to @code{defsystem}: @lisp (defsystem my-cl-system :default-component-class cl-source-file.cl ...) @end lisp Another builtin class @code{cl-source-file.lsp} is offered for files ending in @file{.lsp}. If you want to use a different extension for which ASDF doesn't provide builtin support, or want to support versions of ASDF earlier than 2.014.14 (but later than 2.000), you can define a class as follows: @lisp ;; Prologue: make sure we're using a sane package. (defpackage :my-asdf-extension (:use :asdf :common-lisp) (:export #:cl-source-file.lis)) (in-package :my-asdf-extension) (defclass cl-source-file.lis (cl-source-file) ((type :initform "lis"))) @end lisp Then you can use it as follows: @lisp (defsystem my-cl-system :default-component-class my-asdf-extension:cl-source-file.lis ...) @end lisp Of course, if you're in the same package, e.g. in the same file, you won't need to use the package qualifier before @code{cl-source-file.lis}. Actually, if all you're doing is defining this class and using it in the same file without other fancy definitions, you might skip package complications: @lisp (in-package :asdf) (defclass cl-source-file.lis (cl-source-file) ((type :initform "lis"))) (defsystem my-cl-system :default-component-class cl-source-file.lis ...) @end lisp It is possible to achieve the same effect in a way that supports both ASDF 1 and ASDF 2, but really, friends don't let friends use ASDF 1. Please upgrade to ASDF 3. In short, though: do same as above, but @emph{before} you use the class in a @code{defsystem}, you also define the following method: @lisp (defmethod source-file-type ((f cl-source-file.lis) (s system)) (declare (ignorable f s)) "lis") @end lisp @comment FIXME: Add a FAQ about how to use a new system class... @node TODO list, Inspiration, FAQ, Top @comment node-name, next, previous, up @chapter TODO list Here is an old list of things to do, in addition to the bugs that are now tracked on launchpad: @url{https://launchpad.net/asdf}. @section Outstanding spec questions, things to add ** packaging systems *** manual page component? ** style guide for .asd files You should either use keywords or be careful with the package that you evaluate defsystem forms in. Otherwise @code{(defsystem partition ...)} being read in the @code{cl-user} package will intern a @code{cl-user:partition} symbol, which will then collide with the @code{partition:partition} symbol. Actually there's a hairier packages problem to think about too. @code{in-order-to} is not a keyword: if you read @code{defsystem} forms in a package that doesn't use ASDF, odd things might happen. ** extending defsystem with new options You might not want to write a whole parser, but just to add options to the existing syntax. Reinstate @code{parse-option} or something akin. ** Diagnostics A ``dry run'' of an operation can be made with the following form: @lisp (let ((asdf::*verbose-out* *standard-output*)) (loop :for (op . comp) :in (asdf::traverse (make-instance ' :force t) (asdf:find-system )) :do (asdf:explain op comp))) @end lisp This uses unexported symbols. What would be a nice interface for this functionality? @section Missing bits in implementation ** reuse the same scratch package whenever a system is reloaded from disk Have a package ASDF-USER instead of all these temporary packages? ** proclamations probably aren't ** A revert function Other possible interface: have a ``revert'' function akin to @code{make clean}. @lisp (asdf:revert 'asdf:compile-op 'araneida) @end lisp would delete any files produced by @code{(compile-system :araneida)}. Of course, it wouldn't be able to do much about stuff in the image itself. How would this work? @code{traverse} There's a difference between a module's dependencies (peers) and its components (children). Perhaps there's a similar difference in operations? For example, @code{(load "use") depends-on (load "macros")} is a peer, whereas @code{(load "use") depends-on (compile "use")} is more of a ``subservient'' relationship. @node Inspiration, Concept Index, TODO list, Top @comment node-name, next, previous, up @chapter Inspiration @section mk-defsystem (defsystem-3.x) We aim to solve basically the same problems as @code{mk-defsystem} does. However, our architecture for extensibility better exploits CL language features (and is documented), and we intend to be portable rather than just widely-ported. No slight on the @code{mk-defsystem} authors and maintainers is intended here; that implementation has the unenviable task of supporting pre-ANSI implementations, which is no longer necessary. The surface defsystem syntax of asdf is more-or-less compatible with @code{mk-defsystem}, except that we do not support the @code{source-foo} and @code{binary-foo} prefixes for separating source and binary files, and we advise the removal of all options to specify pathnames. The @code{mk-defsystem} code for topologically sorting a module's dependency list was very useful. @section defsystem-4 proposal Marco and Peter's proposal for defsystem 4 served as the driver for many of the features in here. Notable differences are: @itemize @item We don't specify output files or output file extensions as part of the system. If you want to find out what files an operation would create, ask the operation. @item We don't deal with CL packages If you want to compile in a particular package, use an @code{in-package} form in that file (ilisp / SLIME will like you more if you do this anyway) @item There is no proposal here that @code{defsystem} does version control. A system has a given version which can be used to check dependencies, but that's all. @end itemize The defsystem 4 proposal tends to look more at the external features, whereas this one centres on a protocol for system introspection. @section kmp's ``The Description of Large Systems'', MIT AI Memo 801 Available in updated-for-CL form on the web at @url{http://nhplace.com/kent/Papers/Large-Systems.html} In our implementation we borrow kmp's overall @code{PROCESS-OPTIONS} and concept to deal with creating component trees from @code{defsystem} surface syntax. [ this is not true right now, though it used to be and probably will be again soon ] @c ------------------- @node Concept Index, Function and Class Index, Inspiration, Top @unnumbered Concept Index @printindex cp @node Function and Class Index, Variable Index, Concept Index, Top @unnumbered Function and Class Index @printindex fn @node Variable Index, , Function and Class Index, Top @unnumbered Variable Index @printindex vr @bye cl-asdf-3.0.3/doc/cclan.png000066400000000000000000000251311223164443400153660ustar00rootroot00000000000000‰PNG  IHDRS,[T¼gAMA± üa IDATxœíy€Õµÿ?§zzö6aDEP\\qßHÜ£F_~‰ Qž&š÷LŒ‰“˜øD5ÑDcb\@¢¢O4Ê2"È\ˆâ€‚Ê°LÏÚuTU¯Õ]·ºkýýcº¦êÖ¹·¾uë.çœ{®( Æ]€ÿƒ(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p<Š¾èìÑØø—u/<Øo½+pš‘§®Ý%¡·ÝÇç}…o?#Úþxå.TôåüÞX¨§™ÐöÈ €êz¬}T¹¯;¥à{îŠÆé³ÖÛ‡RzÌMÇûaµÀ©;.z2Qe'ÞtL©î½N]©2“OˆìÓßãÏÖ¸¹À©Úþnê)¤ªq´lÄE-ASl»í¾.çXPÖO¡ÚÉçÉBkÓtl¿*Þ˜ ¤“JhÜOÍ|a|š†í×ڔœB ¥D/É" Ài*vÜðg‹Òâ»×>yzOJ=Pó§ íöG,J+ÿç¥NY?göŠÏ£‰”*ðØÑYDÚÓ¼pN2ú¾ÃíqSçúÙ~§Ý¹®@*ο¸ÐGécó‘›” ä’{{$œm[óÜKï´€Ý_½1&›Œ§Iøì/+NûKÔKm+þôܧ& $<¿À©66\:Oì³r_·Ë‘†/|lJhÒïe“Rà4Ÿ}} sžÉ”¤cÉÌ ƒ/™uŠZè÷ãØ~M©ŒÍ˜¦ø¸ã<å8¡íö§íö¨Sóôåà4[åk8ž‘ßý=}šróм$íœZÏ’¯_CkÛýÿÀøùwµ5¥îè¦>*£TÉ|Õ…™  —™üÈcÓÚ­g=‘'¥ÝRO³1¡$ãõÝ0IÔÝ'_i¸Ýž)_›/¥¹rºõáG?î’¾çNJ¿˜…£ªo‰6wæÖ&Ó;•„T J eùFÚúà¸ËŸßl}±ê´¬Ãy-äðíw¾7ã…w"V•Ë€tc U'}ýØš´áêhoÝÑžT–¶u³çlÏ&l…ÈŒ'ŸqPïA¥já/ÿÞ:ö§3M?öœç (ûÝøþ:ö‘¬PþÐ2÷ªºJCD,¥¢dd¼$bô?ï –¯\¹n{—iš¦mß4ó˜p¶;\Ä[œæŽðˆû>½»‰W”Ü£.´åáq‹|R’¿õtá-ó-³‚}_¦j¢SÊÆL©«’+f5D²Êr‘N¦Ü37×iå*6ðµv lÈ{¿øÎW9äü¿j—Ã~9~sÄ)- Ï$ˆÒ•%Êç I9IÒ@(*²| £“Ü1 eJ@Cä+€áâŠÊb·¤FÏCÇÙ~B‹J»Q —/¨ä„i£®‹ÆRH›?™éÐätéóÕƒ¤öÌ‘c_ïĨ<ò›“«æß3¿-û8Ý'á=ö­êwØè#zö·F,ÛÛA×ÿ³ÑîØ¢;¶´{œR D<{Ÿžã ÓäœêuáÄþJíž‹'"Ëo{µ e ˜vèœ÷{œ8ip`Çß_x§ÕE€ùù–N¤¼Eú%ÕµíóÎxîe}ª%²Kö]ÓpÞ“š…>j™õ{ØꄓͳYºËóiTùþñWV:䌓{ðƒ_ÙµèÛ¿‰æ;f×âôµŸ¼Åzà‘þ›€Ò;¯s¹Yôøâ¦Îâêr£¨æ˜Ó†—²ð‡ ºŒÒ`àz=‹có ë ‰S Òðì²íÙ†´¡ýN¾°¯Û…¾÷·hY+À óòoÏtS­W+"bLÕI)¹ÇíÚ‚‰Å"ž¸À9qO™ˆ„DDÂzc•Ç {<4\/}GãâÅ^©¢—0Ê4õ¤f†VÍXóÊ@­ðNÞù¦ Pëj[\²¸èJ0G ëyÂÀcþz¦ÈÓçO:ùÏμÉÒC0sÓâtWÂñïäÿ^`œ5J«£«cåø›Ö ¬ñ§h¸eqËö'gx%k¹¹¿©Y Åi”¿÷ŸKß~Â;ù¼íf»«¹vôØ0P7XÙévG*ºú)_¤ÎX´/ôH¥¿Æ‡ÐlÐêãêßóËQ!tfHÍÖ÷³Ìõ⨛g­ÜUQ?%V‰Ë[ˆ(ضþ`ÒÈ9Ëõæi6ÞT[²¤è,"H-N§Ü¯€)‡kf{˜a4»^,Ÿ:p- ¢F¢¯êpj‡¯¡ïÇìˆdörh«@Ò&kÑ4¦zÝ7yB@¿µ?ÒÌ€×´n¨5üPÚiá?}#sëÁį_Tvq(¯pÁ»£çþlÑèÎö¬H£FrÅÀýtK°ÑR6·fÑŒ”€ãh&»«ß§ ìÞ_E³§`0Í×+Bx@@{ö”6JOõÓG-³YZ9‰MB  Z:ó68èqZ °RÒø<Æ}A³ C:AÛ|2ÉÏ7ºÈÚš9‰m$«EÓ{ú¢3@Óa Ìú,–¿&[•w4Ë0üµûiöÞ²]Œ<ÉPDAäY²Ý¡ÇéI ¿éD¯* îd­I˜sðÖ„/ãÆ:û×û=L,Ôë~„»BÓ+€ÈôWÑSº„ô«Þ`¿ ?Õ´m›vÒÁ}>õY˜tèqZ3ÛµSs w6ºÊÝpoÍ„J|кN¯ßWDó¶Šëqj\¬f§/pÅxÈdõLCOÝ„68§L›Ó7õêãa^ÐÇO(ˆü² ­·XS °=â•Î†_%pø}#|¶"ɈחÝRO©é#kç)tF€Î†< –û©=;_[¨" _Ͳ= óQS/×#Ô,¿¥Ñ}$©ÕîÖtº(û±êižs)Ý÷mžs>ÓK~oû-F¯¦¢Úœvy'qºzÍκœVZÙ5kŽ4&ð‰ßÒ|¦¥@EýûeWCµkZ4ÏÇ“ññërz€Îkj €­~K³]sbØÒ¨?b3Ø,x,èrz´ý5ßF@«^µ‹#:S+™ «+ñ)9ë“Ž­–RÖïîé÷cç³RG/Ô€"ºÞGIŠf{&³úñï$šEU¹o¼-@èµY+w¦ôèJí¥Uu_Sîxþè“3C—ÓòþnM¥nœR_y8iˆQµ¶–þ'&'.|POëqZP¶ hYsdü´« ÄÇ=³¶ñù¥Q¬á!8´ßɱ`ȯ§5Eq¯«Åïüôû”ÊÍ©5m ÌK§ÅšãìE;Íh4y¨*¥û&rj®0†kÉÞ¸ 0”júÅΪϷ¸ôˆÉ™zŠîY²ÙNZ³ÅL»!Ω”ßq-u«+óí§´ûÏq-Ρéf‡W­¤Ÿ4Wi•NÓP6e³oâ¬Óì< úԹݭHB€ËE´›ŽòCâ…ù¿·žR…ÇŽÎÙ©5úã¼S–æ›×Ø·ï@öí ¬MhZ÷ÛGUu_«·M]yWX}NϺ#—¬´šûćHºÁ¨î›< UY-Ðþ›Û’!‚Cûü Ã©-·øÆë€Á±s‡½ÞKمؠqKߧËãÚÝ~»’ºc)®ªJmD¬NŠ!ež‚K‡ØöúòˆÍì•Îy£bØÉ'Ö$ËÝ0Ýl:ø¨ÐÒëY Éb uð°“KÅ6ÈÈÑWÿÜöèOõ²5ò@ä‰k½¥f‡¾  óúÂÃoؤ‘¼V‘[µDwýûÊR1B""WeMøakWgÔ4;Õ™º¾’#m¿Êº¹ãJBÅ5ç¼Ô¢”RMÓO©>|xÝ©Ó›”R¦í¹ àÔ|%}p:ÚætÄ?:urýžˆˆLÔmšŸŒ©9$kÂvÓ‚šî›Ó–÷ܳ %CöÖµ02_TS†Sí&ék'êØø¹€õšÂû_e Ø”5Y¬©:BSnåÇ^wݱ}¦ ÂeÑ|{~œžk§=J‹R†‡ôô­£!ŒBe7`Ç&~cçzeŸh¾Èw0åCg6´·£»ÓêÌKK[€]YÜé’ÐÊБõ†6gàZ" ³V3bJ¶8EîeÕT4œ+¼à£ž†µ~—hºÔˆ.Ö”Þ· K}²2[*ÛO\Í‘?~óyó¸Ñà Y8}úÂó£]IvTk”6+ü¨`l×æwY /\€†_5='#Å€de¤,ÜÌL wm0Á\žÝ Öö»)7|ï:WÏIós€#všKqÚ'Ò3í\ýãɇ×Õ½øɸ'ï7Èâö™„ÐéP*ofM…]§–§_‹Ü¿€h֚Κ;›Ì®¥%Ÿ´žhKÀÙyϽ}Œ>°_ÀëÍ”áFÇìCBÖ¥è¨c㕈H¯T)-/_väÈI?^•´¸Æ4ÍE2| ˆÈ±ÙŠ` ¤”Rg¥¥¶^_l›O<K9'~bPѤ”Rªéûïÿ‹&eО`W¾c)?œvØš1µ-‰ÔŽÕW–Ä—}÷¿Ï!µT)I±êG‡—‹ˆP:jÚâÖØyÓ4WÈðCEDFÚ§\Ç“¦Cj}*§Ÿ_rJPŸxG*§ÇXmçt¥”RÓ{‰ôšî z¯ 4µÂø†¯õûδ±×ýIù®g°–~¨³œlB»%¬þJ‘½P‘êóæ:œ™¦ù¾1|x"Qs'VTLœ›RçéÕðTNk  Ç´¹ñw‘Êé*«'” Q¥”:EDäGìq"°ÿîå´Ÿ3†êÙÏ·eîQNol!¶~ï@^MÐq¥8nI"¡Øj>Ó4#ý“9Z,Rœºj0#§;ÛBµ±o%•Ó–+ì¼{oRÊSçÈ­`xÞ ù|™^b ˆš7Ç•¨ 7.SHõÁ‡UAB·W!€$vRïþÙŒ©…ÌÄp·¥)ëQVuB§KWäŠÎû?R”¿û™»'”ƒ¹á®L£‡†gí¼›_¶lHºh*üõÚîð%¡6v´‡ÔÈo—™J %ßY°zõ³G†$1Þª I=ôÌ@Iù r—ÉÊåÉó€ÍzÖ춿üPÁ¨›¯:몛GbãSRÎj¶C¨û"ðÄ.€+Ù}q:.~ÿm–îÈè1lXûiË+åÎiÇ5¡¸¾E¤×/œ Éœ6žJþà\l™{I% ¡J©iŽ¢ŸuujHDBS•RjmÕÓvÕ P—7¥>9UçÛՆߛJ©¨jYpÏ5ûÄ´'E6OS¬Ä«-NFÅo_}¨¤"3§j•£Ä*;pxÝ)–%^¥ÕÓŽ…—ûõÙ‘x&3 ‘J©ãœl†X×æ’¢#¬ïèg†ˆ¿VqNùB8}Âiq&ÄNµ<Ð3…¦]O;z'j„”Rªã…}SÒfùöUÇêÛO5rÔ¤[âú먩2èúÐz€ˆHx±²“%|,-s§Mq4M“BšdûL˜¦R#êÝeúÏnn|¸@TC{‰=•*ÿæS?H íw¦õÞ/ÕjþêC7¬‹­¤|ÐqßÎ(<Üebª1…(½èN•Úûڮ‰³·¾}¡±öt',š@›(;æDžð÷ ¢ƒì•¦ŠµæM?ëoÄjžW^~-µž*åôM"bÔL[íT@×zê‚Ì:éD¬><$E“U¼ž¥*·“°±Ë4MÕÑàë hÀg=5ÆÎP†*fèïû_ßz⥵Ÿv(¤òÀããöõ¯Ì[iç <âîïÌ\¸5ŠÑOsFlsãÃÐßýéƒ/Küe] ú;G€Z¿à+¹)~‡¸ç:ñÄ'•²ïµ×º8,LÒæZá^^øY hýá·²»ö„G§†µ;?«Å‡^1¢I¹Î_NO*±=&Ÿ¼¢*ùŠ‹žopQ™âL%£%ö'±uªuGGùñw5×óÑ­3ÿT½UëlU¡×d›*_Ïšû1íÿT@Á¥õ€_N«÷·µÄ+æ|Í 3û7î¹hmõöA}·®ˆ®”0…‘†ÿØЛÛ(a×ßZ?\ €uµ=nÉQ0ÊJ+{ï?jÌá}Ò&‡åZØ°æ­Ò'ï ç9Lo'¾ ¤íÁ>cYºü™&­["ÊÅ/MŠJv)@pæiÃ=4¯öËâWãÿ·­yî¥w"Šx›­P‚zeX& Šè®][×/û*.ª¬.0>° }Ó²¬lX´®tF«ËµÞØŽ.y·ïúk_±ï+5š·VgË嘤bèéçfë‘Ž*Í’ö¶¡pê² -m*áþX!4lMb±=ççvF¬²ÿï|oÆ+"í]QÓàí:‰§µ¡Nת˜¾9ôêpîóŽÑhf!T”YaÓjÕ§$u#@¥•úáMQ,(ÓTñ5úÖï²úÖ†Y+vJÕÈSK^¿+‚Pï{}|:ü¯±°É¹O#î¹fuJÉKòAk ï ÎS.ÝõY»‡©5] ??ëZð¯.ì—èÉê– I )ÿ85??–»×;r;VY«¥>/¹üsºïr{ŠC{gî£Ì¨©ãRé…¢}9ûû]5¸ ÎZî­Œüv8³àŸÓ±/Å…~¯fI Õm!Í(*©£WÝ”3ö3hü¹Ç 7S뢛¯aoÚ±3³Á?§§ÝšPP.aC€²æ¾¾jÓŽÎÌO¨dÔh–,%‡X§¤¤vüd;DÚå¥s>ÞÕÉ»6&ô‚ ²*®Zk»";tA4”—ÆßÃÔÖw„‡}ý˜^Ÿ-zQ<Â7U´en¤œ÷±,þõÒƒî;°·`ÍtÃûxBµö$6 !UõSÆ”›M¯=>/¾¡.µ·]ÚVã„!?ì5kõÅîå”qóaÈÝ'-]!Ì´9}üÜ0¸†ÌœZ¸÷zEQ ôJº×K †½pt⢳iþËï¶ÄúÖÒ!gœÜséÑ cÞp‚öæŽÌ„ßš£¾ZPØ gXÂ#½Ó]øòËQ K€ÞÞÑЬêw^â)£ÿyç¥&{1fÌ>+€PÝ9ˆ8À^Å@Pñ—Áî*½RAßGï+®F}¼×ììá•lXÕ«ä,ï"x"N{ö„M³Ü‚#K§0}¯êï¼Jïp”Í­¥ƒ½Ò}VTÕážI5KU?–}F°³ï§ÊIìº÷Gf›=¼tMm›ÁRNUâ»8éÈ…Óó¡éE¥µNJ¿zOâY.ðLú¨Tß6¬hTT)uJß^.œ^æŸm?2]1;ÃàWÑÖÇsÙ¼…"óŽÚ6žT@h”ÚªÄü˜Í…Ó¾EаE+ó2€.ugå}|BÒ•¢©x±EjŠWº%`uûõÖ%žC®f°|:/ ¤ÛÍ•SžQhôRÖhG#ÄF± “s)Mf|‚Ôè,“¶:†Éx¢åÄi90'Þ¤Zâu‚Êw2>—ÒdF'(±[h¡Ïà@ö<ɉÓj Ù²Èiuü:+â‹ q±P 0P(!—ƒoĨ;'Nëx!Xå{‚q¬I@›ÔÙžé\Ì#åÄé”b`†í ñüu°CÃ[+à(T†3âΉÓ1}÷æ/>ãz"Ú¤HG+`Yº{c'¡¼è|P£ëñ©7ïççã÷n¥£ É"[-&{´}\nbà‡ÒLÇi°æ%Z/_€^z±=-ôóN¢‡Û¾}F¬ù!7NCDn_„Y+h´mòâgÁ× >ÒfÅ,›ÆË ¶çÈSkÈW²¡ ²“z¢€Öž¨6<§æqˆ~î{ýeÏ£’—§Öú‘æðÍ^KÁk ,]€ýMBC5z!ò¾U+N ÄhJ®œ^x @äæex4•F9@»îf2ú;$õj°ÜîkÏ“€s¹qÚ÷7=þµñ6/•S5€©½™Ìg Ë®L/,¶¼‚©j#Çáø;­h|Ÿ_Ö”½Aµ¾'Ý=î" õ•¨žF&]4Y?e}ƒšs丼²ôÒ¹3ÅGWß³_¶’X£C÷mŽÓ°cÆ Dsý¼œ¬—.ëÿþÏÆöÄj`ÇD9¦wPÓ¸\—¬–ßÖ°@͹lÊè´¼7w•ÓªÈŽÖØn–Có›õFqß½z\ŸÅAÙöúºÐW앵åR` Ö+¨ROÏqÌùª«e{K†0B7’g\~9;È™3.éJ÷KCR;™†a EáP¨¸,,XùG‘ð8þs:@…Æ`¢¼ÕÉÕó)C¼8¥y8F®~,VTMN³¥°’I¨´²¢8û³EÖ+ (£zÿÒ~8ãÁo§ÁÉÑsó¤51)yq´·nŽô§ñÁ)ÅòPôÿe’ÆÇ}M[Ö‹*0Sv¾hZàëÍG3þ§Žib'7øÙ­ÚùpZ~Í=UÞ©öX„J«=ËþàCG)9¯Õª-ßÓÏ(må~O¡]§$½.]ЪT«¸“#Z”Ê?À„üBª”÷ iî{¶gôF‚(Êö8úlkYì {5”|·<ïuqä¦&lhsú ùSHbÓÂCöÚ¶¢“Ó“çŽ<9]·Ìei“÷º)}d\9¥ƒP%Vaô8âì´óÛž¶¥×÷%@äYá#ó~ÿæÎPEU±@ä[¥ämRI*”T¦·KDhŸcÏ–UðÌ7Ôœ÷f¤Í6°F¦ßäD?Ь§b”ö<許Ù‰w+:× Ý4~#PúYYœº÷ªƒe„`”•W—¤–ØsÉýn@kÌûàÄò@{Ð9=òmÇîa%Eå=ªjjkɪ‰ú"¡¨”È}&P4-`?úà^Pdþ–·•W÷Û“‰ŒC‰‚Yç™À¯ûÞ %+äôK% šÇ¼^¬ì€\/¾dh7ÙëÌ ccïäԊΠQ@ñO=Ö"úÆÞÉi@E–3>èyóÞÉ)€bÞN€o—­ŠØk9Up@x‚÷Š$ŸØ[9U°m>@}Mà®Ä{%§ ‘_·üw~ñÜ°7ŽO@ۣߋ¥Ÿ•ëmÙè{a=U‘ßN‹Œ+üÓß9hìæ€^îñéóÃÞÇ©ºž¾¡ òŽc57õƒ½¯=U´—®ÿ€ñ›ËÊIíõ:ÕÓÖ–Ë·^^Œ2öFNËÔkpÉõ¯´±×}û "/^Ñ”oì)š{_ûC·ØNöTØõgᶜÐ3ˆ…å.øÒsÚ¶æÅÅMY¢ÖÅqÑ ÖÃîºý®îŽ: _nNÛÖ½¹héºÝÖköWŽ4ÀÜp£µª(€¨ñîèÆötû_îiŒˆ”T9ãâd¿„ÎËÞüWSGîÙ›‘OýE,;þ¢%Ÿ.xôCëßã^'(gót§‘†g—lü4i³Œ£¤²²³}{K[Žñ;óE,×?üÄÁqÚ¥¾kDËúØ7µÙcœ<ÿ’€]H¼ V?Ъ”RŸÿî¢Ôji­Œ:ÿÉMQçÞ覧.?j@‰‘¶€";Œª1¿~¯#s‘2¢õj§,•«ótwÐïoØ‹Ò^v÷¥¶\¤aÖŠ´}ºÝŒ5¡ÞCŽ>qlMzå2›æÏI›®ë¹ÏOFD»¾ÕúZäG·æ(à p:ç”Øaño¿‘ü°Vx’Ú “ï ”m™Ú.(#Þê®<ò¯êßlmyñý­ù‹ën´Þ_d¸r[7å¿™eÅbŠ¦_Ä–VÝŒÒË/´ÂŒFfwSùûÿ{–3´<ã©/¥@cÝvö{¦¾[ œw=mþ±C©\÷å ”Ú;¬§þøìGµ ùAÞœ>cm ¦ ÜGÀ­/Û[yn¾M; äËiÛÝ&X^]#‚]iÐèù[¹°iVwˆÏ—ÓEï€5)U¯4èNŒßßúUš…ü!_N¡öŒÓ{ ‚=åŽ ÿ–îž'§‘ùŽ¿‘yo?²çÀíì‰}Ô¼VlY¾T!'œ€öÀ±”y—`qÕ€@ʳ›PowR£ºCx~œ6-RÎ.RXˆ×Ý)‡‡9ø?ºCx~úÓùm8Ûrªì[‡ïaóËY+wUÔOñŽ‰žò››^þ'Sóµ|i†§lybÎÇQzŽ¾ øùi>œ¶5Lù<&$Üá‘zBä•ï}h=yùÐ㦤õÈypyìæÏãÿíûI¥ñ ABbh[3ó©Æ¸\†LÏ1îg&äª$Œ¾snR[\ñ˜ud@¡œLÓôªãñý“m5ÆùÁ”ÆA®œ¶izWCÿœv¬8Á!”Xp¶¢~ðVp&Šœ8myqxº­^¤hš[bÓ•š \$¥ÔäÔ©kƉ‘íb @íÕÕƧmKîüg[lƶmÌF÷¬ñkÒ+ÈÐ3*4i¢Sgí´ÌçÞP Âãi7ÜÄ7Uùç4òØ-[íÃP”>?xëíö!㫵®[jùôò‰Á;Â/îb³zcFÖµ"Š—Þß/¾(RýsúÏouž%<ñ‚Ómïç‘w,fì™™ïÒ³%T;-JÝåf[Eöæ›Î‚QUS æÖmQ€–i—2Põ=>mž¼ç‰eê½ÎéÈò%Œl¥±öÌLèÄJ‘i`™&Ö¢øDZýKBëe3c‚1WO¬1€/?ôZ`ÀŸƒñKóÛ?Qä4ð"Æ/’.-˜Pl•©ó÷9PÊØûxtZÙ¯.Ši$E.‰wJ-—ZÕ«|1|륞‚²Yí31éÒ’Å*ºìÁŒ–ønSÝ«[V1ûÏNz¡ögñªüŽÑjמ8ZðËiÛ[†TåOR¶Ð2õ⢌7û :íÊÊ#ÊŽÚñ€BÙƒ‰{t|æ0€õës¿œ®Ø ò‘·“ÑûDnÊ°]”ßmo²¨W¹­—W7”"Èéã“. ¼ÚZ^ÍAjürú¤­~¿=3eè1ê»Ëÿî~k ‹ºUʯ?¼`¡vÊ+S ?¹0_˧lürº§×w^ª›^ù× Ðõ¸~«”™ÏA”/i6ÞA gè—ª¼@†Y‹?øå´9vtNú¹ü†^óÞÕ——‘¯uT*ý?ï¥W­ ” Pž:â W€³!ç}#‹ÝöËîUÐ<Óí¿_«{ú¬´yf¡ÀÞÉ.ÝØÐ’ ƒœm|» €Zèr%ÓDÜïSäÐ&§dÑðY·Xö-äÌi¥«Óó9U[ã'û”`˜&/rs¢Ú¿ñ×PH§š¼6½Ë9sê^_†öH\ë¤,}¢uìG¾ç¬Y¥¥ð¬$ »jÑ¿ú(‹OøåÔ#}Ø-ÂHvr2^Í@jªJ IB*Ï)³ k+…RiÛÙµE  åb~…ô²ðЙÚq¦låà<©R*漦\RX÷ºf“È`ú7}üzZlî¤Þ};¹›Zò1ä ä—SÛVÑê:]»)UhJ¡\æ–Iÿ'¦•y6+ D)‰<§e0ü¿ªœãŽ+7%&‰ÜÙ H |úåôl[áªצ_ŒÌ:e'¤ìŽÚðºÐŸkº]ó(QzîHåÈ(½ôç=œÛÞúM¢²§áu€²)™éÁ§«å§´§ÛoæÖŠˆHè¶äÓf$_³ÿK¿Ó]XVñQ3õ¼“6ò’åz*Bø¡˜Y¯cÅQ""rJ 6)ßúÓ6§¥¤X‚É!©«µ8Íd taÙ‹Ó3S3–ô®Xu’ö|¶Ý^…ˆHå|¿l¸Â7§oÅìúe&­øì˜=Ô²H˜™ºÔ§n ºJr9;Üé\N“kšÑ¿Æ› õY_?¢¶Ì2KçcöÍië!§L½ÞŽŸîXzN‘ÚWÓK–§©ÖiONã—­ã¤ZýLÌ÷D±þÝ/£‰ÂüûKEÆ¿åÜÓg€C¯¹}s'€d´é¤å#ÙNg†‹íÏ‘a>E‘EŒúdò;é12è¿‚1ñåâ/õê¤ñN’ó„ôÎæzàRÍÜko¸¦Ò¹1†´Šœä3Eù·óDÉÓÖukÁ!3},C“àyƒÿbDZvP‚¯”…ÊËßÎ%€;rò•lüÆ÷Åöõõ»žÜ÷ÇÞ9µm‘>~§ áÁ“NÝ/À &¹ùŸnyxú§.²&<ì?Vrþ»)^Ê–'ž[Ü 2ñ•îž«Oï–{jJ¹µúš›z¸'ÎŽ˜˜Ý€fã=/tqÛ¡Ý!:÷½â›æ?ÿú'1­žô˜xuÀ.Ü_ZäµF‰ÌTÕíÿ%Æ^ûx7`oŒÑÝÝ(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£Àið(p< œ§Á£ÀiðøÿdYbÖz9rIEND®B`‚cl-asdf-3.0.3/doc/favicon.ico000066400000000000000000000004761223164443400157260ustar00rootroot00000000000000(( ÌÌÌÿÿÿ"""""""""""""""""""!"""" " """"  """"" """""""""""""""""" """""" """"""!"""""" """"" """""" """""" """"""""""""cl-asdf-3.0.3/doc/index.html000066400000000000000000000570631223164443400156060ustar00rootroot00000000000000 ASDF - Another System Definition Facility

ASDF

Another System Definition Facility

ASDF 3

ASDF 3 is the current successor to Daniel Barlow's ASDF. It was rewritten for improved portability, robustness, usability, extensibility, configurability, internal consistency, and the ability to create standalone executables. It was pre-released as 2.27 on February 1st 2013, released as 3.0.0 on May 15th 2013, with further stable releases since.

What it is

ASDF stands for Another System Definition Facility, in the continuity of the Lisp DEFSYSTEM of yore.

ASDF 3 contains two parts: asdf/defsystem and uiop.

asdf/defsystem

is a tool to describe how Lisp source code is organized in systems, and how to build a system in term of actions that depend on previous actions.

Typical actions consist in compiling a Lisp source file (if not up to date) and loading the resulting compilation output (if not both loaded and up to date). And you must typically compile and load files that define packages, macros, variables, before you may compile and load other files that use them.

It is roughly what Common Lisp hackers use to build and load software where C hackers might use GNU Make to build software and ld.so to load it.

asdf/defsystem is the part that people usually refer to as ASDF, with uiop being only a supporting library, that happens to be distributed at the same time, by necessity.

uiop

also known as asdf/driver, the Utilities for Implementation- and OS- Portability, is a Common Lisp portability library and runtime support system that helps you write Common Lisp software in a portable way.

In addition to many general-purpose Lisp utilities, it notably provides portable abstractions to gloss over implementation quirks, support hot-upgrade of code, manipulate pathnames, create programs, use command-line arguments, access the environment, use the filesystem, call other programs and parse their output, compile Lisp code, muffle conditions, or configure Lisp software. See its README.

uiop is distributed as part of the ASDF, its source code is transcluded in the single-file asdf.lisp being distributed and the precompiled fasls provided by Lisp implementations. ASDF relies heavily on it for its portability layer and runtime support, particularly so as to handle pathnames and filesystem access. uiop is useful on its own and can also be compiled and distributed separately.

What it is not

ASDF will not download missing software components for you. For that, you want Quicklisp, that builds upon ASDF, and is great for pulling and installing tarballs of packages you may depend upon; we also recommend clbuild, that now builds upon Quicklisp, as a great tool for pulling from version control packages you need to modify or want to contribute to. We recommend you should not use asdf-install anymore, as it is an older similar piece of software that is both unmaintained and obsolete.

If you're unsatisfied with ASDF, other somewhat actively maintained build systems for Common-Lisp that may or may not satisfy you include: François-René Rideau's XCVB (trying to build object and image files deterministically and in parallel, has fallen behind ASDF since 2012), or its polar opposite, Drew McDermott's YTools (trying to maintain coherence of the current Lisp image at a fine grain), Dmitriy Ivanov's ASDlite (a somewhat improved incompatible variant of ASDF 1, less featureful than ASDF 3), or Alastair Bridgewater's one-package-per-file quick-build (similar to faslpath below, also reimplemented as the ASDF extension asdf-package-system). Older systems that are not maintained anymore include Mark Kantrowitz's mk-defsystem (free software successor of the old proprietary DEFSYSTEM's and predecessor of ASDF, obsolete), Sean Ross's mudballs (an attempt at making things cleaner than in ASDF, aborted), Peter von Etter's faslpath (a much simpler system establishing a mapping between packages and files) Alexander Kahl's evol (a reimplementation of the GNU autotools stack in Lisp, abandoned), and probably more. However, none of these systems seems to ever have had the traction of ASDF.

Supported Implementations

ASDF 3 now supports all CL implementations that seem to have any current user base, and then some.

Most implementations provide ASDF as a module, and you can simply (require "asdf"). (All of them but CLISP also accept :asdf, "ASDF" or 'asdf as an argument.) All of these implementations provide at least ASDF 2, and a few of them aready provide ASDF 3 (abcl, allegro, ccl, clisp, cmucl, ecl, sbcl). Hopefully soon all will follow suit; but in the meantime, you can download ASDF 3, and use (asdf:load-system :asdf) to upgrade to the latest ASDF from a properly configured ASDF 2, which you should do before you use ASDF for anything else.

A few implementations don't provide ASDF yet, but have announced they will in their next release. As for remaining implementations, they are obsolete and/or mostly unmaintained; still ASDF 3 supports them if you load it manually, though there might never be a next release to provide it through require.

Provide ASDF 3 Provide ASDF 2 Will provide it Obsolete
Free abcl ccl clisp cmucl ecl sbcl mkcl xcl gcl mcl
Proprietary allegro lispworks mocl scl cormanlisp genera

If there is an old or new implementation that we are missing, it shouldn't be hard to adapt ASDF to support it. Ask us!

Examples

Download any of the many packages available through Quicklisp to see as many examples.

Documentation

You can read our manual:

Regarding the internal design of ASDF in general, and the work we did on ASDF 2, see the last draft version of our paper for ILC 2010, Evolving ASDF: More Cooperation, Less Coordination, or the slides of the ASDF 3 tutorial presented at ELS 2013.

Finally, while the manual covers all the basics, some advanced or new features remain underdocumented. Please contact our mailing-list (see below) for any issue that isn't well-documented enough.

Until we write more documentation on the further innovations of ASDF 3, the documentation strings, the source code, the changelog and the git log are unfortunately your best chances for discovering the available functionality.

Getting it

Though they may lag behind the version here, ASDF comes bundled with most Lisps. To get the greatest and latest, you can:

  • download just the latest release source for asdf.lisp;
  • download the latest release tarball to get all bells and whistles;
  • pull the latest development tree from our git repository 
    git clone git://common-lisp.net/projects/asdf/asdf.git
    (note that our "master" branch is for current development; get our "release" branch for the latest stable release. Run make to create build/asdf.lisp);
  • browse the latest development tree from our git repository: gitweb
  • download the tarball of a past release: archives

Extensions

Known extensions to ASDF include:

  • asdf-contrib, a collection of most of the below.
  • asdf-encodings, to compile Lisp source files with character encodings other than UTF-8.
  • asdf-finalizers, to allow macros to include code to be evaluated at the end of a file being compiled.
  • asdf-dependency-grovel, to compute the actual dependencies in a big ASDF system.
  • poiu, to compile a system in parallel.
  • asdf-system-connections, lets you specify systems that are automatically loaded when two other systems are loaded, to connect them.
  • asdf-flv, to bind file-local variables around the compilation of some files.
  • asdf-package-system, to compile Lisp source files with one package per file that also determines dependencies, in the style of quick-build or faslpath (hopefully to be merged into a future ASDF 3.0.4 or 3.1 release.

Former extensions, now superseded, include:

  • asdf-binary-locations allowed one to redirect where ASDF creates its output files, so they don't clash between implementations and don't pollute source directories. It is superseded by asdf/defsystem builtin asdf-output-translations mechanism; a limited compatibility mode is available to easily convert your former ABL configuration into an AOT configuration. common-lisp-controller and cl-launch used to provide similar mechanisms, and have also been superseded by asdf-output-translations.
  • asdf-bundle, née asdf-ecl, allowed you to create a single-file bundle out of a system, for easier delivery. It is now a builtin part of asdf/defsystem, and allows to deliver a single FASL for a system, or (on supported implementations), a standalone executable program.
  • asdf-utils was a collection of utilities that originated with ASDF. It is now superseded by uiop, aka asdf/driver, which is part of ASDF, and exports its functionality in its own package uiop.
  • asdf-condition-control, initially part of XCVB's xcvb-driver, allowed you to muffle uninteresting conditions during compilation. Is now superseded by equivalent functionality in uiop.

Contributing

Join our mailing list, check the code out from git, send questions, ideas and patches!

Reporting Bugs

To report bugs, you can use our launchpad project. If you're unsure about the bug or want to discuss how to fix it, you can send email to the project mailing-list below.

Mailing Lists

  • asdf-devel: A list for questions, suggestions, bug reports, patches, and so on. It's for everyone and everything. Please join the conversation!
  • asdf-announce: A low-volume mailing-list for announcements only, mostly regarding new releases. Posting is restricted to project administrators and to important notices. Please subscribe to it if you're a Lisp implementation or distribution vendor, who needs to know when to upgrade the ASDF you distribute, but are otherwise not interested in day to day design and development.

To subscribe to these mailing lists, send an email to, e.g., asdf-devel+subscribe at common-lisp.net. For more information about mailing lists at common-lisp.net, see here.

Contributing

Join our mailing list, check the code out from git, send questions, ideas and patches!

What is happening

October 2013
Version 3.0.3 of ASDF 3 has been released. It contains many bug fixes, including notably better Windows support.
Since July 2013
François-René Rideau has resigned as maintainer after releasing ASDF 3.0.1. Robert P. Goldman is interim maintainer until someone more gifted, charming, dedicated, and better-looking can be secured to fill the role.
November 2012 to June 2013
François-René Rideau completely rewrites ASDF and publishes ASDF 3, pre-released as 2.27 in February 2013, and released as 3.0.1 in May 2013. It now includes both the traditional asdf/defsystem and a formalized portability library uiop (née asdf/driver). asdf/defsystem is a backward-compatible reimplementation of ASDF with correct timestamp propagation based on a consistent dependency model, and featuring support for bundle output, deferred warnings check, and more. uiop provides many abstractions to write portable Common Lisp programs. Last version: 3.0.1.
December 2009 to October 2012
François-René Rideau is de facto maintainer, with notable contributions from Robert P. Goldman, but also Juanjo Garcia-Ripoll and James Anderson. ASDF 2.000 is released in May 2010 with many clean-ups, better configurability, some new features, and updated documentation. The ASDF 2 series culminates with ASDF 2.26 in October 2012, which in addition to many bug fixes and small features includes support for file encodings, around-compile and compile-check hooks. Last version: 2.26.
May 2006 to November 2009
Gary King is de facto maintainer, with notable contributions from Robert P. Goldman, Nikodemus Siivola, Christophe Rhodes, Daniel Herring. Many small features and bug fixes, making the project more maintainable, moving to using git and common-lisp.net. Last version: 1.369.
May 2004 to April 2006
Christophe Rhodes is de facto maintainer, with notable contributions from Nikodemus Siivola, Peter Van Eynde, Edi Weitz, Kevin Rosenberg. The system made more robust, a few more features. Last version: 1.97.
August 2001 to May 2004
Created then developed by Daniel Barlow, with notable contributions from Christophe Rhodes, Kevin Rosenberg, Edi Weitz, Rahul Jain. Last version: 1.85.
cl-asdf-3.0.3/doc/lisp-logo120x80.png000066400000000000000000000322121223164443400167740ustar00rootroot00000000000000‰PNG  IHDRxVÂR”gAMAÖØÔOX2tEXtSoftwareAdobe ImageReadyqÉe<4IDATxÚì}˜UÖö[&ç<Ã0„!g‰T$¨+ˆ«`€³kZ]×UWÝ5­®aM¨ˆY’s2aržNõŸsªº»ª§gÅôýÔ<5Ý]]]uï=é=áÞRTUÅÉíÿîf99' |r;Ià“ÛIŸÜ~“ÍfüØ}t §ª°G&É«lŠâ;®z<´»éŠÅÂGú ‹G=¬öp¨ª‡~C§Ó¹°Òqg,|Üí¢ßŸYzïÖ¸Îf—ãªÊ×´A±Úäú| yu9ùœ$ºþpúmjÃYÔ†dz£ŸGÓ9!­§óœô¿ŽÚPFïk¨¡+èbË蚨ݛU‹¾¶Hûé›îÆj(¶¹?÷Íãvh×¢~)ôçñ8é¸Fß¹aáþºòé'õ‰ûÆ@–Lj¿—q¢þñ÷AH5›ÇÔ#/|mßøªÚøj×p·HÈ¢À¿Ózª ¡×É´¢=›ˆ墤ђ¶S)Â?ôÁÿ3#{ªâÄÒ»XÕô:Sµ¸u@íëh_Hû<Ú÷þŸ’àßM'п[hB’®:jE‚DTDºtꆜŽ)X±"%¥ÕB^•¤ÀLÜf\@EѤ”®g ‘ó].ÕNR’êq;Ç*ªg¬GÅ3"Í@°ˆÎy‰^¿=iƒz;î`Mãv9Tg]å<·Ó1š¤,\TÂC*Ôãj$Õ^©ý6Ñxà/c’)*ÐCÒìö°`*>ú²Êó£[xXUÒ«êQj‡£Ñ+§Ä WAc}-’ãlè ·Ó…èè0d´ŠgâÇyœ“Ý•ßÙ`Ž)¦ýÚãOøè’zý;äv5¸Ý 5OºœŽÔ¤„h´j ¶Ìíl¤½Þ;ÉÆi6Š©GÒ…ÍÛ PZZƒ°°°éîÒ93®‰áC;ÐgUTvBBþë99¼D´‹/Œ˜èP„G„à–›F£w¯L|¿<3g¯@ˆÝ†[gœóÏë ]°ª¢ ß=Ï<:Žúzº·âwŠÇÑp¯ÛQÇ꼆ö§ØîŸ$°y#u§¤V|B’ÚÚba¥bÒ9Ýñʳ“Q_× À‚Õ¨›Žg·MÂÈÓ:!:*N—W^z*î½c¬œCªUˆË„8 žúçd"\a†ÆF’“¢qÁ¤~uZgÜrÃ(tí’˦ À+öÐu“ñÄ?&Âfµcü¸ž6¸#â¢#pæé]b#õmÅgŸoÒ41™›´‡0œ[dÔæHÒ(·z뫨O…´Oùÿ™À|¯ydãT’Ökl6 NÞ £†µƒ³±^Ù±]ª$ÄÆjYI>mn¹~4ºw™·³?ZK’iÅëo¯D›ÌL»x‰À¤üÑ·OI¼«×ÂÒvcÄ°lÛYˆ…_oÃ…ç÷ÃØ3»‹QWô?xß‘ígB«¼+ÐçkÈíâͧÝþ˜ÀÊ•<äON±ØBE¥’ ^½ö Þÿd©c¸ç,"N¤ ÛÓÏ‹ÓGvF«ô"h$"çŽï)`jÊä~X¼t—Tãò)ƒðö{«»û–ÿ¸7Üþ*ÇÚuyâ‚j@Kógo¹ëC’Þ]ض£—\ý**ˆÐ!X¾j?IòNd¤ÇcíúpS]}ùP ÜÆuǼù›ñÍ’\T’dï;pDGñFnÜÙksiÄ©¦¾:c  ±óüÅo†rŒÙ¤èˆ Jîv7T§{y t6ýæ¼³{!!>ýû¶ t(¿?±o¼p¬6ÞœµãÇtµ½à«mس¯Ûw‘êuŠw3D&UnᇦҵñVLíöùÈü^Õ¾Wõ6qo,ò·Ãn·¢g· ô%–WP‰ªÊz¾úô²…Õˆ‹ #µZ%v‘¥óÎ¥s‰ØßZHõ†ØµAãÆë ‘@U ôPt7Ú{-›ÉWv4ºIÕ»±lå>,[±W~‚¤4)¾~Èø«Šßëf& :»nà€ }g±†0H»^o¥¯Î¤ý›?` CYê¬-j ‹¡~ºD²%üçí¸j?P§.÷ï€9_lÅ#ÿZDÒc#Û«âñg¾,Ä ± W¨f%¦Ý[1$Å‹•šJœbŽ‚ÕÁ×mÌ—ó­K`¼¤é­ôÿlës?lÚ’/×TÝÑnDv ™¬¯­ö¨5ô¡ÿ‰À•îÆÊ[D|q]ïÀzGCQu»@ȃמÜŽ¤§ÅbÎümtŠ*è—GÞF*X Æ€AôÛøé7>žÒm¦% ˆ¢_C1|§šîj±*ͳ’Ú”Óø…Á^çÀg©â òØ(ÖPÚœB€SÕïßýž ¯ºew#¬aÑÀð@ 0KŠá°³>Ú€Ââ òC-¤n­MFM <*A¡vEõ‘Ò„Í\YiBDEizLõžj¸¨¼%B¶Îˆ'|)‘3ox•77iµœ¬X䱋æ&Äí¨ùÖj|¾ºè÷ˆ¢3ÜueLT«,püVÏ¢@V(Ôé}uÓ¹GJkÉžÚ%ËâE¢ÐcÄŠoä HAvïqý~Þߛ߯ û›v-•¡õÅÔ‹á|‹~Žñº ×/ Ñ‘¡¦ã.—ÆtÃ0Bé. I³Å·£áB=ú»’à·£._:ÈHQØÜ 'Jór¡±aŠ ñü¥Ç@CÕ'¬2Ø’…†Aª›±ÕjS¯À$ô¦Û(MT;¿2"÷K¸¦3ÚµM$Ûíc ¹`žÔ£Ok[ï™ ü®•Åj#Z»RAóO³h?ø›K0ù{•Ò{˜I:ÌÒ€‰ Øá•-ì•FÆf}{´FRR¤IRƒKžQZƒKbÐãÞ`…EσŠAŽ!@‰ûB¿jŸ„’V¯:æ€GV›T×6J¿8¼zéEýqÃUCðØÓ‹Ñàth h=q'ŽtàÔ_ŸÀ, d+UE€ÂÎìXC"õ± >0¨/øTž‘`Ãq?¡øü6mâ‘‘£ …%€À–miá³Ò”aš0%à~ÆÏ~³c<fÇ7@¹T¬¢#Ã@& ¶Ö)^ÁŒk†á¦«‡àñg¿“`Œ•ã¾1±hdÐ}^‚ê YFþôk˜{ß.à¼] 5I¶ðx}l ƒÁØbTèŸaÑ hàþ Ré“ zMLˆ@Vf¼> ð ªb`³­4^3P"-¶ÓâKfJ7šÝ-Aß3êߺí0 ‹ªñÜãçJ„,>.œˆ*~þ-Ó‡cʤÞøü«øbQ®p|Ìßäš¡-ZÅ˧ÔàsN4#>gÓþëFÈ´pÕUN´G&h¿4H¦‰Xð¦×¹T‚ªS BÃìÞ~™”£S­2âôã’èe$JÁTzÕ«˜Y &¥&àäg“ê×5ÍnÅÿÞ^ˆð<õñ¢²E-O=¿.œØò*ðÌ‹Ë$J¦Õ>æ]¢kb—ëçÐÛ1'’ÀçÓ¾€öËôϽ4ƒ¯¡·£þ;kH©j«Y[¼«K*´ÐŸd•®Ã#òT´2›ÈˆPL»è¤$Gi9WÝ6ó`dµŠ5dp€ñ«UK »òöSƒJ‚èö˜ÛþÏg¿G¯îi˜~é@ £††Ú$R÷×G¿FmƒKóñ}ýW‚î¾ëóXXC¸þìK]ÐNŠžIû´?L{kÚt§ öè¦Ð,w]9lÑÉ^ÇÐD½Äô˜š‰ÖéÑÈ& Á\]Z^‹»K°{?Ù‹nÒòz¬ÚP€Ü=o¼·Ë~<(ß[m 2[Å‘šÓƒ_¿c»D’ˆJñ'UÕhƒ‡°Liª!ÀcD ðm›E¼ña#2ׂ!ë6â³ùÛ1þŒßo9§œB·‰t7TO±FÄiÞ‹ª#>úã$AFZ:¨èÞ9]s’‘Ù:ñ±aZVG0vÖo)Â;nÄÖG`³éö†:»i[1^~g»w4>œ·/¾±UU¤Óuíä'7÷è“ŽsÎêL p{VúÃÇœUQüDÒÓ~F×HQ•cˆªcgæð 36KèûŸmÆèaíHz­ÂœÌ؃úeb蠶ص» ïÆÖíEâC1DàT£«¦ø|GEwÃèÄbú>^Óp'ÆþíCi/¡|%N(© '©ž¸˜0òóbÑ»[zuI“÷1Q¡Rÿ¤elT8æì‘8|`Ÿ è•7?Ø€YmÂçóëÚ …xøéïñÏûF£I>çƒYÚÏ>3§ôÎ@¯®)xô¹DÂyàZ¦€jòU¿£ÝlâC&¸ A³~9–Z0UbÔ=¨}#NÍÆ SZ“Ö²£¼ªž˜yæÌß)c–œ&^A*™¢(¿ò²zŸOáo’$î¦y/—#N±Ú>„V]zÂÒ…—Ó)“í¡áã¬á‘’€ïÚ1]hOIŠÒgU'h°9lv›†€ĶÛ-øø‹øÏ««4IÖÎåVqæðlÜsó‘~®­âk©ÅO.Fî¾²&StÃ|VÌaLs”C5K¨<Ž qpãﹿmZÅ`ø , œ%nƒ˜rÁw»ÅÜWû2^ªnbàÃ"GñI[ÄÌävpVj}Zø‹Âå³.Á¥[¾Ab·Q†kªo¦·Í:·¸ ÙéQÒ?§ È@iE} ÜXEUÕHª9)! þ|&ÿöüñ°qK1~X§ƒ­cÛ÷”¡¤¼ ¤â-z–ð¿3×açÞ "¶­)Lå€ð™$«ˆ+3tk1)exÇ êª‹ûb( 3&«èýËñ¿wÖcÅš|ÁVNkª~W^O¿¤J‚Åäƒöñ¹Uú¿ÇaœšˆCH|†Oh§Ã9!+;¿…lp\µ…Xtp_¶yß¾œÊ•&\bKÜÄ÷à0±Ì†*ñcM³¸…ˆðUvräißJ1K|™¹%¸ö/ 0ÚC,bM¾z3í i3!t?âæœ2—àz œË6îÇjƒ —½ƒ´!S½œ”VVVa»|Ꙉ‹%çÝŽ¿<º%eu¸tRWT“„ºÜž ÒûãúlßU"jò«%0bp&PoÔ8*rÚÅ‹›”žIÝõ NÜõðwØER\Uã µ‡Û®éÎñÈݧᩗÄ¢%û[d®`©`# Ö´¸æ0Áëê?¬º¦.©k—Vb›x 2[EkN=qhR|¾'éšvÇWxèö!èß;•ÂÜ`/gÛì I½+èÍy¶AECÀ‡Q(9Ìwý¥}pÁ9á¢op8ñÈs+EzKó©z¯æS EZéÏh8ch&aÛŸÎíd»j6-6„0âR<ö½9úÄ÷·`Š$ma—¶Ö7:Å3èDõ"c~íš“„Ï¿ÞàϨgìQÌ5LÁÑW-¥Ín´rÑà;ôoÜñûÁZ_b}mchÏ®é ¢+·i+`Äë2&ØÊ+¬Æ5÷,ÂÍWôÆÔóºG{|u{šçJ±aû+Q@ªžë—|ÚŒþÝyí@ŒÕV¤ÊJzñ_¯¬!„Z©—ó˜G@õù¥ŠÏ—ôøþI¤]ÆÊ–=™Þó1 266Œz÷Q{Vm,¦íGHýV¡ŠŠ1WœÄÎj‹>ÝS0¤_º˜+6E¬­¼mïØ.Á¬aŒ£ÏTU57£¥›L©û“T´G›§›étºÂÛ·MÔ@ û}1¦Ò¦hâêZêè#Ï­ÆÚ͇q×µ§=ŠFEU#ZZß…9¾ i„ËÿÜ/ÈE=Ùß²»wß0ÃI…²³üÎ'Û±xE¾øþÐ)Tª˜Ž‹ÿLDlKR:nt6ÎÖV¤—Ët!«á¸ØPlÛUŠWfmÂʵE¨¨n{Ïæ‚_õòIÕŠJžKš’Ž3OËÆÅ;#‹Í¿áþd’+ÉñÃ%u¤JS·ÈXêX'HlÕßoÅj÷úÅŒˆg§ Wv¦FG´J‹ñŽŒ´HAÓŒp½¨%iTñüo÷cËŽRÜBnÍø‘YÄÝžfÕ3_’UÞå“»aô©mðyPŸt "`Æ„`i]±¦o|°U'n°˜°wN¹6eûÚ³K2Æœ–%×áòZxw¤f?ûmÂ/Ì܄ʪ™û´½!†áb0øöÇ[±pÉ>Üxyoœ?®£0¨“Ú1yBg<ûêZ æ LP•À¨bòÏÍN€Å§·Ävó,¨æ:>ëv¥3©Ñ°””Hx Æ™¸­2¢P¹³T$™;5bHkÜwã@ìØSŽžúGJëpÏ£ßãûÙ¸iZ/’¤Xápö%• E&&Dzo¹¢¯Ûöȵ90ÿ¿–i±ïfb*& '»Ù.+–šSOÉÉe öè{ÓÀRJׯ$Õ¿_/ËC1ZB|˜ï>ÚïT€™5©C"^R\jëœxðß+°yÇÜ}ÝbÎÓEGjñÁ¼RÚ¼A5R ¶Ùl—Ë{M!L™´çÌi)­ok60¯e“,f#¯ CV¶¹ãì'ž?>mi€ÛfÆàƒ/vañòƒ¤CHš÷âÇ E¸êÏ]1‰ÎaieŸ2غ\"e¦ãª¨Õ{H]s|Aq-ªªEÍ23AÒˆñ:dÇ!';ìa”&ŪКÛ$ÑX|ðùNüç (-«G‚.±l•x¦G˺uŽGœc±¢øÚ¬‰XrWo,$pyHRa¡„BˆØ~ž‹½«ðè]CÅìLŸÚCbß.?$ö»å †rt»ÜŒÛÏæjVR×#èãâcWÑŠá;ºeBtn—„9ên‘nü¼E{еCrÉ}Úº³D¨ÔÒÒÀÕձϼ_|·Ó§ôÄ°A­„g™ó[Z€¿Jˆ ŨS3õ¨NÓøžªúãà.WËaS¶íQ!Øš[‚çßÜ€ï–牴q%‚EÚ%:*ãG·ÇXc퉉=†Ø±e“ X¶*ÏìËGØÄ^¯#üqÅ ñȧb0i’¿\?˜ÒA¸¤ØäþÈÍ_K†ë›#°l SLâ—َƆ ßzåRt"¢²„1òÝ—W‰+o[à³ÁìNÄÒ@ñ+‡õ¼¶Ç¸1¡Ym&ôyÙäîèß+UÐqM­ST·EùEú/ÒÅSO8 5ûÓxÞ.a.&¦†T 5ŽÕNÀ^zr”´3ؘXˆH³Èî¾ôÎÁÌñÄ„OÜ?’|}^žµK,{þåúSp!¹xS¿›Ì£ò_ŠÈGkÖÃKßJ=v­Å6q´°¨9í¡­[Bè´U Ù¼8ì=P.öˆÿR½L°`Ä@Cª‘ÇlźB¬Z_$¹ÝÉ:bÙMVçìnpÀÀ­þ¼Bm}„‘¤qp…máûóvböœâÎEaY媺MIŒÄÍW÷“¨3'›%ˆÕdÆÞŸW!Áq‰©¿o:¶—³žz`>[¸Ï¿±þk9O5n»¦/ž¼o8nø{lÙù Y)ž”cJz·ô!Rd?Jñ4.¸äÂA!WNí'^òͲøÛSË…[wãû±D³jìÜ>gÌƈA­%øÀ©@Îsq€Çsì‘nS(!fö§¹»÷WHHó‹ïö!¯ †ü\«¨W”̃áDÔÛ¯(Rèñ<Ô íöÍ|K’xX¾çß<~ïidÿå~Þ¢@6Y\µòØ +±|M¾x¿cˆhŒÛþ¶ë·žxuÍ+pmuá²w”c&°ùÔ©Qav÷¾®3’žyd¼Ø9¯ßf·)xôù•¤ö™]˜ã"4$¹À®§{wOƲ]}º¥h  ‘õ¢aom—V6¥øJ_˜êë$¡5X¿å0©É<ÈÃbÿ8€Áö×\ âŠ?÷ÄÅ“ºiÓGUÅPÐÓÕ°fúxþ<óê:-àAà_EÌ™ ¶›'e®Åv²ï[sËMÀlä6øï[ëñÆû›Ñ1;ß9}»§âž.Å7?úÉcÙ†Ü}åMUÕãÖ>»³°Ä¬O¶ˆoØR¿˜¬¢yî -žmõ-Ë1dŽJ9=ü8ØÄ×dõl Â@^_{H¿ RÉý%tyTõ¯w“Ûþ÷§À¢eûåÚ¾úlýç,ÁœÝ SÏë¦ûÑß›S{¤nö‘í~ü¿«°|u.˜ƒ»o(ÞÆ/®A~QõÏVÙY‚ß>N=ôyq5ÔÜqÓ()xóxgéôK.àêEX³±X+/yN ‘Ý&ƒûd sN‚œ¿hÉAü÷Íu(«jJŒ–ìv`XïX¸Ÿ1' ®¸ þD¾¸¢Zš¬4¬(ÇRTQ\R‡òŠF!FÑ‘:,Y~{UjU(ô×¹}"?²3ã ±wÕs·ˆô¿MBðâÌõP¸eºuJÂ3¯­Å¼¯ö‰où‰®ÄO–`Àä/ªîÔäË›ÏMl1ˆ`ñr¸!°êMÅyô{0QKÊëñêìMX¸d¿VI}‚}$ï=9L9zh.>¿+¹?‘M2GÍ‘¸IŠ^ï—Å摸öž¯D[p°¥”Ü Nƒ²FyðÖSqúÐ62Fj<›Î#?ý¿µØ°¥WMé‰éSz`÷J¼L®×ä]X %ÅÇN`§LÙ-XzœÜëÜéÞÎ*Ì?2å«®‚MÏúø'u{37Š¹j1 ŠÂ[﫪šÏk%•»vÓaRÙ[EêÈü\B{£aÑá!A gÒ¸Ž¢AdQ´ãZÕ¾)’f󰃈sÝ}‹Ð·G*î›1XêÄX{M» ž}}­D·8›vÃe}EÓ»¥E;~Aàô%aû¾ùÊ>EŒÁãðþÜíDèb4:µÂË1h)Õ%¥Òjþ÷3-ÇLà4]zõ-ŽºòÉ“ûáúKû Üÿ”MãVàGò?ûjV¨fµs9™¯Ø^ŸWÚ@Έ!™‚`9¶-„õ¨-iá£ÓWÕÚ¸5·<»FwÀTJV‹J¾íAþSþÔMÎYLèøy2?­Ó£ðW’fŽw«þå~ éM–f­2dî½øôË]’š4¶#Ÿ’.aÑÒƒd ò¤þ›‰í+ PšNËeÓ5K ¾Ÿ™tìv‰©ÃIqö}•õm¿s¥D¬LSi½µNÆ8¹¿8ß ÙÁföj5Åœ–ûš:õÔ«kÄGnNš½îÓ-†° f¿i’hàú.YuV=^‰mAmóº]• xóÃmDÜvÈ×È#mþËcKð§1äÞZÑ»"žÆ»ŸmÃê Ÿâž"ížf2%ÞY™\ô°jC!õÿªBkò †öo>]“¤ðo×rlÙQ"Õ¦GpL¾¾Ñ­Γfd¬*s —¾yî1¸ÓYW6ehEé]r¤týWÇçtk¶Ñ?O¢-â’<þÂjìØ[ [@ý3»\¸×Ž\'®GÎLF+"°ÔQì<šÉÛHzM/ùlZîUÏìè«çx™Ó[tÀíñx'¡Óuî{r®¿¤·H¬o K<µó`^•äÇÛÄîÓÑNʃ¨}ÕäþíÚ[A¶º„®Qƒº‡$HÒH“i‰ ‘å£x: 3ZAq%žyyââ"ïÚþùKO•ÀÄ5Û!õPEymëï>»ZԆϫŠiò»±Ìï5V4RÀd¾Y ÈEúÏk±`ñ-áî>Ñ@ϸ¢&×5ú­ÍÞ·lYúÆU+ϼ¶3¦õCX˜5h­«U.P´Û­AsGj3@OÑ¡‘kp¾4&×»Õ“f«§1ਗ…†ØñÚìuXµ.Ÿ5ˆ’·dæÑÓ…\üÖ !ëàã/ü€;®¤©5`ÒV@ãUÕ\º8¹• U¢dœ‰IOÆluÈ*°KÇBÅ­E j³ –”ÖËw‰â‡*z†Éc¨QLö/èZ=Jöæaÿ¬N²Ýä8|Ð%$xicUiBÜ ]oR†¥zµ#ƒFEK˜$%„ä¿›JÇ7o;̈~gCƒëØòÁJËp(5-iþgŸo7ebé j¦ ÉEò«÷€Y% LÓEYØ›È/ÔùæBƒØ0üõæAR—­MhSå:ÿyc¶ì,A" @»ÌXtËIB÷ΉhO>©7¯ê+àAU› ³‘•–(aø9÷™#U\ ä]®yql˜½ÙŒ­oùdÕÇžcíÀåC\äh·[j‰rV[%eµãcb#Ô93§à2^[5‰cÀÀJu°Îé³ 7g.\r@Tçîú C}Y¶Ý:%Ê2  «°ž:»ŽüK¶ÉI‰áÈnƒî’Ð5'‘v¼ø­j³¥ŠÞÖh€#ë}Ègq©o×Q{"ØF• z¾3çµ½`QiÆ–¨­2ÎâÐð‹o­óàp8g·hßUÚl¡#ËŽTã±ç–KÑ7ÉÛØhy‡ê‚(¾ÉÓþï@¿ýñ6q=Øî^wI Ô{+6üæZÅô‹zá¥ÇNÇ€^é>•Ã§å XM~%×sÝúÐb,]•g(}iʲ`€Õ¢?îAmÆŒ¨>#ã-40(V_MsöéP½Ä±@u~%¾úþ>ž¿ ‹W䡲ª‘—ã0O”×Ý>ãg¨ŸéûJêßÆ­Å,ÉofǽŒÝdqRz¬yó7MÈuP2%4iâúfêy.oŸÌß-ªtØ€ ߬Áåk ¤:‚Ñ0vd[L$ÿДèPýåinW&hGr‘¸”Æ«Îxä¤ñ%x°ç@…”ºzLvÙß0Ž0-^y+×¢IüØÙzH6XgŒË¬f>Èpriö–cæÇ[°vãa¼ñï1‚°¹Ò”ë³6l-ñ%,XrãÃqñyñ§3;ÀáR› ¥EÃí}ìù3hp¸®ÁQæ ÿ´u²TõâäÔØÑ÷?²(íÝWÎGZJ´¦®ÔftoSó'v¤kNxj9f}ºüÌlrô[‘¹C$‰c¼3¦õ&Tí ÒOÕ7Àì.¬ZWàŸqOí=´ †õo…¡t=Ÿvñ4©\mñÕ÷ûñÏ´i¬œCŽ&;?”~ë1Æ•“ H§hšc懛ñþ¼\_ hÁâ}’~õÝ-X_b¡Kð3¯­÷püÈleæ~ªj€Ð5Ï‹Z¹>ŸMÎ+uõçQÝOss•£îu„ Ë*QQãJ‰ Ç´sĵ1é^ƒ>V›ÑÑ,iÚÇãåGωyþ­¸öîEä—¡uFîŸ1@E5¨@ïõ¼ó‡x¶ï.î}•>s:o`ŸT‘Þ9N¬I¯áOõ/+Ì&®F®Ü¨2ŸkR™-™E2`Þxò‡ŸïÂÿÞݤ¯£ø–·ðøæCl9W‰lÜqÄ—¥ò“j®=Ç×ÜýïÈöÚQWS ÜD_ï~"l°) žž¢¦ð L¾æCY)Ök#}ÖJõ×öúvÕ´X‚ŠŽÔä·‰£ßÐè¥×šgÂ'Ej…ÞP2KVæû•ÄدGŠÌ`ðNõTÍüajŸÏ9goœ âSÉ쨞€ß!°ñ^T«JÐãºqöÙ’³VbØ’ï&—²}ÛXœE&§;!}o‘ )kÄŠµ\*Õhóù…'–¿>{#ŠJjˆžîñÇJ«Ÿ»é·jéènpåNœö>>zu2 –ÛÀuftî›ÝË>,Ù«ìÂÆí%’8kx©ýa’¿öÁ¼?w—ôUóNêM'öMjÂVŠ´ÇÅ„~[Wç˜ÿk˜›³;6:¢[UuýÖs/›÷þw>ìV‹É/R+òèÿ÷çW¡Ÿt\9¥'âcB1íö…R£üð]ƒñÖGÛðïÿ­•Øoë´(z4^„ÑêúÍG$GË%0ª\úõLiqN”¢š%.é™|vŽL*sË,·OšŒëg0Êþ‘€Ooa·Œ‘:—ñ½‡œ’ŽéS{bIè—ßí70Ó&vǸYZª•$=½‹è~‹È4TT:|eAfâ$/éËëï]ÄaKGUUÍè£-N$õl#>kçq©{ÿtÙ{xù‰ h“ë+Ôƒj®yâÎpîÔÛ¡õ[ ðp-®£Aj×:Ý6˜g.®í¸íŠ¾°Ø” ëÚ@æ{ ˜ ‘íàç(yÜAƒŠïÞ^É1CVøˆ¬GE•“«ëúâ(sYë6¹¦¦AILŒ.|äéïÓ6lî(qk®±’V=J-nËS\8AjÓÕ+©JL>²Y;{S@ V­/FuVd'3Ó£ À$šë­|Ò¨ø|p8KÌ—¢=«U1‡3QŽIÄLÖŒÔ&ÔíØ­­îiÃßï,•^3Á­˜ÈP©®ä{웆ÔäH±«Ì{<·ùëâÂs:I;¹NëÛee¾3'»s¼j‘ɬqm˜:ãsb„zê£:Žš½þ'eéð lÔ‘ôÔÔع ¾ÙKnœ'Ï_ðÙÕâqÏÕ]œs…Êêu>Ô­…òT¢T}…|ÀÒÕù¾D8_—í Õb ˆ ùïu±ø'1P&ÆqøRÑ%ÿR“#L%fH€xïßéIQ8LûÚÌž³Ckìˆ6ú“[TIœ>4ӧƹ&ëëe‡˜qÊq{n)Þþd§´•ëÅÎ'MeQü\lÑW©Ÿ|í<ºO=?qñ,hËKþ¤í{ú(uðÜÈèðñe• ŸO¼êc\{q_LŸ£­™¥÷‡Çm à¨!­IêÈ\´¦͹ðoò‹j±i{©©0€ƒüñ60†8!s©ztJDaq>]¸Û‡zyu>#–óVxzÂ) œpõÝ‹¤¼—§Àxg>r¢ã¾ý%oË„<ýÔL|<·#ÊïŠkðiN¾öþVq]²ŠA/= ¦êQ*;ö”âŽ,Ñ‹\}ŲþçÐá—~òÙdƒCb#÷s Óô;¾”y¸lw¹K<‹]£3‡µÕ#9fImú^“úë àp¹|¶7§}Úµ‰ö…#Õ€_#ÀwË“JU•¨~FR|¨n õü2>=%Âà·+¨©sÉš_òœ Ž}S_äWâÅ·7ù¤˜–Ô'Í@8 ^|g£ØþzÒf¼þÈÕSºaäàV’ßeöâDþì9Ûq˃ßñ, §Ûéb@µþçà×x´/hšv5»4SIe?ûÊjY ƒç÷ë™,\¬úõñQ÷¥« Làj8‡›9×±²xÜaÈXðä0£ˆÇy%XjpnöÜÓÛûR˜¾*Qßl 5ÊfÒ(,áP´sÇÚ6V™Xõ™€ìïßwcLÛAbì‚ŽéõÚ{â­·ñŠü¸žo^tB*eðëm¯666*É ‘ßsüwü¥aá’½¤ž³‚Jª¯ ÎãÉJäîÕV²áobÉ.ž9<ÓÂ4I¯6ÕeÙ˹‹ö¢¦ÞῦªÅƒÞWt„ÍéÖ¢[ÚÅãï· D·œ‰Sóó…¹>kòøŽòYõ¥/=¢zÉÉM’ÓÎ_®ÃÄîF ðÙ†ËDu>‡çó\åÉ×Ì#T_ÏÙ%.©9¡ÏRú-ž~‰RǨ¨ïg~¸9;8圮˜|v'™áçñxL Ù²`)dpc4Ϭî-Í“‰lm2¢d~²¿P^•è«ïm#{[+ÓVØh+ù¸Q^ÙàÓ,a±¼B®1&ªð*w.t$BÝxy/¤&†KM4Ū9w6l="ŒÇAš±§“Œž…ÿìÙ(éBþ+.©Ÿž÷ê ‡ñì«kP^ídÆÚQ]ÝxŠÕj©=уý[=â=—ötE±&.žûÚû“f}º cOo‡K&vÓÖÖðhuÎF¸ät»eÝÅðx9vwx®S=ƒlåuí˜ ÒeÇ'_î•e%†õOG+riœúœ¤z‡ Õµþ =œÄ¸PSÀÕû 7þm‰Ì‹zøöÁbN¸xÑÒCزK hð5Ï=³ÂIhë…pÐJÅ©ýÒ1ë³ÒFnë‘Ò¼ûéNbŠbìË«&f³ñãáÎ%öšÿK ôoE`ﶂöd"ôˆÛ{säfÎY˜‹¾]SqÑÄ®èÒ!A_#R{*ɺ‡q¨¨FüO–$L‡ \-âÄ6¾ðp¨d6x¨¯×B'véÚ%œ3bÚÊz~»zÓa ®?óA[±'$Ô*¼KÈç¾éÁ%¤–m¨ªvú?·oܨ,"p¶OûxWÞà%G ÉÄ' vës¾ÚMªYQíVõvº÷Ó¿ôÿÖönËioCƒ’öúæ]GƬyè;ÄÆ„bÄ 68ol{¤%Gaçž QÏ#·ÆEçvDCƒ;÷–cë®Rì"uÉö¸<ú ñª|Ïïy>ï)æØÝ|⥵åjãê|Þ³¯oÀGŸïÆä íeβ¶È‹]ÈþrÜ›Qi…eëÐ&ãGóüæV¾•ò¼O e¿¿¬¢eeµƒVôåN˜QnË8já—¿ÆÀþ^ìÝØÀžÕØà@DDøµ4ÿâÛ=ɼϨÔ/wNïKê6CTªGÖÚŠ"ÕFr±ókK Œ×½ÚµO#8Kf¿îÉöãYÛv—£ŒÐ³¢'LÑV¢/QaœŸÆÒ~ïõ}±ï`µ¸t¬Áȸ<{¢Uj„æv¹UÉ*q¦¬¢Aæ]ñ<`T0Am6K w?~—¶Ïh߯*648ÔWËÛ|rÅcÒ‡]rœágÍVqº­’×ÎRµ ɱq‘ÒaÐRƒ¼Ø˜ƒº¶¦I‰Ñ²zk\L¸,–Æs+ÉÎÅdžèiD\\8Ê˪™À¤Ê,tŽ#:,ÔvG¨Ýrcmƒ+“W³ÍÎŒÁ€ÞiಡÖi‘úc{ü)Av=äÕHÕe÷N‰b›yÝ̼¢Jj#I“Eõ=zÖ˜we«Ÿž.Ë3y“”Rµ!ûñ?ŸXÑcۼ܎ÜR,^™'INLðwaaÖ:W£ç%‡Ûý€ÅjçE¸ï§ý>Ú¿6Ž¡Ûí”ÅädɘEÒX²6àùÒšZ·(séÂÓLGѳÿl«¦ýAµ=nF÷"<7ȯê³ko¹ýí¶‹ºd¶=¹0\%ÂIõ”¤prqbй]¬H:K¥Å®È4ÏÀb:ÿª²Þòý˜¢U*:ââô^Aq56ï(ÅöÜ2’ê*T×9%AB¨:<ÄZh³(¯;®ç-Šµ(À]Mû¦_{ðþ6n¾z›w=ñž¨X,ç’ʼ ¦Ö1`ÍÆâx^|Ü­jq_–t;©ò¤ÄAÔ‰q<$atœ«HØÕ‰Ž¶k’Hš†ýX¶³üÊOƒá% isâÀ!‹¢º¥ÀP–9´({ˆ%ßjQ{×Ñè^Âöº™­Tßq’ÀÇ·ñ ½Î»dnU"T®œBê}$Ñ¡!âÎD Ø¼Â¢”Ka£Ãå õ¸É&’VµÇ˜X´gã0álÖ+íüTç°P{#}QMß煉6’Ä/!"o´Øl„ú£8hÊRϾ,ðúʪ"ÈEIV¸bœ0Q4I±*™ô¾=Ñ6•Ömy RÇådç ܪûˆêrÖÕ×¹ªÂœÔÁPNÔTË“Ûïs³œ‚“>¹ý·ÿ'ÀF«\^2Y*IEND®B`‚cl-asdf-3.0.3/doc/style.css000066400000000000000000000104551223164443400154550ustar00rootroot00000000000000body { line-height: 130%; margin-left: 2cm; margin-right: 2cm; } /* @group anchors */ a.none { text-decoration: none; color:black } a.none:visited { text-decoration: none; color:black } a.none:active { text-decoration: none; color:black } a.none:hover { text-decoration: none; color:black } a { text-decoration: none; } a:visited { text-decoration: none; } a:active { text-decoration: underline; } a:hover { text-decoration: underline; } /* @end */ /* @group toc */ .table-of-contents { font-size: 90%; margin-bottom: 1em; padding-bottom: 1em; } .table-of-contents h2, h3, h4 { padding-top: 0; padding-bottom: 0; margin-top: 0; margin-bottom: 1px; } .table-of-contents h2 { font-size: inherit; font-style: inherit; position: relative; left: 2em; } .table-of-contents h3 { font-size: inherit; font-style: inherit; position: relative; left: 4em; } .table-of-contents h4 { font-size: inherit; font-style: inherit; position: relative; left: 6em; } .table-of-contents h5 { font-size: inherit; font-style: inherit; position: relative; left: 8px; } /* @end */ /* @group header-footer */ .header { position:relative; /* Position is declared "relative" to gain control of stacking order (z-index). */ width:auto; min-width:120px; font-size: medium; background-color: #3aa244; color:#ffffff; border: solid #417b39 4px; padding: 1mm 1mm 1mm 1em; } #footer { font-size: small; font-style: italic; background-color: #346632; border-top: 2px solid; border-bottom: 2px solid; border-color: #417b39; padding-top: 2mm; padding-bottom: 2mm; float: left; width: 100%; height: 04mm; } #footer #timestamp { float: right; } #footer .copyright { display: block; padding-top: 0.1em; margin-top: 0.1em; } #footer a:link { font-weight:bold; text-decoration:underline; } #footer a:visited { font-weight:bold; text-decoration:underline; } #footer a:hover { font-weight:bold; color:#002244; text-decoration:underline; } .header h2 { padding-top: 0px; margin-top: 0.2em; margin-bottom: 0.6em; } .header h4 { padding-top: 0px; margin-top: 0.2em; margin-bottom: 0.6em; } .logo { float: right; text-align: right; right: 2em; } /* @end */ /* @group documentation */ .hidden { visibility: hidden; } .documentation { margin-right: 1em; margin-left: 1em; clear: both; } .function { } .documentation pre { margin-left: 0em; margin-right: 0em; } .documentation.header { display: block; position: relative; border: none white 0px; border-top: thin; border-top-style: solid; border-top-width: 1pt; padding-top: 4px; margin-top: 2em; font-size: inherit; background-color: transparent; color: black; } .documentation .name-and-args { width: 80%; float: left; } .documentation.contents { top: 10px; position: relative; margin-bottom: 1.8em; margin-left: 4em; margin-right: 4em; clear: both; } .documentation-name { font-weight: bold; float: left; padding-right: 10px; width: 125px; } .documentation-kind { float: right; font-style: italic; color: gray; padding-left: 10px; } .documentation-arguments { float: left; font-style: italic; } .documentation p { clear: both; } /* @end */ .system-links { width: 14%; text-align: left; padding-right: 1em; padding-top: 1.5em; float: right; font-size: 80%; } .system-links li { padding-top: 10px; font-family: Arial, Helvetica, sans-serif; } .contents { // width: 90%; padding-left: 2em; padding-right: 2em; padding-top: 2em; padding-bottom: 1.5em; } .check {font-size: x-small; text-align:right;} .check a:link { font-weight:bold; color:#a0a0ff; text-decoration:underline; } .check a:visited { font-weight:bold; color:#a0a0ff; text-decoration:underline; } .check a:hover { font-weight:bold; color:#000000; text-decoration:underline; } .changelog { font-size: 75%; padding: 1em 2em 2em; vertical-align: top; color: #686868; } .changelog-author { text-align: right; color: #686868; } .changelog-description { padding-left: 2em; color: #000000; padding-bottom: 1em; font-size: 120%; padding-right: 2em; } .nav { padding-left: 1em; vertical-align: middle; } pre { font: 90% Courier New, Courier, mono; color: #000000; background: #daefe9; overflow: auto; border: 1px solid #995f04; padding: 0.25em 0.5em; margin-left: 4em; margin-right: 4em; } cl-asdf-3.0.3/find-component.lisp000066400000000000000000000117371223164443400166530ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Finding components (asdf/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system) (:export #:find-component #:resolve-dependency-name #:resolve-dependency-spec #:resolve-dependency-combination ;; Conditions #:missing-component #:missing-component-of-version #:retry #:missing-dependency #:missing-dependency-of-version #:missing-requires #:missing-parent #:missing-required-by #:missing-version)) (in-package :asdf/find-component) ;;;; Missing component conditions (with-upgradability () (define-condition missing-component-of-version (missing-component) ((version :initform nil :reader missing-version :initarg :version))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (defmethod print-object ((c missing-dependency) s) (format s (compatfmt "~@<~A, required by ~A~@:>") (call-next-method c nil) (missing-required-by c))) (define-condition missing-dependency-of-version (missing-dependency missing-component-of-version) ()) (defmethod print-object ((c missing-component) s) (format s (compatfmt "~@") (missing-requires c) (when (missing-parent c) (coerce-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) (format s (compatfmt "~@") (missing-requires c) (missing-version c) (when (missing-parent c) (coerce-name (missing-parent c)))))) ;;;; Finding components (with-upgradability () (defgeneric* (find-component) (base path) (:documentation "Find a component by resolving the PATH starting from BASE parent")) (defgeneric resolve-dependency-combination (component combinator arguments)) (defmethod find-component ((base string) path) (let ((s (find-system base nil))) (and s (find-component s path)))) (defmethod find-component ((base symbol) path) (cond (base (find-component (coerce-name base) path)) (path (find-component path nil)) (t nil))) (defmethod find-component ((base cons) path) (find-component (car base) (cons (cdr base) path))) (defmethod find-component ((parent parent-component) (name string)) (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! (values (gethash name (component-children-by-name parent)))) (defmethod find-component (base (name symbol)) (if name (find-component base (coerce-name name)) base)) (defmethod find-component ((c component) (name cons)) (find-component (find-component c (car name)) (cdr name))) (defmethod find-component (base (actual component)) (declare (ignorable base)) actual) (defun resolve-dependency-name (component name &optional version) (loop (restart-case (return (let ((comp (find-component (component-parent component) name))) (unless comp (error 'missing-dependency :required-by component :requires name)) (when version (unless (version-satisfies comp version) (error 'missing-dependency-of-version :required-by component :version version :requires name))) comp)) (retry () :report (lambda (s) (format s (compatfmt "~@") name)) :test (lambda (c) (or (null c) (and (typep c 'missing-dependency) (eq (missing-required-by c) component) (equal (missing-requires c) name)))))))) (defun resolve-dependency-spec (component dep-spec) (let ((component (find-component () component))) (if (atom dep-spec) (resolve-dependency-name component dep-spec) (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) (defmethod resolve-dependency-combination (component combinator arguments) (error (compatfmt "~@") (cons combinator arguments) component)) (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) (declare (ignorable combinator)) (when (featurep (first arguments)) (resolve-dependency-spec component (second arguments)))) (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788 (resolve-dependency-name component (first arguments) (second arguments)))) cl-asdf-3.0.3/find-system.lisp000066400000000000000000000523371223164443400161760ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Finding systems (asdf/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/cache) (:export #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd #:with-system-definitions #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition #:*system-definition-search-functions* #:search-for-system-definition #:*central-registry* #:probe-asd #:sysdef-central-registry-search #:find-system-if-being-defined #:*systems-being-defined* #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:clear-defined-systems #:*defined-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) (in-package :asdf/find-system) (with-upgradability () (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply 'format s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) (format s (compatfmt "~@") (error-name c) (error-pathname c) (error-condition c))))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) (defun coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error (compatfmt "~@") name)))) (defun primary-system-name (name) ;; When a system name has slashes, the file with defsystem is named by ;; the first of the slash-separated components. (first (split-string (coerce-name name) :separator "/"))) (defun coerce-filename (name) (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) (defvar *defined-systems* (make-hash-table :test 'equal) "This is a hash table whose keys are strings, being the names of the systems, and whose values are pairs, the first element of which is a universal-time indicating when the system definition was last updated, and the second element of which is a system object.") (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) (defun registered-systems () (loop :for registered :being :the :hash-values :of *defined-systems* :collect (coerce-name (cdr registered)))) (defun register-system (system) (check-type system system) (let ((name (component-name system))) (check-type name string) (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) (unless (eq system (cdr (gethash name *defined-systems*))) (setf (gethash name *defined-systems*) (cons (if-let (file (ignore-errors (system-source-file system))) (get-file-stamp file)) system))))) (defun clear-defined-systems () ;; Invalidate all systems but ASDF itself, if registered. (let ((asdf (cdr (system-registered-p :asdf)))) (setf *defined-systems* (make-hash-table :test 'equal)) (when asdf (setf (component-version asdf) *asdf-version*) (setf (builtin-system-p asdf) t) (register-system asdf))) (values)) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) (defun clear-system (name) "Clear the entry for a system in the database of systems previously loaded. Note that this does NOT in any way cause the code of the system to be unloaded." ;; There is no "unload" operation in Common Lisp, and ;; a general such operation cannot be portably written, ;; considering how much CL relies on side-effects to global data structures. (remhash (coerce-name name) *defined-systems*)) (defun map-systems (fn) "Apply FN to each defined system. FN should be a function of one argument. It will be called with an object of type asdf:system." (loop :for registered :being :the :hash-values :of *defined-systems* :do (funcall fn (cdr registered))))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- (with-upgradability () (defvar *system-definition-search-functions* '()) (defun cleanup-system-definition-search-functions () (setf *system-definition-search-functions* (append ;; Remove known-incompatible sysdef functions from old versions of asdf. (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) *system-definition-search-functions*) ;; Tuck our defaults at the end of the list if they were absent. ;; This is imperfect, in case they were removed on purpose, ;; 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))))) (cleanup-system-definition-search-functions) (defun search-for-system-definition (system) (block () (let ((name (coerce-name system))) (flet ((try (f) (if-let ((x (funcall f name))) (return x)))) (try 'find-system-if-being-defined) (map () #'try *system-definition-search-functions*) (try 'sysdef-preloaded-system-search))))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. A 'system directory designator' is a pathname or an expression which evaluates to a pathname. For example: (setf asdf:*central-registry* (list '*default-pathname-defaults* #p\"/home/me/cl/systems/\" #p\"/usr/share/common-lisp/systems/\")) This is for backward compatibility. Going forward, we recommend new users should be using the source-registry. ") (defun probe-asd (name defaults &key truename) (block nil (when (directory-pathname-p defaults) (if-let (file (probe-file* (ensure-absolute-pathname (parse-unix-namestring name :type "asd") #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) nil) :truename truename)) (return file)) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) (when (and (os-windows-p) (physical-pathname-p defaults)) (let ((shortcut (make-pathname :defaults defaults :case :local :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) (when target (return (pathname target)))))))))) (defun sysdef-central-registry-search (system) (let ((name (primary-system-name system)) (to-remove nil) (to-replace nil)) (block nil (unwind-protect (dolist (dir *central-registry*) (let ((defaults (eval dir)) directorized) (when defaults (cond ((directory-pathname-p defaults) (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) (when file (return file)))) (t (restart-case (let* ((*print-circle* nil) (message (format nil (compatfmt "~@") system dir defaults))) (error message)) (remove-entry-from-registry () :report "Remove entry from *central-registry* and continue" (push dir to-remove)) (coerce-entry-to-directory () :test (lambda (c) (declare (ignore c)) (and (not (directory-pathname-p defaults)) (directory-pathname-p (setf directorized (ensure-directory-pathname defaults))))) :report (lambda (s) (format s (compatfmt "~@") directorized dir)) (push (cons dir directorized) to-replace)))))))) ;; cleanup (dolist (dir to-remove) (setf *central-registry* (remove dir *central-registry*))) (dolist (pair to-replace) (let* ((current (car pair)) (new (cdr pair)) (position (position current *central-registry*))) (setf *central-registry* (append (subseq *central-registry* 0 position) (list new) (subseq *central-registry* (1+ position)))))))))) (defvar *preloaded-systems* (make-hash-table :test 'equal)) (defun make-preloaded-system (name keys) (apply 'make-instance (getf keys :class 'system) :name name :source-file (getf keys :source-file) (remove-plist-keys '(:class :name :source-file) keys))) (defun sysdef-preloaded-system-search (requested) (let ((name (coerce-name requested))) (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) (when foundp (make-preloaded-system name keys))))) (defun register-preloaded-system (system-name &rest keys) (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) (register-preloaded-system "asdf" :version *asdf-version*) (register-preloaded-system "uiop" :version *asdf-version*) (register-preloaded-system "asdf-driver" :version *asdf-version*) (register-preloaded-system "asdf-defsystem" :version *asdf-version*) (defmethod find-system ((name null) &optional (error-p t)) (declare (ignorable name)) (when error-p (sysdef-error (compatfmt "~@")))) (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) (defvar *systems-being-defined* nil "A hash-table of systems currently being defined keyed by name, or NIL") (defun find-system-if-being-defined (name) (when *systems-being-defined* ;; notable side effect: mark the system as being defined, to avoid infinite loops (ensure-gethash (coerce-name name) *systems-being-defined* nil))) (defun call-with-system-definitions (thunk) (if *systems-being-defined* (call-with-asdf-cache thunk) (let ((*systems-being-defined* (make-hash-table :test 'equal))) (call-with-asdf-cache thunk)))) (defun clear-systems-being-defined () (when *systems-being-defined* (clrhash *systems-being-defined*))) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined) (defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () ,@body))) (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. (with-system-definitions () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) ;; Note that our backward-compatible *readtable* is ;; a global readtable that gets globally side-effected. Ouch. ;; Same for the *print-pprint-dispatch* table. ;; We should do something about that for ASDF3 if possible, or else ASDF4. (*readtable* readtable) (*print-pprint-dispatch* print-pprint-dispatch) (*print-readably* nil) (*default-pathname-defaults* ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. (pathname-directory-pathname (physicalize-pathname pathname)))) (handler-bind ((error #'(lambda (condition) (error 'load-system-definition-error :name name :pathname pathname :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") name pathname) (with-muffled-loader-conditions () (load* pathname :external-format external-format))))))) (defvar *old-asdf-systems* (make-hash-table :test 'equal)) (defun check-not-old-asdf-system (name pathname) (or (not (equal name "asdf")) (null pathname) (let* ((version-pathname (subpathname pathname "version.lisp-expr")) (version (and (probe-file* version-pathname :truename nil) (read-file-form version-pathname))) (old-version (asdf-version))) (or (version<= old-version version) (ensure-gethash (list pathname old-version) *old-asdf-systems* #'(lambda () (let ((old-pathname (if-let (pair (system-registered-p "asdf")) (system-source-file (cdr pair))))) (warn "~@<~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ and having an old version registered is a configuration error. ~ ASDF will ignore this configured system rather than downgrade itself. ~ In the future, you may want to either: ~ (a) upgrade this configured ASDF to a newer version, ~ (b) install a newer ASDF and register it in front of the former in your configuration, or ~ (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ Note that the older ASDF might be registered implicitly through configuration inherited ~ from your system installation, in which case you might have to specify ~ :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ or other source-registry configuration file, environment variable or lisp parameter. ~ Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ that you might want to upgrade (if a recent enough version is available) ~ or else remove altogether (since most implementations ship with a recent asdf); ~ if you lack the system administration rights to upgrade or remove this package, ~ then you might indeed want to either install and register a more recent version, ~ or use :ignore-inherited-configuration to avoid registering the old one. ~ Please consult ASDF documentation and/or experts.~@:>~%" old-version old-pathname version pathname) t))))))) (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME FOUNDP is true when a system was found, either a new unregistered one or a previously registered one. FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is PATHNAME when not null is a path from where to load the system, either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." (let* ((name (coerce-name name)) (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk (previous (cdr in-memory)) (previous (and (typep previous 'system) previous)) (previous-time (car in-memory)) (found (search-for-system-definition name)) (found-system (and (typep found 'system) found)) (pathname (ensure-pathname (or (and (typep found '(or pathname string)) (pathname found)) (and found-system (system-source-file found-system)) (and previous (system-source-file previous))) :want-absolute t :resolve-symlinks *resolve-symlinks*)) (foundp (and (or found-system pathname previous) t))) (check-type found (or null pathname system)) (unless (check-not-old-asdf-system name pathname) (cond (previous (setf found nil pathname nil)) (t (setf found (sysdef-preloaded-system-search "asdf")) (assert (typep found 'system)) (setf found-system found pathname nil)))) (values foundp found-system pathname previous previous-time))) (defmethod find-system ((name string) &optional (error-p t)) (with-system-definitions () (let ((primary-name (primary-system-name name))) (unless (or (equal name primary-name) (nth-value 1 (gethash primary-name *systems-being-defined*))) (find-system primary-name nil))) (loop (restart-case (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (assert (eq foundp (and (or found-system pathname previous) t))) (let ((previous-pathname (and previous (system-source-file previous))) (system (or previous found-system))) (when (and found-system (not previous)) (register-system found-system)) (when (and system pathname) (setf (system-source-file system) pathname)) (when (and pathname (let ((stamp (get-file-stamp pathname))) (and stamp (not (and previous (or (pathname-equal pathname previous-pathname) (and pathname previous-pathname (pathname-equal (physicalize-pathname pathname) (physicalize-pathname previous-pathname)))) (stamp<= stamp previous-time)))))) ;; only load when it's a pathname that is different or has newer content, and not an old asdf (load-asd pathname :name name))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (return (cond (in-memory (when pathname (setf (car in-memory) (get-file-stamp pathname))) (cdr in-memory)) (error-p (error 'missing-component :requires name)))))) (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@") name)) (initialize-source-registry))))))) cl-asdf-3.0.3/footer.lisp000066400000000000000000000050211223164443400152160ustar00rootroot00000000000000;;;; ----------------------------------------------------------------------- ;;;; ASDF Footer: last words and cleanup (asdf/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/operate :asdf/bundle :asdf/concatenate-source :asdf/output-translations :asdf/source-registry :asdf/backward-internals :asdf/defsystem :asdf/backward-interface)) (in-package :asdf/footer) ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. (with-upgradability () #+(or abcl clisp clozure cmu ecl mkcl sbcl) (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* #+clisp ,x #+clozure ccl:*module-provider-functions* #+(or cmu ecl) ext:*module-provider-functions* #+mkcl mk-ext:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*))) #+(or ecl mkcl) (progn (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) #+(or (and ecl win32) (and mkcl windows)) (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* (loop :for f :in #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* :collect (if (eq f 'module-provide-asdf) f #'(lambda (name) (let ((l (multiple-value-list (funcall f name)))) (and (first l) (register-pre-built-system (coerce-name name))) (values-list l)))))))) #+cmu (with-upgradability () (defun herald-asdf (stream) (format stream " ASDF ~A" (asdf-version))) (setf (getf ext:*herald-items* :asdf) `(herald-asdf))) ;;;; Done! (with-upgradability () #+allegro (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*)) (dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*)) (provide :asdf) (cleanup-upgraded-asdf)) (when *load-verbose* (asdf-message ";; ASDF, version ~a~%" (asdf-version))) cl-asdf-3.0.3/header.lisp000066400000000000000000000072521223164443400151600ustar00rootroot00000000000000;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; This is ASDF 3.0.3: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . ;;; Note first that the canonical source for ASDF is presently ;;; . ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting ;;; bugs. There are usually two "supported" revisions - the git master ;;; branch is the latest development version, whereas the git release ;;; branch may be slightly older but is considered `stable' ;;; -- LICENSE START ;;; (This is the MIT / X Consortium license as taken from ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; ;;; Copyright (c) 2001-2012 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; ;;; -- LICENSE END ;;; The problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file. #+xcvb (module ()) (in-package :cl-user) #+cmu (eval-when (:load-toplevel :compile-toplevel :execute) (declaim (optimize (speed 1) (safety 3) (debug 3))) (setf ext:*gc-verbose* nil)) #+(or abcl clisp clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :asdf3 *features*) (let* ((existing-version (when (find-package :asdf) (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) (etypecase ver (string ver) (cons (format nil "~{~D~^.~}" ver)) (null "1.0")))))) (first-dot (when existing-version (position #\. existing-version))) (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot)))) (existing-major-minor (subseq existing-version 0 second-dot)) (existing-version-number (and existing-version (read-from-string existing-major-minor))) (away (format nil "~A-~A" :asdf existing-version))) (when (and existing-version (< existing-version-number 2.27)) (rename-package :asdf away) (when *load-verbose* (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) cl-asdf-3.0.3/interface.lisp000066400000000000000000000141541223164443400156670ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. (asdf/package:define-package :asdf/interface (:nicknames :asdf :asdf-utilities) (:recycle :asdf/interface :asdf) (:unintern #:*asdf-revision* #:around #:asdf-method-combination #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p #:split #:make-collector #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source :asdf/backward-internals :asdf/backward-interface) ;; TODO: automatically generate interface with reexport? (:export #:defsystem #:find-system #:locate-system #:coerce-name #:oos #:operate #:make-plan #:perform-plan #:sequential-plan #:system-definition-pathname #:with-system-definitions #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:load-systems* #:require-system #:test-system #:clear-system #:operation #:make-operation #:find-operation #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation #:build-system #:build-op #:load-op #:prepare-op #:compile-op #:prepare-source-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain #:action-description #:component-sideway-dependencies #:needed-in-image-p ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT. #:component-load-dependencies #:run-shell-command ; deprecated, do not use #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #+ecl #:make-build #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:lib-op #:dll-op #:binary-op #:program-op #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op #:load-compiled-concatenated-source-op #:monolithic-concatenate-source-op #:monolithic-load-concatenated-source-op #:monolithic-compile-concatenated-source-op #:monolithic-load-compiled-concatenated-source-op #:operation-monolithic-p #:required-components #:component-loaded-p #:component #:parent-component #:child-component #:system #:module #:file-component #:source-file #:c-source-file #:java-source-file #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file #:file-type #:source-file-type #:component-children ; component accessors #:component-children-by-name #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-system #:component-encoding #:component-external-format #:component-depends-on ; backward-compatible name rather than action-depends-on #:module-components ; backward-compatibility #:operation-on-warnings #:operation-on-failure ; backward-compatibility #:component-property ; backward-compatibility #:traverse ; backward-compatibility #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:system-licence #:system-source-file #:system-source-directory #:system-relative-pathname #:system-homepage #:system-mailto #:system-bug-tracker #:system-long-name #:system-source-control #:map-systems #:*system-definition-search-functions* ; variables #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* #:*load-system-operation* #:*asdf-verbose* ;; unused. For backward-compatibility only. #:*verbose-out* #:asdf-version #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility #:error-name #:error-pathname #:load-system-definition-error #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-component-of-version #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors #:duplicate-names #:non-toplevel-system #:non-system-system #:try-recompiling #:retry #:accept ; restarts #:coerce-entry-to-directory #:remove-entry-from-registry #:*encoding-detection-hook* #:*encoding-external-format-hook* #:*default-encoding* #:*utf-8-external-format* #:clear-configuration #:*output-translations-parameter* #:initialize-output-translations #:disable-output-translations #:clear-output-translations #:ensure-output-translations #:apply-output-translations #:compile-file* #:compile-file-pathname* #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check #:enable-asdf-binary-locations-compatibility #:*default-source-registries* #:*source-registry-parameter* #:initialize-source-registry #:compute-source-registry #:clear-source-registry #:ensure-source-registry #:process-source-registry #:system-registered-p #:registered-systems #:already-loaded-systems #:resolve-location #:asdf-message #:*user-cache* #:user-output-translations-pathname #:system-output-translations-pathname #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname #:user-source-registry #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory)) cl-asdf-3.0.3/lisp-action.lisp000066400000000000000000000253021223164443400161460ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Actions to build Common Lisp software (asdf/package:define-package :asdf/lisp-action (:recycle :asdf/lisp-action :asdf) (:intern #:proclamations #:flags) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system :asdf/operation :asdf/action) (:export #:try-recompiling #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op #:call-with-around-compile-hook #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:lisp-compilation-output-files #:flags)) (in-package :asdf/lisp-action) ;;;; Component classes (with-upgradability () (defclass cl-source-file (source-file) ((type :initform "lisp"))) (defclass cl-source-file.cl (cl-source-file) ((type :initform "cl"))) (defclass cl-source-file.lsp (cl-source-file) ((type :initform "lsp")))) ;;;; Operation classes (with-upgradability () (defclass basic-load-op (operation) ()) (defclass basic-compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) (flags :initarg :flags :accessor compile-op-flags :initform nil)))) ;;; Our default operations: loading into the current lisp image (with-upgradability () (defclass prepare-op (upward-operation sideway-operation) ((sideway-operation :initform 'load-op))) (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation) ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, ;; so we need to directly depend on prepare-op for its side-effects in the current image. ((selfward-operation :initform '(prepare-op compile-op)))) (defclass compile-op (basic-compile-op downward-operation selfward-operation) ((selfward-operation :initform 'prepare-op) (downward-operation :initform 'load-op))) (defclass prepare-source-op (upward-operation sideway-operation) ((sideway-operation :initform 'load-source-op))) (defclass load-source-op (basic-load-op downward-operation selfward-operation) ((selfward-operation :initform 'prepare-source-op))) (defclass test-op (selfward-operation) ((selfward-operation :initform 'load-op)))) ;;;; prepare-op, compile-op and load-op ;;; prepare-op (with-upgradability () (defmethod action-description ((o prepare-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod perform ((o prepare-op) (c component)) (declare (ignorable o c)) nil) (defmethod input-files ((o prepare-op) (c component)) (declare (ignorable o c)) nil) (defmethod input-files ((o prepare-op) (s system)) (declare (ignorable o)) (if-let (it (system-source-file s)) (list it)))) ;;; compile-op (with-upgradability () (defmethod action-description ((o compile-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o compile-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defgeneric call-with-around-compile-hook (component thunk)) (defmethod call-with-around-compile-hook ((c component) function) (call-around-hook (around-compile-hook c) function)) (defun perform-lisp-compilation (o c) (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, ;; we consult input-files, the first of which should be the one to compile-file (input-file (first (input-files o c))) ;; on some implementations, there are more than one output-file, ;; but the first one should always be the primary fasl that gets loaded. (outputs (output-files o c))) (multiple-value-bind (output warnings-p failure-p) (destructuring-bind (output-file &optional #+clisp lib-file #+(or ecl mkcl) object-file warnings-file) outputs (call-with-around-compile-hook c #'(lambda (&rest flags) (with-muffled-compiler-conditions () (apply 'compile-file* input-file :output-file output-file :external-format (component-external-format c) :warnings-file warnings-file (append #+clisp (list :lib-file lib-file) #+(or ecl mkcl) (list :object-file object-file) flags (compile-op-flags o))))))) (check-lisp-compile-results output warnings-p failure-p "~/asdf-action::format-action/" (list (cons o c)))))) (defun report-file-p (f) (equalp (pathname-type f) "build-report")) (defun perform-lisp-warnings-check (o c) (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) (actual-warnings-files (loop :for w :in expected-warnings-files :when (get-file-stamp w) :collect w :else :do (warn "Missing warnings file ~S while ~A" w (action-description o c))))) (check-deferred-warnings actual-warnings-files) (let* ((output (output-files o c)) (report (find-if #'report-file-p output))) (when report (with-open-file (s report :direction :output :if-exists :supersede) (format s ":success~%")))))) (defmethod perform ((o compile-op) (c cl-source-file)) (perform-lisp-compilation o c)) (defun lisp-compilation-output-files (o c) (let* ((i (first (input-files o c))) (f (compile-file-pathname i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) `(,f ;; the fasl is the primary output, in first position #+clisp ,@`(,(make-pathname :type "lib" :defaults f)) #+ecl ,@(unless (use-ecl-byte-compiler-p) `(,(compile-file-pathname i :type :object))) #+mkcl ,(compile-file-pathname i :fasl-p nil) ;; object file ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) `(,(make-pathname :type *warnings-file-type* :defaults f)))))) (defmethod output-files ((o compile-op) (c cl-source-file)) (lisp-compilation-output-files o c)) (defmethod perform ((o compile-op) (c static-file)) (declare (ignorable o c)) nil) (defmethod output-files ((o compile-op) (c static-file)) (declare (ignorable o c)) nil) (defmethod perform ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) (perform-lisp-warnings-check o c))) (defmethod input-files ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) ;; The most correct way to do it would be to use: ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) ;; but it's expensive and we don't care too much about file order or ASDF extensions. (loop :for sub :in (sub-components c :type 'cl-source-file) :nconc (remove-if-not 'warnings-file-p (output-files o sub))))) (defmethod output-files ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) (if-let ((pathname (component-pathname c))) (list (subpathname pathname (coerce-filename c) :type "build-report")))))) ;;; load-op (with-upgradability () (defmethod action-description ((o load-op) (c cl-source-file)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o load-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o load-op) component) (declare (ignorable o)) (format nil (compatfmt "~@") component)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) (loop (restart-case (return (call-next-method)) (try-recompiling () :report (lambda (s) (format s "Recompile ~a and try loading it again" (component-name c))) (perform (find-operation o 'compile-op) c))))) (defun perform-lisp-load-fasl (o c) (if-let (fasl (first (input-files o c))) (with-muffled-loader-conditions () (load* fasl)))) (defmethod perform ((o load-op) (c cl-source-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-op) (c static-file)) (declare (ignorable o c)) nil)) ;;;; prepare-source-op, load-source-op ;;; prepare-source-op (with-upgradability () (defmethod action-description ((o prepare-source-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod input-files ((o prepare-source-op) (c component)) (declare (ignorable o c)) nil) (defmethod input-files ((o prepare-source-op) (s system)) (declare (ignorable o)) (if-let (it (system-source-file s)) (list it))) (defmethod perform ((o prepare-source-op) (c component)) (declare (ignorable o c)) nil)) ;;; load-source-op (with-upgradability () (defmethod action-description ((o load-source-op) c) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o load-source-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defun perform-lisp-load-source (o c) (call-with-around-compile-hook c #'(lambda () (with-muffled-loader-conditions () (load* (first (input-files o c)) :external-format (component-external-format c)))))) (defmethod perform ((o load-source-op) (c cl-source-file)) (perform-lisp-load-source o c)) (defmethod perform ((o load-source-op) (c static-file)) (declare (ignorable o c)) nil) (defmethod output-files ((o load-source-op) (c component)) (declare (ignorable o c)) nil)) ;;;; test-op (with-upgradability () (defmethod perform ((o test-op) (c component)) (declare (ignorable o c)) nil) (defmethod operation-done-p ((o test-op) (c system)) "Testing a system is _never_ done." (declare (ignorable o c)) nil)) cl-asdf-3.0.3/operate.lisp000066400000000000000000000232571223164443400153720ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations (asdf/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export #:operate #:oos #:*systems-being-operated* #:build-system #:load-system #:load-systems #:load-systems* #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf #:component-loaded-p #:already-loaded-systems)) (in-package :asdf/operate) (with-upgradability () (defgeneric* (operate) (operation component &key &allow-other-keys) (:documentation "Operate does three things: 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). 3. It then calls TRAVERSE with the operation and system as arguments The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code. If a VERSION argument is supplied, then operate also ensures that the system found satisfies it using the VERSION-SATISFIES method. Note that dependencies may cause the operation to invoke other operations on the system or its components: the new operations will be created with the same initargs as the original one. The :FORCE or :FORCE-NOT argument to OPERATE can be: T to force the inside of the specified system to be rebuilt (resp. not), without recursively forcing the other systems we depend on. :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list :FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced.")) (define-convenience-action-methods operate (operation component &key) ;; I'd like to at least remove-plist-keys :force :force-not :verbose, ;; but swank.asd relies on :force (!). :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. :if-no-component (error 'missing-component :requires component)) (defvar *systems-being-operated* nil "A boolean indicating that some systems are being operated on") (defmethod operate :around (operation component &rest keys &key verbose (on-warnings *compile-file-warnings-behaviour*) (on-failure *compile-file-failure-behaviour*) &allow-other-keys) (declare (ignorable operation component)) (let* ((systems-being-operated *systems-being-operated*) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) (operation-name (reify-symbol (etypecase operation (operation (type-of operation)) (symbol operation)))) (component-path (typecase component (component (component-find-path component)) (t component)))) ;; Before we operate on any system, make sure ASDF is up-to-date, ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. (unless systems-being-operated (when (upgrade-asdf) ;; If we were upgraded, restart OPERATE the hardest of ways, for ;; its function may have been redefined, its symbol uninterned, its package deleted. (return-from operate (apply (find-symbol* 'operate :asdf) (unreify-symbol operation-name) component-path keys)))) ;; Setup proper bindings around any operate call. (with-system-definitions () (let* ((*verbose-out* (and verbose *standard-output*)) (*compile-file-warnings-behaviour* on-warnings) (*compile-file-failure-behaviour* on-failure)) (call-next-method))))) (defmethod operate :before ((operation operation) (component component) &key version &allow-other-keys) (let ((system (component-system component))) (setf (gethash (coerce-name system) *systems-being-operated*) system)) (unless (version-satisfies component version) (error 'missing-component-of-version :requires component :version version))) (defmethod operate ((operation operation) (component component) &rest keys &key plan-class &allow-other-keys) (let ((plan (apply 'make-plan plan-class operation component keys))) (apply 'perform-plan plan keys) (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) (apply 'operate operation component args)) (setf (documentation 'oos 'function) (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" (documentation 'operate 'function)))) ;;;; Common operations (with-upgradability () (defvar *load-system-operation* 'load-op "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken. This may change in the future as we will implement component-based strategy for how to load or compile stuff") (defun build-system (system &rest keys) "Shorthand for `(operate 'asdf:build-op system)`." (apply 'operate 'build-op system keys) t) (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force force-not verbose version)) (apply 'operate *load-system-operation* system keys) t) (defun load-systems* (systems &rest keys) "Loading multiple systems at once." (dolist (s systems) (apply 'load-system s keys))) (defun load-systems (&rest systems) "Loading multiple systems at once." (load-systems* systems)) (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys) "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force force-not verbose version)) (apply 'operate 'compile-op system args) t) (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys) "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force force-not verbose version)) (apply 'operate 'test-op system args) t)) ;;;; Define require-system, to be hooked into CL:REQUIRE when possible, ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL (with-upgradability () (defun component-loaded-p (c) (action-already-done-p nil (make-instance 'load-op) (find-component c ()))) (defun already-loaded-systems () (remove-if-not 'component-loaded-p (registered-systems))) (defun require-system (s &rest keys &key &allow-other-keys) (apply 'load-system s :force-not (already-loaded-systems) keys)) (defvar *modules-being-required* nil) (defclass require-system (system) ((module :initarg :module :initform nil :accessor required-module))) (defmethod perform ((o compile-op) (c require-system)) (declare (ignorable o c)) nil) (defmethod perform ((o load-op) (s require-system)) (declare (ignorable o)) (let* ((module (or (required-module s) (coerce-name s))) (*modules-being-required* (cons module *modules-being-required*))) (assert (null (component-children s))) (require module))) (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) (declare (ignorable component combinator)) (unless (length=n-p arguments 1) (error (compatfmt "~@") (cons combinator arguments) component combinator)) (let* ((module (car arguments)) (name (string-downcase module)) (system (find-system name nil))) (assert module) ;;(unless (typep system '(or null require-system)) ;; (warn "~S depends on ~S but ~S is registered as a ~S" ;; component (cons combinator arguments) module (type-of system))) (or system (let ((system (make-instance 'require-system :name name))) (register-system system) system)))) (defun module-provide-asdf (name) (let ((module (string-downcase name))) (unless (member module *modules-being-required* :test 'equal) (let ((*modules-being-required* (cons module *modules-being-required*)) #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal))) (handler-bind ((style-warning #'muffle-warning) (missing-component (constantly nil)) (error #'(lambda (e) (format *error-output* (compatfmt "~@~%") name e)))) (let ((*verbose-out* (make-broadcast-stream))) (let ((system (find-system module nil))) (when system (require-system system :verbose nil) t))))))))) ;;;; Some upgrade magic (with-upgradability () (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. (when *systems-being-defined* (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) (clrhash *systems-being-defined*) (dolist (s l) (find-system s nil))))) (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) cl-asdf-3.0.3/operation.lisp000066400000000000000000000047101223164443400157240ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Operations (asdf/package:define-package :asdf/operation (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:operation #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. #:build-op ;; THE generic operation #:*operations* #:make-operation #:find-operation #:feature)) (in-package :asdf/operation) ;;; Operation Classes (when-upgrading (:when (find-class 'operation nil)) (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) (declare (ignorable o slot-names initargs)) (values))) (with-upgradability () (defclass operation () ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) :initform nil :initarg :original-initargs :accessor operation-original-initargs))) (defmethod initialize-instance :after ((o operation) &rest initargs &key force force-not system verbose &allow-other-keys) (declare (ignorable force force-not system verbose)) (unless (slot-boundp o 'original-initargs) (setf (operation-original-initargs o) initargs))) (defmethod print-object ((o operation) stream) (print-unreadable-object (o stream :type t :identity nil) (ignore-errors (format stream "~{~S~^ ~}" (operation-original-initargs o)))))) ;;; make-operation, find-operation (with-upgradability () (defparameter *operations* (make-hash-table :test 'equal)) (defun make-operation (operation-class &rest initargs) (ensure-gethash (cons operation-class initargs) *operations* (list* 'make-instance operation-class initargs))) (defgeneric find-operation (context spec) (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) (defmethod find-operation (context (spec operation)) (declare (ignorable context)) spec) (defmethod find-operation (context (spec symbol)) (unless (member spec '(nil feature)) ;; NIL designates itself, i.e. absence of operation ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS (apply 'make-operation spec (operation-original-initargs context)))) (defmethod operation-original-initargs ((context symbol)) (declare (ignorable context)) nil) (defclass build-op (operation) ())) cl-asdf-3.0.3/output-translations.lisp000066400000000000000000000353441223164443400200120ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; asdf-output-translations (asdf/package:define-package :asdf/output-translations (:recycle :asdf/output-translations :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:*output-translations* #:*output-translations-parameter* #:invalid-output-translation #:output-translations #:output-translations-initialized-p #:initialize-output-translations #:clear-output-translations #:disable-output-translations #:ensure-output-translations #:apply-output-translations #:validate-output-translations-directive #:validate-output-translations-form #:validate-output-translations-file #:validate-output-translations-directory #:parse-output-translations-string #:wrapping-output-translations #:user-output-translations-pathname #:system-output-translations-pathname #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname #:environment-output-translations #:process-output-translations #:compute-output-translations #+abcl #:translate-jar-pathname )) (in-package :asdf/output-translations) (when-upgrading () (undefine-function '(setf output-translations))) (with-upgradability () (define-condition invalid-output-translation (invalid-configuration warning) ((format :initform (compatfmt "~@")))) (defvar *output-translations* () "Either NIL (for uninitialized), or a list of one element, said element itself being a sorted list of mappings. Each mapping is a pair of a source pathname and destination pathname, and the order is by decreasing length of namestring of the source pathname.") (defun output-translations () (car *output-translations*)) (defun set-output-translations (new-value) (setf *output-translations* (list (stable-sort (copy-list new-value) #'> :key #'(lambda (x) (etypecase (car x) ((eql t) -1) (pathname (let ((directory (pathname-directory (car x)))) (if (listp directory) (length directory) 0)))))))) new-value) #-gcl2.6 (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) #+gcl2.6 (defsetf output-translations set-output-translations) (defun output-translations-initialized-p () (and *output-translations* t)) (defun clear-output-translations () "Undoes any initialization of the output translations." (setf *output-translations* '()) (values)) (register-clear-configuration-hook 'clear-output-translations) (defun validate-output-translations-directive (directive) (or (member directive '(:enable-user-cache :disable-cache nil)) (and (consp directive) (or (and (length=n-p directive 2) (or (and (eq (first directive) :include) (typep (second directive) '(or string pathname null))) (and (location-designator-p (first directive)) (or (location-designator-p (second directive)) (location-function-p (second directive)))))) (and (length=n-p directive 1) (location-designator-p (first directive))))))) (defun validate-output-translations-form (form &key location) (validate-configuration-form form :output-translations 'validate-output-translations-directive :location location :invalid-form-reporter 'invalid-output-translation)) (defun validate-output-translations-file (file) (validate-configuration-file file 'validate-output-translations-form :description "output translations")) (defun validate-output-translations-directory (directory) (validate-configuration-directory directory :output-translations 'validate-output-translations-directive :invalid-form-reporter 'invalid-output-translation)) (defun parse-output-translations-string (string &key location) (cond ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) (error (compatfmt "~@") string)) ((eql (char string 0) #\") (parse-output-translations-string (read-from-string string) :location location)) ((eql (char string 0) #\() (validate-output-translations-form (read-from-string string) :location location)) (t (loop :with inherit = nil :with directives = () :with start = 0 :with end = (length string) :with source = nil :with separator = (inter-directory-separator) :for i = (or (position separator string :start start) end) :do (let ((s (subseq string start i))) (cond (source (push (list source (if (equal "" s) nil s)) directives) (setf source nil)) ((equal "" s) (when inherit (error (compatfmt "~@") string)) (setf inherit t) (push :inherit-configuration directives)) (t (setf source s))) (setf start (1+ i)) (when (> start end) (when source (error (compatfmt "~@") string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) (defparameter *default-output-translations* '(environment-output-translations user-output-translations-pathname user-output-translations-directory-pathname system-output-translations-pathname system-output-translations-directory-pathname)) (defun wrapping-output-translations () `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. #+(or #|clozure|# ecl mkcl sbcl) ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) (when h `(((,h ,*wild-path*) ())))) #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) (defun user-output-translations-pathname (&key (direction :input)) (in-user-configuration-directory *output-translations-file* :direction direction)) (defun system-output-translations-pathname (&key (direction :input)) (in-system-configuration-directory *output-translations-file* :direction direction)) (defun user-output-translations-directory-pathname (&key (direction :input)) (in-user-configuration-directory *output-translations-directory* :direction direction)) (defun system-output-translations-directory-pathname (&key (direction :input)) (in-system-configuration-directory *output-translations-directory* :direction direction)) (defun environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) (defgeneric process-output-translations (spec &key inherit collect)) (defun inherit-output-translations (inherit &key collect) (when inherit (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) (defun* (process-output-translations-directive) (directive &key inherit collect) (if (atom directive) (ecase directive ((:enable-user-cache) (process-output-translations-directive '(t :user-cache) :collect collect)) ((:disable-cache) (process-output-translations-directive '(t t) :collect collect)) ((:inherit-configuration) (inherit-output-translations inherit :collect collect)) ((:ignore-inherited-configuration :ignore-invalid-entries nil) nil)) (let ((src (first directive)) (dst (second directive))) (if (eq src :include) (when dst (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) (let ((loc (resolve-location src :ensure-directory t :wilden t))) (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) (cond ((location-function-p dst) (funcall collect (list trusrc (ensure-function (second dst))))) ((eq dst t) (funcall collect (list trusrc t))) (t (let* ((trudst (if dst (resolve-location dst :ensure-directory t :wilden t) trusrc))) (funcall collect (list trudst t)) (funcall collect (list trusrc trudst))))))))))) (defmethod process-output-translations ((x symbol) &key (inherit *default-output-translations*) collect) (process-output-translations (funcall x) :inherit inherit :collect collect)) (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect) (cond ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) :inherit inherit :collect collect)) ((probe-file* pathname :truename *resolve-symlinks*) (process-output-translations (validate-output-translations-file pathname) :inherit inherit :collect collect)) (t (inherit-output-translations inherit :collect collect)))) (defmethod process-output-translations ((string string) &key inherit collect) (process-output-translations (parse-output-translations-string string) :inherit inherit :collect collect)) (defmethod process-output-translations ((x null) &key inherit collect) (declare (ignorable x)) (inherit-output-translations inherit :collect collect)) (defmethod process-output-translations ((form cons) &key inherit collect) (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect))) (defun compute-output-translations (&optional parameter) "read the configuration, return it" (remove-duplicates (while-collecting (c) (inherit-output-translations `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) :test 'equal :from-end t)) (defvar *output-translations-parameter* nil) (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) "read the configuration, initialize the internal configuration variable, return the configuration" (setf *output-translations-parameter* parameter (output-translations) (compute-output-translations parameter))) (defun disable-output-translations () "Initialize output translations in a way that maps every file to itself, effectively disabling the output translation facility." (initialize-output-translations '(:output-translations :disable-cache :ignore-inherited-configuration))) ;; checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in ;; the latter, initialize. ASDF will call this function at the start ;; of (asdf:find-system). (defun ensure-output-translations () (if (output-translations-initialized-p) (output-translations) (initialize-output-translations))) (defun* (apply-output-translations) (path) (etypecase path (logical-pathname path) ((or pathname string) (ensure-output-translations) (loop* :with p = (resolve-symlinks* path) :for (source destination) :in (car *output-translations*) :for root = (when (or (eq source t) (and (pathnamep source) (not (absolute-pathname-p source)))) (pathname-root p)) :for absolute-source = (cond ((eq source t) (wilden root)) (root (merge-pathnames* source root)) (t source)) :when (or (eq source t) (pathname-match-p p absolute-source)) :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) ;; Hook into uiop's output-translation mechanism #-cormanlisp (setf *output-translation-function* 'apply-output-translations) #+abcl (defun translate-jar-pathname (source wildcard) (declare (ignore wildcard)) (flet ((normalize-device (pathname) (if (find :windows *features*) pathname (make-pathname :defaults pathname :device :unspecific)))) (let* ((jar (pathname (first (pathname-device source)))) (target-root-directory-namestring (format nil "/___jar___file___root___/~@[~A/~]" (and (find :windows *features*) (pathname-device jar)))) (relative-source (relativize-pathname-directory source)) (relative-jar (relativize-pathname-directory (ensure-directory-pathname jar))) (target-root-directory (normalize-device (pathname-directory-pathname (parse-namestring target-root-directory-namestring)))) (target-root (merge-pathnames* relative-jar target-root-directory)) (target (merge-pathnames* relative-source target-root))) (normalize-device (apply-output-translations target)))))) cl-asdf-3.0.3/plan.lisp000066400000000000000000000524121223164443400146600ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Plan (asdf/package:define-package :asdf/plan (:recycle :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system :asdf/cache :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action) (:export #:component-operation-time #:mark-operation-done #:plan-traversal #:sequential-plan #:*default-plan-class* #:planned-action-status #:plan-action-status #:action-already-done-p #:circular-dependency #:circular-dependency-actions #:node-for #:needed-in-image-p #:action-index #:action-planned-p #:action-valid-p #:plan-record-dependency #:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies #:visit-dependencies #:compute-action-stamp #:traverse-action #:circular-dependency #:circular-dependency-actions #:call-while-visiting-action #:while-visiting-action #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p #:planned-p #:index #:forced #:forced-not #:total-action-count #:planned-action-count #:planned-output-action-count #:visited-actions #:visiting-action-set #:visiting-action-list #:plan-actions-r #:required-components #:filtered-sequential-plan #:plan-system #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component #:traverse-actions #:traverse-sub-actions)) (in-package :asdf/plan) ;;;; Generic plan traversal class (with-upgradability () (defclass plan-traversal () ((system :initform nil :initarg :system :accessor plan-system) (forced :initform nil :initarg :force :accessor plan-forced) (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) (total-action-count :initform 0 :accessor plan-total-action-count) (planned-action-count :initform 0 :accessor plan-planned-action-count) (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) (visiting-action-list :initform () :accessor plan-visiting-action-list)))) ;;;; Planned action status (with-upgradability () (defgeneric plan-action-status (plan operation component) (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT in the PLAN")) (defgeneric (setf plan-action-status) (new-status plan operation component) (:documentation "Sets the ACTION-STATUS associated to the action of OPERATION on COMPONENT in the PLAN")) (defclass planned-action-status (action-status) ((planned-p :initarg :planned-p :reader action-planned-p :documentation "a boolean, true iff the action was included in the plan.") (index :initarg :index :reader action-index :documentation "an integer, counting all traversed actions in traversal order.")) (:documentation "Status of an action in a plan")) (defmethod print-object ((status planned-action-status) stream) (print-unreadable-object (status stream :type t :identity nil) (with-slots (stamp done-p planned-p index) status (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index)))) (defmethod action-planned-p (action-status) (declare (ignorable action-status)) ; default method for non planned-action-status objects t) ;; TODO: eliminate NODE-FOR, use CONS. ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. ;; However, see also component-operation-time and mark-operation-done (defun node-for (o c) (cons (type-of o) c)) (defun action-already-done-p (plan operation component) (action-done-p (plan-action-status plan operation component))) (defmethod plan-action-status ((plan null) (o operation) (c component)) (declare (ignorable plan)) (multiple-value-bind (stamp done-p) (component-operation-time o c) (make-instance 'action-status :stamp stamp :done-p done-p))) (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) (declare (ignorable plan)) (let ((to (type-of o)) (times (component-operation-times c))) (if (action-done-p new-status) (remhash to times) (setf (gethash to times) (action-stamp new-status)))) new-status)) ;;;; forcing (with-upgradability () (defgeneric action-forced-p (plan operation component)) (defgeneric action-forced-not-p (plan operation component)) (defun normalize-forced-systems (x system) (etypecase x ((member nil :all) x) (cons (list-to-hash-set (mapcar #'coerce-name x))) ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) (defun action-override-p (plan operation component override-accessor) (declare (ignorable operation)) (let* ((override (funcall override-accessor plan))) (and override (if (typep override 'hash-table) (gethash (coerce-name (component-system (find-component () component))) override) t)))) (defmethod action-forced-p (plan operation component) (and ;; Did the user ask us to re-perform the action? (action-override-p plan operation component 'plan-forced) ;; You really can't force a builtin system and :all doesn't apply to it, ;; except it it's the specifically the system currently being built. (not (let ((system (component-system component))) (and (builtin-system-p system) (not (eq system (plan-system plan)))))))) (defmethod action-forced-not-p (plan operation component) (and ;; Did the user ask us to not re-perform the action? (action-override-p plan operation component 'plan-forced-not) ;; Force takes precedence over force-not (not (action-forced-p plan operation component)))) (defmethod action-forced-p ((plan null) operation component) (declare (ignorable plan operation component)) nil) (defmethod action-forced-not-p ((plan null) operation component) (declare (ignorable plan operation component)) nil)) ;;;; action-valid-p (with-upgradability () (defgeneric action-valid-p (plan operation component) (:documentation "Is this action valid to include amongst dependencies?")) (defmethod action-valid-p (plan operation (c component)) (declare (ignorable plan operation)) (if-let (it (component-if-feature c)) (featurep it) t)) (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil) (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil) (defmethod action-valid-p ((plan null) operation component) (declare (ignorable plan operation component)) (and operation component t))) ;;;; Is the action needed in this image? (with-upgradability () (defgeneric needed-in-image-p (operation component) (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful, or could it just as well have been done in another Lisp image?")) (defmethod needed-in-image-p ((o operation) (c component)) ;; We presume that actions that modify the filesystem don't need be run ;; in the current image if they have already been done in another, ;; and can be run in another process (e.g. a fork), ;; whereas those that don't are meant to side-effect the current image and can't. (not (output-files o c)))) ;;;; Visiting dependencies of an action and computing action stamps (with-upgradability () (defun map-direct-dependencies (operation component fun) (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) :for dep-o = (find-operation operation dep-o-spec) :when dep-o :do (loop :for dep-c-spec :in dep-c-specs :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) :when dep-c :do (funcall fun dep-o dep-c)))) (defun reduce-direct-dependencies (operation component combinator seed) (map-direct-dependencies operation component #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed)))) seed) (defun direct-dependencies (operation component) (reduce-direct-dependencies operation component #'acons nil)) (defun visit-dependencies (plan operation component dependency-stamper &aux stamp) (map-direct-dependencies operation component #'(lambda (dep-o dep-c) (when (action-valid-p plan dep-o dep-c) (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c))))) stamp) (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) ;; In a distant future, get-file-stamp and component-operation-time ;; shall also be parametrized by the plan, or by a second model object. (let* ((stamp-lookup #'(lambda (o c) (if-let (it (plan-action-status plan o c)) (action-stamp it) t))) (out-files (output-files o c)) (in-files (input-files o c)) ;; Three kinds of actions: (out-op (and out-files t)) ; those that create files on the filesystem ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing ;; When was the thing last actually done? (Now, or ask.) (op-time (or just-done (component-operation-time o c))) ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) (dep-stamp (visit-dependencies plan o c stamp-lookup)) ;; Time stamps from the files at hand, and whether any is missing (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (in-stamps (mapcar #'get-file-stamp in-files)) (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (all-present (not (or missing-in missing-out))) ;; Has any input changed since we last generated the files? (earliest-out (stamps-earliest out-stamps)) (latest-in (stamps-latest (cons dep-stamp in-stamps))) (up-to-date-p (stamp<= latest-in earliest-out)) ;; If everything is up to date, the latest of inputs and outputs is our stamp (done-stamp (stamps-latest (cons latest-in out-stamps)))) ;; Warn if some files are missing: ;; either our model is wrong or some other process is messing with our files. (when (and just-done (not all-present)) (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" (action-description o c) missing-in (length missing-in) (and missing-in missing-out) missing-out (length missing-out))) ;; Note that we use stamp<= instead of stamp< to play nice with generated files. ;; Any race condition is intrinsic to the limited timestamp resolution. (if (or just-done ;; The done-stamp is valid: if we're just done, or ;; if all filesystem effects are up-to-date and there's no invalidating reason. (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) (values done-stamp ;; return the hard-earned timestamp (or just-done out-op ;; a file-creating op is done when all files are up to date ;; a image-effecting a placeholder op is done when it was actually run, (and op-time (eql op-time done-stamp)))) ;; with the matching stamp ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet (values t nil))))) ;;;; Generic support for plan-traversal (with-upgradability () (defgeneric plan-record-dependency (plan operation component)) (defgeneric call-while-visiting-action (plan operation component function) (:documentation "Detect circular dependencies")) (defmethod initialize-instance :after ((plan plan-traversal) &key (force () fp) (force-not () fnp) system &allow-other-keys) (with-slots (forced forced-not) plan (when fp (setf forced (normalize-forced-systems force system))) (when fnp (setf forced-not (normalize-forced-systems force-not system))))) (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component)) (or (and (action-forced-not-p plan o c) (plan-action-status nil o c)) (values (gethash (node-for o c) (plan-visited-actions plan))))) (defmethod action-valid-p ((plan plan-traversal) (o operation) (s system)) (and (not (action-forced-not-p plan o s)) (call-next-method))) (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) (with-accessors ((action-set plan-visiting-action-set) (action-list plan-visiting-action-list)) plan (let ((action (cons operation component))) (when (gethash action action-set) (error 'circular-dependency :actions (member action (reverse action-list) :test 'equal))) (setf (gethash action action-set) t) (push action action-list) (unwind-protect (funcall fun) (pop action-list) (setf (gethash action action-set) nil)))))) ;;;; Actual traversal: traverse-action (with-upgradability () (define-condition circular-dependency (system-definition-error) ((actions :initarg :actions :reader circular-dependency-actions)) (:report (lambda (c s) (format s (compatfmt "~@") (circular-dependency-actions c))))) (defmacro while-visiting-action ((p o c) &body body) `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body))) (defgeneric traverse-action (plan operation component needed-in-image-p)) (defmethod traverse-action (plan operation component needed-in-image-p) (block nil (unless (action-valid-p plan operation component) (return nil)) (plan-record-dependency plan operation component) (let* ((aniip (needed-in-image-p operation component)) (eniip (and aniip needed-in-image-p)) (status (plan-action-status plan operation component))) (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) ;; Already visited with sufficient need-in-image level: just return the stamp. (return (action-stamp status))) (labels ((visit-action (niip) (visit-dependencies plan operation component #'(lambda (o c) (traverse-action plan o c niip))) (multiple-value-bind (stamp done-p) (compute-action-stamp plan operation component) (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) (cond ((and add-to-plan-p (not niip)) ;; if we need to do it, (visit-action t)) ;; then we need to do it in the image! (t (setf (plan-action-status plan operation component) (make-instance 'planned-action-status :stamp stamp :done-p (and done-p (not add-to-plan-p)) :planned-p add-to-plan-p :index (if status (action-index status) (incf (plan-total-action-count plan))))) (when add-to-plan-p (incf (plan-planned-action-count plan)) (unless aniip (incf (plan-planned-output-action-count plan)))) stamp)))))) (while-visiting-action (plan operation component) ; maintain context, handle circularity. (visit-action eniip))))))) ;;;; Sequential plans (the default) (with-upgradability () (defclass sequential-plan (plan-traversal) ((actions-r :initform nil :accessor plan-actions-r))) (defgeneric plan-actions (plan)) (defmethod plan-actions ((plan list)) plan) (defmethod plan-actions ((plan sequential-plan)) (reverse (plan-actions-r plan))) (defmethod plan-record-dependency ((plan sequential-plan) (operation operation) (component component)) (declare (ignorable plan operation component)) (values)) (defmethod (setf plan-action-status) :after (new-status (p sequential-plan) (o operation) (c component)) (when (action-planned-p new-status) (push (cons o c) (plan-actions-r p))))) ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p (with-upgradability () (defgeneric make-plan (plan-class operation component &key &allow-other-keys) (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) (define-convenience-action-methods make-plan (plan-class operation component &key)) (defgeneric perform-plan (plan &key)) (defgeneric plan-operates-on-p (plan component)) (defvar *default-plan-class* 'sequential-plan) (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) :system (component-system c) keys))) (traverse-action plan o c t) plan)) (defmethod perform-plan :around ((plan t) &key) (let ((*package* *package*) (*readtable* *readtable*)) (with-compilation-unit () ;; backward-compatibility. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys) (apply 'perform-plan (plan-actions plan) keys)) (defmethod perform-plan ((steps list) &key force &allow-other-keys) (loop* :for (o . c) :in steps :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) :do (perform-with-restarts o c))) (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list)) (plan-operates-on-p (plan-actions plan) component-path)) (defmethod plan-operates-on-p ((plan list) (component-path list)) (find component-path (mapcar 'cdr plan) :test 'equal :key 'component-find-path))) ;;;; Incidental traversals (with-upgradability () (defclass filtered-sequential-plan (sequential-plan) ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) (component-type :initform t :initarg :component-type :reader plan-component-type) (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) (keep-component :initform t :initarg :keep-component :reader plan-keep-component))) (defmethod initialize-instance :after ((plan filtered-sequential-plan) &key (force () fp) (force-not () fnp) other-systems) (declare (ignore force force-not)) (with-slots (forced forced-not action-filter system) plan (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system))) (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system))) (setf action-filter (ensure-function action-filter)))) (defmethod action-valid-p ((plan filtered-sequential-plan) o c) (and (funcall (plan-action-filter plan) o c) (typep c (plan-component-type plan)) (call-next-method))) (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys) (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) (loop* :for (o . c) :in actions :do (traverse-action plan o c t)) plan)) (define-convenience-action-methods traverse-sub-actions (operation component &key)) (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys) (apply 'traverse-actions (direct-dependencies operation component) :system (component-system component) keys)) (defmethod plan-actions ((plan filtered-sequential-plan)) (with-slots (keep-operation keep-component) plan (loop* :for (o . c) :in (call-next-method) :when (and (typep o keep-operation) (typep c keep-component)) :collect (cons o c)))) (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) (remove-duplicates (mapcar 'cdr (plan-actions (apply 'traverse-sub-actions goal-operation system (remove-plist-key :goal-operation keys)))) :from-end t))) cl-asdf-3.0.3/source-registry.lisp000066400000000000000000000352051223164443400170750ustar00rootroot00000000000000;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 (asdf/package:define-package :asdf/source-registry (:recycle :asdf/source-registry :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) (:export #:*source-registry-parameter* #:*default-source-registries* #:invalid-source-registry #:source-registry-initialized-p #:initialize-source-registry #:clear-source-registry #:*source-registry* #:ensure-source-registry #:*source-registry-parameter* #:*default-source-registry-exclusions* #:*source-registry-exclusions* #:*wild-asd* #:directory-asd-files #:register-asd-directory #:collect-asds-in-directory #:collect-sub*directories-asd-files #:validate-source-registry-directive #:validate-source-registry-form #:validate-source-registry-file #:validate-source-registry-directory #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry #:user-source-registry #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory #:environment-source-registry #:process-source-registry #:compute-source-registry #:flatten-source-registry #:sysdef-source-registry-search)) (in-package :asdf/source-registry) (with-upgradability () (define-condition invalid-source-registry (invalid-configuration warning) ((format :initform (compatfmt "~@")))) ;; Using ack 1.2 exclusions (defvar *default-source-registry-exclusions* '(".bzr" ".cdv" ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" "debian")) ;; debian often builds stuff under the debian directory... BAD. (defvar *source-registry-exclusions* *default-source-registry-exclusions*) (defvar *source-registry* nil "Either NIL (for uninitialized), or an equal hash-table, mapping system names to pathnames of .asd files") (defun source-registry-initialized-p () (typep *source-registry* 'hash-table)) (defun clear-source-registry () "Undoes any initialization of the source registry." (setf *source-registry* nil) (values)) (register-clear-configuration-hook 'clear-source-registry) (defparameter *wild-asd* (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) (defun directory-asd-files (directory) (directory-files directory *wild-asd*)) (defun collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) (defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) (collect-sub*directories directory (constantly t) #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal))) #'(lambda (dir) (collect-asds-in-directory dir collect)))) (defun validate-source-registry-directive (directive) (or (member directive '(:default-registry)) (and (consp directive) (let ((rest (rest directive))) (case (first directive) ((:include :directory :tree) (and (length=n-p rest 1) (location-designator-p (first rest)))) ((:exclude :also-exclude) (every #'stringp rest)) ((:default-registry) (null rest))))))) (defun validate-source-registry-form (form &key location) (validate-configuration-form form :source-registry 'validate-source-registry-directive :location location :invalid-form-reporter 'invalid-source-registry)) (defun validate-source-registry-file (file) (validate-configuration-file file 'validate-source-registry-form :description "a source registry")) (defun validate-source-registry-directory (directory) (validate-configuration-directory directory :source-registry 'validate-source-registry-directive :invalid-form-reporter 'invalid-source-registry)) (defun parse-source-registry-string (string &key location) (cond ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) (error (compatfmt "~@") string)) ((find (char string 0) "\"(") (validate-source-registry-form (read-from-string string) :location location)) (t (loop :with inherit = nil :with directives = () :with start = 0 :with end = (length string) :with separator = (inter-directory-separator) :for pos = (position separator string :start start) :do (let ((s (subseq string start (or pos end)))) (flet ((check (dir) (unless (absolute-pathname-p dir) (error (compatfmt "~@") string)) dir)) (cond ((equal "" s) ; empty element: inherit (when inherit (error (compatfmt "~@") string)) (setf inherit t) (push ':inherit-configuration directives)) ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) (t (push `(:directory ,(check s)) directives)))) (cond (pos (setf start (1+ pos))) (t (unless inherit (push '(:ignore-inherited-configuration) directives)) (return `(:source-registry ,@(nreverse directives)))))))))) (defun register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (collect-asds-in-directory directory collect) (collect-sub*directories-asd-files directory :exclude exclude :collect collect))) (defparameter *default-source-registries* '(environment-source-registry user-source-registry user-source-registry-directory system-source-registry system-source-registry-directory default-source-registry)) (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) (defun wrapping-source-registry () `(:source-registry #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) :inherit-configuration #+cmu (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun default-source-registry () `(:source-registry #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/")) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv-absolute-directory "XDG_DATA_HOME") (subpathname (user-homedir-pathname) ".local/share/")) ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") '("/usr/local/share" "/usr/share")))) ,@(when (os-windows-p) (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) (defun user-source-registry (&key (direction :input)) (in-user-configuration-directory *source-registry-file* :direction direction)) (defun system-source-registry (&key (direction :input)) (in-system-configuration-directory *source-registry-file* :direction direction)) (defun user-source-registry-directory (&key (direction :input)) (in-user-configuration-directory *source-registry-directory* :direction direction)) (defun system-source-registry-directory (&key (direction :input)) (in-system-configuration-directory *source-registry-directory* :direction direction)) (defun environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) (defgeneric* (process-source-registry) (spec &key inherit register)) (defun* (inherit-source-registry) (inherit &key register) (when inherit (process-source-registry (first inherit) :register register :inherit (rest inherit)))) (defun* (process-source-registry-directive) (directive &key inherit register) (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) (ecase kw ((:include) (destructuring-bind (pathname) rest (process-source-registry (resolve-location pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname (funcall register (resolve-location pathname :ensure-directory t))))) ((:tree) (destructuring-bind (pathname) rest (when pathname (funcall register (resolve-location pathname :ensure-directory t) :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude) (appendf *source-registry-exclusions* rest)) ((:default-registry) (inherit-source-registry '(default-source-registry) :register register)) ((:inherit-configuration) (inherit-source-registry inherit :register register)) ((:ignore-inherited-configuration) nil))) nil) (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register) (cond ((directory-pathname-p pathname) (let ((*here-directory* (resolve-symlinks* pathname))) (process-source-registry (validate-source-registry-directory pathname) :inherit inherit :register register))) ((probe-file* pathname :truename *resolve-symlinks*) (let ((*here-directory* (pathname-directory-pathname pathname))) (process-source-registry (validate-source-registry-file pathname) :inherit inherit :register register))) (t (inherit-source-registry inherit :register register)))) (defmethod process-source-registry ((string string) &key inherit register) (process-source-registry (parse-source-registry-string string) :inherit inherit :register register)) (defmethod process-source-registry ((x null) &key inherit register) (declare (ignorable x)) (inherit-source-registry inherit :register register)) (defmethod process-source-registry ((form cons) &key inherit register) (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) (defun flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) (with-pathname-defaults () ;; be location-independent (inherit-source-registry `(wrapping-source-registry ,parameter ,@*default-source-registries*) :register #'(lambda (directory &key recurse exclude) (collect (list directory :recurse recurse :exclude exclude)))))) :test 'equal :from-end t)) ;; Will read the configuration and initialize all internal variables. (defun compute-source-registry (&optional parameter (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates (register-asd-directory directory :recurse recurse :exclude exclude :collect #'(lambda (asd) (let* ((name (pathname-name asd)) (name (if (typep asd 'logical-pathname) ;; logical pathnames are upper-case, ;; at least in the CLHS and on SBCL, ;; yet (coerce-name :foo) is lower-case. ;; won't work well with (load-system "Foo") ;; instead of (load-system 'foo) (string-downcase name) name))) (cond ((gethash name registry) ; already shadowed by something else nil) ((gethash name h) ; conflict at current level (when *verbose-out* (warn (compatfmt "~@") directory recurse name (gethash name h) asd))) (t (setf (gethash name registry) asd) (setf (gethash name h) asd)))))) h))) (values)) (defvar *source-registry-parameter* nil) (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) ;; Record the parameter used to configure the registry (setf *source-registry-parameter* parameter) ;; Clear the previous registry database: (setf *source-registry* (make-hash-table :test 'equal)) ;; Do it! (compute-source-registry parameter)) ;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in ;; the latter, initialize. ASDF will call this function at the start ;; of (asdf:find-system) to make sure the source registry is initialized. ;; However, it will do so *without* a parameter, at which point it ;; will be too late to provide a parameter to this function, though ;; you may override the configuration explicitly by calling ;; initialize-source-registry directly with your parameter. (defun ensure-source-registry (&optional parameter) (unless (source-registry-initialized-p) (initialize-source-registry parameter)) (values)) (defun sysdef-source-registry-search (system) (ensure-source-registry) (values (gethash (primary-system-name system) *source-registry*)))) cl-asdf-3.0.3/system.lisp000066400000000000000000000116431223164443400152530ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Systems (asdf/package:define-package :asdf/system (:recycle :asdf :asdf/system) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) (:export #:system #:proto-system #:system-source-file #:system-source-directory #:system-relative-pathname #:reset-system #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license #:system-defsystem-depends-on #:component-build-pathname #:build-pathname #:component-entry-point #:entry-point #:homepage #:system-homepage #:bug-tracker #:system-bug-tracker #:mailto #:system-mailto #:long-name #:system-long-name #:source-control #:system-source-control #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) (with-upgradability () (defgeneric* (find-system) (system &optional error-p)) (defgeneric* (system-source-file) (system) (:documentation "Return the source file in which system is defined.")) (defgeneric component-build-pathname (component)) (defgeneric component-entry-point (component)) (defmethod component-entry-point ((c component)) (declare (ignorable c)) nil)) ;;;; The system class (with-upgradability () (defclass proto-system () ; slots to keep when resetting a system ;; To preserve identity for all objects, we'd need keep the components slots ;; but also to modify parse-component-form to reset the recycled objects. ((name) (source-file) #|(children) (children-by-names)|#)) (defclass system (module proto-system) ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. (;; {,long-}description is now inherited from component, but we add the legacy accessors (description :accessor system-description) (long-description :accessor system-long-description) (author :accessor system-author :initarg :author :initform nil) (maintainer :accessor system-maintainer :initarg :maintainer :initform nil) (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license :initform nil) (homepage :accessor system-homepage :initarg :homepage :initform nil) (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil) (mailto :accessor system-mailto :initarg :mailto :initform nil) (long-name :accessor system-long-name :initarg :long-name :initform nil) ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced. ;; I'm introducing the slot before the conventions are set for maximum compatibility. (source-control :accessor system-source-control :initarg :source-control :initform nil) (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) (build-pathname :initform nil :initarg :build-pathname :accessor component-build-pathname) (entry-point :initform nil :initarg :entry-point :accessor component-entry-point) (source-file :initform nil :initarg :source-file :accessor system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) (defun reset-system (system &rest keys &key &allow-other-keys) (change-class (change-class system 'proto-system) 'system) (apply 'reinitialize-instance system keys))) ;;;; Pathnames (with-upgradability () (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) (system-source-file (find-system system-name))) (defun system-source-directory (system-designator) "Return a pathname object corresponding to the directory in which the system specification (.asd file) is located." (pathname-directory-pathname (system-source-file system-designator))) (defun (system-relative-pathname) (system name &key type) (subpathname (system-source-directory system) name :type type)) (defmethod component-pathname ((system system)) (let ((pathname (or (call-next-method) (system-source-directory system)))) (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age (slot-value system 'relative-pathname)) ;; systems that directly access this slot. (setf (slot-value system 'relative-pathname) pathname)) pathname)) (defmethod component-relative-pathname ((system system)) (parse-unix-namestring (and (slot-boundp system 'relative-pathname) (slot-value system 'relative-pathname)) :want-relative t :type :directory :ensure-absolute t :defaults (system-source-directory system))) (defmethod component-parent-pathname ((system system)) (system-source-directory system)) (defmethod component-build-pathname ((c component)) (declare (ignorable c)) nil)) cl-asdf-3.0.3/test/000077500000000000000000000000001223164443400140105ustar00rootroot00000000000000cl-asdf-3.0.3/test/asdf-pathname-test.script000066400000000000000000000600641223164443400207310ustar00rootroot00000000000000;;; -*- Lisp -*- (defpackage :asdf-pathname-test (:use :asdf :uiop :uiop/common-lisp :asdf/cache :asdf-test)) (in-package :asdf-pathname-test) ;;(setf *unspecific-pathname-type* nil) #+gcl (trace compile-file-pathname*) ;;; test asdf pathname specifications ;;; ;;; Originally written by James Anderson, refactored by Francois-Rene Rideau ;;; ;;; Creates a test transcript build/results/${implementation}-pathnames.text ;;; The tests construct a simple system/module/source-file system definition and ;;; verify that component pathname specifications refer to lisp source files in the directories ;;; '/test/{system1,system2}/' ;;; any failure is recorded as a transcript entry which indicates ;;; ( ( system-pathname module-pathname file-pathname ) missing-pathnames ) ;;; where missing pathnames is a list of the component-pathname values ;;; which failed to designate an intended file. ;;; If there, if the pathname is logical, both the logical and physical pathname appears. ;;; where NIL appears, the probe-file succeeded. ;;; ;;; the test creates the logical host "ASDFTEST" and the system "test-system". ;;; both are removed at the conclusion. ;;; ;;; 20100314: ;;; (:module "a/b/c.d") => (make-pathname :directory '(:relative "a" "b" "c.d")) ;;; (:file "a/b/c.d") => (make-pathname :directory '(:relative "a" "b") :name "c.d" :type "lisp")) ;;; (:static-file "a/b/c.d") => (make-pathname :directory '(:relative "a" "b") :name "c" :type "d")) ;;; (:module "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b" "c.d")) ;;; (:file "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b") :name "c.d" :type "lisp")) ;;; (:static-file "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b") :name "c" :type "d")) ;;; ;;; (:file "file2.lisp") means #p"file2.lisp.lisp" ;;; (:static-file "file2.lisp") means #p"file2.lisp" ;;; (:file "module1-1/file3.lisp") means #p"module1-1/file3.lisp.lisp" (assuming /) ;;; (:static-file "module1-1/file3.lisp") means #p"module1-1/file3.lisp" (defun setup-asdftest-logical-host (&key (root *build-directory*) (bin-type (compile-file-type))) (setf (logical-pathname-translations "ASDFTEST") `((,(format nil "**;*.~a" bin-type) ,(subpathname root (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type bin-type :version nil))) (,(format nil "**;*.~a.*" bin-type) ,(subpathname root (make-pathname :directory '(:relative "asdf-bin" :wild-inferiors) :name :wild :type bin-type :defaults root))) ("**;*.*" ,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) :name :wild :type :wild :version nil))) ("**;*.*.*" ,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) :name :wild :type :wild)))))) (defclass test-status () ((system-count :initform 0) (directory-count :initform 0) (file-count :initform 0) (system-failures :initform 0) (directory-failures :initform 0) (file-failures :initform 0) (failures :initform ()))) (defparameter *test-status* (make-instance 'test-status)) (defun pathname-defsystem (&key system-pathname module-pathname file-pathname (support-absolute-string-pathnames t) (root-directory-namestring (namestring *build-directory*))) `(defsystem :test-system :pathname ,system-pathname :source-file ,(subpathname system-pathname "nosuchfile.asd") :components ((:module :module1 :pathname ,module-pathname :components ((:file "file" :pathname ,file-pathname) (:file "module2/file" :pathname ,file-pathname) ,@(unless (or (typep system-pathname 'logical-pathname) (typep module-pathname 'logical-pathname)) `((:file "typed-file.type" :pathname ,file-pathname) (:static-file "static-file.type" :pathname ,file-pathname) (:file "module2/typed-file.type" :pathname ,file-pathname) (:static-file "module2/static-file.type" :pathname ,file-pathname) ,@(when support-absolute-string-pathnames `((:static-file ,(strcat root-directory-namestring "asdf-src/system1/module1/file.lisp") :pathname ,file-pathname)))))))))) (defun translate-if-needed (pathname) (if (typep pathname 'logical-pathname) (cons (translate-logical-pathname pathname) pathname) pathname)) (defun test-module (module &key configuration (test-status *test-status*)) (with-slots (system-count directory-count file-count system-failures directory-failures file-failures failures) test-status (incf directory-count) (cond ((probe-file* (component-pathname module)) t) (t (incf directory-failures) (push (list (type-of module) (component-find-path module) (translate-if-needed (component-pathname module)) configuration (list (if-let (parent (component-parent module)) (component-pathname parent)))) failures) nil)))) (defparameter *backtraces* 0) (defparameter *max-backtraces* 2) (defun test-file (file &key configuration (test-status *test-status*) (start-time 0)) (with-slots (system-count directory-count file-count system-failures directory-failures file-failures failures) test-status (incf file-count) (unless (block nil (handler-bind ((error #'(lambda (c) (incf *backtraces*) (when (<= *backtraces* *max-backtraces*) (print-condition-backtrace c)) (return nil)))) (with-open-file (stream (component-pathname file) :direction :output :if-exists (or #+(and sbcl os-windows) :rename-and-delete :supersede) :if-does-not-exist :error) (print start-time stream) t))) (incf file-failures) (push (list (type-of file) (component-find-path file) (translate-if-needed (component-pathname file)) configuration (list (component-pathname (component-system file)) (component-pathname (component-parent file)))) failures)))) (defun test-pathname-configuration (&key system-pathname module-pathname file-pathname (start-time (get-universal-time)) (test-status *test-status*) (support-absolute-string-pathnames t) (root-directory-namestring (namestring *build-directory*)) (result-stream *standard-output*)) (with-slots (system-count directory-count file-count system-failures directory-failures file-failures failures) test-status (let ((configuration (list system-pathname module-pathname file-pathname)) (system-definition (pathname-defsystem :system-pathname system-pathname :module-pathname module-pathname :file-pathname file-pathname :support-absolute-string-pathnames support-absolute-string-pathnames :root-directory-namestring root-directory-namestring))) (handler-bind ((error (lambda (c) (incf system-failures) (format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition) (print-condition-backtrace c :stream *error-output*) (format result-stream "~&~%***~%error: ~a~%~s" c system-definition) (return-from test-pathname-configuration test-status)))) (unless (and (or (typep system-pathname 'logical-pathname) (typep module-pathname 'logical-pathname)) (and (stringp file-pathname) (find #\. file-pathname))) (incf system-count) (with-asdf-cache (:override t) (clear-system :test-system) (let* ((system (let ((*verbose-out* nil)) (eval system-definition))) (module (first (component-children system))) (file-components (component-children module))) (incf file-count (length file-components)) (incf directory-count 2) (test-module system :test-status test-status :configuration configuration) (test-module module :test-status test-status :configuration configuration) (dolist (file file-components) (test-file file :test-status test-status :configuration configuration :start-time start-time)))))))) test-status) (defun print-test-report (&key (test-status *test-status*) (result-stream *standard-output*) (start-time 0) test-files files modules systems) (with-slots (system-count directory-count file-count system-failures directory-failures file-failures failures) test-status (format result-stream "~% target files [~s]~:{~% ~s -> ~s~}~%" (length test-files) (mapcar #'(lambda (file) (list file (if (probe-file file) (if (> (file-write-date file) start-time) :ok :untouched) :missing))) test-files)) (format result-stream "~&~%~% translations: ~a: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST")) (format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s" systems modules files) (let ((homogeneous-failures 0) (*print-length* nil)) (format result-stream "~&~%~% pathname failures [~s]:" (length failures)) (dolist (failure failures) (destructuring-bind (type name intended-pathname configuration parent-pathnames) failure (format result-stream "~&~%~:[ ~;!~]~a~24T~s~% missing:~24T~s~% configuration:~24T~s~% parent pathnames:~24T~s" (flet ((logical-p (p) (typep p 'logical-pathname))) (when (or (every #'logical-p configuration) (notany #'logical-p configuration)) (incf homogeneous-failures))) type name intended-pathname configuration parent-pathnames))) (terpri result-stream) (print (print `(:result :type ,(lisp-implementation-type) :version ,(lisp-implementation-version) :file ,(pathname result-stream) :system-failures (,system-failures ,system-count) :directory-failures (,directory-failures ,directory-count) :file-failures (,file-failures ,file-count) :homogeneous ,homogeneous-failures) result-stream) *trace-output*) (terpri *trace-output*) (force-output *trace-output*) (and (zerop system-failures) (zerop directory-failures) (zerop file-failures) (zerop homogeneous-failures))))) (defun make-test-files (&key (root *build-directory*) (support-string-pathnames t) (support-absolute-string-pathnames t) (root-directory-namestring (namestring root))) (let ((systems `(,(subpathname root "asdf-src/system1/") ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1")) ,(parse-namestring "ASDFTEST:system1;") ,@(when support-string-pathnames `(,(format nil "~{/~a~}/asdf-src/system1" (rest (pathname-directory root))))))) (modules `(nil ,(make-pathname :directory '(:relative) :name nil :type nil) ,(make-pathname :directory '(:relative "module2") :name nil :type nil) ,(make-pathname :directory '(:relative "module2" "module3") :name nil :type nil) ,(subpathname root "asdf-src/system2/module4/") ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name nil :type nil) ,(parse-namestring "ASDFTEST:system2;module4;") ,@(when support-string-pathnames `("" "module2" "module2/" "module2/module3" "module2/module3/" ,@(when support-absolute-string-pathnames `(,(strcat root-directory-namestring "asdf-src/system1/module1") ,(strcat root-directory-namestring "asdf-src/system1/module1/") ,(strcat root-directory-namestring "asdf-src/system1/module2/") ,(strcat root-directory-namestring "asdf-src/system1/module2/module3/") ,(strcat root-directory-namestring "asdf-src/system2/module4/"))))))) (files `(nil ,(parse-unix-namestring "./untyped-file") ,(parse-unix-namestring "file") ,(parse-unix-namestring "./file.lisp") ,(parse-unix-namestring "typed-file.type") ,(parse-unix-namestring "module2/untyped-file") ,(parse-unix-namestring "module2/file.lisp") ,(parse-unix-namestring "module2/module3/file.lisp") ,(subpathname root "asdf-src/system1/module1/untyped-file") ,(subpathname root "asdf-src/system1/module1/file.lisp") ,(subpathname root "asdf-src/system1/module2/untyped-file") ,(subpathname root "asdf-src/system1/module2/file.lisp") ,(subpathname root "asdf-src/system1/module2/module3/file.lisp") ,(subpathname root "asdf-src/system2/module4/file.lisp") ,(make-pathname :host "ASDFTEST" :device nil :directory '(:absolute "system2" "module4") :name "file" :type "lisp" :version nil) ,(parse-namestring "ASDFTEST:system2;module4;file.lisp") ,@(when support-string-pathnames `(,(strcat root-directory-namestring "asdf-src/system1/module1/file.lisp"))))) (test-files (remove-duplicates (sort (loop ;; enumerate (system x module x file) pathname variations for relative ;; file component names. no additions for the absolute specifications, ;; as they should reiterate one of the relative names for directory in (flet ((src-dir (&rest path) (append (or (pathname-directory root) (list :relative)) (cons "asdf-src" path)))) (list (src-dir "system1") (src-dir "system1" "module1") (src-dir "system1" "module2") (src-dir "system1" "module2" "module3") (src-dir "system2" "module4"))) ;; :pathname #p"untyped-file" collect (make-pathname :directory directory :name "untyped-file" :type nil :defaults root) ;; :file "file" collect (make-pathname :directory directory :name "file" :type "lisp" :defaults root) ; for source files collect (make-pathname :directory directory :name "file" :type nil :defaults root) ; for static files ;; :file "typed-file.type" collect (make-pathname :directory directory :name "typed-file.type" :type "lisp" :defaults root) ; for source files collect (make-pathname :directory directory :name "typed-file" :type "type" :defaults root) ; for static files for :pathname arg ;; :static-file "static-file.type" collect (make-pathname :directory directory :name "static-file" :type "type" :defaults root) ;; :file "module2/file" collect (make-pathname :directory directory :name "file" :type "lisp" :defaults root) ;; :file "module2/typed-file.type" collect (make-pathname :directory directory :name "typed-file.type" :type "lisp" :defaults root) ; for source files ;;collect (make-pathname :directory directory :name "typed-file.type" :type nil) ; for static files ;; invalid as static file, unlike the below. ;; :static-file "module2/static-file.type" collect (make-pathname :directory directory :name "static-file" :type "type" :defaults root) ;;; source file pathname variations collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil :defaults root) collect (make-pathname :directory (append directory '("module2")) :name "file" :type "lisp" :defaults root) collect (make-pathname :directory (append directory '("module2")) :name "typed-file.type" :type "lisp" :defaults root) collect (make-pathname :directory (append directory '("module2")) :name "static-file" :type "type" :defaults root) collect (make-pathname :directory (append directory '("module2" "module3")) :name "file" :type "lisp" :defaults root) collect (make-pathname :directory (append directory '("module2" "module3")) :name "file" :type "lisp" :defaults root)) #'string-lessp ;; generate an alternative key in case namestring fails on a name w/ a dot :key #'(lambda (p) (format nil "~{~a~^.~}~@[.~a~]~@[.~a~]" (rest (pathname-directory p)) (pathname-name p) (pathname-type p)))) :test #'equalp :from-end t))) (values systems modules files test-files))) (defun test-component-pathnames (&key (root *build-directory*) (delete-host t) (support-string-pathnames nil) (support-absolute-string-pathnames nil)) #+gcl (format t "root: ~S~%" root) (unwind-protect (let ((root-directory-namestring (format nil "~{/~a~}/" (rest (pathname-directory root)))) (test-status (setf *test-status* (make-instance 'test-status))) (*print-pretty* nil) (start-time 0)) (with-slots (system-count directory-count file-count system-failures directory-failures file-failures failures) test-status (with-open-file (result-stream (subpathname *build-directory* (format nil "results/~(~A~)-pathnames.text" *implementation*)) :direction :output :if-exists :supersede :if-does-not-exist :create) #-gcl2.6 (setup-asdftest-logical-host :root root) (multiple-value-bind (systems modules files test-files) (make-test-files :root root :support-string-pathnames support-string-pathnames :support-absolute-string-pathnames support-absolute-string-pathnames :root-directory-namestring root-directory-namestring) (dolist (file test-files) (ensure-directories-exist file) (with-open-file (stream file :direction :output :if-exists :supersede :if-does-not-exist :create) stream)) (multiple-value-bind (second minute hour day month year) (decode-universal-time (setf start-time (get-universal-time)) 0) (let ((header (format nil "~4,'0d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0dZ : ~a ~a ~a" year month day hour minute second (lisp-implementation-type) (lisp-implementation-version) (asdf-version)))) (format result-stream ";;; ~a~%~%" header) (format *trace-output* "~%;;; ~a~%~%" header))) (sleep 1) (dolist (system-pathname systems) (dolist (module-pathname modules) (dolist (file-pathname files) (test-pathname-configuration :system-pathname system-pathname :module-pathname module-pathname :file-pathname file-pathname :start-time start-time :support-absolute-string-pathnames support-absolute-string-pathnames :root-directory-namestring root-directory-namestring :result-stream result-stream :test-status test-status)))) (print-test-report :test-status test-status :result-stream result-stream :start-time start-time :test-files test-files :files files :modules modules :systems systems))))) (when delete-host (setf (logical-pathname-translations "ASDFTEST") nil)) (clear-system "test-system"))) (asdf:initialize-source-registry) (format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*)) (asdf:initialize-output-translations) (format t "output translations: ~S~%" (asdf::output-translations)) #+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*))) #-(or xcl gcl2.6) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6 (progn ;; we're testing with unix, are we not? (assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname))) (assert-pathname-equal (resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz") (assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t) #p"/foo/bar/baz/") (assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t :wilden t) (wilden #p"/foo/bar/baz/")) (assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory nil :wilden t) (wilden #p"/foo/bar/")) #-gcl (assert-pathname-equal (resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :ensure-directory nil :wilden t) #p"/foo/bar/**/baz/*.*") (assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-1)))) (assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-2)))) (or (test-component-pathnames :delete-host t :support-string-pathnames nil) (leave-test "test failed" 1))) #| (load "LIBRARY:de;setf;utility;asdf;cp-test.lisp") (logical-pathname-translations "ASDFTEST") (gethash "test-system" asdf::*defined-systems*) |# cl-asdf-3.0.3/test/bad-shell-command000077500000000000000000000000231223164443400172000ustar00rootroot00000000000000#! /bin/sh exit 2 cl-asdf-3.0.3/test/defmacro-foo.lisp000066400000000000000000000001111223164443400172330ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defmacro foo (x) `(1+ ,x)) cl-asdf-3.0.3/test/defsetf-foo.lisp000066400000000000000000000002441223164443400171020ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defvar *foo* (make-hash-table :test 'equal)) (defun set-foo (x v) (setf (gethash x *foo*) v)) (defsetf foo set-foo) cl-asdf-3.0.3/test/defun-foo.lisp000066400000000000000000000001041223164443400165560ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defun foo (x) (1+ x)) cl-asdf-3.0.3/test/defun-setf-foo.lisp000066400000000000000000000002201223164443400175140ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defvar *foo* (make-hash-table :test 'equal)) (defun (setf foo) (v x) (setf (gethash x *foo*) v)) cl-asdf-3.0.3/test/dll-test.lisp000066400000000000000000000001341223164443400164270ustar00rootroot00000000000000#+ecl (ffi:clines " extern int sample_function(); int sample_function() { return 42; } ") cl-asdf-3.0.3/test/dll-user.lisp000066400000000000000000000001231223164443400164240ustar00rootroot00000000000000(in-package :test-package) (ffi:def-function "sample_function" () :returning :int) cl-asdf-3.0.3/test/duplicate-components-test.script000066400000000000000000000010321223164443400223440ustar00rootroot00000000000000;;; -*- Lisp -*- (handler-case (asdf:find-system "duplicate-components") (asdf:duplicate-names (x) (declare (ignore x)) t) (asdf:load-system-definition-error (x) (if (and (asdf/find-system::error-condition x) (typep (asdf/find-system::error-condition x) 'asdf:duplicate-names)) t (error "LOAD-SYSTEM-DEFINITION-ERROR not as expected (no contained DUPLICATE-NAMES error)."))) (:no-error (x) (error "FIND-SYSTEM of duplicate-components returned ~S instead of raising DUPLICATE-NAMES error." x))) cl-asdf-3.0.3/test/duplicate-components.asd000066400000000000000000000001221223164443400206310ustar00rootroot00000000000000(defsystem duplicate-components :components ((:file "foo") (:file "foo"))) cl-asdf-3.0.3/test/file1.lisp000066400000000000000000000001241223164443400156760ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *file1* t) cl-asdf-3.0.3/test/file2.lisp000066400000000000000000000001121223164443400156740ustar00rootroot00000000000000(in-package :test-package) (assert *file1*) (defvar *f2c* 0) (incf *f2c*) cl-asdf-3.0.3/test/file3-only.asd000066400000000000000000000001171223164443400164610ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem file3-only :components ((:file "file3"))) cl-asdf-3.0.3/test/file3.lisp000066400000000000000000000001241223164443400157000ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *file3* t) cl-asdf-3.0.3/test/file4.lisp000066400000000000000000000000541223164443400157030ustar00rootroot00000000000000(in-package :test-package) (assert *file3*) cl-asdf-3.0.3/test/good-shell-command000077500000000000000000000000231223164443400174020ustar00rootroot00000000000000#! /bin/sh exit 0 cl-asdf-3.0.3/test/graveyard/000077500000000000000000000000001223164443400157745ustar00rootroot00000000000000cl-asdf-3.0.3/test/graveyard/test-preferences-1.lisp000066400000000000000000000001211223164443400222730ustar00rootroot00000000000000(in-package #:common-lisp-user) (defvar *test-preferences-variable-1* :default) cl-asdf-3.0.3/test/graveyard/test-preferences-1.script000066400000000000000000000006721223164443400226430ustar00rootroot00000000000000;;; -*- Lisp -*- (load "script-support") (load "../asdf") (exit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (in-package :asdf) (setf asdf::*load-preference-files* t) (asdf:oos 'asdf:load-op 'test-preferences-system-1) (assert (eq common-lisp-user::*test-preferences-variable-1* :load)) (asdf:oos 'asdf:test-op 'test-preferences-system-1) (assert (eq common-lisp-user::*test-preferences-variable-1* :test)) )cl-asdf-3.0.3/test/graveyard/test-preferences-system-1.asd000066400000000000000000000020611223164443400234220ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package #:common-lisp) (defpackage #:test-preferences-1-asdf-system (:use #:common-lisp #:asdf)) (in-package #:asdf) (defsystem test-preferences-system-1 :components ((:file "test-preferences-1")) :in-order-to ((test-op (load-op test-preferences-system-1)))) (defmethod operation-done-p ((o test-op) (c (eql (find-system 'test-preferences-system-1)))) (values nil)) (defmethod load-preferences ((system (eql (find-system 'test-preferences-system-1))) (operation test-op)) ;; the default load-preferences does nothing for anything other than a ;; basic-load-op. So, ... we hack it (load (make-pathname :name "test-preferences-system-test" :type "lisp" :defaults *default-pathname-defaults*))) (defmethod preference-file-for-system/operation ((system (eql (find-system 'test-preferences-system-1))) (operation load-op)) (make-pathname :name "test-preferences-system-load" :type "lisp" :defaults *default-pathname-defaults*)) cl-asdf-3.0.3/test/graveyard/test-preferences-system-load.lisp000066400000000000000000000001141223164443400243760ustar00rootroot00000000000000(in-package #:common-lisp-user) (setf *test-preferences-variable-1* :load) cl-asdf-3.0.3/test/graveyard/test-preferences-system-test.lisp000066400000000000000000000001141223164443400244360ustar00rootroot00000000000000(in-package #:common-lisp-user) (setf *test-preferences-variable-1* :test) cl-asdf-3.0.3/test/graveyard/test6.script000066400000000000000000000007431223164443400202730ustar00rootroot00000000000000;;; -*- Lisp -*- ;; no preference loading by default (load "script-support") (load "../asdf") (in-package #:common-lisp-user) (defvar *test6* nil) (exit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (defmethod asdf:preference-file-for-system/operation ((system (eql (asdf:find-system 'test1))) operation) (merge-pathnames (make-pathname :name "test1" :type "preferences"))) (asdf:operate 'asdf:load-op 'test1) (assert (null *test6*))) cl-asdf-3.0.3/test/graveyard/test7.script000066400000000000000000000010471223164443400202720ustar00rootroot00000000000000;;; -*- Lisp -*- ;; load preferences if asdf::*load-preference-files* is true (load "script-support") (load "../asdf") (in-package #:common-lisp-user) (defvar *test6* nil) (exit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) (defmethod asdf:preference-file-for-system/operation ((system (eql (asdf:find-system 'test1))) operation) (merge-pathnames (make-pathname :name "test1" :type "preferences"))) (setf asdf::*load-preference-files* t) (asdf:operate 'asdf:load-op 'test1) (assert (eq *test6* :yes))) cl-asdf-3.0.3/test/hello-world-example.asd000066400000000000000000000002671223164443400203670ustar00rootroot00000000000000;; Example executable program (defsystem :hello-world-example :build-operation program-op :entry-point "hello:entry-point" :depends-on (:uiop) :components ((:file "hello"))) cl-asdf-3.0.3/test/hello.lisp000066400000000000000000000005021223164443400160010ustar00rootroot00000000000000(defpackage :hello (:use :cl :uiop) (:export #:main #:entry-point)) (in-package :hello) (defun main (&rest arguments) (format t "hello, world~%") (when arguments (format t "You passed ~D arguments:~%~{ ~S~%~}" (length arguments) arguments))) (defun entry-point () (apply 'main *command-line-arguments*)) cl-asdf-3.0.3/test/in-progress.lisp000066400000000000000000000016271223164443400171570ustar00rootroot00000000000000(in-package asdf) (assert (equalp (let ((*system-definition-search-functions* '(sysdef-central-registry-search)) (*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/"))) (handler-bind ((error (lambda (c) (when (find-restart 'remove-entry-from-registry) (invoke-restart 'remove-entry-from-registry))))) (find-system "a" nil)) *central-registry*) (list "/tmp/ok-1/" "/tmp/ok-2/")) ) (assert (equalp (let ((*system-definition-search-functions* '(sysdef-central-registry-search)) (*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/"))) (handler-bind ((error (lambda (c) (when (find-restart 'coerce-entry-to-directory) (invoke-restart 'coerce-entry-to-directory))))) (find-system "a" nil)) *central-registry*) (list "/tmp/ok-1/" #p"/tmp/bad/" "/tmp/ok-2/")) ) cl-asdf-3.0.3/test/lambda.lisp000066400000000000000000000001171223164443400161200ustar00rootroot00000000000000;; -*- coding: latin-2 -*- (in-package :asdf-test) (setf *lambda-string* "λ") cl-asdf-3.0.3/test/logical-file.lisp000066400000000000000000000001331223164443400172250ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *logical-file* t) cl-asdf-3.0.3/test/make-hello-world.lisp000066400000000000000000000012271223164443400200460ustar00rootroot00000000000000;;; -*- Lisp -*- #+lispworks (lispworks:load-all-patches) (load (make-pathname :name "script-support" :defaults *load-pathname*)) (load-asdf) #+ecl (require :cmp) (asdf-test::register-directory asdf-test::*asdf-directory*) ;; we need UIOP, and ECL can dump. (asdf-test::register-directory asdf-test::*uiop-directory*) (asdf:upgrade-asdf) ;; may recompile and rename away package asdf? (asdf-test::frob-packages) (with-test () ;;(dolist (s '(:asdf :uiop :asdf/defsystem :uiop)) (DBG :foo s (asdf::builtin-system-p (find-system s)))) ;;(trace perform-plan perform) (operate 'load-fasl-op :hello-world-example) (operate 'program-op :hello-world-example)) cl-asdf-3.0.3/test/package-test.lisp000066400000000000000000000000341223164443400172460ustar00rootroot00000000000000(in-package :asdf/package) cl-asdf-3.0.3/test/run-tests.sh000077500000000000000000000370151223164443400163210ustar00rootroot00000000000000#!/bin/sh # run-tests {lisp invocation} {scripts-regex} # - read lisp forms one at a time from standard input # - quit with exit status 0 on getting eof # - quit with exit status >0 if an unhandled error occurs usage () { echo "$0 [lisp invocation] [scripts-regex]" echo " - read lisp forms one at a time from matching scripts" echo " - quit with exit status 0 on getting eof" echo " - quit with exit status >0 if an unhandled error occurs" echo " you need to supply the .script in the second argument" echo " lisps include abcl, allegro, allegromodern, ccl (clozure)," echo " clisp, cmucl, ecl, gcl, gclcvs, sbcl, scl and xcl." echo "OPTIONS:" echo " -d -- debug mode" echo " -h -- show this message." echo " -u -- upgrade tests." echo " -c -- clean load test" echo " -l -- load systems tests" echo " -t -- test interactively" echo " -H -- extract all asdf versions to upgrade from" } unset DEBUG_ASDF_TEST upgrade clean_load load_systems test_interactively extract_all SHELL=/bin/sh export SHELL DEBUG_ASDF_TEST GCL_ANSI ASDF_OUTPUT_TRANSLATIONS while getopts "cdtHulhu" OPTION do case $OPTION in d) DEBUG_ASDF_TEST=t ;; u) upgrade=t ;; c) clean_load=t ;; l) load_systems=t ;; t) test_interactively=t ;; H) extract_all=t ;; h) usage exit 1 ;; esac done shift $(($OPTIND - 1)) if [ x"$1" = "xhelp" ]; then usage exit 1 fi lisp=${1:-sbcl} ; shift ECHO () { printf '%s\n' "$*" ;} ECHOn () { printf '%s' "$*" ;} DBG () { ECHO "$*" >& 2 ;} simple_term_p () { case "$1" in *[!a-zA-Z0-9-+_,.:=%/]*) return 1 ;; *) return 0 ;; esac } kwote0 () { ECHOn "$1" | sed -e "s/\([\\\\\"\$\`]\)/\\\\\\1/g" ;} kwote1 () { if simple_term_p "$1" ; then ECHOn "$1" else ECHOn "\"$(kwote0 "$1")\"" ; fi ;} kwote () { ( set +x k="" ; for i ; do ECHOn "$k" ; kwote1 "$i" ; k=" " ; done ; echo ) } DO () { kwote "$@" ; "$@" ; } do_tests () { if [ -z "$*" ]; then scripts="*.script" else scripts="$*" fi env | grep -i asdf ## We go through great lengths to avoid " in the command line, ## the quoting of which many Windows implementations get wrong. ## While we're at it, we also avoid spaces and backslashes. ( DO $bcmd $eval '(or`,#.(load(string`|script-support.lisp|))#.(asdf-test::compile-asdf-script))' ) if [ $? -ne 0 ] ; then echo "Compilation FAILED" >&2 echo "you can retry compilation with:" >&2 echo ./test/run-tests.sh $lisp >&2 echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 echo "$icmd" >&2 echo "then copy/paste:" >&2 echo '(load "test/script-support.lisp") (asdf-test::compile-asdf-script)' >&2 else echo "Compiled OK" >&2 test_count=0 test_pass=0 test_fail=0 failed_list="" for i in $scripts ; do echo "Testing: $i" >&2 test_count=`expr "$test_count" + 1` rm -f ~/.cache/common-lisp/"`pwd`"/* || true if DO $bcmd $eval "'(#.(load(string'|script-support.lisp|))#.(asdf-test::load-asdf)#.(asdf-test::frob-packages)#.(asdf-test::with-test()(load(string'|$i|))))" ; then echo "Using $command, $i passed" >&2 test_pass=`expr "$test_pass" + 1` else echo "Using $command, $i failed" >&2 test_fail=`expr "$test_fail" + 1` failed_list="$failed_list $i" echo "you can retry compilation with:" >&2 echo ./test/run-tests.sh $lisp $i >&2 echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 echo "(cd test ; $icmd )" >&2 echo "then copy/paste:" >&2 echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-cache () (load \"$i\")))" >&2 fi echo >&2 echo >&2 done echo >&2 echo "-#---------------------------------------" >&2 echo "Using $command" >&2 echo "Ran $test_count tests: " >&2 echo " $test_pass passing and $test_fail failing" >&2 if [ $test_fail -eq 0 ] ; then echo "all tests apparently successful" >&2 echo success > ../build/results/status else echo "failing test(s): $failed_list" >&2 fi echo "-#---------------------------------------" >&2 echo >&2 fi } # # not used currently but leave here for future reference. # case $(uname) in CYGWIN*) os=windows ;; Darwin) os=macos ;; Linux) os=linux ;; *) os=unknown ;; esac # terminate on error set -e command= flags= nodebug= eval= bcmd= icmd= case "$lisp" in abcl) command="${ABCL:-abcl}" flags="--noinit --nosystem --noinform" eval="--eval" ;; allegro|allegro8|allegromodern|allegromodern8) case "$lisp" in allegro) command="${ALLEGRO:-alisp}" ;; allegro8) command="${ALLEGRO8:-alisp8}" ;; allegromodern) command="${ALLEGROMODERN:-mlisp}" ;; allegromodern8) command="${ALLEGROMODERN8:-mlisp8}" ;; esac flags="-q" nodebug="-batch" if [ "$os" = windows ] && [ -z "$ALLEGRO_NOISY" ] ; then bcmd="$command +c $flags" ; fi eval="-e" ;; ccl) command="${CCL:-ccl}" flags="--no-init --quiet" nodebug="--batch" eval="--eval" ;; clisp) command="${CLISP:-clisp}" flags="-norc --silent -ansi -I " nodebug="-on-error exit" eval="-x" ;; cmucl) # cmucl likes to have its executable called lisp, but so does scl # Please use a symlink or an exec ... "$@" trampoline script. command="${CMUCL:-cmucl}" flags="-noinit" nodebug="-batch" eval="-eval" ;; ecl) command="${ECL:-ecl}" flags="-norc -load sys:cmp" eval="-eval" ;; ecl_bytecodes) command="${ECL:-ecl}" flags="-norc -eval (ext::install-bytecodes-compiler)" eval="-eval" ;; gcl) GCL_ANSI=t command="${GCL:-gcl}" flags="-batch" eval="-eval" ;; gclcvs) GCL_ANSI=t command="${GCLCVS:-gclcvs}" flags="-batch" eval="-eval" ;; lispworks) command="${LISPWORKS:-lispworks}" # If you have a licensed copy of lispworks, # you can obtain the "lispworks" binary with, e.g. # echo '(hcl:save-image "/lispworks" :environment nil)' > /tmp/build.lisp ; # ./lispworks-6-0-0-x86-linux -siteinit - -init - -build /tmp/build.lisp flags="-siteinit - -init -" eval="-eval" ;; mkcl) command="${MKCL:-mkcl}" flags="-norc" eval="-eval" ;; sbcl) command="${SBCL:-sbcl}" flags="--noinform --no-userinit --no-sysinit" nodebug="--disable-debugger" eval="--eval" ;; scl) command="${SCL:-scl}" flags="-noinit" nodebug="-batch" eval="-eval" ;; xcl) command="${XCL:-xcl}" flags="--no-userinit --no-siteinit --noinform" eval="--eval" ;; *) echo "Unsupported lisp: $1" >&2 echo "Please add support to run-tests.sh" >&2 exit 42 ;; esac if ! type "$command" > /dev/null ; then echo "lisp implementation not found: $command" >&2 exit 43 fi ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)" : ${bcmd:=$command $flags} ${icmd:=$command $flags} # batch and interactive if [ -z "${DEBUG_ASDF_TEST}" ] ; then bcmd="$bcmd $nodebug" fi create_config () { cd ${ASDFDIR} mkdir -p build/results/ build/test-source-registry-conf.d build/test-asdf-output-translations-conf.d } upgrade_tags () { if [ -n "$ASDF_UPGRADE_TEST_TAGS" ] ; then echo $ASDF_UPGRADE_TEST_TAGS ; return fi # REQUIRE is a magic tag meaning whatever your implementation provides, if anything # # 1.85 (2004-05-16) is the last release by Daniel Barlow (not 1.37, which is the README revision!) # 1.97 (2006-05-14) is the last release before Gary King takes over # 1.369 (2009-10-27) is the last release by Gary King # # 2.000 to 2.019 and 2.20 to 2.26 and beyond are Faré's "stable" ASDF 2 releases # 2.26.61 is the last single-file, single-package ASDF. # 2.27 and beyond are Faré's "stable" ASDF 3 pre-releases # # 2.000 (2010-05-31) was the first ASDF 2 release # 2.008 (2010-09-10) was a somewhat stable ASDF 2 release # 2.011 (2010-11-28) was used by CLISP 2.49, Debian squeeze, Ubuntu 10.04 LTS # 2.014.6 (2011-04-06) was used by Quicklisp in 2011 # 2.019 (2011-11-27) was stable # 2.20 (2012-01-18) was in CCL 1.8, Ubuntu 12.04 LTS # 2.22 (2012-06-12) was used by debian wheezy # 2.26 (2012-10-30) was used by Quicklisp # 2.27 (2013-02-01) is the first ASDF 3 pre-release # 2.32 (2013-03-05) is the first really stable ASDF 3 pre-release # 3.0.1 (2013-05-16) is the first stable ASDF 3 release echo REQUIRE 1.85 1.97 1.369 # git tag -l '2.0??' # git tag -l '2.??' echo 2.000 2.008 2.011 2.014.6 2.019 2.20 2.22 2.26 echo 2.27 2.32 git tag -l '3.0.[1-9]' } upgrade_methods () { if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then echo $ASDF_UPGRADE_TEST_METHODS ; return fi cat < $file ;; 2.2[7-9]*|2.[3-9]*|3.*) mkdir -p build/old/build git archive ${tag} | (cd build/old/ ; tar xf -) make -C build/old mv build/old/build/asdf.lisp build/asdf-${tag}.lisp rm -rf build/old ;; *) echo "Don't know how to extract asdf.lisp for version $tag" exit 55 ;; esac fi } extract_all_tagged_asdf () { for i in `upgrade_tags` ; do extract_tagged_asdf $i done } valid_upgrade_test_p () { case "${1}:${2}:${3}" in # It's damn slow. Also, for some reason, we punt on anything earlier than 2.25, # and only need to test it once, below for 2.24. abcl:1.*|abcl:2.00[0-9]:*|abcl:201[0-9]:*|abcl:2.2[0-3]:*) : ;; # Skip allegro modern on 1.x -- fails for rpgoldman on his mac (!) allegromodern:1.*) : ;; # ccl fasl numbering broke loading of old asdf 2.0 ccl:2.0[01]*) : ;; # my old ubuntu clisp 2.44.1 is wired in # with an antique ASDF 1.374 from CLC that can't be downgraded. # 2.00[0-7] use UID, which fails on that CLISP and was removed afterwards. # Note that for the longest time, CLISP has included 2.011 in its distribution. # Since we punt on the upgrade, let's only do the test once, for 2.26. clisp:2.00[0-7]:*|clisp:1.*|clisp:2.0[01]*|clisp:2.2[0-5]:*) : ;; # Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade. # Weird unidentified problems before 2.018, so we punt equally for everything before, # and only need to test it once: above, for 2.017. cmucl:1.*|cmucl:2.00*|cmucl:2.01[0-6]:*) : ;; # Skip many ECL tests, for various ASDF issues ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) : ;; # GCL 2.6 is only supported with ASDF 2.27, so skip earlier versions gcl:1.*|gcl:2.0*|gcl:2.2[0-6]*) : ;; # MKCL is only supported starting with 2.24, so skip earlier versions mkcl:1.*|mkcl:2.0[01]*|mkcl:2.2[0-3]:*) : ;; # XCL support starts with ASDF 2.014.2 # — It also dies during upgrade trying to show the backtrace. xcl:1.*|xcl:2.00*|xcl:2.01[0-4]:*|xcl:*) : ;; *) return 0 ;; esac return 1 } run_upgrade_tests () { cd ${ASDFDIR} mkdir -p build/results/ rm -f build/*.*f* uiop/*.*f* test/*.*f* ## Remove stale FASLs from ASDF 1.x, especially when different implementations have same name ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls/\" :implementation \"asdf/\")) (t (\"${ASDFDIR}/build/fasls/\" :implementation \"root/\")) :ignore-inherited-configuration)" su=test/script-support.lisp for tag in `upgrade_tags` ; do for method in `upgrade_methods` ; do if valid_upgrade_test_p $lisp $tag $method ; then echo "Testing ASDF upgrade from ${tag} using method $method" extract_tagged_asdf $tag $bcmd $eval \ "'(#.(load(string'|$su|))#.#.\`(in-package,:asdf-test)#.(test-upgrade$method\`|$tag|))" || { echo "upgrade FAILED for $lisp from $tag using method $method" ; echo "you can retry just that test with:" ; echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ASDF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ; echo "or more interactively (and maybe with rlwrap or in emacs), start with:" echo "$icmd" echo "then copy/paste:" echo "(load \"$su\") (asdf-test::da) (test-upgrade $method \"$tag\")" exit 1 ;} fi ; done ; done 2>&1 | tee build/results/${lisp}-upgrade.text } run_tests () { create_config cd ./test/ echo failure > ../build/results/status thedate=`date "+%Y-%m-%d"` rm -f "../build/results/${lisp}.text" || : do_tests "$@" 2>&1 | \ tee "../build/results/${lisp}.text" "../build/results/${lisp}-${thedate}.save" read a < ../build/results/status clean_up if [ success = "$a" ] ; then ## exit code return 0 else echo "To view full results and failures, try the following command:" >&2 echo " less -p ABORTED build/results/${lisp}.text" >&2 return 1 fi } clean_up () { rm -rf ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d } test_clean_load () { case $lisp in gcl|cmucl) return 0 ;; # These are hopeless esac cd ${ASDFDIR} mkdir -p build/results/ nop=build/results/${lisp}-nop.text load=build/results/${lisp}-load.text $bcmd $eval \ "(or'#.(load(string'|test/script-support.lisp|):verbose():print())#.(asdf-test::exit-lisp'0))" \ > $nop 2>&1 $bcmd $eval \ "(or'#.(load(string'|test/script-support.lisp|):verbose():print())#.(asdf-test::verbose())#.(load(string'|build/asdf.lisp|):verbose())#.(asdf/image:quit'0))" \ > $load 2>&1 if diff $nop $load ; then echo "GOOD: Loading ASDF on $lisp produces no message" >&2 ; return 0 else echo "BAD: Loading ASDF on $lisp produces messages" >&2 ; return 1 fi } test_load_systems () { case $lisp in gcl) return 0 ;; # This one is hopeless esac cd ${ASDFDIR} mkdir -p build/results/ echo "Loading all these systems: $*" $bcmd $eval \ "(or #.(load(string'|test/script-support.lisp|))#.(asdf-test::with-test()(asdf-test::test-load-systems $*)))" \ 2>&1 | tee build/results/${lisp}-systems.text } test_interactively () { cd ${ASDFDIR} mkdir -p build/results/ rlwrap $icmd $eval "(or'#.(load(string'|test/script-support.lisp|))#.(asdf-test::interactive-test'($*)))" } if [ -z "$command" ] ; then echo "Error: cannot find or do not know how to run Lisp named $lisp" elif [ -n "$test_interactively" ] ; then test_interactively "$@" elif [ -n "$clean_load" ] ; then test_clean_load elif [ -n "$load_systems" ] ; then test_load_systems "$@" elif [ -n "$upgrade" ] ; then run_upgrade_tests elif [ -n "$extract_all" ] ; then extract_all_tagged_asdf else run_tests "$@" fi ; exit # NB: "; exit" makes it robust wrt the script being modified while running. cl-asdf-3.0.3/test/script-support.lisp000066400000000000000000000633331223164443400177270ustar00rootroot00000000000000;;;;; Minimal life-support for testing ASDF from a blank Lisp image. #| Some constraints: * We cannot rely on any test library that could be loaded by ASDF. And we cannot even rely on ASDF being present until we load it. But we *can* rely on ASDF being present *after* we load it. * evaluating this file MUST NOT print anything, because we use it in the forward-ref test to check that nothing is printed. * We make sure that none of our symbols clash with uiop or asdf, so we may use-package them during testing. |# (defpackage :asdf-test (:use :common-lisp) (:export #:asym #:acall #:asymval #:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation* #:deftest #:is #:signals #:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal #:hash-table->alist #:load-asdf #:maybe-compile-asdf #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:compile-load-asdf #:compile-load-asdf-upgrade #:load-asdf-system #:clean-load-asdf-system #:register-directory #:load-test-system #:with-test #:test-asdf #:debug-asdf #:assert-compare #:assert-equal #:leave-test #:def-test-system #:action-name #:in-plan-p #:test-source #:test-fasl #:resolve-output #:output-location #:quietly #:join-namestrings)) (in-package :asdf-test) (declaim (optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) (proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) (defvar *trace-symbols* `(;; If you want to trace some stuff while debugging ASDF, ;; here's a nice place to say what. ;; These string designators will be interned in ASDF after it is loaded. ;;#+ecl ,@'( :perform :input-files :output-files :compile-file* :compile-file-pathname* :load*) )) (defvar *debug-asdf* nil) (defvar *quit-when-done* t) (defun verbose (&optional (verbose t) (print verbose)) (setf *load-verbose* verbose *compile-verbose* verbose) (setf *load-print* print *compile-print* print)) (verbose nil) ;;; Minimal compatibility layer (eval-when (:compile-toplevel :load-toplevel :execute) #+allegro (setf excl:*warn-on-nested-reader-conditionals* nil excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) ; We need that BEFORE any mention of package ASDF. #+cmucl (setf ext:*gc-verbose* nil) #+gcl (when (and (= system::*gcl-major-version* 2) (= system::*gcl-minor-version* 6)) (pushnew :gcl2.6 *features*) (shadowing-import 'system:*load-pathname* :asdf-test)) #+lispworks (setf system:*stack-overflow-behaviour* :warn)) #+(or gcl genera) (unless (fboundp 'ensure-directories-exist) (defun ensure-directories-exist (path) #+genera (fs:create-directories-recursively (pathname path)) #+gcl (lisp:system (format nil "mkdir -p ~S" (namestring (make-pathname :name nil :type nil :defaults path)))))) ;;; Survival utilities (defun asym (name &optional package errorp) (let* ((pname (or package :asdf)) (package (find-package pname))) (if package (or (find-symbol (string name) package) (when errorp (error "Can't find symbol ~A in ~A" name pname))) (when errorp (error "Can't find package ~A" pname))))) (defun acall (name &rest args) (apply (apply 'asym (if (consp name) name (list name))) args)) (defun ucall (name &rest args) (apply (asym name :uiop) args)) (defun asymval (name &optional package) (symbol-value (asym name package))) (defsetf asymval (name &optional package) (new-value) ;; NB: defun setf won't work on GCL2.6 (let ((sym (gensym "SYM"))) `(let ((,sym (asym ,name ,package))) (if ,sym (setf (symbol-value ,sym) ,new-value) (error "NIHIL EX NIHILO"))))) (defun finish-outputs* () (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*) :do (finish-output s))) (defun redirect-outputs () (finish-outputs*) (setf *error-output* *standard-output* *trace-output* *standard-output*)) (redirect-outputs) ;; Put everything on standard output, for the sake of scripts ;;; Poor man's test suite, lacking stefil. (defmacro deftest (name formals &body body) `(defun ,name ,formals ,@body)) (defmacro is (x) `(progn (format *error-output* "~&Checking whether ~S~%" ',x) (finish-output *error-output*) (assert ,x))) (defmacro signals (condition sexp &aux (x (gensym))) `(progn (format *error-output* "~&Checking whether ~S signals ~S~%" ',sexp ',condition) (finish-output *error-output*) (handler-case ,sexp (,condition (,x) (format *error-output* "~&Received signal ~S~%" ,x) (finish-output *error-output*) t) (:no-error (&rest ,x) (error "Expression ~S fails to raise condition ~S, instead returning~{ ~S~}" ',sexp ',condition ,x)) (t (,x) (error "Expression ~S raises signal ~S, not ~S" ',sexp ,x ',condition))))) ;;; Helpful for debugging (defun pathname-components (p) (when p (let ((p (pathname p))) (list :host (pathname-host p) :device (pathname-device p) :directory (pathname-directory p) :name (pathname-name p) :type (pathname-type p) :version (pathname-version p))))) (defun assert-pathname-equal-helper (qx x qy y) (cond ((equal x y) (format t "~S and ~S both evaluate to same path:~% ~S~%" qx qy x)) ((ucall :pathname-equal x y) (warn "These two expressions yield pathname-equal yet not equal path~%~ the first expression ~S yields this:~% ~S~% ~S~% the other expression ~S yields that:~% ~S~% ~S~%" qx x (pathname-components x) qy y (pathname-components y))) (t (error "These two expressions yield paths that are not pathname-equal~%~ the first expression ~S yields this:~% ~S~% ~S~% the other expression ~S yields that:~% ~S~% ~S~%" qx x (pathname-components x) qy y (pathname-components y))))) (defmacro assert-pathname-equal (x y) `(assert-pathname-equal-helper ',x ,x ',y ,y)) (defun assert-length-equal-helper (qx x qy y) (unless (= (length x) (length y)) (error "These two expressions yield sequences of unequal length~% The first, ~S, has value ~S of length ~S~% The other, ~S, has value ~S of length ~S~%" qx x (length x) qy y (length y)))) (defun assert-pathnames-equal-helper (qx x qy y) (assert-length-equal-helper qx x qy y) (loop :for n :from 0 :for qpx = `(nth ,n ,qx) :for qpy = `(nth ,n ,qy) :for px :in x :for py :in y :do (assert-pathname-equal-helper qpx px qpy py))) (defmacro assert-pathnames-equal (x y) `(assert-pathnames-equal-helper ',x ,x ',y ,y)) ;; More pathname madness. ;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet. ;; We still want to work despite and host/device funkiness, ;; so we do it the hard way. (defparameter *test-directory* (truename (make-pathname :name nil :type nil :version nil :defaults (or *load-pathname* *compile-file-pathname* *default-pathname-defaults*)))) (defun make-sub-pathname (&rest keys &key defaults &allow-other-keys) (merge-pathnames (apply 'make-pathname keys) defaults)) (defun relative-dir (&rest dir) #-gcl (cons ':relative dir) #+gcl dir) (defun back-dir () #-gcl :back #+gcl :parent) (defparameter *asdf-directory* (truename (make-sub-pathname :directory (relative-dir (back-dir)) :defaults *test-directory*))) (defparameter *uiop-directory* (truename (make-sub-pathname :directory (relative-dir "uiop") :defaults *asdf-directory*))) (defparameter *build-directory* (make-sub-pathname :directory (relative-dir "build") :defaults *asdf-directory*)) (defparameter *implementation* (or #+allegro (ecase excl:*current-case-mode* (:case-sensitive-lower :mlisp) (:case-insensitive-upper :alisp)) #+armedbear :abcl #+clisp :clisp #+clozure :ccl #+cmu :cmucl #+corman :cormanlisp #+digitool :mcl #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl) #+gcl :gcl #+lispworks :lispworks #+mkcl :mkcl #+sbcl :sbcl #+scl :scl #+xcl :xcl)) (defparameter *early-fasl-directory* (make-sub-pathname :directory (relative-dir "fasls" (string-downcase *implementation*)) :defaults *build-directory*)) (defun asdf-name (&optional tag) (format nil "asdf~@[-~A~]" tag)) (defun asdf-lisp (&optional tag) (make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*)) (defun debug-lisp () (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *uiop-directory*)) (defun early-compile-file-pathname (file) (compile-file-pathname (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*))) (defun asdf-fasl (&optional tag) (early-compile-file-pathname (asdf-lisp tag))) ;;; Test helper functions (load (debug-lisp)) (verbose t nil) (defmacro assert-compare (expr) (destructuring-bind (op x y) expr `(assert-compare-helper ',op ',x ',y ,x ,y))) (defun assert-compare-helper (op qx qy x y) (unless (funcall op x y) (error "These two expressions fail comparison with ~S:~% ~ ~S evaluates to ~S~% ~S evaluates to ~S~%" op qx x qy y))) (defmacro assert-equal (x y) `(assert-compare (equal ,x ,y))) (defun touch-file (file &key offset timestamp in-filesystem) (let* ((base (or timestamp (get-universal-time))) (stamp (if offset (+ base offset) base))) (if (and (asymval :*asdf-cache*) (not in-filesystem)) (acall :register-file-stamp file stamp) (multiple-value-bind (sec min hr day month year) (decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime (unless in-filesystem (error "Y U NO use stamp cache?")) (ucall :run-program `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D" year month day hr min sec) ,(ucall :native-namestring file))) (assert-equal (file-write-date file) stamp))))) (defun mark-file-deleted (file) (unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?")) (acall :register-file-stamp (acall :normalize-namestring file) nil)) (defun hash-table->alist (table) (loop :for key :being :the :hash-keys :of table :using (:hash-value value) :collect (cons key value))) (defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit (finish-outputs*) #+(or abcl xcl) (ext:quit :status code) #+allegro (excl:exit code :quiet t) #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) #+(or cmu scl) (unix:unix-exit code) #+ecl (si:quit code) #+gcl (lisp:quit code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext)) (quit* (find-symbol "QUIT" :sb-ext))) (cond (exit `(,exit :code code :abort t)) (quit* `(,quit* :unix-status code :recklessly-p t)))) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun leave-test (message return) "Print MESSAGE and throw RETURN, which should be a POSIX error code (an integer, 0 for success), up as exit code." (finish-outputs*) (fresh-line *error-output*) (when message (format *error-output* message) (fresh-line *error-output*)) (finish-outputs*) (throw :asdf-test-done return)) (defmacro with-test ((&optional) &body body) `(call-with-test (lambda () ,@body))) (defun call-with-test (thunk) "Unless the environment variable DEBUG_ASDF_TEST is bound, write a message and exit on an error. If *asdf-test-debug* is true, enter the debugger." (redirect-outputs) (let ((result (catch :asdf-test-done (handler-bind ((error (lambda (c) (ignore-errors (format *error-output* "~&TEST ABORTED: ~A~&" c)) (finish-outputs*) (cond (*debug-asdf* (format t "~&It's your baby, fix it!~%") (break)) (t (ignore-errors (ucall :print-condition-backtrace c :count 69 :stream *error-output*)) (leave-test "Script failed" 1)))))) (funcall (or (asym :call-with-asdf-cache) 'funcall) thunk) (leave-test "Script succeeded" 0))))) (when *quit-when-done* (exit-lisp result)))) ;;; These are used by the upgrade tests (defmacro quietly (&body body) `(call-quietly #'(lambda () ,@body))) (defun call-quietly (thunk) (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (funcall thunk))) (defun interactive-test (&optional files) (verbose t nil) (loop :for file :in files :do (load (string-downcase file))) (setf *package* (some 'find-package '(:asdf :uiop :asdf/utility :asdf/package :asdf-test))) (load "contrib/debug.lisp")) (defun load-asdf-lisp (&optional tag) (quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*))) (defun load-asdf-fasl (&optional tag) (quietly (load (asdf-fasl tag)))) (defun register-directory (dir) (pushnew dir (symbol-value (asym :*central-registry*)))) (defun load-asdf-system (&rest keys) (quietly (register-directory *asdf-directory*) (register-directory *uiop-directory*) (apply (asym :oos) (asym :load-op) :asdf keys))) (defun call-with-asdf-conditions (thunk &optional verbose) (declare (ignorable verbose)) (handler-bind (#+sbcl ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) #'muffle-warning) #+(and ecl (not ecl-bytecmp)) ((or c::compiler-note c::compiler-debug-note c::compiler-warning) ;; ECL emits more serious warnings than it should. #'muffle-warning) #+mkcl ((or compiler:compiler-note) #'muffle-warning) #-(or cmu scl) ;; style warnings shouldn't abort the compilation [2010/02/03:rpg] (style-warning #'(lambda (w) ;; escalate style-warnings to warnings - we don't want them. (when verbose (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A" (type-of w) w)) (muffle-warning w)))) (funcall thunk))) (defmacro with-asdf-conditions ((&optional verbose) &body body) `(call-with-asdf-conditions #'(lambda () ,@body) ,verbose)) (defun compile-asdf (&optional tag verbose upgradep) (let* ((alisp (asdf-lisp tag)) (afasl (asdf-fasl tag)) (tmp (make-pathname :name "asdf-tmp" :defaults afasl))) (ensure-directories-exist afasl) (multiple-value-bind (result warnings-p failure-p) (compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose) (flet ((bad (key) (when result (ignore-errors (delete-file result))) key) (good (key) (when (probe-file afasl) (delete-file afasl)) (rename-file tmp afasl) key)) (cond ((null result) (bad :no-output)) (failure-p (or #+clisp (good :expected-full-warnings) (bad :unexpected-full-warnings))) (warnings-p (or ;; CLISP has full warnings for method redefinition in eval-when. ;; CMUCL: ? ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291. ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?) #+(or clisp cmu ecl scl xcl) (good :expected-style-warnings) (and upgradep (good :unexpected-style-warnings)) (bad :unexpected-style-warnings))) (t (good :success))))))) (defun maybe-compile-asdf (&optional tag) (let ((alisp (asdf-lisp tag)) (afasl (asdf-fasl tag))) (cond ((not (probe-file alisp)) :not-found) ((and (probe-file afasl) (> (file-write-date afasl) (file-write-date alisp)) (ignore-errors (load-asdf-fasl tag))) :previously-compiled) (t (compile-asdf tag))))) (defun compile-asdf-script () (with-test () #-gcl2.6 (ecase (with-asdf-conditions () (maybe-compile-asdf)) (:not-found (leave-test "Testsuite failed: unable to find ASDF source" 3)) (:previously-compiled (leave-test "Reusing previously-compiled ASDF" 0)) (:no-output (leave-test "Testsuite failed: ASDF compilation failed without output" 1)) (:unexpected-full-warnings (leave-test "Testsuite failed: ASDF compiled with unexpected full warnings" 1)) (:expected-full-warnings (leave-test "ASDF compiled with full warnings, ignored for your implementation" 0)) (:unexpected-style-warnings (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1)) (:expected-style-warnings (leave-test "ASDF compiled with style-warnings, ignored for your implementation" 0)) (:success (leave-test "ASDF compiled cleanly" 0))))) (defun compile-load-asdf (&optional tag upgradep) ;; emulate the way asdf upgrades itself: load source, compile, load fasl. (load-asdf-lisp tag) (let ((results (compile-asdf tag nil upgradep))) (ecase results ((:no-output :unexpected-full-warnings :unexpected-style-warnings) (warn "ASDF compiled with ~S" results) (unless (and upgradep (eq results :unexpected-style-warnings)) (leave-test "failed to compile ASDF" 1))) ((:expected-full-warnings :expected-style-warnings :success))) (load-asdf-fasl tag))) (defun compile-load-asdf-upgrade (&optional tag) (compile-load-asdf tag t)) ;;; Now, functions to compile and load ASDF. (defun load-test-system (x &key verbose) (let ((*load-print* verbose) (*load-verbose* verbose)) (register-directory *test-directory*) (acall :oos (asym :load-op) x :verbose verbose))) (defun get-asdf-version () (when (find-package :asdf) (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) (etypecase ver (string ver) (cons (format nil "~{~D~^.~}" ver)) (null "1.0")))))) (defun output-location (&rest sublocation) (list* *asdf-directory* "build/fasls" :implementation sublocation)) (defun resolve-output (&rest sublocation) (acall :resolve-location (apply 'output-location sublocation))) (defun test-source (file) (acall :subpathname *test-directory* file)) (defun test-output-dir () (resolve-output "asdf" "test")) (defun test-output (file) (acall :subpathname (test-output-dir) file)) (defun test-fasl (file) (acall :compile-file-pathname* (test-source file))) (defun clean-asdf-system () ;; If compiled by an antique ASDFs without output translations: (flet ((d (x) (acall :delete-file-if-exists x))) (let ((asdf-fasl (compile-file-pathname (asdf-lisp)))) (d asdf-fasl) (d (acall :apply-output-translations asdf-fasl)) (d (asdf-fasl))))) (defun load-asdf-lisp-clean () (load-asdf-lisp) (clean-asdf-system)) (defun configure-asdf () (format t "Configuring ASDF~%") (when (asym :getenvp) (format t "Enabling debugging~%") (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))) (when *trace-symbols* (format t "Tracing~{ ~A~}~%" *trace-symbols*) (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))) (when (asym :initialize-source-registry) (acall :initialize-source-registry `(:source-registry :ignore-inherited-configuration))) (when (asym :initialize-output-translations) (acall :initialize-output-translations `(:output-translations (,(acall :wilden *asdf-directory*) ,(acall :wilden (resolve-output "asdf/"))) (t ,(acall :wilden (resolve-output "root"))) :ignore-inherited-configuration))) (when (asym :*central-registry*) (set (asym :*central-registry*) `(,*test-directory*))) (format t "Being a bit verbose~%") (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t)) (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal)) (format t "Comparing directories~%") (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf))))) (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!) (unless (equal *test-directory* x) (format t "Interestingly, while *test-directory* has components~% ~S~%~ ASDF finds the ASDs in~% ~S~%Using the latter.~%" (pathname-components *test-directory*) (pathname-components x))) (setf *test-directory* x))) t) (defun frob-packages () (format t "Frob packages~%") (use-package :asdf :asdf-test) (when (find-package :uiop) (use-package :uiop :asdf-test)) (when (find-package :asdf/cache) (use-package :asdf/cache :asdf-test)) (setf *package* (find-package :asdf-test)) t) (defun load-asdf-lisp-and-test-uiop (&optional tag) (load-asdf-lisp tag) (unless (and (member :asdf *features*) (or (member :asdf3 *features*) (and (member :asdf2 *features*) (acall :version-satisfies (acall :asdf-version) "2.11.4")))) (leave-test "UIOP will break ASDF < 2.011.4 - skipping test." 0)) (configure-asdf) (register-directory *asdf-directory*) (register-directory *uiop-directory*) (register-directory *test-directory*) (DBG :lalatu (asymval :*central-registry*)) (quietly (acall :oos (asym :load-op) :uiop)) (acall :oos (asym :load-op) :test-module-depend)) (defun load-asdf (&optional tag) #+gcl2.6 (load-asdf-lisp tag) #-gcl2.6 (load-asdf-fasl tag) (configure-asdf)) (defun debug-asdf () (setf *debug-asdf* t) (setf *quit-when-done* nil) (setf *package* (find-package :asdf-test))) (defun just-load-asdf-fasl () (load-asdf-fasl)) ;; Actual scripts rely on this function: (defun common-lisp-user::load-asdf () (load-asdf)) (setf *package* (find-package :asdf-test)) (defmacro def-test-system (name &rest rest) `(apply (asym :register-system-definition) ',name :pathname ,*test-directory* :source-file nil ',rest)) (defun in-plan-p (plan x) (member x (acall :plan-actions plan) :key (asym :action-path) :test 'equal)) (defmacro test-load-systems (&rest x) `(do-test-load-systems ',x)) (defun do-test-load-systems (systems) (load-asdf-lisp) (dolist (sys systems) (format t "~&Trying to load ~A~%" sys) (acall :load-system sys)) (format t "~&Done!~%")) (defun test-upgrade (old-method new-method tag) ;; called by run-test (with-test () (verbose t nil) (setf tag (string tag)) (when old-method (cond ((string-equal tag "REQUIRE") (format t "Requiring some previous ASDF ~A~%" tag) (ignore-errors (funcall 'require "asdf")) (if (member "ASDF" *modules* :test 'equalp) (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version)) (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0))) (t (format t "Loading old asdf ~A via ~A~%" tag old-method) (funcall old-method tag)))) (when (find-package :asdf) (configure-asdf)) (when (and (null old-method) (eq 'load-asdf-fasl new-method) (not (probe-file (asdf-fasl)))) (if (ignore-errors (funcall 'require "asdf") t) (leave-test "Your failed to compile ASDF before your run (test-upgrade ()'load-asdf-fasl ...)" 1) (leave-test "Your Lisp doesn't provide ASDF. Skipping (test-upgrade ()'load-asdf-fasl ...)" 0))) (format t "Now loading new asdf via method ~A~%" new-method) (funcall new-method) (format t "Testing it~%") (register-directory *test-directory*) (load-test-system :test-asdf/all) (assert (asymval '#:*file1* :test-package)) (assert (asymval '#:*file3* :test-package)))) (defun join-namestrings (namestrings) (with-output-to-string (s) (loop :with separator = (acall :inter-directory-separator) :for (n . morep) :on namestrings :do (format s "~A~@[~C~]" n (and morep separator))))) ;; These are shorthands for interactive debugging of test scripts: (!a common-lisp-user::debug-asdf debug-asdf da debug-asdf common-lisp-user::da debug-asdf la load-asdf common-lisp-user::la load-asdf ll load-asdf-lisp v verbose) #| For the record, the following form is sometimes useful to insert in asdf/plan:compute-action-stamp to find out what's happening. It depends on the DBG macro in contrib/debug.lisp, that you should load in your asdf/plan by inserting an (uiop-debug) form in it. (let ((action-path (action-path (cons o c)))) (DBG :cas action-path just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c) ;;; blah )) |# cl-asdf-3.0.3/test/sources/000077500000000000000000000000001223164443400154735ustar00rootroot00000000000000cl-asdf-3.0.3/test/sources/level1/000077500000000000000000000000001223164443400166635ustar00rootroot00000000000000cl-asdf-3.0.3/test/sources/level1/file1.lisp000066400000000000000000000003651223164443400205600ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *file-tmp* t) (eval-when (:compile-toplevel :execute) (format t "compiling level1/file1~%")) (eval-when (:load-toplevel :execute) (format t "loading level1/file1~%")) cl-asdf-3.0.3/test/sources/level1/level2/000077500000000000000000000000001223164443400200545ustar00rootroot00000000000000cl-asdf-3.0.3/test/sources/level1/level2/file2.lisp000066400000000000000000000000631223164443400217450ustar00rootroot00000000000000(in-package :test-package) (defvar *file-tmp2* t) cl-asdf-3.0.3/test/sources/level1/level2/static.file000066400000000000000000000000001223164443400221720ustar00rootroot00000000000000cl-asdf-3.0.3/test/sources/level1/test-tmp.cl000066400000000000000000000000001223164443400207460ustar00rootroot00000000000000cl-asdf-3.0.3/test/stamp-propagation/000077500000000000000000000000001223164443400174555ustar00rootroot00000000000000cl-asdf-3.0.3/test/stamp-propagation/file1.lisp000066400000000000000000000000531223164443400213440ustar00rootroot00000000000000(in-package :asdf-test) (eval-note :file1) cl-asdf-3.0.3/test/stamp-propagation/file2.lisp000066400000000000000000000000531223164443400213450ustar00rootroot00000000000000(in-package :asdf-test) (eval-note :file2) cl-asdf-3.0.3/test/stamp-propagation/test-stamp-propagation.lisp000066400000000000000000000172311223164443400247740ustar00rootroot00000000000000;; NB: This test file is supposed to work using old defsystems: ;; not just ASDF 2.26, but also legacy defsystems from Allegro, Genera, LispWorks (unless (find-package :asdf-test) (load (merge-pathnames (make-pathname :defaults *load-pathname* :name "script-support" :directory '(:relative :back)) *load-pathname*))) (unless (find-package :asdf) (asdf-test::load-asdf) (asdf-test::frob-packages) (use-package :uiop :asdf)) (in-package :asdf-test) (DBG :foo) (defparameter *eval-notes* ()) (defun note-eval (when file) (format t "~&XXX ~S ~S~%" when file) (push `(,when ,file #|,*load-pathname* ,*compile-file-pathname*|#) *eval-notes*)) (defun eval-notes () (prog1 (reverse *eval-notes*) (setf *eval-notes* nil))) (defmacro eval-note (&optional x) `(progn (eval-when (:compile-toplevel) (note-eval :compile-toplevel ',x)) (eval-when (:load-toplevel) (note-eval :load-toplevel ',x)) (eval-when (:execute) (note-eval :execute ',x)))) (eval-note :tsp) (defvar *tsp* (asdf::pathname-directory-pathname *load-pathname*)) (defparameter *defsystems* '(#+(or allegro genera lispworks) :native #+mk-defsystem :mk-defsystem #+asdf :asdf)) (defvar *default-defsystem* (first *defsystems*)) (defvar asdf::*asdf-cache* nil) ;; if defparameter instead of defvar, disable any surrounding cache (defun lisppath (filename) (asdf::subpathname *tsp* filename)) (defun faslpath (lisppath &optional (defsystem *default-defsystem*)) (funcall (if (and (eq defsystem :asdf) (fboundp 'asdf::compile-file-pathname*)) 'asdf::compile-file-pathname* 'compile-file-pathname) (etypecase lisppath (pathname lisppath) (string (lisppath lisppath))))) (defun use-cache-p (defsystem) (and (eq defsystem :asdf) (asdf:version-satisfies (asdf:asdf-version) "2.27") asdf::*asdf-cache*)) #+allegro (excl:defsystem :test-stamp-propagation (:default-pathname #.*tsp*) (:definitions "file1.lisp" "file2.lisp")) #+genera (sct:defsystem :test-stamp-propagation (:default-pathname #.*tsp* :patchable nil) (:definitions "file1.lisp" "file2.lisp")) #+lispworks (scm:defsystem :test-stamp-propagation (:default-pathname #.*tsp*) :members ("file1" "file2") :rules ((:in-order-to :compile ("file2") (:caused-by (:compile "file1")) (:requires (:load "file1"))))) #+asdf (asdf:defsystem :test-stamp-propagation :pathname #.*tsp* :source-file nil :serial t :components ((:file "file1") (:file "file2"))) #+mk-defsystem (mk:defsystem :test-stamp-propagation (:default-pathname #.*tsp* :patchable nil) (:serial "file1.lisp" "file2.lisp")) (defun reload (&optional (defsystem *default-defsystem*)) (format t "~&ASDF-CACHE before ~S~%" asdf::*asdf-cache*) (setf *eval-notes* nil) (setf *compile-verbose* t *load-verbose* t) (ecase defsystem #+asdf (:asdf (note-eval :compiling :system) (unless (use-cache-p :asdf) ;; faking the cache only works for one plan (asdf:compile-system :test-stamp-propagation)) (note-eval :loading :system) (asdf:load-system :test-stamp-propagation)) #+mk-defsystem (:mk-defsystem (note-eval :compiling :system) (mk:compile-system :test-stamp-propagation) (note-eval :loading :system) (mk:load-system :test-stamp-propagation)) (:native (note-eval :compiling :system) #+allegro (excl:compile-system :test-stamp-propagation) #+lispworks (scm:compile-system :test-stamp-propagation) #+genera (sct:compile-system :test-stamp-propagation) (note-eval :loading :system) #+allegro (excl:load-system :test-stamp-propagation) #+lispworks (scm:load-system :test-stamp-propagation) #+genera (sct:load-system :test-stamp-propagation))) (format t "~&ASDF-CACHE after ~S~%" asdf::*asdf-cache*) (let ((n (eval-notes))) (format t "~&EVAL-NOTES ~S~%" n) n)) (defun clear-sys (&optional (defsystem *default-defsystem*)) #+asdf (when (eq defsystem :asdf) (asdf:clear-system :test-stamp-propagation) (asdf:defsystem :test-stamp-propagation :pathname #.*tsp* :source-file nil :serial t :components ((:file "file1") (:file "file2"))))) (defun touch (filename) #+genera filename ;; TODO: do something with it! #-genera (uiop:run-program `("touch" ,(uiop:native-namestring filename)) :output t :error-output t)) (defun clear-fasls (&optional (defsystem *default-defsystem*)) (loop :for file :in '("file1.lisp" "file2.lisp") :for faslpath = (faslpath file defsystem) :do (if (and (eq defsystem :asdf) asdf::*asdf-cache*) (mark-file-deleted faslpath) (delete-file-if-exists faslpath)))) (defun sanitize-log (log) (remove-duplicates (remove '(:loading :system) log :test 'equal) :test 'equal :from-end t)) (defun adjust-stamp-cache (base l1 f1 l2 f2) (clrhash asdf::*asdf-cache*) (touch-file (lisppath "file1.lisp") :timestamp base :offset l1) (touch-file (faslpath "file1.lisp") :timestamp base :offset f1) (dolist (l (asdf:output-files (make-instance 'asdf:compile-op) (asdf:find-component :test-stamp-propagation '("file1")))) (touch-file l :timestamp base :offset f1)) (touch-file (lisppath "file2.lisp") :timestamp base :offset l2) (touch-file (faslpath "file2.lisp") :timestamp base :offset f2) (dolist (l (asdf:output-files (make-instance 'asdf:compile-op) (asdf:find-component :test-stamp-propagation '("file2")))) (touch-file l :timestamp base :offset f2))) (defun test-defsystem (&optional (defsystem *default-defsystem*)) (format t "~%~%Testing stamp propagation by defsystem ~S~%" defsystem) #+(or allegro clisp) (progn (DBG "removing any old fasls from another flavor of the implementation") (clear-fasls defsystem)) (when (use-cache-p defsystem) (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) -1000 -10000 -1000 -10000)) (DBG "loading system") (reload defsystem) (clear-sys defsystem) (cond ((use-cache-p defsystem) (DBG "marking all files old but first source file, and reloading") (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) 0 -1000 -1000 -1000)) (t (DBG "touching first source file and reloading") (sleep #-os-windows 3 #+os-windows 5) (touch (lisppath "file1.lisp")))) (DBG "defsystem should recompile & reload everything") (assert-equal (sanitize-log (reload defsystem)) '((:compiling :system) (:compile-toplevel :file1) (:load-toplevel :file1) (:compile-toplevel :file2) (:load-toplevel :file2))) (clear-sys defsystem) (cond ((use-cache-p defsystem) (DBG "marking the old fasl new, the second one up to date") (adjust-stamp-cache (file-write-date (lisppath "file1.lisp")) 100 500 100 100)) (t (DBG "touching first fasl file and reloading") (sleep #-os-windows 3 #+os-windows 5) (touch (faslpath "file1.lisp" defsystem)))) (DBG "defsystem should reload it, recompile & reload the other") (assert-equal (sanitize-log (reload defsystem)) '((:compiling :system) (:load-toplevel :file1) (:compile-toplevel :file2) (:load-toplevel :file2))) (DBG "cleaning up") (clear-fasls defsystem)) (cond #+asdf3 ;; TODO: figure out why ABCL and XCL fail to recompile anything. ((and #+(or abcl xcl) (use-cache-p :asdf)) (test-defsystem :asdf)) (t (signals error (test-defsystem :asdf)))) #+(or genera lispworks) (test-defsystem :native) #+(or allegro) (signals error (test-defsystem :native)) #+mkdefsystem (signals error (test-defsystem :mk-defsystem)) cl-asdf-3.0.3/test/stderr000077500000000000000000000002571223164443400152450ustar00rootroot00000000000000#! /bin/sh # This script simply writes some text to STDERR, to check and # make sure that ASDF:RUN-SHELL-COMMAND handles it properly. echo "Writing to standard error." >& 2 cl-asdf-3.0.3/test/test-around-compile.script000066400000000000000000000015131223164443400211310ustar00rootroot00000000000000;;; -*- Lisp -*- (defun call-in-base-2 (thunk) (let ((*read-base* 2)) (funcall thunk))) (DBG "Testing around-compile with a function name") (def-test-system 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 (fmakunbound 'add10) (DBG "Testing around-compile with a lambda") (def-test-system test-around-compile-lambda :around-compile (lambda (thunk) (let ((*read-base* 9)) (funcall thunk))) :components ((:file "test"))) (load-system 'test-around-compile-lambda :force t) (assert (= 10 (funcall 'add10 1))) ;; add10 must have been compiled in base 16 cl-asdf-3.0.3/test/test-asdf.asd000066400000000000000000000043551223164443400164020ustar00rootroot00000000000000(defpackage :test-asdf-system (:use :cl :asdf)) (in-package :test-asdf-system) (defsystem :test-asdf) (defsystem :test-asdf/all :version "0" :depends-on ((:version :test-asdf/file2 "2") :test-asdf/file4)) (defsystem :test-asdf/file1 :components ((:file "file1" :if-feature :common-lisp) (:file "does-not-exist" :if-feature (:not :common-lisp)))) (defsystem :test-asdf/file2 :version "2.2" :depends-on (:test-asdf/file1) :components ((:module "foo" :pathname "" :components ((:module "bar" :pathname "" :components ((:file "file2"))))))) (defsystem :test-asdf/file4 :components ((:file "file3") (:file "file4" :in-order-to ((load-op (load-op "file3")) (compile-op (load-op "file3")))))) (defsystem :test-asdf/test9-1 :version "1.1" :components ((:file "file2")) :depends-on ((:version :test-asdf/test9-2 "2.0"))) (defsystem :test-asdf/test-module-depend :depends-on ((:feature :sbcl (:require :sb-posix)) (:feature :allegro (:require "osi"))) :components ((:file "file1" :if-feature :common-lisp) (:file "doesnt-exist" :if-feature (:not :common-lisp)) (:module "quux" :pathname "" :depends-on ("file1") :components ((:file "file2") (:module "file3mod" :pathname "" :components ((:file "file3" :in-order-to ((compile-op (feature :common-lisp)))) (:file "does-not-exist" :in-order-to ((compile-op (feature (:not :common-lisp)))))) :if-component-dep-fails :ignore))))) (defsystem :test-asdf/test9-2 :version "1.0" :components ((:file "file1"))) (defsystem :test-asdf/test9-3 :depends-on ((:version :test-asdf/test9-2 "1.0"))) (defsystem :test-asdf/test-source-directory-1 :pathname "some/relative/pathname/") (defsystem :test-asdf/test-source-directory-2 :pathname "some/relative/pathname/with-file.type") (defsystem :test-asdf/bundle-1 :components ((:file "file1") (:file "file3"))) (defsystem :test-asdf/bundle-2 :depends-on (:test-asdf/bundle-1) :components ((:file "file2"))) (defsystem :test-asdf/dll-test :components ((:file "dll-test"))) (defsystem :test-asdf/dll-user :components ((:file "dll-user"))) cl-asdf-3.0.3/test/test-asdf.script000066400000000000000000000006701223164443400171330ustar00rootroot00000000000000(load-system "test-asdf/test-module-depend") (defparameter *plan* (make-plan () 'load-op "test-asdf/test-module-depend")) (DBG :foo *plan* (component-depends-on 'compile-op '("test-asdf/test-module-depend" "quux" "file3mod" "file3")) (asdf::component-if-feature (find-component "test-asdf/test-module-depend" '("quux" "file3mod" "file3")))) (assert (not (in-plan-p *plan* '(compile-op "test-asdf/test-module-depend" "file1")))) cl-asdf-3.0.3/test/test-builtin-source-file-type.script000066400000000000000000000035371223164443400230630ustar00rootroot00000000000000;;; -*- Lisp -*- ;;(trace source-file-type) (progn (format t "~D~%" (asdf:asdf-version)) (def-test-system test-builtin-source-file-type-1 :default-component-class cl-source-file.cl :serial t :components ((:cl-source-file "file1") ; for the package (:file "test-tmp"))) (load-system 'test-builtin-source-file-type-1 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (assert-equal (mapcar #'pathname-type (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) '("lisp" "cl")) (delete-package :test-package) (def-test-system test-builtin-source-file-type-2 :default-component-class cl-source-file.cl :serial t :components ((:file "file1" :type "lisp") ; for package (:file "test-tmp"))) (asdf:load-system 'test-builtin-source-file-type-2 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (def-test-system test-builtin-source-file-type-3 :default-component-class cl-source-file.lsp :serial t :components ((:cl-source-file "file1") ; for the package (:file "test-tmp"))) (asdf:load-system 'test-builtin-source-file-type-3 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (assert-equal (mapcar #'pathname-type (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) '("lisp" "cl")) (delete-package :test-package) (def-test-system test-builtin-source-file-type-4 :default-component-class cl-source-file.lsp :serial t :components ((:file "file1" :type "lisp") ; for package (:file "test-tmp"))) (asdf:load-system 'test-builtin-source-file-type-4 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))) cl-asdf-3.0.3/test/test-bundle.script000066400000000000000000000042111223164443400174620ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) ;;;--------------------------------------------------------------------------- ;;; Check to see if the bundle functionality is doing something. ;;;--------------------------------------------------------------------------- (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (asdf:clear-system :test-asdf/bundle-1) (asdf:clear-system :test-asdf/bundle-2) (when (find-package :test-package) (delete-package :test-package)) #+(and darwin (or abcl ecl)) (leave-test "Bundle test doesn't work on Mac on this lisp." 0) #+(or (and ecl ecl-bytecmp) gcl) ;; actually available on ABCL 1.2.0 and later. (leave-test "bundles not on this implementation" 0) #+abcl (let* ((version (lisp-implementation-version)) (version-nums (subseq version 0 (position-if-not (lambda (x) (find x "0123456789.")) version)))) (when (version< version-nums "1.2.0") (leave-test "Your old ABCL is known to fail this test script, so skipping it." 0))) (defparameter *bundle-1* (output-file 'fasl-op :test-asdf/bundle-1)) (defparameter *bundle-2* (output-file 'fasl-op :test-asdf/bundle-2)) (defparameter *mono-bundle-2* (output-file 'monolithic-fasl-op :test-asdf/bundle-2)) (DBG :test-bundle *bundle-1* *bundle-2*) (assert-equal (list *bundle-2*) (input-files 'load-fasl-op :test-asdf/bundle-2)) (delete-file-if-exists *bundle-1*) (delete-file-if-exists *bundle-2*) (delete-file-if-exists *mono-bundle-2*) (operate 'load-fasl-op :test-asdf/bundle-2) (DBG "Check that the bundles were indeed created.") (assert (probe-file *bundle-2*)) (assert (probe-file *bundle-1*)) (DBG "Check that the files were indeed loaded.") (assert (symbol-value (find-symbol* :*file1* :test-package))) (assert (symbol-value (find-symbol* :*file3* :test-package))) (DBG "Now for the mono-fasl") (operate 'monolithic-fasl-op :test-asdf/bundle-2) (assert (probe-file *mono-bundle-2*)) ;;; Test DLL-op on ECL. #+ecl (progn (operate 'dll-op :test-asdf/dll-test) (si:load-foreign-module (first (output-files 'dll-op :test-asdf/dll-test))) (operate 'load-op :test-asdf/dll-user) (assert (= (test-package::sample-function) 42))) cl-asdf-3.0.3/test/test-compile-file-failure.asd000066400000000000000000000001321223164443400214440ustar00rootroot00000000000000(defsystem test-compile-file-failure :components ((:file "test-compile-file-failure"))) cl-asdf-3.0.3/test/test-compile-file-failure.lisp000066400000000000000000000007051223164443400216520ustar00rootroot00000000000000(in-package :asdf) (eval-when (:compile-toplevel :load-toplevel :execute) ;; CLISP 2.48 has a bug that makes this test fail. Hopefully, everyone uses 2.49 or better. ;; The ECL bytecode compiler also fails. ;; Work around: #+(and ecl ecl-bytecmp) (when (and (eq asdf:*compile-file-failure-behaviour* :error) #+ecl (equal (compile-file-type) "fasc")) (error 'compile-file-error :description "faking it")) (warn "Warning.")) cl-asdf-3.0.3/test/test-compile-file-failure.script000066400000000000000000000007671223164443400222170ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf) #+gcl2.6 (leave-test "GCL 2.6 sucks. Skipping test." 0) (assert (handler-case (let ((*compile-file-failure-behaviour* :warn)) (load-system 'test-compile-file-failure :force t) t) (compile-file-error () nil))) (assert (handler-case (let ((*compile-file-failure-behaviour* :error)) (load-system 'test-compile-file-failure :force t) nil) (compile-file-error () t))) cl-asdf-3.0.3/test/test-concatenate-source.lisp000066400000000000000000000003241223164443400214370ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *file3* t) (defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *file1* t) (in-package :test-package) (assert *file1*) cl-asdf-3.0.3/test/test-concatenate-source.script000066400000000000000000000025231223164443400217770ustar00rootroot00000000000000;;; -*- Lisp -*- (def-test-system :test-concatenate-source :depends-on (:file3-only) :components ((:file "file2" :depends-on ("foo")) (:module "foo" :pathname "" :components ((:file "file1") (:file "file4" :if-feature (:not :common-lisp)))))) (defparameter mcso (make-operation 'monolithic-concatenate-source-op)) (defparameter mccso (make-operation 'monolithic-compile-concatenated-source-op)) (defparameter mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op)) (defparameter sys (find-system :test-concatenate-source)) (assert (operation-monolithic-p mcso)) (assert-pathnames-equal (input-files mcso sys) (loop :for n :in '(3 1 2) :collect (test-source (format nil "file~D.lisp" n)))) #-xcl ;; xcl has buggy translate-pathname (assert-pathname-equal (output-file mcso sys) (apply-output-translations (resolve-output "asdf/test/test-concatenate-source--all-systems.lisp"))) (assert-pathnames-equal (output-files mcso sys) (input-files mccso sys)) ;; on ECL, we get un-equal pathnames. (assert-pathname-equal (first (output-files mccso sys)) (test-fasl "test-concatenate-source--all-systems.lisp")) (assert-pathnames-equal (output-files mccso sys) (input-files mlccso sys)) (operate 'monolithic-load-compiled-concatenated-source-op sys) (assert (symbol-value (find-symbol* :*file3* :test-package))) cl-asdf-3.0.3/test/test-configuration.script000066400000000000000000000113321223164443400210620ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf) (use-package :asdf-test) #+gcl2.6 (defmacro with-standard-io-syntax (&body body) `(progn ,@body)) (defparameter *tmp-directory* (subpathname *asdf-directory* "build/")) (setf *central-registry* nil) (defun under-tmp-directory (designator &optional (defaults *tmp-directory*)) (namestring (subpathname defaults designator))) (defun create-conf-files (&optional (path *tmp-directory*)) (let ((v `(("conf.d/conf1.conf" ((:directory ,(under-tmp-directory "dir1/")))) ("conf.d/conf2.conf" ((:tree ,(under-tmp-directory "dir2/")))) ;; this is for testing the :here directive ("dir5/conf.conf" ((:directory (:here "dir6")))) ("dir8/conf.conf" ((:directory (:here)))) ("dir9/dira/conf.conf" ((:tree (:here))))))) (loop :for (file contents) :in v :for name = (under-tmp-directory file path) :do (ensure-directories-exist name) (with-open-file (out name :direction :output :if-exists :supersede) (with-standard-io-syntax (format out "~{~S~%~}" contents)))))) (defparameter *tmp-asd-directories* (loop :for dir :in '("dir1/" ; foo0 "dir2/dir3/" ; foo1 "dir2/dir4/" ; foo2 "dir2/" ; foo3 ;; system here should be found because of :here directive "dir5/dir6/" ; foo4 ;; system here should /not/ be found because of :here directive "dir5/dir7/" ; foo5 "dir8/" ; foo6 "dir9/dira/" ; foo7 should be found because of :here :tree "dir9/dira/dirc/" ; foo8 ditto "dir9/dirb/") ; foo9 should /not/ be found -- not under :here :tree :collect (under-tmp-directory dir))) (defun create-asd-files () (loop :for d :in *tmp-asd-directories* :for i :from 0 :do (ensure-directories-exist d) (with-open-file (s (merge-pathnames* (format nil "foo~D.asd" i) d) :direction :output :if-exists :rename-and-delete :if-does-not-exist :create) (format s "(defsystem :foo~D)~%" i)))) (assert-equal (asdf::parse-output-translations-string (join-namestrings '("/foo" "/bar" "" "/baz" "/quux"))) '(:output-translations ("/foo" "/bar") :inherit-configuration ("/baz" "/quux"))) (assert-equal (asdf::parse-output-translations-string (join-namestrings '("/" ""))) '(:output-translations ("/" nil) :ignore-inherited-configuration)) (assert-equal (asdf::parse-output-translations-string (join-namestrings '("/" "" ""))) '(:output-translations ("/" nil) :inherit-configuration)) (assert-equal (asdf::parse-output-translations-string (join-namestrings '("/" "/"))) '(:output-translations ("/" "/") :ignore-inherited-configuration)) (assert-equal (asdf::parse-output-translations-string "(:output-translations (\"/\" \"/\") :ignore-inherited-configuration)") '(:output-translations ("/" "/") :ignore-inherited-configuration)) (create-asd-files) (create-conf-files) (format t "~&subdirectories of dir2/: ~S~%" (subdirectories (under-tmp-directory "dir2/"))) (assert-equal 2 (length (subdirectories (under-tmp-directory "dir2/")))) (format t "~&subdirectories of dir5/: ~S~%" (subdirectories (under-tmp-directory "dir5/"))) (assert-equal 2 (length (subdirectories (under-tmp-directory "dir5/")))) (initialize-source-registry `(:source-registry (:include ,(under-tmp-directory "conf.d/")) (:include ,(under-tmp-directory "dir5/")) (:include ,(under-tmp-directory "dir8/")) (:include ,(under-tmp-directory "dir9/dira/")) :ignore-inherited-configuration)) (format t "~&Source Registry: ~S~%" asdf::*source-registry*) (assert (find-system :foo0 nil)) (assert (find-system :foo1 nil)) (assert (find-system :foo2 nil)) (assert (find-system :foo3 nil)) (assert (find-system :foo4 nil)) (assert (not (find-system :foo5 nil))) (assert (find-system :foo6 nil)) (assert (find-system :foo7 nil)) (assert (find-system :foo8 nil)) (assert (not (find-system :foo9 nil))) (format t "~&A: ~S~%B: ~S~%" (namestring (system-relative-pathname :foo3 "bar/baz.lisp")) (under-tmp-directory "dir2/bar/baz.lisp")) (assert-equal (namestring (system-relative-pathname :foo3 "bar/baz.lisp")) (under-tmp-directory "dir2/bar/baz.lisp")) cl-asdf-3.0.3/test/test-deferred-warnings.script000066400000000000000000000054701223164443400216270ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) (enable-deferred-warnings-check) (def-test-system :unintern-foo :components ((:file "unintern-foo"))) (def-test-system :use-foo-only :depends-on (:unintern-foo) :components ((:file "use-foo"))) (def-test-system :use-then-defun-foo :depends-on (:unintern-foo) :serial t :components ((:file "use-foo") (:file "defun-foo"))) (def-test-system :use-then-defmacro-foo :depends-on (:unintern-foo) :serial t :components ((:file "use-foo") (:file "defmacro-foo"))) (def-test-system :use-setf-foo-only :depends-on (:unintern-foo) :components ((:file "use-setf-foo"))) (def-test-system :use-setf-then-defun-foo :depends-on (:unintern-foo) :serial t :components ((:file "use-setf-foo") (:file "defun-setf-foo"))) (def-test-system :use-setf-then-defsetf-foo :depends-on (:unintern-foo) :serial t :components ((:file "use-setf-foo") (:file "defsetf-foo"))) (DBG :tdw0 *compile-file-warnings-behaviour*) (handler-bind ((error (lambda (c) (DBG :cfwbi-ufo c)))) (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-foo-only :force t))) (handler-bind ((error (lambda (c) (DBG :cfwbi-usfo c)))) (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-setf-foo-only :force t))) (DBG :tdw1 *warnings-file-type*) (assert (handler-case (let ((*warnings-file-type* nil)) (load-system :use-foo-only :force t) t) (error () (DBG :wftn c) nil))) (unless *warnings-file-type* (leave-test "Your Lisp does not support deferred-warnings" 0)) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) (perform 'compile-op :use-foo-only) nil) (compile-warned-error () t))) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) (perform 'compile-op :use-setf-foo-only) nil) (compile-warned-error () t))) (let ((*compile-file-warnings-behaviour* :error)) (load-system :use-then-defun-foo)) (setf *compile-file-warnings-behaviour* :error) (load-system :use-setf-then-defun-foo) ;;#+clozure (format t "~S~%" asdf/lisp-build::*warnings*) ;;#+clozure (trace load compile-file check-deferred-warnings check-lisp-compile-warnings) ;; FIXME: on CCL, the defmacro warning is found while loading the defmacro fasl. ;; We should probably beef up the detection in reify-deferred-warnings, ;; possibly file a bug. #-clozure (assert (handler-case (load-system :use-then-defmacro-foo :force t) ((or compile-file-error compile-warned-error) () t) ;;(t (c) (DBG :utdf0 c)) (:no-error (&rest values) (DBG :utdf1 values) nil))) #-clozure (assert (handler-case (load-system :use-setf-then-defsetf-foo :force t) ((or compile-file-error compile-warned-error) () t) ;;(t (c) (DBG :ustdf0 c)) (:no-error (&rest values) (DBG :ustdf1 values) nil))) cl-asdf-3.0.3/test/test-defsystem-errors.script000066400000000000000000000010041223164443400215230ustar00rootroot00000000000000;;; -*- Lisp -*- (defun defsystem-error-handler (form &optional (error 'error)) (handler-case (eval form) (error () t) (:no-error (&rest values) (declare (ignore values)) (error "Expected an error out of ~S" form)))) (defmacro defsystem-error ((&optional (error 'error)) &rest r) `(defsystem-error-handler '(def-test-system ,@r) ',error)) (defsystem-error (non-system-system) :foo :class :cl-source-file) (defsystem-error (non-toplevel-system) :foo :components ((:system :bar))) cl-asdf-3.0.3/test/test-encodings.script000066400000000000000000000112461223164443400201700ustar00rootroot00000000000000;;; -*- Lisp -*- (defparameter *lambda-string* nil) (defun string-char-codes (s) (loop :for c :across s :collect (char-code c))) (defun expected-char-codes (x) #-asdf-unicode '(#xCE #xBB) #+asdf-unicode (ecase x (:utf-8 '(955)) ((:latin1 :latin-1) '(206 187)) ((:latin2 :latin-2) '(206 357)) ((:latin3 :latin-3) '(206 287)) (:koi8-r '(1085 9577)) (:default (expected-char-codes #+clozure ccl:*default-external-format* #+sbcl sb-impl::*default-external-format* #-(or clozure sbcl) (error "can't determine default external-format"))))) (defmacro with-encoding-test ((encoding &key (op 'load-source-op) (path "lambda")) def-test-system &body body) (let ((sys (second def-test-system))) `(with-asdf-cache (:override t) (format t "~&Test ~A: should be ~A~%" ',sys ',encoding) (setf *lambda-string* nil) ,def-test-system (let ((c (find-component ',sys ',path))) ;; mlisp has an issue of :LATIN-2 vs :latin-2. Smooth things with string-equal. (assert-compare (string-equal (component-encoding c) ',encoding)) (loop :for o :in (output-files 'compile-op c) :do (delete-file-if-exists o))) ,@(when op `((operate ',op ',(second def-test-system) :force t))) ,@body (eval `(assert-equal (string-char-codes ,*lambda-string*) (expected-char-codes ',',encoding)))))) #-asdf-unicode (leave-test "No Unicode support to test on this lisp implementation" 0) #+abcl (let* ((version (lisp-implementation-version)) (version-nums (subseq version 0 (position-if-not (lambda (x) (find x "0123456789.")) version)))) (when (version< version-nums "1.1.2") (leave-test "Your old ABCL is known to fail this test script, so skipping it." 0))) (with-encoding-test (:utf-8) (def-test-system :test-encoding-explicit-u8 :components ((:file "lambda" :encoding :utf-8)))) ;; NB: recent clozure can autodetect without asdf-encodings with :default (!) #+sbcl (progn #+sbcl (setf sb-impl::*default-external-format* :latin-3) (with-encoding-test (:default) (def-test-system :test-encoding-explicit-default :components ((:file "lambda" :encoding :default)))) (with-encoding-test (:utf-8) (def-test-system :test-encoding-implicit-default :components ((:file "lambda"))))) ;; Try to load asdf-encodings (setf *central-registry* (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF *uiop-directory* ;; be sure that ouir uiop is there, too. ;; try finding asdf-encodings it right next to asdf. (subpathname *asdf-directory* "../asdf-encodings/"))) (unless (find-system :asdf-encodings nil) ;; try harder by enabling the user's source-registry (initialize-source-registry "")) (unless (find-system :asdf-encodings nil) (leave-test "Couldn't find ASDF-ENCODINGS. Skipping the rest the test." 0)) ;; Disable any user source registry. (initialize-source-registry `(:source-registry :ignore-inherited-configuration)) (load-system :asdf-encodings) #-lispworks (with-encoding-test (:latin-2) (def-test-system :test-encoding-implicit-autodetect :components ((:file "lambda")))) #+sbcl (with-encoding-test (:koi8-r) (def-test-system :test-encoding-explicit-koi8-r :components ((:file "lambda" :encoding :koi8-r)))) (with-encoding-test (:utf-8) (def-test-system :test-file-encoding-u8 :encoding :latin-1 :components ((:file "lambda" :encoding :utf-8)))) (with-encoding-test (:latin-1) (def-test-system :test-file-encoding-l1 :encoding :utf-8 :components ((:file "lambda" :encoding :latin-1)))) (with-encoding-test (:utf-8 :op load-source-op) (def-test-system :test-system-encoding-u8 :encoding :utf-8 :components ((:file "lambda")))) (with-encoding-test (:utf-8 :op load-op) (def-test-system :test-system-encoding-u8-load-op :encoding :utf-8 :components ((:file "lambda")))) (with-encoding-test (:latin-1) (def-test-system :test-system-encoding-l1 :encoding :latin-1 :components ((:file "lambda")))) #-ecl-bytecmp (with-encoding-test (:latin-1 :op load-op) (def-test-system :test-system-encoding-l1-load-op :encoding :latin-1 :components ((:file "lambda")))) (with-encoding-test (:utf-8 :path ("foo" "lambda")) (def-test-system :test-module-encoding-u8 :encoding :latin-1 :components ((:module "foo" :pathname "" :encoding :utf-8 :components ((:file "lambda")))))) (with-encoding-test (:latin-1 :path ("foo" "lambda")) (def-test-system :test-module-encoding-l1 :encoding :utf-8 :components ((:module "foo" :pathname "" :encoding :latin-1 :components ((:file "lambda")))))) cl-asdf-3.0.3/test/test-file000066400000000000000000000003211223164443400156230ustar00rootroot00000000000000Single double entry triple word entry escape + escape - escape _ escape . escape , escape % escape @ escape : escape / escape \ escape ! escape & escape * escape [ escape ] escape ( escape ) escape { escape } cl-asdf-3.0.3/test/test-force.asd000066400000000000000000000001171223164443400165530ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-force :components ((:file "file1"))) cl-asdf-3.0.3/test/test-force.script000066400000000000000000000011261223164443400173110ustar00rootroot00000000000000;;; -*- Lisp -*- (load-system 'test-force) (defparameter file1 (test-fasl "file1")) (defparameter file1-date (file-write-date file1)) (defparameter date1 (- file1-date 600)) (defparameter date2 (- file1-date 300)) (assert file1) (assert file1-date) ;; unforced, date should stay same (touch-file "test-force.asd" :timestamp date1) (touch-file "file1.lisp" :timestamp date1) (touch-file file1 :timestamp date2) (load-system 'test-force) (assert-equal (get-file-stamp file1) date2) ;; forced, it should be later (load-system 'test-force :force t) (assert (>= (get-file-stamp file1) file1-date)) cl-asdf-3.0.3/test/test-inline-methods.script000066400000000000000000000010041223164443400211250ustar00rootroot00000000000000;;; -*- Lisp -*- (defparameter *a* 0) (def-test-system :foo :components ((:file "file1" :perform (load-op :before (o c) (incf *a*) (format t "Method run before ~A~%" (action-description o c)))) (:file "file2" :depends-on ("file1") :perform (load-op (o c) (incf *a*) (format t "Method run for ~A~%" (action-description o c)) (call-next-method))))) (load-system :foo) (assert-equal *a* 2) cl-asdf-3.0.3/test/test-logical-pathname.asd000066400000000000000000000001341223164443400206610ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem test-logical-pathname :components ((:file "logical-file"))) cl-asdf-3.0.3/test/test-logical-pathname.script000066400000000000000000000043221223164443400214210ustar00rootroot00000000000000;;; -*- Lisp -*- #+gcl2.6 (leave-test "GCL 2.6 doesn't do Logical pathnames" 0) (setf (logical-pathname-translations "ASDF") #+(or allegro clisp) `(("**;*.*.*" ,(asdf::wilden *asdf-directory*))) #-(or allegro clisp) `(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (asdf::wilden *asdf-directory*))) ("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (asdf::wilden *asdf-directory*))) ("**;*.*.*" ,(resolve-location `(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf") :wilden t)))) (setf asdf/cache:*asdf-cache* nil) (DBG :logical (logical-pathname-translations "ASDF") (translate-logical-pathname "ASDF:test;test-logical-pathname.asd") (truename "ASDF:test;test-logical-pathname.asd")) #+xcl (leave-test "GCL 2.6 doesn't do Logical pathnames well enough" 0) (DBG "Test logical pathnames in central registry") (setf *central-registry* '(#p"ASDF:test;")) (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (DBG "loading" (oos 'load-op :test-logical-pathname :force t)) (DBG "Test logical pathnames in source-registry, non-recursive") (clear-system :test-logical-pathname) (setf *central-registry* '()) (initialize-source-registry '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration)) (load-system :test-logical-pathname :force t :verbose t) (DBG "Test logical pathnames in source-registry, recursive") (clear-system :test-logical-pathname) (setf *central-registry* '()) (initialize-source-registry ;; Bug: Allegro Express 8.2 and 9.0 incorrectly read #p"ASDF:" as relative. ;; other bug: around 2.26.xx (before the nil-pathname cleanup, though), ;; CLISP borks badly if the path below is #p"ASDF:" ;; and it tries to load ASDF itself from a logical-pathname. '(:source-registry (:tree #p"ASDF:test;") :ignore-inherited-configuration)) (load-system :test-logical-pathname :force t) #+(or clisp abcl) (leave-test "CLISP and ABCL translate logical pathnames in *LOAD-PATHNAME*" 0) (defparameter sys (find-system :test-logical-pathname)) (assert (logical-pathname-p (component-pathname sys))) (assert (logical-pathname-p (system-source-file sys))) (DBG "Done") cl-asdf-3.0.3/test/test-macosx.script-ignore000066400000000000000000000005051223164443400207660ustar00rootroot00000000000000;;; -*- mode: common-lisp; -*- ;;;--------------------------------------------------------------------------- ;;; Run this on a Mac OS X machine to make sure that the OS flags are correct. ;;;--------------------------------------------------------------------------- (assert (uiop:os-macosx-p)) (assert (uiop:os-unix-p)) cl-asdf-3.0.3/test/test-missing-lisp-file.script000066400000000000000000000027541223164443400215560ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; This is supposed to verify that if a lisp file is lost, then any attempt to ;;; make the system will fail. I.e., we verify that we won't just load a stale ;;; fasl when the source file is lost. ;;;--------------------------------------------------------------------------- (def-test-system test-missing-lisp-file :components ((:file "file2" :in-order-to ((compile-op (load-op "fileMissing")) (load-op (load-op "fileMissing")))) (:file "fileMissing"))) (defparameter missing-name (test-source "fileMissing.lisp")) (defparameter template-file (test-source "file1.lisp")) (concatenate-files (list template-file) missing-name) (unless (probe-file missing-name) (format t "File copy failed.~%")) (asdf:operate 'asdf:load-op 'test-missing-lisp-file) ;; test that it compiled (defparameter file1 (test-fasl "file2")) (defparameter file2 (test-fasl "fileMissing")) (defparameter file1-date (file-write-date file1)) (assert file1-date) (assert (file-write-date file2)) ;; and loaded (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) ;; now remove the lisp file we created, and wait for an error (delete-file-if-exists missing-name) ;; we shouldn't be able to find the input-file for the compile-op, and that ;; should be an error. (assert (nth-value 1 (ignore-errors (asdf:operate 'asdf:load-op 'test-missing-lisp-file)))) cl-asdf-3.0.3/test/test-module-depend.asd000066400000000000000000000003761223164443400202060ustar00rootroot00000000000000(defsystem :test-module-depend :components ((:file "file1") (:module "quux" :pathname "" :depends-on ("file1") :components ((:file "file2") (:module "file3mod" :pathname "" :components ((:file "file3"))))))) cl-asdf-3.0.3/test/test-module-depend.script000066400000000000000000000026241223164443400207410ustar00rootroot00000000000000;;; -*- Lisp -*- (load-system 'test-module-depend) ;; test that it compiled (defparameter file1.lisp (component-pathname (find-component 'test-module-depend "file1"))) (defparameter file1.fasl (first (output-files 'compile-op '(test-module-depend "file1")))) (defparameter file2.fasl (first (output-files 'compile-op '(test-module-depend "quux" "file2")))) (defparameter file3.fasl (first (output-files 'compile-op '(test-module-depend "quux" "file3mod" "file3")))) (defparameter file1-date (get-file-stamp file1.fasl)) (defparameter file3-date (get-file-stamp file3.fasl)) (assert-pathname-equal file1.fasl (test-fasl "file1")) (assert-pathname-equal file2.fasl (test-fasl "file2")) (assert-pathname-equal file3.fasl (test-fasl "file3")) (assert (and file1-date file3-date)) ;; and loaded (assert (asymval '#:*file1* :test-package)) ;; now touch file1 and its fasl so the fasl is out of date, ;; and check that file2 _is_ also recompiled ;; this didn't work before the cross-module (intra-system) dependency bug was fixed. (touch-file file1.lisp :timestamp (- file3-date 60)) (touch-file file1.fasl :timestamp (- file3-date 90)) (touch-file file2.fasl :timestamp (- file3-date 30)) (touch-file file3.fasl :timestamp (- file3-date 15)) (load-system 'test-module-depend) (assert (>= (get-file-stamp file2.fasl) file3-date)) ;; does this properly go to the second level? (assert (>= (get-file-stamp file3.fasl) file3-date)) cl-asdf-3.0.3/test/test-module-excessive-depend.script000066400000000000000000000067671223164443400227510ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Here's what we are trying to test. Let us say we have a system X that ;;; contains a file, "file1" and a module, "quux" that depends on file 1. In ;;; turn, "quux" contains "file2" which depends on loading another system, Y ;;; (note that this dependency cannot be recorded using only the defsystem ;;; grammar; we must use an ancillary method definition). If we over-force ;;; actions, then the recompiling of "file1" will force "quux" to be loaded, ;;; forcing "file2" load and in turn forcing the reload and recompilation of Y. ;;; If operations are done properly, a change to file1 will force recompilation ;;; and reloading of "file2," but /not/ of system Y. ;;;--------------------------------------------------------------------------- (def-test-system :test-module-excessive-depend :components ((:file "file1") (:module "quux" :pathname "" :depends-on ("file1") :components ((:file "file2"))))) (defun find-quux () (find-component :test-module-excessive-depend "quux")) (defun find-file2 () (find-component (find-quux) "file2")) (defmethod component-depends-on ((op load-op) (c (eql (find-file2)))) (cons `(load-op ,(find-system "file3-only")) (call-next-method))) (defmethod component-depends-on ((op compile-op) (c (eql (find-file2)))) (cons `(load-op ,(find-system "file3-only")) (call-next-method))) (DBG "loading test-module-excessive-depend" (operate 'load-op 'test-module-excessive-depend)) ;; test that it compiled (defparameter file1 (test-fasl "file1")) (defparameter file2 (test-fasl "file2")) (defparameter file3 (test-fasl "file3")) (defparameter file1-date (file-write-date file1)) (defparameter file2-date (file-write-date file2)) (defparameter file3-date (file-write-date file3)) (unless (and file1-date file2-date file3-date) (error "Failed to compile one of the three files ~ that should be compiled for this test: ~{~a~}" (mapcar #'cdr (remove-if #'car (pairlis (list file1-date file2-date file3-date) '("file1" "file2" "file3")))))) ;; and loaded (assert (eval (find-symbol* '#:*file1* :test-package))) (assert (eval (find-symbol* '#:*file3* :test-package))) ;; now touch file1 and check that file2 _is_ also recompiled ;; but that file3 is _not_ recompiled. ;; this will only work if the cross-module (intra-system) ;; dependency bug is fixed and the excessive compilation bug is fixed. (defparameter before file3-date) (touch-file (test-source "file1.lisp") :timestamp (- before 60)) (touch-file file1 :timestamp (- before 90)) (touch-file (test-source "file2.lisp") :timestamp (- before 30)) (touch-file file2 :timestamp (- before 15)) (defparameter plan (traverse 'load-op 'test-module-excessive-depend)) (defparameter file3c (find-component :file3-only "file3")) #|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|# (when (loop :for (o . c) :in plan :thereis (and (eq c file3c) (typep o 'asdf:compile-op))) (error "Excessive operations on file3-only system. Bad propagation of dependencies.")) (operate 'load-op 'test-module-excessive-depend) (assert (>= (file-write-date file1) before)) (assert (>= (file-write-date file2) before)) (unless (= (file-write-date file3) file3-date) (error "Excessive compilation of file3.lisp: traverse bug.")) cl-asdf-3.0.3/test/test-module-pathnames.script000066400000000000000000000034761223164443400214700ustar00rootroot00000000000000;;; -*- Lisp -*- (def-test-system :test-module-pathnames :pathname #.*test-directory* :components ((:module "sources/level1" :serial t :components ((:file "file1") (:file "level2/file2") (:static-file "level2/static.file") (:static-file "test-tmp.cl"))))) (DBG "Loading the system") (asdf:load-system 'test-module-pathnames) (DBG "Checking pathnames") (flet ((pathname-foo (x) (list (or (normalize-pathname-directory-component (pathname-directory x)) '(:relative)) (pathname-name x) (pathname-type x)))) (let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file"))) (test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl")))) (assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp)) '((:relative) "test-tmp" "cl")) (assert-equal (pathname-foo (asdf:component-relative-pathname static)) '((:relative "level2") "static" "file")))) (assert (find-package :test-package) () "package test-package not found") (assert (find-symbol (symbol-name '*file-tmp*) :test-package) () "symbol `*file-tmp*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) () "symbol `*file-tmp*` has wrong value") (defun pf (path) (let* ((fasl (apply-output-translations (subpathname *test-directory* path :type (compile-file-type))))) (assert (probe-file fasl) () "Cannot find compiled file ~S" fasl))) (pf "sources/level1/file1") (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) () "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) () "symbol `*file-tmp2*` has wrong value") (pf "sources/level1/level2/file2") cl-asdf-3.0.3/test/test-modules-serial.asd000066400000000000000000000005071223164443400204050ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-modules-serial :serial t :components ((:module "a" :serial t :pathname "." :components ((:file "file1") (:file "file2"))) (:module "b" :pathname "b" :components ((:file "file3"))))) cl-asdf-3.0.3/test/test-modules.asd000066400000000000000000000004371223164443400171320ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-modules :components ((:module "a" :pathname "." :components ((:file "file1"))) (:module "b" :pathname "b" :depends-on ("a") :components ((:file "file2"))))) cl-asdf-3.0.3/test/test-multiple.asd000066400000000000000000000005261223164443400173140ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-multiple :components ((:file "file3"))) (asdf:defsystem test-multiple-too :components ((:file "file1") (:file "file2" :depends-on ("file1")) (:file "file3" :depends-on ("file1" "file2")))) (asdf:defsystem test-multiple-free :depends-on (:test-multiple) :components ((:file "file4"))) cl-asdf-3.0.3/test/test-multiple.script000066400000000000000000000015241223164443400200500ustar00rootroot00000000000000;;; -*- Lisp -*- (defparameter asd (subpathname *test-directory* "test-multiple.asd")) (defparameter tmp (subpathname *test-directory* "../build/")) (defparameter asd2 (subpathname tmp "test-multiple-too.asd")) (defparameter file4 (test-fasl "file4")) (setf *central-registry* `(,*test-directory* ,tmp)) ;; Don't rely on ln -s on Windows (cond ((os-unix-p) (multiple-value-bind (output error-output return-code) (uiop:run-program (format nil "ln -sf ~A ~A" (native-namestring asd) (native-namestring asd2)) :ignore-error-status t) (declare (ignore output error-output)) (oos 'load-source-op (if (zerop return-code) 'test-multiple-too 'test-multiple)))) (t (oos 'load-source-op 'test-multiple))) (assert (asymval :*file3* :test-package)) (load-system 'test-multiple-free) (assert (probe-file* file4)) cl-asdf-3.0.3/test/test-nested-1.lisp000066400000000000000000000000301223164443400172670ustar00rootroot00000000000000(in-package :asdf-test) cl-asdf-3.0.3/test/test-nested-components-1.asd000066400000000000000000000010321223164443400212550ustar00rootroot00000000000000;;; -*- Mode: common-lisp; Syntax: Common-Lisp; -*- (defsystem test-nested-components-a :components ((:module "nested-components" :pathname "" :components ((:file "test-nested-1"))))) (defsystem test-nested-components-b :pathname "" :components ((:file "test-nested-1"))) (defsystem db-agraph-preflight :components ((:module "preflight-checks" :components ((:file "preflight"))))) (defsystem db-agraph-preflight-2 :pathname "preflight-checks" :components ((:file "preflight"))) cl-asdf-3.0.3/test/test-nested-components.script000066400000000000000000000011041223164443400216540ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; check that added nesting via modules doesn't confuse ASDF (setf *central-registry* nil) (load "test-nested-components-1.asd") (print (list :a (traverse 'compile-op 'test-nested-components-a) (traverse 'compile-op 'test-nested-components-b) :x (traverse 'compile-op 'db-agraph-preflight) (traverse 'compile-op 'db-agraph-preflight-2))) #| (oos 'compile-op 'test-nested-components-a) (oos 'compile-op 'test-nested-components-b) (print (list (traverse 'load-op 'test-nested-components-a) (traverse 'load-op 'test-nested-components-b))) |# cl-asdf-3.0.3/test/test-package.asd000066400000000000000000000007131223164443400170520ustar00rootroot00000000000000;;; NB: This way of managing packages is explicitly NOT recommended. ;;; However, it is found in the wild, and debugging it is a pain, so ;;; we should probably not break. The thing that this is testing is ;;; that unrelated definitions of symbols naming ASDF keywords should ;;; not affect the parsing of a system. (in-package :cl-user) ; BAD BAD BAD (asdf:defsystem test-package :components ((:module "foo" :components ((:file "bar") (:file "baz"))))) cl-asdf-3.0.3/test/test-package.script000066400000000000000000000002471223164443400176110ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :cl-user) (asdf-test::with-test () (defun module () 1) (load "test-package.asd") (defclass module () ()) (load "test-package.asd")) cl-asdf-3.0.3/test/test-program.script000066400000000000000000000036601223164443400176670ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG :foo (current-lisp-file-pathname)) (unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks sbcl) t #+cmu nil ;; uncomment if you have 32-bit gcc support - or can autodetect #+clisp (version-satisfies (first (split-string (lisp-implementation-version) :separator " ")) "2.48")) (DBG "Creating standalone programs is not supported on your CL implementation") (leave-test "Skipping test" 0)) (defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example))) (assert (absolute-pathname-p exe)) ;; Try to load lisp-invocation from xcvb (setf *central-registry* (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF *uiop-directory* ;; try finding xcvb's lisp-invocation right next to asdf. (subpathname *asdf-directory* "../xcvb/"))) (unless (find-system :lisp-invocation nil) ;; try harder by enabling the user's source-registry (initialize-source-registry "")) (unless (find-system :lisp-invocation nil) (leave-test "Couldn't find lisp-invocation. Skipping the rest the test." 0)) (load-system :lisp-invocation) ;; Disable any user source registry. (initialize-source-registry `(:source-registry :ignore-inherited-configuration)) (delete-file-if-exists exe) (assert-equal (multiple-value-list (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))))) '(nil nil 0)) (assert (probe-file* exe)) (assert-equal (run-program `(,(native-namestring exe)) :output :lines) '("hello, world")) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines) '("hello, world" "You passed 3 arguments:" " \"a\"" " \"b c\"" " \"d\"")) cl-asdf-3.0.3/test/test-redundant-recompile.script000066400000000000000000000024461223164443400221620ustar00rootroot00000000000000;;; -*- Lisp -*- #| ;;;This test system definition attempts to replicate the excess dependencies ;;;that seem to give rise to launchpad bug 590517 ;;;(https://bugs.launchpad.net/asdf/+bug/590517) 1) from clean, check that all fasl files build and that some function defined in the second file is present 2) load again. Check to make sure that nothing is recompiled. |# (def-test-system test-redundant-recompile :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1"))) (load-system 'test-redundant-recompile) ;; test that it compiled (defparameter file1 (test-fasl "file1")) (defparameter file2 (test-fasl "file2")) (defparameter file1-date (file-write-date file1)) (defparameter file2-date (file-write-date file2)) (format t "~&test-redundant-recompile 1: ~S ~S~%" file1 file1-date) (format t "~&test-redundant-recompile 2: ~S ~S~%" file2 file2-date) (assert file1-date) (assert file2-date) ;; and loaded (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) ;; now rerun the load-op and check that no files are recompiled (load-system 'test-redundant-recompile) (assert (= file1-date (file-write-date file1))) (assert (= file2-date (file-write-date file2))) cl-asdf-3.0.3/test/test-retry-loading-component-1.script000066400000000000000000000014561223164443400231370ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test asdf:try-recompiling restart (defvar *caught-error* nil) (delete-file-if-exists "try-reloading-dependency.asd") (asdf::clear-defined-systems) (handler-bind ((error #'(lambda (c) (format t "~&Caught error ~s" c) (setf *caught-error* t) (concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd") (DBG "trlc1 5") (multiple-value-bind (name mode) (find-symbol* :retry :asdf) (assert (eq mode :external) () "Mode of ~s was not external" name) (let ((restart (find-restart name c))) (assert restart) (when restart (invoke-restart restart))))))) (load-system 'try-reloading-1)) (assert *caught-error*) cl-asdf-3.0.3/test/test-run-program.script000066400000000000000000000235541223164443400204750ustar00rootroot00000000000000;; -*- Lisp -*- (declaim (optimize (debug 3) (safety 3))) ;; On Windows, normalize away CRLF into jut the unixy LF. (defun dewindowize (x) (block () (setf x (remove (code-char 13) x)) #+(and (or sbcl lispworks) os-windows) ;; buggy implementations output extra space on Windows. Also old CCL. (when (eql #\space (last-char x)) (return (subseq x 0 (1- (length x))))) x)) (DBG "Testing echo ok 1 via run-program as a list") (assert-equal "ok 1" (dewindowize (run-program '("echo" "ok" "1") :output '(:string :stripped t)))) (DBG "Testing echo ok 1 via run-program as a string") (assert-equal "ok 1" (dewindowize (run-program "echo ok 1" :output '(:string :stripped t)))) ;;; test asdf run-shell-command function (setf *verbose-out* nil) (DBG "Testing true via run-shell-command") (assert-equal 0 (run-shell-command "true")) (DBG "Testing false via run-shell-command") (assert-equal 1 (run-shell-command "false")) (DBG "Testing bad shell command via run-shell-command") (unless (< 0 (run-shell-command "./bad-shell-command")) (error "Failed to capture exit status indicating shell command failure.")) #+os-unix (progn (DBG "Testing good shell command in current directory via run-shell-command") (unless (equal 0 (run-shell-command "./good-shell-command")) (error "Failed to capture exit status indicating shell command success.")) ;; this test checks for a problem there was in allegro -- :output :interactive ;; would try to open T as a stream for INPUT. (assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell t :output :interactive))) (assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell nil :output :interactive))) (assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell t :output :interactive :ignore-error-status t))) (assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell nil :output :interactive :ignore-error-status t))) (assert-equal '("foo" "bar baz" 42) (multiple-value-list (run-program "cat ; echo bar baz >&2 ; exit 42" :input '("foo") :output :string :error-output '(:string :stripped t) :ignore-error-status t))) (assert-equal '(("foo" "bar" "baz" "quux") nil 0) (multiple-value-list (run-program "echo foo ; echo bar >&2 ; echo baz ; echo quux >& 2" :output :lines :error-output :output)))) #-(and sbcl os-windows) (let ((ok1 (format nil "; $ echo ok 1~%ok 1"))) (DBG "Testing awkward legacy output capture via run-shell-command") (assert-equal (dewindowize (stripln (with-output-to-string (s) (let ((*verbose-out* s)) (run-shell-command "echo ~A 1" "ok"))))) ok1) #-ecl (assert-equal (dewindowize (stripln (with-output-to-string (s) (let ((*verbose-out* t) (*standard-output* s)) (let ((status (run-shell-command "echo ok ~D" 1))) (unless (zerop status) (error "Didn't get good exit status."))))))) ok1)) ;; NB1: run-shell-command is deprecated. Use run-program instead. ;; NB2: we do NOT support stderr capture to *verbose-out* anymore in run-shell-command. ;; If you want 2>&1 redirection, you know where to find it. (assert-equal '(:ok 1) (run-program "echo :ok 1" :output :forms)) (assert-equal "ok" (dewindowize (stripln (with-output-to-string (*standard-output*) (run-program "echo ok" :output t :error-output :output))))) ;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess) ;;#+lispworks (trace system:run-shell-command system:pid-exit-status) #| Testing run-program |# ;; We add a newline to the end of a string and return it. ;; We do it in this specific manner so that under unix, windows and macos, ;; format will choose the correct type of newline delimiters (defun nl (str) (format nil "~A~%" str)) ;; Convert the input format to a string stream, read it into a string, ;; and see if they match. (defun slurp-stream-string/check (input-string &key (test #'string=)) (let ((input-string (format nil input-string))) (with-open-stream (s (make-string-input-stream input-string)) (is (funcall test input-string (slurp-stream-string s)))))) ;; Call with a bunch of strings to call the above function upon. (defun slurp-stream-string/checks (&rest input-string-list) (dolist (input-string input-string-list) (funcall #'slurp-stream-string/check input-string))) ;; Check to see if the input-string ins converted correctly to the ;; output-form (defun slurp-stream-lines/check (input-string output-form &key (test #'equal)) (let ((input-string (format nil input-string))) (with-open-stream (s (make-string-input-stream input-string)) (is (funcall test output-form (slurp-stream-lines s)))))) ;; Check to see if the individual input/output lists passed into this ;; function are correct. (defun slurp-stream-lines/checks (&rest control-forms) (dolist (form control-forms) (destructuring-bind (input-string output-form) form (funcall #'slurp-stream-lines/check input-string output-form)))) (deftest test/slurp-stream-string () ;; Check to make sure the string is exactly what it is when read ;; back through a stream. This is a format specifier so we can ;; portably test newline processing. (slurp-stream-string/checks "" " " "~%" "~%~%" "~%~%~%" "one~%two~%three~%~%four" "one two three four" "one two~%three four") ;; Check some boundary cases on the types passed. (signals error (slurp-stream-string nil)) (signals error (slurp-stream-string 42)) (signals error (slurp-stream-string "not valid")) t) (deftest test/slurp-stream-lines () (slurp-stream-lines/checks ;; input-string first, then expected output-form after its parsing '("" nil) '(" " (" ")) '("~%" ("")) '("~%~%" ("" "")) '("~%~%~%" ("" "" "")) '("foo" ("foo")) '("~%foo" ("" "foo")) '("~%foo~%" ("" "foo")) ; consumes last newline! '("one~%two~%~%three" ("one" "two" "" "three")) '("one~%two~%~%three~%" ("one" "two" "" "three")) '("one two three four" ("one two three four")) '("one two~%three four~%" ("one two" "three four"))) ;; Check some boundary cases on the types passed. ;; NOTE: NIL is ok since it means read from stdin! (signals error (slurp-stream-lines 42)) (signals error (slurp-stream-lines "not valid")) t) (defun common-test/run-program () ;; Can we echo a simple string? (assert-equal '("abcde") (run-program '("echo" "abcde") :output :lines)) (assert-equal (nl "fghij") (run-program '("echo" "fghij") :output :string)) ;; Are spaces handled properly? (assert-equal '("Hello World") (run-program '("echo" "Hello World") :output :lines)) (assert-equal (nl "Hello World") (run-program '("echo" "Hello World") :output :string)) (assert-equal (nl "Hello World") (run-program "echo Hello World" :output :string)) ;; Test that run-program fails properly with an ;; empty program string #+(or clozure (and allegro os-unix) cmu (and lispworks os-unix) sbcl scl) (signals error (run-program '("") :output :lines)) ;; An empty string itself is ok since it is passed to the shell. (assert-equal "" (run-program "" :output :string)) ;; Test that run-program fails properly with a ;; nil program list #+(or clozure (and allegro os-unix) cmu sbcl scl) (signals error (run-program nil :output :lines)) ;; Test that run-program fails properly when the ;; executable doesn't exist. (signals error (run-program '("does-not-exist") :output :lines)) (signals error (run-program "does-not-exist" :output :lines)) (assert-equal '(nil nil 0) (multiple-value-list (run-program "echo ok" :output nil))) (assert-equal '(nil nil 0) (multiple-value-list (run-program '("echo" "ok") :output nil))) t) (defun unix-only-test/run-program () (assert-equal '("ok 1") (run-program "echo ok 1" :output :lines)) (assert-equal '("ok 1") (run-program '("echo" "ok 1") :output :lines)) (assert-equal "ok 1" (run-program '("echo" "ok 1") :output '(:string :stripped t))) (assert-equal '(nil nil 0) (multiple-value-list (run-program "true"))) (signals subprocess-error (run-program "false")) (assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :ignore-error-status t))) (let ((tf (native-namestring (test-source "test-file")))) ;; a basic smoke test (assert-equal '("Single") (run-program `("grep" "Single" ,tf) :output :lines)) ;; Make sure space is handled correctly (assert-equal '("double entry") (run-program `("grep" "double entry" ,tf) :output :lines)) ;; Make sure space is handled correctly (assert-equal '("triple word entry") (run-program `("grep" "triple word entry" ,tf) :output :lines)) ;; Testing special characters (loop :for char :across "+-_.,%@:/\\!&*(){}" :for str = (string char) :do (assert-equal (list (format nil "escape ~A" str)) (run-program `("grep" ,(format nil "[~A]" str) ,tf) :output :lines))) ;; Test that run-program signals an error ;; with an executable that doesn't return 0 (signals subprocess-error (run-program '("false") :output :lines)) ;; Test that we can suppress the error on run-program (is (null (run-program '("false") :output :lines :ignore-error-status t)))) t) (defun windows-only-test/run-program () ;; a basic smoke test (assert-equal "ok" (dewindowize (run-program '("cmd" "/c" "echo" "ok") :output :line))) (assert-equal "ok 1" (dewindowize (run-program "echo ok 1" :output :line))) ;; clozure: beware http://trac.clozure.com/ccl/ticket/1118 t) (deftest test/run-program () #+os-unix (common-test/run-program) #+os-unix (unix-only-test/run-program) #+os-windows (windows-only-test/run-program) (terpri) t) (test/run-program) cl-asdf-3.0.3/test/test-samedir-modules.asd000066400000000000000000000007471223164443400205600ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-samedir-modules :components ((:module "here" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")) :pathname ""))) #| from clean, check that all fasl files build and that some function defined in the second file is present |# cl-asdf-3.0.3/test/test-samedir-modules.script000066400000000000000000000006641223164443400213130ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG "loading test-samedir-modules") (asdf:operate 'asdf:load-op 'test-samedir-modules) (defparameter file1 (test-fasl "file1")) (defparameter file2 (test-fasl "file2")) (defparameter file1-date (file-write-date file1)) (DBG "test that it compiled" file1 file1-date) (assert file1-date) (assert (file-write-date file2)) (DBG "and loaded") (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) cl-asdf-3.0.3/test/test-source-file-type-1.asd000066400000000000000000000006411223164443400210110ustar00rootroot00000000000000;; Should work with both ASDF 1 and ASDF 2. (defclass cl-source-file-1 (cl-source-file) ()) (defmethod asdf::source-file-type ((f cl-source-file-1) (s system)) (declare (ignorable f s)) (format t "Hello, world!~%") "cl") (defsystem test-source-file-type-1 :default-component-class cl-source-file-1 :serial t :components ((:cl-source-file "file1") ; for the package (:file "test-tmp"))) cl-asdf-3.0.3/test/test-source-file-type-2.asd000066400000000000000000000004311223164443400210070ustar00rootroot00000000000000;; Works only in ASDF 2 (defclass cl-source-file-2 (cl-source-file) ((type :initform "cl"))) (defsystem test-source-file-type-2 :default-component-class cl-source-file-2 :serial t :components ((:file "file1" :type "lisp") ; for package (:file "test-tmp"))) cl-asdf-3.0.3/test/test-source-file-type.script000066400000000000000000000011031223164443400214020ustar00rootroot00000000000000;;; -*- Lisp -*- ;;(trace asdf::source-file-type asdf::source-file-explicit-type) (progn (asdf:load-system 'test-source-file-type-1 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (assert (equal (mapcar #'pathname-type (mapcar #'asdf:component-pathname (asdf:module-components (asdf:find-system :test-source-file-type-1)))) '("lisp" "cl"))) (delete-package :test-package) (asdf:load-system 'test-source-file-type-2 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))) cl-asdf-3.0.3/test/test-stamp-propagation.script000066400000000000000000000001261223164443400216570ustar00rootroot00000000000000(load (subpathname *test-directory* "stamp-propagation/test-stamp-propagation.lisp")) cl-asdf-3.0.3/test/test-static-and-serial.script000066400000000000000000000033321223164443400215200ustar00rootroot00000000000000;;; -*- Lisp -*- #| make sure that serial t and static-files don't cause full rebuilds all the time... |# (in-package :asdf-test) (defparameter s '(def-test-system static-and-serial :version "0.1" :serial t :components ((:static-file "file2.lisp") (:static-file "run-tests.sh") (:file "file1")))) (eval s) (load-test-system 'static-and-serial) (defparameter file1.lisp (component-pathname (find-component 'static-and-serial "file1"))) (defparameter file2.lisp (component-pathname (find-component 'static-and-serial "file2.lisp"))) (defparameter run-tests.sh (component-pathname (find-component 'static-and-serial "run-tests.sh"))) (defparameter file1.fasl (first (output-files 'compile-op '(static-and-serial "file1")))) (assert-pathname-equal file1.lisp (test-source "file1.lisp")) ;; differ on LispWorks. Sigh. (assert-pathname-equal file2.lisp (test-source "file2.lisp")) (assert-pathname-equal run-tests.sh (test-source "run-tests.sh")) (assert-pathname-equal file1.fasl (test-fasl "file1")) ;; differ on CCL. Sigh. (defparameter file1-date (get-file-stamp file1.fasl)) (defparameter date1 (- file1-date 600)) (defparameter date2 (- file1-date 300)) (defparameter date3 (- file1-date 150)) (assert file1-date) (assert (asymval :*file1* :test-package)) (format t "file: ~S~%date: ~S~%" file1.fasl file1-date) ;; date should stay same (clear-system 'static-and-serial) (delete-package :test-package) (eval s) (touch-file file2.lisp :timestamp date1) (touch-file run-tests.sh :timestamp date1) (touch-file file1.lisp :timestamp date2) (touch-file file1.fasl :timestamp date3) (DBG "load again" (oos 'load-op 'static-and-serial)) (assert (asymval :*file1* :test-package)) (assert-equal (get-file-stamp file1.fasl) date3) cl-asdf-3.0.3/test/test-sysdef-asdf.script000066400000000000000000000004461223164443400204270ustar00rootroot00000000000000;;; -*- Lisp -*- (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (load-system :asdf) (initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) (:directory ,*uiop-directory*) :ignore-inherited-configuration)) (load-system :asdf) cl-asdf-3.0.3/test/test-system-pathnames.script000066400000000000000000000017751223164443400215270ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem :test-system-pathnames :pathname "sources/level1" :components ((:file "file1") (:file "file2" :pathname "level2/file2") (:static-file "level2/static.file") (:static-file "test-tmp.cl"))) (load-system 'test-system-pathnames) (assert (find-package :test-package) () "package test-package not found") (assert (find-symbol (symbol-name '*file-tmp*) :test-package) () "symbol `*file-tmp*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) () "symbol `*file-tmp*` has wrong value") (assert (probe-file (test-fasl "sources/level1/file1")) () "compiled file not found") (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) () "symbol `*file-tmp2*` has wrong value") (assert (probe-file (test-fasl "sources/level1/level2/file2")) () "compiled file not found") cl-asdf-3.0.3/test/test-tmp.cl000066400000000000000000000004021223164443400161010ustar00rootroot00000000000000;; part of the test-module-pathnames test (in-package :test-package) (defparameter *test-tmp-cl* t) (eval-when (:compile-toplevel :execute) (format t "compiling test-tmp.cl~%")) (eval-when (:load-toplevel :execute) (format t "loading test-tmp.cl~%")) cl-asdf-3.0.3/test/test-tmp.lsp000066400000000000000000000004041223164443400163030ustar00rootroot00000000000000;; part of the test-module-pathnames test (in-package :test-package) (defparameter *test-tmp-cl* t) (eval-when (:compile-toplevel :execute) (format t "compiling test-tmp.lsp~%")) (eval-when (:load-toplevel :execute) (format t "loading test-tmp.lsp~%")) cl-asdf-3.0.3/test/test-touch-system-1.script000066400000000000000000000023221223164443400210140ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test system def reloading if touched ;;; system that can be found using *system-definition-search-functions* (defun system-registered-time (name) (if-let (data (asdf::system-registered-p name)) (car data))) (defparameter test1.asd (nth-value 2 (locate-system :test1))) (assert-pathname-equal test1.asd (test-source "test1.asd")) (defparameter file1.lisp (test-source "file1.lisp")) (defparameter file2.lisp (test-source "file2.lisp")) (defparameter file1.fasl (test-fasl "file1.lisp")) (defparameter file2.fasl (test-fasl "file2.lisp")) (defparameter date1 (get-file-stamp test1.asd)) (defparameter date2 (- date1 600)) (defparameter date3 (- date1 300)) (touch-file test1.asd :timestamp date2) (touch-file file1.lisp :timestamp date3) (touch-file file2.lisp :timestamp date3) (assert-equal nil (system-registered-time :test1)) (find-system :test1) (defparameter date4 (get-file-stamp file2.fasl)) (defparameter date5 (system-registered-time :test1)) (DBG :blah date1 date2 date3 date4 date5) (assert-equal date2 date5) (assert-equal date2 date5) (assert (>= date4 date3)) (sleep 1) (touch-file test1.asd) (find-system :test1) (defparameter date6 (system-registered-time :test1)) (assert (> date6 date4)) cl-asdf-3.0.3/test/test-touch-system-2.script000066400000000000000000000013211223164443400210130ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test system definition reloading if touched ;;; system that canNOT be found using *system-definition-search-functions* (defun system-registered-time (name) (let ((data (asdf::system-registered-p name))) (when data (car data)))) (defparameter test1.asd (nth-value 2 (locate-system :test1))) (assert-pathname-equal test1.asd (test-source "test1.asd")) (assert test1.asd) (setf asdf:*central-registry* nil) (load test1.asd) (assert (find-system :test1)) (defparameter date1 (system-registered-time :test1)) (assert date1) (touch-file test1.asd :timestamp date1 :offset +2) (find-system :test1) (defparameter date2 (system-registered-time :test1)) (assert date2) (assert (> date2 date1)) cl-asdf-3.0.3/test/test-try-recompiling-1.script000066400000000000000000000013621223164443400214770ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test asdf:try-recompiling restart (defparameter *caught-error* nil) (delete-file-if-exists (test-fasl "try-recompiling-1")) #-gcl (handler-bind ((error (lambda (c) (setf *caught-error* t) (multiple-value-bind (name mode) (find-symbol (symbol-name 'try-recompiling) :asdf) (assert (eq mode :external)) (let ((restart (find-restart name c))) #+(or) ;; debug (print (list c restart (compute-restarts c))) (when restart (invoke-restart restart))))))) (oos 'load-op 'try-recompiling-1)) #-gcl (assert *caught-error*) cl-asdf-3.0.3/test/test-urls-1.asd000066400000000000000000000001741223164443400166030ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-urls-1 :pathname #p"http://www.scieneer.com/files/" :components ((:file "test"))) cl-asdf-3.0.3/test/test-urls-1.script000066400000000000000000000023061223164443400173370ustar00rootroot00000000000000;;; -*- Lisp -*- #+scl (require :http-library) ;; Compare the source files with local versions before loading them. #+(and (or abcl scl) trust-the-net) (flet ((compare (url local) (with-open-file (stream1 url :element-type 'character :external-format :utf-8) (with-open-file (stream2 local :element-type 'character :external-format :utf-8) (loop (let ((ch1 (read-char stream1 nil nil)) (ch2 (read-char stream2 nil nil))) (unless (eql ch1 ch2) (error "Unexpected source content.")) (unless (and ch1 ch2) (return)))))))) (let* ((system (find-system "test-urls-1")) (url (asdf:component-pathname (asdf:find-component system "test")))) (compare url "test.lisp")) (load-system 'test-urls-1) ;; test that it compiled (let* ((path (component-pathname (find-component "test-urls-1" "test"))) (test (test-fasl path)) (test-date (file-write-date test))) (format t "~&test-urls-1 1: ~S ~S~%" test test-date) (assert test-date))) cl-asdf-3.0.3/test/test-urls-2.asd000066400000000000000000000001151223164443400165770ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-urls-2 :components ((:file "test"))) cl-asdf-3.0.3/test/test-urls-2.script000066400000000000000000000023121223164443400173350ustar00rootroot00000000000000;;; -*- Lisp -*- #+scl (require :http-library) (progn (setf asdf:*central-registry* '("http://www.scieneer.com/files/")) ;; Compare the source files with local versions before loading them. #+(and (or abcl scl) trust-the-net) (flet ((compare (url local) (with-open-file (stream1 url :element-type 'character :external-format :utf-8) (with-open-file (stream2 local :element-type 'character :external-format :utf-8) (loop (let ((ch1 (read-char stream1 nil nil)) (ch2 (read-char stream2 nil nil))) (unless (eql ch1 ch2) (error "Unexpected source content.")) (unless (and ch1 ch2) (return)))))))) (let ((url (system-definition-pathname "test-urls-2"))) (compare url "test-urls-2.asd")) (let* ((system (asdf:find-system "test-urls-2")) (url (component-pathname (find-component system "test")))) (compare url "test.lisp")) (load-system 'test-urls-2) ;; Test that it compiled (let* ((path (component-pathname (find-component "test-urls-2" "test"))) (test (test-fasl path)) (test-date (file-write-date test))) (format t "~&test-urls-2 1: ~S ~S~%" test test-date) (assert test-date)))) cl-asdf-3.0.3/test/test-utilities.script000066400000000000000000000247141223164443400202360ustar00rootroot00000000000000;;; -*- Lisp -*- (assert (every #'directory-pathname-p (list (make-pathname* :name nil :type "" :directory '(:absolute "tmp")) (make-pathname* :name "" :directory '(:absolute "tmp")) (make-pathname* :type "" :directory '(:absolute "tmp")) ;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here, ;; and some implementations will enforce it. (make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp")) (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")) (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))))) (assert (every (complement #'directory-pathname-p) (list (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp")) (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp"))))) ;; These are funky and non portable, omit from tests: ;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp")) ;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp")) (macrolet ((ts (x y) `(assert-equal (multiple-value-list (split-unix-namestring-directory-components ,@x)) ',y))) (ts ("" :ensure-directory t) (:relative nil nil nil)) (ts ("" :ensure-directory nil) (:relative nil nil nil)) (ts ("/" :ensure-directory t) (:absolute nil nil nil)) (ts ("/" :ensure-directory nil) (:absolute nil nil nil)) (ts ("/aa/ba" :ensure-directory t) (:absolute ("aa" "ba") nil nil)) (ts ("/aa/ba" :ensure-directory nil) (:absolute ("aa") "ba" nil))) (assert (version-satisfies (asdf-version) (asdf-version))) (assert (version-satisfies (asdf-version) "3.0")) (assert (version-satisfies (asdf-version) "2.0")) (assert (version<= "2.0" (asdf-version))) (assert (not (version-satisfies (asdf-version) "666"))) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar"))) '(#p"foo" #p"bar")) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t) '(#p"foo/" #p"bar/")) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t) '(#p"/foo" #p"/bar")) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t :ensure-directory t) '(#p"/foo/" #p"/bar/")) (assert-equal (mapcar 'location-function-p '((:function f) (:function (lambda (path absolute-source) (declare (ignore absolute-source)) path)) (function previous-isnt-keyword) (:function f too many arguments))) '(t t nil nil)) (initialize-source-registry '()) #| (unless (find-system :swank nil) (leave-test "Cannot find SWANK" 0)) (load-system :swank) ;;(setq swank-loader::*fasl-directory* (resolve-output "slime/")) ;;(ensure-directories-exist swank-loader::*fasl-directory*) ;;(DBG :foo swank-loader::*fasl-directory*) (swank-loader:init) |# (defparameter *ok-symbols* '(;; slots names asdf/action:accept asdf/action:action asdf/action:done-p asdf/action:stamp asdf/bundle:prologue-code asdf/bundle:build-args asdf/bundle:epilogue-code asdf/bundle:name-suffix asdf/component:absolute-pathname asdf/component:around-compile asdf/component:author asdf/component:children asdf/component:children-by-name asdf/component:components asdf/component:components-by-name asdf/component:default-component-class asdf/component:defsystem-depends-on asdf/component:description asdf/component:%encoding asdf/component:if-feature asdf/component:inline-methods asdf/component:in-order-to asdf/component:licence asdf/component:long-description asdf/component:maintainer asdf/component:name asdf/component:operation-times asdf/component:parent asdf/component:properties asdf/component:relative-pathname asdf/component:sideway-dependencies asdf/component:version asdf/lisp-action:flags asdf/operation:feature asdf/operation:original-initargs asdf/plan:index asdf/plan:forced asdf/plan:forced-not asdf/plan:planned-action-count asdf/plan:planned-output-action-count asdf/plan:planned-p asdf/plan:total-action-count asdf/plan:visited-actions asdf/plan:visiting-action-set asdf/plan:visiting-action-list asdf/system:bug-tracker asdf/system:build-pathname asdf/system:entry-point asdf/system:homepage asdf/system:long-name asdf/system:mailto asdf/system:source-control ;; restarts asdf/action:accept asdf/find-component:retry asdf/find-system:coerce-entry-to-directory asdf/find-system:remove-entry-from-registry asdf/lisp-action:try-recompiling ;; types asdf/bundle:user-system #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition ;; on some implementations only asdf/bundle:bundle-system asdf/bundle:register-pre-built-system asdf/bundle:static-library uiop/os:parse-file-location-info uiop/os:parse-windows-shortcut uiop/os:read-little-endian uiop/os:read-null-terminated-string ;; backward compatibility upgrade only asdf/backward-internals:make-sub-operation asdf/backward-interface:on-failure asdf/backward-interface:on-warnings asdf/find-system:contrib-sysdef-search asdf/find-system:sysdef-find-asdf )) (defun defined-symbol-p (symbol) (or (boundp symbol) (fboundp symbol) (macro-function symbol) (find-class symbol nil))) (defun fishy-exported-symbols (package &optional (ok-symbols *ok-symbols*)) (loop :for symbol :being :the external-symbols :of package :unless (or (defined-symbol-p symbol) ;;(symbol-call :swank :classify-symbol symbol) (member symbol ok-symbols)) :collect symbol)) (defun fishy-asdf-exported-symbols () (remove-duplicates (loop :for package :in (list-all-packages) :when (and (string-prefix-p "ASDF/" (package-name package)) (not (equal (package-name package) "ASDF/COMMON-LISP"))) :nconc (fishy-exported-symbols package)) :from-end t)) (assert-equal nil (fishy-asdf-exported-symbols)) (delete-package* :asdf-test-package-1) (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/c/")) (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/")) (ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/")) (register-directory *asdf-directory*) (register-directory *uiop-directory*) (copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/1.x")) (copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/b/2")) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))) (assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))) (assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))) (assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))) (delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/")) (assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))) (delete-directory-tree (subpathname *build-directory* "deleteme/") :validate (lambda (x) (and (<= 5 (length (pathname-directory x))) (subpathp x *build-directory*)))) (assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/")))) (assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/")))) (assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x")))) (assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))) #+(and sbcl sb-unicode) (assert +non-base-chars-exist-p+) #+(or clozure (and sbcl (not sb-unicode))) (assert (not +non-base-chars-exist-p+)) (assert (base-string-p (make-string 10 :element-type 'base-char))) (assert-equal "abcd" (strcat "a" nil "bc" "d")) (assert-equal "abcd" (reduce/strcat '("a" nil "bc" "d"))) (defparameter *last-char-code* (1- (or #+allegro excl:real-char-code-limit char-code-limit))) (defparameter *last-char* (code-char *last-char-code*)) (defparameter *last-char-string* (string *last-char*)) #-non-base-chars-exist-p (progn (assert (base-string-p (make-string 10 :element-type 'character))) (assert (typep *last-char* 'base-char))) (defun basify (s) (coerce s 'base-string)) (defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!) #+non-base-chars-exist-p (progn (assert (not (base-string-p *last-char-string*))) (assert (not (base-string-p (make-string 10 :element-type 'character)))) (assert (not (base-string-p (unbasify "abc")))) (assert (base-string-p (basify "abc"))) (assert (base-string-p (strcat "a" nil #\b (unbasify "cd")))) (assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd"))))) (assert (base-string-p (strcat (basify "ab") (basify "cd")))) (assert (not (base-string-p (strcat (basify "ab") #\c *last-char* (unbasify "d"))))) (assert (base-string-p (strcat (basify "ab") #\c #\d)))) (assert-equal +crlf+ (map 'string 'code-char '(13 10))) (assert-equal +lf+ (map 'string 'code-char '(10))) (assert-equal +cr+ (map 'string 'code-char '(13))) (defparameter acrlf (strcat "a" +crlf+)) (defparameter blf (strcat "b" +lf+)) (defparameter ccr (strcat "c" +cr+)) (macrolet ((ts (x y z) `(progn (assert-equal (list ,x ,y) (multiple-value-list (stripln ,z))) (assert-equal (strcat ,x ,y) ,z)))) (ts "a" +crlf+ acrlf) (ts "b" +lf+ blf) (ts "c" +cr+ ccr) (ts acrlf +crlf+ (strcat acrlf +crlf+)) (ts blf +cr+ (strcat blf +cr+)) (ts "c" +crlf+ (strcat ccr +lf+)) (ts (strcat acrlf "b") +lf+ (strcat acrlf blf))) (DBG :wtf-s) (with-temporary-file (:stream s :direction :io :prefix "LEP") (println "Hello, World" s) (file-position s 0) (assert-equal (read-line s) "Hello, World")) (DBG :wtf-p) (let ((pn (with-temporary-file (:pathname pn :direction :output :prefix "LEP") (assert-equal (read-file-lines pn) ()) pn))) (assert (not (probe-file pn)))) (DBG :wtf-s-p) (let ((pn (with-temporary-file (:stream s :pathname p :keep t :direction :io :prefix "LEP") (println "Hello, World" s) (DBG :wsp s p (probe-file p)) p))) (assert-equal (read-file-lines pn) '("Hello, World")) (delete-file pn)) cl-asdf-3.0.3/test/test-version.script000066400000000000000000000033241223164443400177020ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG "Check that there is an ASDF version that correctly parses to a non-empty list") (assert (consp (parse-version (asdf-version) 'error))) (DBG "Check that ASDF is newer than 1.234") (assert-compare (version<= "1.234" (asdf-version))) (DBG "Check that ASDF is not a compatible replacement for 1.234") (assert (not (version-compatible-p (asdf-version) "1.234"))) (DBG "Check that asdf.asd is not registered and we're using a fallback system") (defparameter *asdf* (find-system :asdf)) (assert-equal nil (system-source-directory *asdf*)) (DBG "Check that the fallback system bears the current asdf version") (assert-equal (asdf-version) (component-version *asdf*)) (def-test-system :versioned-system-1 :pathname #.*test-directory* :version "1.0") (def-test-system :versioned-system-2 :pathname #.*test-directory* :version "1.1") (def-test-system :versioned-system-3 :defsystem-depends-on ((:version :test-asdf/file2 "2.1")) :pathname #.*test-directory* :version "1.2") (def-test-system :versioned-system-file-form :defsystem-depends-on ((:version :test-asdf/file2 "2.1")) :pathname #.*test-directory* :version (:read-file-form "version.lisp-expr" :at 0)) (def-test-system :versioned-system-file-line :defsystem-depends-on ((:version :test-asdf/file2 "2.1")) :pathname #.*test-directory* :version (:read-file-line "version.lisp-expr" :at 1)) (defun vtest (name v &optional (true t)) (or (eq true (version-satisfies (find-system name) v)) (error "no satisfaction: ~S version ~A not ~A" name v true))) (vtest :versioned-system-1 "1.0") (vtest :versioned-system-2 "1.0") (vtest :versioned-system-3 "2.0" nil) (vtest :versioned-system-file-form "1.0") (vtest :versioned-system-file-line "1.0") cl-asdf-3.0.3/test/test-weakly-depends-on-present.script000066400000000000000000000021241223164443400232160ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Check to see if a weakly-depended-on system, which is present in the ;;; directory, actually gets loaded. ;;;--------------------------------------------------------------------------- (def-test-system test-weakly-depends-on-present :weakly-depends-on (file3-only) :components ((:file "file1"))) (DBG "Loading" (operate 'load-op 'test-weakly-depends-on-present)) (DBG "The weakly-depended-on system, file3-only, should be loaded...") (defparameter *file3* (test-fasl "file3")) (defparameter *file3-date* (file-write-date *file3*)) (DBG "test1 1" *file3* *file3-date*) (assert *file3-date*) (assert (symbol-value (find-symbol (symbol-name :*file3*) :test-package))) (DBG "The depending system (test-weakly-depends-on-present) loads successfully. [2011/12/14:rpg]") (defparameter *file1* (test-fasl "file1")) (defparameter *file1-date* (file-write-date *file1*)) (DBG "test1 2" *file1* *file1-date*) (assert *file1-date*) (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) cl-asdf-3.0.3/test/test-weakly-depends-on-unpresent.asd000066400000000000000000000001631223164443400230250ustar00rootroot00000000000000(defsystem test-weakly-depends-on-unpresent :weakly-depends-on (does-not-exist) :components ((:file "file1"))) cl-asdf-3.0.3/test/test-weakly-depends-on-unpresent.script000066400000000000000000000013161223164443400235630ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; This test verifies that if you have a system with a weakly-depends-on ;;; dependency, and the weakly-depended-on system is NOT THERE, the depending ;;; system will still load successfully. [2011/12/14:rpg] ;;;--------------------------------------------------------------------------- (asdf:load-system 'test-weakly-depends-on-unpresent) ;; test that it compiled (defparameter file1 (test-fasl "file1")) (defparameter file1-date (file-write-date file1)) (format t "~&test1 1: ~S ~S~%" file1 file1-date) (assert file1-date) ;; and loaded (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))) cl-asdf-3.0.3/test/test-xach-update-bug.script000066400000000000000000000036561223164443400212030ustar00rootroot00000000000000;;; -*- Lisp -*- (setf asdf/cache:*asdf-cache* nil) ;; disable cache between those two very different compilations. (defparameter foo :test-asdf-location-change) (DBG "load foo. Should load from xach-foo-1/") (setf *central-registry* (list (subpathname *test-directory* "xach-foo-1/"))) (defparameter foo1 (find-system foo)) (assert-pathname-equal (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (system-source-file foo1)) (assert-equal (mapcar 'component-name (component-children foo1)) '("a")) (assert-pathname-equal (subpathname *test-directory* "xach-foo-1/a.lisp") (component-pathname (find-component foo1 "a"))) (assert-equal nil (find-component foo1 "b")) (load-system foo) (defparameter loaded (find-symbol* :loaded :first-version)) (assert-equal (symbol-value loaded) t) (DBG "load foo again. Should not do anything -- already loaded") (setf (symbol-value loaded) :test-that-we-dont-reload) (load-system foo) (assert-equal (symbol-value loaded) :test-that-we-dont-reload) (assert (not (find-package :second-version))) (DBG "Now, change registry so foo is found from xach-foo-2/") (setf *central-registry* (list (subpathname *test-directory* "xach-foo-2/"))) (defparameter foo2 (find-system foo)) (assert (eq foo1 foo2)) ;; the object should be the same (assert-equal (mapcar 'component-name (component-children foo2)) '("a" "b")) (assert-pathname-equal (subpathname *test-directory* "xach-foo-2/test-asdf-location-change.asd") (system-source-file foo2)) (assert-pathname-equal (subpathname *test-directory* "xach-foo-2/a.lisp") (component-pathname (find-component foo2 "a"))) (assert-pathname-equal (subpathname *test-directory* "xach-foo-2/b.lisp") (component-pathname (find-component foo2 "b"))) (DBG "load foo yet again. It should see the pathname has changed and load it anew") (load-system foo) (assert (symbol-value (find-symbol* :loaded :second-version))) (assert-equal 42 (symbol-call :second-version :wtf)) cl-asdf-3.0.3/test/test.lisp000066400000000000000000000007211223164443400156600ustar00rootroot00000000000000;;;; Example lisp code. (in-package :asdf-test) (eval-when (:compile-toplevel) (format t "This is compile-time and the *read-base* is ~D~%" *read-base*)) (eval-when (:load-toplevel) (format t "This is load-time and the *read-base* is ~D~%" *read-base*)) (eval-when (:execute) (format t "This is execute-time and *read-base* is ~D~%" *read-base*)) (defun tst (x) (1+ x)) (defun add10 (x) (+ x 10)) (format t "(add10 0) is (in decimal) ~D~%" (add10 0)) cl-asdf-3.0.3/test/test1.asd000066400000000000000000000006761223164443400155520ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test1 :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1"))) #| 1) from clean, check that all fasl files build and that some function defined in the second file is present 2) delete the second fasl file, and build again. do test 1 again and also check the date on file1.fasl |# cl-asdf-3.0.3/test/test1.script000066400000000000000000000054551223164443400163070ustar00rootroot00000000000000;;; -*- Lisp -*- ;; We need use the pathnames used by ASDF. (defparameter test1.asd (system-source-file 'test1)) (defparameter file1.lisp (component-pathname (find-component 'test1 "file1"))) (defparameter file2.lisp (component-pathname (find-component 'test1 "file2"))) (assert-pathname-equal test1.asd (test-source "test1.asd")) ; unhappily, not usually equal. (assert-pathname-equal file1.lisp (test-source "file1.lisp")) ; unhappily, not usually equal. (assert-pathname-equal file2.lisp (test-source "file2.lisp")) ; unhappily, not usually equal. (defparameter *file1.out* (output-files 'compile-op '(test1 "file1"))) (defparameter *file2.out* (output-files 'compile-op '(test1 "file2"))) (defparameter file1.fasl (first *file1.out*)) (defparameter file2.fasl (first *file2.out*)) (assert-pathname-equal file1.fasl (test-fasl "file1")) (assert-pathname-equal file2.fasl (test-fasl "file2")) (defparameter *date* (- (file-write-date test1.asd) 3600)) (touch-file test1.asd :timestamp *date*) ;; touch test1.asd an hour back. (touch-file file1.lisp :timestamp *date* :offset 100) (touch-file file2.lisp :timestamp *date* :offset 200) (assert-equal (get-file-stamp file1.lisp) (+ *date* 100)) (assert-equal (get-file-stamp file2.lisp) (+ *date* 200)) (DBG "loading test1") (load-system 'test1) (defparameter *then* (file-write-date (first *file2.out*))) (assert-compare (<= (+ *date* 3600) *then*)) (DBG "test that it compiled" *date* *then*) (dolist (f (append *file1.out* *file2.out*)) (eval `(assert (probe-file ,f)))) (DBG "and loaded") (assert (asymval :*file1* :test-package)) (DBG "now remove file2 that depends-on file1") (dolist (f *file1.out*) (touch-file f :timestamp (+ *date* 500))) (assert-equal (+ *date* 500) (get-file-stamp file1.fasl)) (map () 'mark-file-deleted *file2.out*) (clear-system 'test1) (DBG "load again") ;;(trace input-files asdf::compute-action-stamp) (defparameter *plan* (nth-value 1 (operate 'load-op 'test1))) (DBG "check that file1 is _not_ recompiled, but file2 is") (assert (in-plan-p *plan* '(compile-op "test1" "file2"))) (assert (not (in-plan-p *plan* '(compile-op "test1" "file1")))) (assert-equal (+ *date* 500) (get-file-stamp file1.fasl)) (defparameter *before* (get-file-stamp file2.fasl)) (assert-compare (<= *then* *before*)) (DBG "now touch file1 and check that file2 _is_ also recompiled") ;; XXX run-shell-command loses if *default-pathname-defaults* is not the ;; unix cwd. this is not a problem for run-tests.sh, but can be in general (touch-file file1.lisp :timestamp (+ *date* 3000)) ;; touch file1 a minute ago. (dolist (f *file2.out*) (touch-file f :timestamp (+ *date* 2000))) ;; touch file2.fasl some time before. (asdf:clear-system 'test1) (asdf:operate 'asdf:load-op 'test1) (DBG :foo (file-write-date file2.fasl) *before*) (assert-compare (>= (file-write-date file2.fasl) *before*)) cl-asdf-3.0.3/test/test2.asd000066400000000000000000000004371223164443400155460ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test2b :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")) :depends-on (version 'test2a "1.1")) cl-asdf-3.0.3/test/test2.script000066400000000000000000000013651223164443400163040ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG "test2: loading test2b1") (asdf:load-system 'test2b1) (DBG "test2: file3 and file4 were compiled") (assert (and (probe-file (test-fasl "file3.lisp")) (probe-file (test-fasl "file4.lisp")))) (DBG "test2: loading test2b2 should fail") #-gcl (handler-case (asdf:load-system 'test2b2) (asdf:missing-dependency (c) (format t "load failed as expected: - ~%~A~%" c)) (:no-error (c) (declare (ignore c)) (error "should have failed, oops"))) (DBG "test2: loading test2b3 should fail") #-gcl (handler-case (asdf:load-system 'test2b3) (asdf:missing-dependency (c) (format t "load failed as expected: - ~%~A~%" c)) (:no-error (c) (declare (ignore c)) (error "should have failed, oops"))) cl-asdf-3.0.3/test/test2a.asd000066400000000000000000000004451223164443400157060ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test2a :version "1.1" :components ((:file "file4" :in-order-to ((compile-op (load-op "file3")) (load-op (load-op "file3")))) (:file "file3"))) #| this system is referenced by test2b[12] |# cl-asdf-3.0.3/test/test2b1.asd000066400000000000000000000004671223164443400157740ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test2b1 :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")) :in-order-to ((load-op (load-op (:version test2a "1.1"))))) cl-asdf-3.0.3/test/test2b2.asd000066400000000000000000000004711223164443400157700ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test2b2 :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")) :in-order-to ((load-op (load-op (:version test2a "1.2"))))) cl-asdf-3.0.3/test/test2b3.asd000066400000000000000000000004411223164443400157660ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test2b3 :version "1.0" :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")) :depends-on (bet-you-cant-find-this)) cl-asdf-3.0.3/test/test3.asd000066400000000000000000000002031223164443400155360ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem test3 :components ((:file "file1" :if-feature :asdf) (:file "file2" :if-feature (:not :asdf)))) cl-asdf-3.0.3/test/test3.script000066400000000000000000000010251223164443400162760ustar00rootroot00000000000000;;; -*- Lisp -*- (defparameter *fasl1* (test-fasl "file1.lisp")) (defparameter *fasl2* (test-fasl "file2.lisp")) (delete-file-if-exists *fasl1*) (delete-file-if-exists *fasl2*) (DBG "should load file1 but not file2") ;;; Use REQUIRE where we boast integration, load-system where not. (if (or #+(or abcl clozure cmu ecl mkcl sbcl) t #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)) (funcall 'require :test3) (load-system :test3)) (assert (probe-file *fasl1*)) (assert (not (probe-file *fasl2*))) cl-asdf-3.0.3/test/test8.script000066400000000000000000000007321223164443400163070ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; make sure we get a missing-component error (in-package :asdf-test) (handler-case (asdf:oos 'asdf:load-op 'system-does-not-exist) (asdf:missing-component-of-version (c) (declare (ignore c)) (error "Should not have gotten 'missing-component-of-version, dang")) (asdf:missing-component (c) (format t "got missing-component as expected: - ~%~A~%" c)) (:no-error (c) (declare (ignore c)) (error "should have failed, oops"))) cl-asdf-3.0.3/test/test9-1.asd000066400000000000000000000002151223164443400157050ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test9-1 :version "1.1" :components ((:file "file1")) :depends-on ((:version :test9-2 "2.0"))) cl-asdf-3.0.3/test/test9-2.asd000066400000000000000000000001411223164443400157040ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test9-2 :version "1.0" :components ((:file "file2"))) cl-asdf-3.0.3/test/test9.script000066400000000000000000000006541223164443400163130ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; make sure we get a missing-component-of-version error (progn (handler-case (load-test-system :test-asdf/test9-1) (asdf:missing-component-of-version (c) (format t "got missing-component-of-version as expected: - ~%~A~%" c)) (:no-error (c) (declare (ignore c)) (error "should have failed, oops"))) (load-test-system :test-asdf/test9-3)) ; positive case, to make sure. cl-asdf-3.0.3/test/try-recompiling-1.asd000066400000000000000000000001331223164443400177600ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem try-recompiling-1 :components ((:file "try-recompiling-1"))) cl-asdf-3.0.3/test/try-recompiling-1.lisp000066400000000000000000000002601223164443400201610ustar00rootroot00000000000000(in-package :asdf-test) #+clisp (eval-when (:compile-toplevel) (fmakunbound 'try-recompiling-1)) (defun try-recompiling-1 () (assert *caught-error*)) (try-recompiling-1) cl-asdf-3.0.3/test/try-reloading-1.asd000066400000000000000000000002031223164443400174120ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem try-reloading-1 :components ((:file "file1")) :depends-on ("try-reloading-dependency")) cl-asdf-3.0.3/test/try-reloading-dependency.hidden000066400000000000000000000001261223164443400220600ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem try-reloading-dependency :components ((:file "file3"))) cl-asdf-3.0.3/test/unintern-foo.lisp000066400000000000000000000003511223164443400173230ustar00rootroot00000000000000(eval-when (:compile-toplevel :load-toplevel :execute) (when (find-package :asdf-test/deferred-warnings) (delete-package :asdf-test/deferred-warnings))) (defpackage :asdf-test/deferred-warnings (:use :uiop :uiop/common-lisp)) cl-asdf-3.0.3/test/use-foo.lisp000066400000000000000000000003361223164443400162600ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defun use-foo (x) (foo x)) #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) (format t "~&~S~%" `(sys::*unknown-functions* ,sys::*unknown-functions*))) cl-asdf-3.0.3/test/use-setf-foo.lisp000066400000000000000000000007001223164443400172120ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defclass () ()) (defun use-setf-foo (v x) (setf (foo x) v)) (defmethod gf ((x ) (y (eql (+ 1 1)))) (setf (foo (make-instance ')) #(1 2 3 4))) (defmethod (setf gf) (value (x ) (y (eql (+ 1 1)))) (setf (foo x) (+ y value))) #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) (format t "~&~S~%" `(sys::*unknown-functions* ,sys::*unknown-functions*))) cl-asdf-3.0.3/test/version.lisp-expr000066400000000000000000000000121223164443400173330ustar00rootroot00000000000000"1.0" 1.0 cl-asdf-3.0.3/test/wild-module.script000066400000000000000000000003721223164443400174620ustar00rootroot00000000000000;;; -*- Lisp -*- (progn (load (asdf::subpathname *asdf-directory* "contrib/wild-modules.lisp")) (def-test-system :wild-module :version "0.0" :components ((:wild-module "systems" :pathname #p"*.asd"))) #-gcl2.6 (load-system :wild-module)) cl-asdf-3.0.3/test/xach-foo-1/000077500000000000000000000000001223164443400156525ustar00rootroot00000000000000cl-asdf-3.0.3/test/xach-foo-1/a.lisp000066400000000000000000000002021223164443400167550ustar00rootroot00000000000000;;;; a.lisp (defpackage :first-version (:use #:cl) (:export #:loaded)) (in-package :first-version) (defparameter loaded t) cl-asdf-3.0.3/test/xach-foo-1/test-asdf-location-change.asd000066400000000000000000000001431223164443400232640ustar00rootroot00000000000000;;;; foo.asd (asdf:defsystem #:test-asdf-location-change :serial t :components ((:file "a"))) cl-asdf-3.0.3/test/xach-foo-2/000077500000000000000000000000001223164443400156535ustar00rootroot00000000000000cl-asdf-3.0.3/test/xach-foo-2/a.lisp000066400000000000000000000002151223164443400167620ustar00rootroot00000000000000;;;; a.lisp (defpackage :second-version (:use #:cl) (:export #:loaded #:wtf)) (in-package :second-version) (defparameter loaded t) cl-asdf-3.0.3/test/xach-foo-2/b.lisp000066400000000000000000000000771223164443400167710ustar00rootroot00000000000000;;;; b.lisp (in-package :second-version) (defun wtf () 42) cl-asdf-3.0.3/test/xach-foo-2/test-asdf-location-change.asd000066400000000000000000000001761223164443400232730ustar00rootroot00000000000000;;;; foo.asd (asdf:defsystem #:test-asdf-location-change :serial t :components ((:file "a") (:file "b"))) cl-asdf-3.0.3/test/xach-foofail/000077500000000000000000000000001223164443400163505ustar00rootroot00000000000000cl-asdf-3.0.3/test/xach-foofail/foofail.lisp000066400000000000000000000006121223164443400206570ustar00rootroot00000000000000(require 'asdf) (let ((*default-pathname-defaults* (make-pathname :name nil :type nil :defaults *load-truename*))) (push (merge-pathnames #p"foo-1/") asdf:*central-registry*) (asdf:load-system "foo") (push (merge-pathnames #p"foo-2/") asdf:*central-registry*) (asdf:load-system "foo")) cl-asdf-3.0.3/uiop/000077500000000000000000000000001223164443400140055ustar00rootroot00000000000000cl-asdf-3.0.3/uiop/README000066400000000000000000000124761223164443400146770ustar00rootroot00000000000000UIOP the Utilities for Implementation- and OS- Portability ========================================================== UIOP is the portability layer of ASDF. It provides utilities that abstract over discrepancies between implementations, between operating systems, and between what the standard provides and what programmers actually need, to write portable Common Lisp programs. It is organized by topic in many files, each of which defines its own package according to its topic: e.g pathname.lisp will define package UIOP/PATHNAME and contain utilities related to the handling of pathname objects. All exported symbols are reexported in a convenience package UIOP. The files that constitute UIOP are, in loading order: * package: to deal with packages and their symbols, most notably including DEFINE-PACKAGE, a variant of defpackage capable of hot-upgrade. * common-lisp: to let you paper over various sub-standard implementations. Big offenders are Corman, GCL, Genera, MCL, all of them unmaintained. Supported without serious issues are: ABCL, Allegro, CCL, CMUCL, CLISP, ECL, LispWorks, MKCL, SBCL, XCL. * utility: to provide macros and functions that do not involve I/O, handling control-flow, (p)lists, characters, strings, functions, classes, conditions, "stamps" (real number or boolean for +/- infinity), versions, etc. It also sports uiop-debug, a useful tool to help you debug programs. * os: to extract information from your environment, including an API identifier, unix vs windows, getenv, hostname, getcwd and chdir, etc. * pathname: to survive the gruesome non-portability trap that are CL pathnames (and their lovecraftian "logical" variant), offering a vast array of functions and a sensible, usable abstraction to specify relative pathnames. * filesystem: to provide portable access to the filesystem, inspecting it, only using truename when desired, using native OS namestrings, atomic file renaming, creating or deleting directories, etc. * stream: to portably deal with character encodings (external formats), element types, safe READing and WRITEing, opening files or temporary files, providing FORMAT-like designators for streams, flushing output buffers, consuming or copying streams, concatenating files, copying files, etc. * image: to portably deal with images, dumping them, restoring from them, registering hooks to run at suitable events in the image lifetime, printing backtraces, handling fatal conditions, using or avoiding debug modes, accessing command line arguments or quitting the process. * run-program: to portably spawn external processes and capture their output. Can also capture error-output, inject input, or let it all be interactive. * lisp-build: to portably compile common-lisp code, handle compilation results, muffle uninteresting conditions, save and restore deferred warnings, run hooks around compilation (to e.g. control optimizations or syntax), identify the pathname of the current file, combine FASLs, etc. * configuration: to write portable configuration files, using best practices to define and validate syntax, search standard paths, let users specify pathnames or pathname patterns, etc. * backward-driver: to provide backward-compatibility with earlier incarnations of this library (i.e. ASDF internals that have leaked, or ASDF-UTILS) * driver: to reexport all the above utilities in a single package UIOP. Documentation ------------- Each file starts with a package definition form that lists the exported symbols. All the exported functions, macros and variables ought to have proper docstrings. If not, then it's a legitimate bug that we invite you to report. Maybe some automated tool will extract all that information and make a webpage from it, at which point it would be nice to insert a link here. Unhappily, at the time of this writing, quickdocs only extracts information from the first package:: http://quickdocs.org/uiop/api Using UIOP ---------- UIOP is part of ASDF 3, and any modern Common Lisp implementation will have all of UIOP available when you (require "asdf"). NB: (require :asdf) also works on all implementations but CLISP. If you need some functionality only available in a recent version of UIOP, but cannot or will not upgrade ASDF, UIOP is also distributed separately; see e.g. in Quicklisp. You may then have to load it like any other library:: (asdf:load-system :uiop) If you want to use UIOP while preserving compatibility with ASDF 2, we recommend that in your ASDF system definition you may use the like of:: :depends-on (#-asdf3 :uiop) Some history ------------ UIOP, formerly known as ASDF-DRIVER (the package and system nicknames live on), evolved from ASDF 2's internal utilities and portability layer. It has since fully superseded functionality from the following libraries: ASDF-UTILS (UIOP carries on the ASDF 2 utilities that this exported), CL-FAD (UIOP's pathname and filesystem functions are much more portable), CL-LAUNCH (UIOP took its image and command-line argument handling from it), EXTERNAL-PROGRAM, TRIVIAL-SHELL and XCVB-DRIVER (UIOP's run-program is better), SLIME's swank-loader (UIOP has better compilation and API identification), TRIVIAL-BACKTRACE (UIOP/IMAGE has all of it and more), etc. UIOP also captures a large subset of the functionality from TRIVIAL-FEATURES, and a small subset of the functionality from ALEXANDRIA. cl-asdf-3.0.3/uiop/asdf-driver.asd000066400000000000000000000001041223164443400166770ustar00rootroot00000000000000;;; -*- mode: lisp -*- (defsystem :asdf-driver :depends-on (:uiop)) cl-asdf-3.0.3/uiop/backward-driver.lisp000066400000000000000000000036261223164443400177540ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;; Hacks for backward-compatibility of the driver (uiop/package:define-package :uiop/backward-driver (:nicknames :asdf/backward-driver) (:recycle :uiop/backward-driver :asdf/backward-driver :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration) (:export #:coerce-pathname #:component-name-to-pathname-components #+(or ecl mkcl) #:compile-file-keeping-object )) (in-package :uiop/backward-driver) ;;;; Backward compatibility with various pathname functions. (with-upgradability () (defun coerce-pathname (name &key type defaults) ;; For backward-compatibility only, for people using internals ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb ;; Will be removed after 2014-01-16. ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") (parse-unix-namestring name :type type :defaults defaults)) (defun component-name-to-pathname-components (unix-style-namestring &key force-directory force-relative) ;; Will be removed after 2014-01-16. ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS") (multiple-value-bind (relabs path filename file-only) (split-unix-namestring-directory-components unix-style-namestring :ensure-directory force-directory) (declare (ignore file-only)) (when (and force-relative (not (eq relabs :relative))) (error (compatfmt "~@") unix-style-namestring)) (values relabs path filename))) #+(or ecl mkcl) (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))) cl-asdf-3.0.3/uiop/common-lisp.lisp000066400000000000000000000234031223164443400171350ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Handle compatibility with multiple implementations. ;;; This file is for papering over the deficiencies and peculiarities ;;; of various Common Lisp implementations. ;;; For implementation-specific access to the system, see os.lisp instead. ;;; A few functions are defined here, but actually exported from utility; ;;; from this package only common-lisp symbols are exported. (uiop/package:define-package :uiop/common-lisp (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package) (:reexport :common-lisp) (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp (:export #:logical-pathname #:translate-logical-pathname #:make-broadcast-stream #:file-namestring) #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!) #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*) #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist) #+mcl (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. ;;;; Early meta-level tweaks #+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl) (eval-when (:load-toplevel :compile-toplevel :execute) ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (when (and #+allegro (member :ics *features*) #+(or clisp cmu ecl mkcl) (member :unicode *features*) #+sbcl (member :sb-unicode *features*)) (pushnew :asdf-unicode *features*))) #+allegro (eval-when (:load-toplevel :compile-toplevel :execute) (defparameter *acl-warn-save* (when (boundp 'excl:*warn-on-nested-reader-conditionals*) excl:*warn-on-nested-reader-conditionals*)) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* nil)) (setf *print-readably* nil)) #+clozure (in-package :ccl) #+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117 (eval-when (:load-toplevel :compile-toplevel :execute) (unless (fboundp 'external-process-wait) (in-development-mode (defun external-process-wait (proc) (when (and (external-process-pid proc) (eq (external-process-%status proc) :running)) (with-interrupts-enabled (wait-on-semaphore (external-process-completed proc)))) (values (external-process-%exit-code proc) (external-process-%status proc)))))) #+clozure (in-package :uiop/common-lisp) #+cormanlisp (eval-when (:load-toplevel :compile-toplevel :execute) (deftype logical-pathname () nil) (defun make-broadcast-stream () *error-output*) (defun translate-logical-pathname (x) x) (defun user-homedir-pathname (&optional host) (declare (ignore host)) (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) (defun file-namestring (p) (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) #+ecl (eval-when (:load-toplevel :compile-toplevel :execute) (setf *load-verbose* nil) (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) (unless (use-ecl-byte-compiler-p) (require :cmp))) #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :ansi-cl *features*) (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) (setf compiler::*compiler-default-type* (pathname "") compiler::*lsp-ext* "")) #+gcl2.6 (eval-when (:compile-toplevel :load-toplevel :execute) (shadow 'type-of :uiop/common-lisp) (shadowing-import 'system:*load-pathname* :uiop/common-lisp)) #+gcl2.6 (eval-when (:compile-toplevel :load-toplevel :execute) (export 'type-of :uiop/common-lisp) (export 'system:*load-pathname* :uiop/common-lisp)) #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations. (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *gcl2.6* t) (deftype logical-pathname () nil) (defun type-of (x) (class-name (class-of x))) (defun wild-pathname-p (path) (declare (ignore path)) nil) (defun translate-logical-pathname (x) x) (defvar *compile-file-pathname* nil) (defun pathname-match-p (in-pathname wild-pathname) (declare (ignore in-wildname wild-wildname)) nil) (defun translate-pathname (source from-wildname to-wildname &key) (declare (ignore from-wildname to-wildname)) source) (defun %print-unreadable-object (object stream type identity thunk) (format stream "#<~@[~S ~]" (when type (type-of object))) (funcall thunk) (format stream "~@[ ~X~]>" (when identity (system:address object)))) (defmacro with-standard-io-syntax (&body body) `(progn ,@body)) (defmacro with-compilation-unit (options &body body) (declare (ignore options)) `(progn ,@body)) (defmacro print-unreadable-object ((object stream &key type identity) &body body) `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body))) (defun ensure-directories-exist (path) (lisp:system (format nil "mkdir -p ~S" (namestring (make-pathname :name nil :type nil :version nil :defaults path)))))) #+genera (eval-when (:load-toplevel :compile-toplevel :execute) (unless (fboundp 'ensure-directories-exist) (defun ensure-directories-exist (path) (fs:create-directories-recursively (pathname path))))) #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick (read-from-string "(eval-when (:load-toplevel :compile-toplevel :execute) (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) (ccl:define-entry-point (_system \"system\") ((name :string)) :int) ;; Note: ASDF may expect user-homedir-pathname to provide ;; the pathname of the current user's home directory, whereas ;; MCL by default provides the directory from which MCL was started. ;; See http://code.google.com/p/mcl/wiki/Portability (defun user-homedir-pathname () (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) (defun probe-posix (posix-namestring) \"If a file exists for the posix namestring, return the pathname\" (ccl::with-cstrs ((cpath posix-namestring)) (ccl::rlet ((is-dir :boolean) (fsref :fsref)) (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) (ccl::%path-from-fsref fsref is-dir))))))")) #+mkcl (eval-when (:load-toplevel :compile-toplevel :execute) (require :cmp) (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics ;;;; Looping (eval-when (:load-toplevel :compile-toplevel :execute) (defmacro loop* (&rest rest) #-genera `(loop ,@rest) #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh. ;;;; compatfmt: avoid fancy format directives when unsupported (eval-when (:load-toplevel :compile-toplevel :execute) (defun frob-substrings (string substrings &optional frob) "for each substring in SUBSTRINGS, find occurrences of it within STRING that don't use parts of matched occurrences of previous strings, and FROB them, that is to say, remove them if FROB is NIL, replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, call FROB with the match and a function that emits a string in the output. Return a string made of the parts not omitted or emitted by FROB." (declare (optimize (speed 0) (safety 3) (debug 3))) (let ((length (length string)) (stream nil)) (labels ((emit-string (x &optional (start 0) (end (length x))) (when (< start end) (unless stream (setf stream (make-string-output-stream))) (write-string x stream :start start :end end))) (emit-substring (start end) (when (and (zerop start) (= end length)) (return-from frob-substrings string)) (emit-string string start end)) (recurse (substrings start end) (cond ((>= start end)) ((null substrings) (emit-substring start end)) (t (let* ((sub-spec (first substrings)) (sub (if (consp sub-spec) (car sub-spec) sub-spec)) (fun (if (consp sub-spec) (cdr sub-spec) frob)) (found (search sub string :start2 start :end2 end)) (more (rest substrings))) (cond (found (recurse more start found) (etypecase fun (null) (string (emit-string fun)) (function (funcall fun sub #'emit-string))) (recurse substrings (+ found (length sub)) end)) (t (recurse more start end)))))))) (recurse substrings 0 length)) (if stream (get-output-stream-string stream) ""))) (defmacro compatfmt (format) #+(or gcl genera) (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) #-(or gcl genera) format)) cl-asdf-3.0.3/uiop/configuration.lisp000066400000000000000000000356001223164443400175510ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Generic support for configuration files (uiop/package:define-package :uiop/configuration (:nicknames :asdf/configuration) (:recycle :uiop/configuration :asdf/configuration :asdf) (:use :uiop/common-lisp :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export #:get-folder-path #:user-configuration-directories #:system-configuration-directories #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory #:configuration-inheritance-directive-p #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) (in-package :uiop/configuration) (with-upgradability () (define-condition invalid-configuration () ((form :reader condition-form :initarg :form) (location :reader condition-location :initarg :location) (format :reader condition-format :initarg :format) (arguments :reader condition-arguments :initarg :arguments :initform nil)) (:report (lambda (c s) (format s (compatfmt "~@<~? (will be skipped)~@:>") (condition-format c) (list* (condition-form c) (condition-location c) (condition-arguments c)))))) (defun get-folder-path (folder) "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path, this function tries to locate the Windows FOLDER for one of :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA." (or #+(and lispworks mswindows) (sys:get-folder-path folder) ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData (ecase folder (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) (:appdata (getenv-absolute-directory "APPDATA")) (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) (defun user-configuration-directories () "Determine user configuration directories" (let ((dirs `(,@(when (os-unix-p) (cons (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/") (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) ,(subpathname (user-homedir-pathname) ".config/common-lisp/")))) (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))) (defun system-configuration-directories () "Determine system user configuration directories" (cond ((os-unix-p) '(#p"/etc/common-lisp/")) ((os-windows-p) (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")) (list it))))) (defun in-first-directory (dirs x &key (direction :input)) "Determine system user configuration directories" (loop :with fun = (ecase direction ((nil :input :probe) 'probe-file*) ((:output :io) 'identity)) :for dir :in dirs :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x))))) (defun in-user-configuration-directory (x &key (direction :input)) "return pathname under user configuration directory, subpathname X" (in-first-directory (user-configuration-directories) x :direction direction)) (defun in-system-configuration-directory (x &key (direction :input)) "return pathname under system configuration directory, subpathname X" (in-first-directory (system-configuration-directories) x :direction direction)) (defun configuration-inheritance-directive-p (x) "Is X a configuration inheritance directive?" (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) (or (member x kw) (and (length=n-p x 1) (member (car x) kw))))) (defun report-invalid-form (reporter &rest args) "Report an invalid form according to REPORTER and various ARGS" (etypecase reporter (null (apply 'error 'invalid-configuration args)) (function (apply reporter args)) ((or symbol string) (apply 'error reporter args)) (cons (apply 'apply (append reporter args))))) (defvar *ignored-configuration-form* nil "Have configuration forms been ignored while parsing the configuration?") (defun validate-configuration-form (form tag directive-validator &key location invalid-form-reporter) "Validate a configuration FORM" (unless (and (consp form) (eq (car form) tag)) (setf *ignored-configuration-form* t) (report-invalid-form invalid-form-reporter :form form :location location) (return-from validate-configuration-form nil)) (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) :for directive :in (cdr form) :when (cond ((configuration-inheritance-directive-p directive) (incf inherit) t) ((eq directive :ignore-invalid-entries) (setf ignore-invalid-p t) t) ((funcall directive-validator directive) t) (ignore-invalid-p nil) (t (setf *ignored-configuration-form* t) (report-invalid-form invalid-form-reporter :form directive :location location) nil)) :do (push directive x) :finally (unless (= inherit 1) (report-invalid-form invalid-form-reporter :arguments (list (compatfmt "~@") :inherit-configuration :ignore-inherited-configuration))) (return (nreverse x)))) (defun validate-configuration-file (file validator &key description) "Validate a configuration file for conformance of its form with the validator function" (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error (compatfmt "~@~%") description forms)) (funcall validator (car forms) :location file))) (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter) "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will be applied to the results to yield a configuration form. Current values of TAG include :source-registry and :output-translations." (let ((files (sort (ignore-errors (remove-if 'hidden-pathname-p (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) #'string< :key #'namestring))) `(,tag ,@(loop :for file :in files :append (loop :with ignore-invalid-p = nil :for form :in (read-file-forms file) :when (eq form :ignore-invalid-entries) :do (setf ignore-invalid-p t) :else :when (funcall validator form) :collect form :else :when ignore-invalid-p :do (setf *ignored-configuration-form* t) :else :do (report-invalid-form invalid-form-reporter :form form :location file))) :inherit-configuration))) (defun resolve-relative-location (x &key ensure-directory wilden) "Given a designator X for an relative location, resolve it to a pathname" (ensure-pathname (etypecase x (pathname x) (string (parse-unix-namestring x :ensure-directory ensure-directory)) (cons (if (null (cdr x)) (resolve-relative-location (car x) :ensure-directory ensure-directory :wilden wilden) (let* ((car (resolve-relative-location (car x) :ensure-directory t :wilden nil))) (merge-pathnames* (resolve-relative-location (cdr x) :ensure-directory ensure-directory :wilden wilden) car)))) ((eql :*/) *wild-directory*) ((eql :**/) *wild-inferiors*) ((eql :*.*.*) *wild-file*) ((eql :implementation) (parse-unix-namestring (implementation-identifier) :ensure-directory t)) ((eql :implementation-type) (parse-unix-namestring (string-downcase (implementation-type)) :ensure-directory t)) ((eql :hostname) (parse-unix-namestring (hostname) :ensure-directory t))) :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) :want-relative t)) (defvar *here-directory* nil "This special variable is bound to the currect directory during calls to PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here directive.") (defvar *user-cache* nil "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") (defun compute-user-cache () "Compute the location of the default user-cache for translate-output objects" (setf *user-cache* (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) (when (os-windows-p) (try (or (get-folder-path :local-appdata) (get-folder-path :appdata)) "common-lisp" "cache" :implementation)) '(:home ".cache" "common-lisp" :implementation))))) (register-image-restore-hook 'compute-user-cache) (defun resolve-absolute-location (x &key ensure-directory wilden) "Given a designator X for an absolute location, resolve it to a pathname" (ensure-pathname (etypecase x (pathname x) (string (let ((p #-mcl (parse-namestring x) #+mcl (probe-posix x))) #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) (if ensure-directory (ensure-directory-pathname p) p))) (cons (return-from resolve-absolute-location (if (null (cdr x)) (resolve-absolute-location (car x) :ensure-directory ensure-directory :wilden wilden) (merge-pathnames* (resolve-relative-location (cdr x) :ensure-directory ensure-directory :wilden wilden) (resolve-absolute-location (car x) :ensure-directory t :wilden nil))))) ((eql :root) ;; special magic! we return a relative pathname, ;; but what it means to the output-translations is ;; "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location (let ((p (make-pathname* :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location (or *here-directory* (pathname-directory-pathname (load-pathname))) :ensure-directory t :wilden nil)) ((eql :user-cache) (resolve-absolute-location *user-cache* :ensure-directory t :wilden nil))) :wilden (and wilden (not (pathnamep x))) :resolve-symlinks *resolve-symlinks* :want-absolute t)) ;; Try to override declaration in previous versions of ASDF. (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) (:ensure-directory boolean)) t) resolve-location)) (defun* (resolve-location) (x &key ensure-directory wilden directory) "Resolve location designator X into a PATHNAME" ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory (loop* :with dirp = (or directory ensure-directory) :with (first . rest) = (if (atom x) (list x) x) :with path = (resolve-absolute-location first :ensure-directory (and (or dirp rest) t) :wilden (and wilden (null rest))) :for (element . morep) :on rest :for dir = (and (or morep dirp) t) :for wild = (and wilden (not morep)) :for sub = (merge-pathnames* (resolve-relative-location element :ensure-directory dir :wilden wild) path) :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub)) :finally (return path))) (defun location-designator-p (x) "Is X a designator for a location?" (flet ((absolute-component-p (c) (typep c '(or string pathname (member :root :home :here :user-cache)))) (relative-component-p (c) (typep c '(or string pathname (member :*/ :**/ :*.*.* :implementation :implementation-type))))) (or (typep x 'boolean) (absolute-component-p x) (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) (defun location-function-p (x) "Is X the specification of a location function?" (and (length=n-p x 2) (eq (car x) :function))) (defvar *clear-configuration-hook* '()) (defun register-clear-configuration-hook (hook-function &optional call-now-p) "Register a function to be called when clearing configuration" (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) (defun clear-configuration () "Call the functions in *CLEAR-CONFIGURATION-HOOK*" (call-functions *clear-configuration-hook*)) (register-image-dump-hook 'clear-configuration) (defun upgrade-configuration () "If a previous version of ASDF failed to read some configuration, try again now." (when *ignored-configuration-form* (clear-configuration) (setf *ignored-configuration-form* nil)))) cl-asdf-3.0.3/uiop/contrib/000077500000000000000000000000001223164443400154455ustar00rootroot00000000000000cl-asdf-3.0.3/uiop/contrib/debug.lisp000066400000000000000000000121151223164443400174240ustar00rootroot00000000000000;;;;; A few essential debugging utilities by Faré, ;;;;; to be loaded in the *PACKAGE* that you wish to debug. ;; ;; We want debugging utilities in the _current_ package, ;; so we don't have to either change the package structure ;; or use heavy package prefixes everywhere. ;; ;; The short names of symbols below are unlikely to clash ;; with global bindings of any well-designed source file being debugged, ;; yet are quite practical in a debugging session. #| ;;; If ASDF is already loaded, ;;; you can load these utilities in the current package as follows: (uiop:uiop-debug) ;; which is the same as: (uiop/utility:uiop-debug) ;; The above macro can be configured to load any other debugging utility ;; that you may prefer to this one, with your customizations, ;; by setting the variable ;; uiop/utility:*uiop-debug-utility* ;; to a form that evaluates to a designator of the pathname to your file. ;; For instance, on a home directory shared via NFS with different names ;; on different machines, with your debug file in ~/lisp/debug-utils.lisp ;; you could in your ~/.sbclrc have the following configuration setting: (require :asdf) (setf uiop/utility:*uiop-debug-utility* '(uiop/pathname:subpathname (uiop/os:user-homedir) "lisp/debug-utils.lisp")) ;;; If ASDF is not loaded (for instance, when debugging ASDF itself), ;;; Try the below, fixing the pathname to point to this file: (eval-when (:compile-toplevel :load-toplevel :execute) (let ((kw (read-from-string (format nil ":DBG-~A" (package-name *package*))))) (unless (member kw *features*) (load "/home/tunes/cl/asdf/contrib/debug.lisp")))) |# ;;; Here we define the magic package-dependent feature. ;;; With it, you should be able to use #+DBG-/PACKAGE-NAME/ ;;; to annotate your debug statements, e.g. upper-case #+DBG-ASDF ;;; This will be all upper-case even in lower-case lisps. (eval-when (:compile-toplevel :load-toplevel :execute) (let ((kw (read-from-string (format nil ":DBG-~:@(~A~)" (package-name *package*))))) (pushnew kw *features*))) ;;; Now for the debugging stuff itself. ;;; First, my all-purpose print-debugging macro (defmacro DBG (tag &rest exprs) "simple debug statement macro: TAG is typically a constant string or keyword, but in general is an expression returning a tag to be printed first; if the expression returns NIL, nothing is printed. EXPRS are expressions, which when the TAG was not NIL are evaluated in order, with their source code then their return values being printed each time. The last expresion is *always* evaluated and its values are returned, but its source and return values are only printed if TAG was not NIL; previous expressions are not evaluated at all if TAG returned NIL. The macro expansion has relatively low overhead in space of time." (let* ((last-expr (car (last exprs))) (other-exprs (butlast exprs)) (tag-var (gensym "TAG")) (thunk-var (gensym "THUNK"))) `(let ((,tag-var ,tag)) (flet ,(when exprs `((,thunk-var () ,last-expr))) (if ,tag-var (DBG-helper ,tag-var (list ,@(loop :for x :in other-exprs :collect `(cons ',x #'(lambda () ,x)))) ',last-expr ,(if exprs `#',thunk-var nil)) ,(if exprs `(,thunk-var) '(values))))))) (defun DBG-helper (tag expressions-thunks last-expression last-thunk) ;; Helper for the above debugging macro (labels ((f (stream fmt &rest args) (with-standard-io-syntax (let ((*print-readably* nil) (*package* (find-package :cl))) (apply 'format stream fmt args) (finish-output stream)))) (z (stream) (f stream "~&")) (e (fmt arg) (f *error-output* fmt arg)) (x (expression thunk) (e "~& ~S => " expression) (let ((results (multiple-value-list (funcall thunk)))) (e "~{~S~^ ~}~%" results) (apply 'values results)))) (map () #'z (list *standard-output* *error-output* *trace-output*)) (e "~A~%" tag) (loop :for (expression . thunk) :in expressions-thunks :do (x expression thunk)) (if last-thunk (x last-expression last-thunk) (values)))) ;;; Quick definitions for use at the REPL (defun w (&rest x) (format t "~&~{~S~^ ~}~%" x)) ;Write, space separated + LF (defun a (&rest x) (format t "~&~{~A~}~%" x)) ;print Anything, no separator, LF (defun e (x) (cons x (ignore-errors (list (eval x))))) ;Evaluate (defmacro x (x) `(format t "~&~S => ~S~%" ',x ,x)) ;eXamine (defun i (&rest x) (apply (read-from-string "swank:inspect-in-emacs") x)) ; SLIME inspection (defun ra (&rest x) (require :cl-ppcre) (apply (read-from-string "cl-ppcre:regex-apropos") x)) (defmacro !a (&rest foo) ; define! Alias `(progn ,@(loop :for (alias name) :on foo :by #'cddr :collect (if (macro-function name) `(defmacro ,alias (&rest x) `(,',name ,@x)) `(defun ,alias (&rest x) (apply ',name x)))))) (!a ;;; common aliases d describe ap apropos !p defparameter m1 macroexpand-1) cl-asdf-3.0.3/uiop/driver.lisp000066400000000000000000000015621223164443400161750ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Re-export all the functionality in UIOP (uiop/package:define-package :uiop/driver (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver) (:reexport ;; NB: excluding uiop/common-lisp ;; which include all of CL with compatibility modifications on select platforms, ;; that could cause potential conflicts for packages that would :use (cl uiop) ;; or :use (closer-common-lisp uiop), etc. :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) cl-asdf-3.0.3/uiop/filesystem.lisp000066400000000000000000001001561223164443400170650ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp filesystem access (uiop/package:define-package :uiop/filesystem (:nicknames :asdf/filesystem) (:recycle :uiop/filesystem :asdf/pathname :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) (:export ;; Native namestrings #:native-namestring #:parse-native-namestring ;; Probing the filesystem #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories #:collect-sub*directories ;; Resolving symlinks somewhat #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks* ;; merging with cwd #:get-pathname-defaults #:call-with-current-directory #:with-current-directory ;; Environment pathnames #:inter-directory-separator #:split-native-pathnames-string #:getenv-pathname #:getenv-pathnames #:getenv-absolute-directory #:getenv-absolute-directories #:lisp-implementation-directory #:lisp-implementation-pathname-p ;; Simple filesystem operations #:ensure-all-directories-exist #:rename-file-overwriting-target #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) (in-package :uiop/filesystem) ;;; Native namestrings, as seen by the operating system calls rather than Lisp (with-upgradability () (defun native-namestring (x) "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system" (when x (let ((p (pathname x))) #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 #+(or cmu scl) (ext:unix-namestring p nil) #+sbcl (sb-ext:native-namestring p) #-(or clozure cmu sbcl scl) (if (os-unix-p) (unix-namestring p) (namestring p))))) (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) "From a native namestring suitable for use by the operating system, return a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (check-type string (or string null)) (let* ((pathname (when string (with-pathname-defaults () #+clozure (ccl:native-to-pathname string) #+sbcl (sb-ext:parse-native-namestring string) #-(or clozure sbcl) (if (os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory) (parse-namestring string))))) (pathname (if ensure-directory (and pathname (ensure-directory-pathname pathname)) pathname))) (apply 'ensure-pathname pathname constraints)))) ;;; Probing the filesystem (with-upgradability () (defun truename* (p) "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts" ;; avoids both logical-pathname merging and physical resolution issues (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil)))) (defun safe-file-write-date (pathname) "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." ;; If FILE-WRITE-DATE returns NIL, it's possible that ;; the user or some other agent has deleted an input file. ;; Also, generated files will not exist at the time planning is done ;; and calls compute-action-stamp which calls safe-file-write-date. ;; So it is very possible that we can't get a valid file-write-date, ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) (and pathname (handler-case (file-write-date (physicalize-pathname pathname)) (file-error () nil)))) (defun probe-file* (p &key truename) "when given a pathname P (designated by a string as per PARSE-NAMESTRING), probes the filesystem for a file or directory with given pathname. If it exists, return its truename is ENSURE-PATHNAME is true, or the original (parsed) pathname if it is false (the default)." (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations (etypecase p (null nil) (string (probe-file* (parse-namestring p) :truename truename)) (pathname (and (not (wild-pathname-p p)) (handler-case (or #+allegro (probe-file p :follow-symlinks truename) #-(or allegro clisp gcl2.6) (if truename (probe-file p) (ignore-errors (let ((pp (physicalize-pathname p))) (and #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) #+(and lispworks unix) (system:get-file-stat pp) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) p)))) #+(or clisp gcl2.6) #.(flet ((probe (probe) `(let ((foundtrue ,probe)) (cond (truename foundtrue) (foundtrue p))))) #+gcl2.6 (probe '(or (probe-file p) (and (directory-pathname-p p) (ignore-errors (ensure-directory-pathname (truename* (subpathname (ensure-directory-pathname p) "."))))))) #+clisp (let* ((fs (find-symbol* '#:file-stat :posix nil)) (pp (find-symbol* '#:probe-pathname :ext nil)) (resolve (if pp `(ignore-errors (,pp p)) '(or (truename* p) (truename* (ignore-errors (ensure-directory-pathname p))))))) (if fs `(if truename ,resolve (and (ignore-errors (,fs p)) p)) (probe resolve))))) (file-error () nil))))))) (defun directory-exists-p (x) "Is X the name of a directory that exists on the filesystem?" (let ((p (probe-file* x :truename t))) (and (directory-pathname-p p) p))) (defun file-exists-p (x) "Is X the name of a file that exists on the filesystem?" (let ((p (probe-file* x :truename t))) (and (file-pathname-p p) p))) (defun directory* (pathname-spec &rest keys &key &allow-other-keys) "Return a list of the entries in a directory by calling DIRECTORY. Try to override the defaults to not resolving symlinks, if implementation allows." (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) #+lispworks '(:link-transparency nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) (defun filter-logical-directory-results (directory entries merger) "Given ENTRIES in a DIRECTORY, remove if the directory is logical the entries which are physical yet when transformed by MERGER have a different TRUENAME. This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames." (if (logical-pathname-p directory) ;; Try hard to not resolve logical-pathname into physical pathnames; ;; otherwise logical-pathname users/lovers will be disappointed. ;; If directory* could use some implementation-dependent magic, ;; we will have logical pathnames already; otherwise, ;; we only keep pathnames for which specifying the name and ;; translating the LPN commute. (loop :for f :in entries :for p = (or (and (logical-pathname-p f) f) (let* ((u (ignore-errors (call-function merger f)))) ;; The first u avoids a cumbersome (truename u) error. ;; At this point f should already be a truename, ;; but isn't quite in CLISP, for it doesn't have :version :newest (and u (equal (truename* u) (truename* f)) u))) :when p :collect p) entries)) (defun directory-files (directory &optional (pattern *wild-file*)) "Return a list of the files in a directory according to the PATTERN, which is not very portable to override. Try not resolve symlinks if implementation allows." (let ((dir (pathname directory))) (when (logical-pathname-p dir) ;; Because of the filtering we do below, ;; logical pathnames have restrictions on wild patterns. ;; Not that the results are very portable when you use these patterns on physical pathnames. (when (wild-pathname-p dir) (error "Invalid wild pattern in logical directory ~S" directory)) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (setf pattern (make-pathname-logical pattern (pathname-host dir)))) (let* ((pat (merge-pathnames* pattern dir)) (entries (append (ignore-errors (directory* pat)) #+clisp (when (equal :wild (pathname-type pattern)) (ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) (filter-logical-directory-results directory entries #'(lambda (f) (make-pathname :defaults dir :name (make-pathname-component-logical (pathname-name f)) :type (make-pathname-component-logical (pathname-type f)) :version (make-pathname-component-logical (pathname-version f)))))))) (defun subdirectories (directory) "Given a DIRECTORY pathname designator, return a list of the subdirectories under it." (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* #-(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) "Given a DIRECTORY, call-function the COLLECTOR function designator on the directory if COLLECTP returns true when CALL-FUNCTION'ed with the directory, and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them." (when (call-function collectp directory) (call-function collector directory)) (dolist (subdir (subdirectories directory)) (when (call-function recursep subdir) (collect-sub*directories subdir collectp recursep collector))))) ;;; Resolving symlinks somewhat (with-upgradability () (defun truenamize (pathname) "Resolve as much of a pathname as possible" (block nil (when (typep pathname '(or null logical-pathname)) (return pathname)) (let ((p pathname)) (unless (absolute-pathname-p p) (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil)) (return p)))) (when (logical-pathname-p p) (return p)) (let ((found (probe-file* p :truename t))) (when found (return found))) (let* ((directory (normalize-pathname-directory-component (pathname-directory p))) (up-components (reverse (rest directory))) (down-components ())) (assert (eq :absolute (first directory))) (loop :while up-components :do (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) :name nil :type nil :version nil :defaults p))) (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components) :defaults p) (ensure-directory-pathname parent))) (push (pop up-components) down-components)) :finally (return p)))))) (defun resolve-symlinks (path) "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." #-allegro (truenamize path) #+allegro (if (physical-pathname-p path) (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) path)) (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. Defaults to T.") (defun resolve-symlinks* (path) "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)." (if *resolve-symlinks* (and path (resolve-symlinks path)) path))) ;;; Check pathname constraints (with-upgradability () (defun ensure-pathname (pathname &key on-error defaults type dot-dot want-pathname want-logical want-physical ensure-physical want-relative want-absolute ensure-absolute ensure-subpath want-non-wild want-wild wilden want-file want-directory ensure-directory want-existing ensure-directories-exist truename resolve-symlinks truenamize &aux (p pathname)) ;; mutable working copy, preserve original "Coerces its argument into a PATHNAME, optionally doing some transformations and checking specified constraints. If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE; then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true, and the all the checks and transformations are run. Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. The boolean T is an alias for ERROR. ERROR means that an error will be raised if the constraint is not satisfied. CERROR means that an continuable error will be raised if the constraint is not satisfied. IGNORE means just return NIL instead of the pathname. The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) that will be called with the the following arguments: a generic format string for ensure pathname, the pathname, the keyword argument corresponding to the failed check or transformation, a format string for the reason ENSURE-PATHNAME failed, and a list with arguments to that format string. If ON-ERROR is NIL, ERROR is used instead, which does the right thing. You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). The transformations and constraint checks are done in this order, which is also the order in the lambda-list: WANT-PATHNAME checks that pathname (after parsing if needed) is not null. Otherwise, if the pathname is NIL, ensure-pathname returns NIL. WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME WANT-RELATIVE checks that pathname has a relative directory component WANT-ABSOLUTE checks that pathname does have an absolute directory component ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again that the result absolute is an absolute pathname indeed. ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. WANT-FILE checks that pathname has a non-nil FILE component WANT-DIRECTORY checks that pathname has nil FILE and TYPE components ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret any file and type components as being actually a last directory component. WANT-NON-WILD checks that pathname is not a wild pathname WANT-WILD checks that pathname is a wild pathname WILDEN merges the pathname with **/*.*.* if it is not wild WANT-EXISTING checks that a file (or directory) exists with that pathname. ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. TRUENAME replaces the pathname by its truename, or errors if not possible. RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (block nil (flet ((report-error (keyword description &rest arguments) (call-function (or on-error 'error) "Invalid pathname ~S: ~*~?" pathname keyword description arguments))) (macrolet ((err (constraint &rest arguments) `(report-error ',(intern* constraint :keyword) ,@arguments)) (check (constraint condition &rest arguments) `(when ,constraint (unless ,condition (err ,constraint ,@arguments)))) (transform (transform condition expr) `(when ,transform (,@(if condition `(when ,condition) '(progn)) (setf p ,expr))))) (etypecase p ((or null pathname)) (string (setf p (parse-unix-namestring p :defaults defaults :type type :dot-dot dot-dot :ensure-directory ensure-directory :want-relative want-relative)))) (check want-pathname (pathnamep p) "Expected a pathname, not NIL") (unless (pathnamep p) (return nil)) (check want-logical (logical-pathname-p p) "Expected a logical pathname") (check want-physical (physical-pathname-p p) "Expected a physical pathname") (transform ensure-physical () (physicalize-pathname p)) (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") (check want-relative (relative-pathname-p p) "Expected a relative pathname") (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") (transform ensure-absolute (not (absolute-pathname-p p)) (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) (check ensure-absolute (absolute-pathname-p p) "Could not make into an absolute pathname even after merging with ~S" defaults) (check ensure-subpath (absolute-pathname-p defaults) "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) (check want-file (file-pathname-p p) "Expected a file pathname") (check want-directory (directory-pathname-p p) "Expected a directory pathname") (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") (transform wilden (not (wild-pathname-p p)) (wilden p)) (when want-existing (let ((existing (probe-file* p :truename truename))) (if existing (when truename (return existing)) (err want-existing "Expected an existing pathname")))) (when ensure-directories-exist (ensure-directories-exist p)) (when truename (let ((truename (truename* p))) (if truename (return truename) (err truename "Can't get a truename for pathname")))) (transform resolve-symlinks () (resolve-symlinks p)) (transform truenamize () (truenamize p)) p))))) ;;; Pathname defaults (with-upgradability () (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) "Find the actual DEFAULTS to use for pathnames, including resolving them with respect to GETCWD if the DEFAULTS were relative" (or (absolute-pathname-p defaults) (merge-pathnames* defaults (getcwd)))) (defun call-with-current-directory (dir thunk) "call the THUNK in a context where the current directory was changed to DIR, if not NIL. Note that this operation is usually NOT thread-safe." (if dir (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir)))) (cwd (getcwd)) (*default-pathname-defaults* dir)) (chdir dir) (unwind-protect (funcall thunk) (chdir cwd))) (funcall thunk))) (defmacro with-current-directory ((&optional dir) &body body) "Call BODY while the POSIX current working directory is set to DIR" `(call-with-current-directory ,dir #'(lambda () ,@body)))) ;;; Environment pathnames (with-upgradability () (defun inter-directory-separator () "What character does the current OS conventionally uses to separate directories?" (if (os-unix-p) #\: #\;)) (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) "Given a string of pathnames specified in native OS syntax, separate them in a list, check constraints and normalize each one as per ENSURE-PATHNAME." (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) :collect (apply 'parse-native-namestring namestring constraints))) (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) "Extract a pathname from a user-configured environment variable, as per native OS, check constraints and normalize as per ENSURE-PATHNAME." ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory (apply 'parse-native-namestring (getenvp x) :ensure-directory (or ensure-directory want-directory) :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) constraints)) (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) "Extract a list of pathname from a user-configured environment variable, as per native OS, check constraints and normalize each one as per ENSURE-PATHNAME." (apply 'split-native-pathnames-string (getenvp x) :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) constraints)) (defun getenv-absolute-directory (x) "Extract an absolute directory pathname from a user-configured environment variable, as per native OS" (getenv-pathname x :want-absolute t :ensure-directory t)) (defun getenv-absolute-directories (x) "Extract a list of absolute directories from a user-configured environment variable, as per native OS" (getenv-pathnames x :want-absolute t :ensure-directory t)) (defun lisp-implementation-directory (&key truename) "Where are the system files of the current installation of the CL implementation?" (declare (ignorable truename)) #+(or clozure ecl gcl mkcl sbcl) (let ((dir (ignore-errors #+clozure #p"ccl:" #+(or ecl mkcl) #p"SYS:" #+gcl system::*system-directory* #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) (funcall it) (getenv-pathname "SBCL_HOME" :ensure-directory t))))) (if (and dir truename) (truename* dir) dir))) (defun lisp-implementation-pathname-p (pathname) "Is the PATHNAME under the current installation of the CL implementation?" ;; Other builtin systems are those under the implementation directory (and (when pathname (if-let (impdir (lisp-implementation-directory)) (or (subpathp pathname impdir) (when *resolve-symlinks* (if-let (truename (truename* pathname)) (if-let (trueimpdir (truename* impdir)) (subpathp truename trueimpdir))))))) t))) ;;; Simple filesystem operations (with-upgradability () (defun ensure-all-directories-exist (pathnames) "Ensure that for every pathname in PATHNAMES, we ensure its directories exist" (dolist (pathname pathnames) (when pathname (ensure-directories-exist (physicalize-pathname pathname))))) (defun rename-file-overwriting-target (source target) "Rename a file, overwriting any previous file with the TARGET name, in an atomic way if the implementation allows." #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic (progn (funcall 'require "syscalls") (symbol-call :posix :copy-file source target :method :rename)) #-clisp (rename-file source target #+clozure :if-exists #+clozure :rename-and-delete)) (defun delete-file-if-exists (x) "Delete a file X if it already exists" (when x (handler-case (delete-file x) (file-error () nil)))) (defun delete-empty-directory (directory-pathname) "Delete an empty directory" #+(or abcl digitool gcl) (delete-file directory-pathname) #+allegro (excl:delete-directory directory-pathname) #+clisp (ext:delete-directory directory-pathname) #+clozure (ccl::delete-empty-directory directory-pathname) #+(or cmu scl) (multiple-value-bind (ok errno) (unix:unix-rmdir (native-namestring directory-pathname)) (unless ok #+cmu (error "Error number ~A when trying to delete directory ~A" errno directory-pathname) #+scl (error "~@" directory-pathname (unix:get-unix-error-msg errno)))) #+cormanlisp (win32:delete-directory directory-pathname) #+ecl (si:rmdir directory-pathname) #+lispworks (lw:delete-directory directory-pathname) #+mkcl (mkcl:rmdir directory-pathname) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) "Delete a directory including all its recursive contents, aka rm -rf. To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be a physical non-wildcard directory pathname (not namestring). If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument which in practice is thus compulsory, and validates by returning a non-NIL result. If you're suicidal or extremely confident, just use :VALIDATE T." (check-type if-does-not-exist (member :error :ignore)) (cond ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname)))) (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname" 'delete-filesystem-tree directory-pathname)) ((not validatep) (error "~S was asked to delete ~S but was not provided a validation predicate" 'delete-filesystem-tree directory-pathname)) ((not (call-function validate directory-pathname)) (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" 'delete-filesystem-tree directory-pathname validate)) ((not (directory-exists-p directory-pathname)) (ecase if-does-not-exist (:error (error "~S was asked to delete ~S but the directory does not exist" 'delete-filesystem-tree directory-pathname)) (:ignore nil))) #-(or allegro cmu clozure sbcl scl) ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, ;; except on implementations where we can prevent DIRECTORY from following symlinks; ;; instead spawn a standard external program to do the dirty work. (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) (t ;; On supported implementation, call supported system functions #+allegro (symbol-call :excl.osi :delete-directory-and-files directory-pathname :if-does-not-exist if-does-not-exist) #+clozure (ccl:delete-directory directory-pathname) #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, ;; do things the hard way. #-(or allegro clozure genera sbcl) (let ((sub*directories (while-collecting (c) (collect-sub*directories directory-pathname t t #'c)))) (dolist (d (nreverse sub*directories)) (map () 'delete-file (directory-files d)) (delete-empty-directory d))))))) cl-asdf-3.0.3/uiop/image.lisp000066400000000000000000000400041223164443400157560ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Starting, Stopping, Dumping a Lisp image (uiop/package:define-package :uiop/image (:nicknames :asdf/image) (:recycle :uiop/image :asdf/image :xcvb-driver) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:*lisp-interaction* #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition #:call-with-fatal-condition-handler #:with-fatal-condition-handler #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* #:*image-postlude* #:*image-dump-hook* #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace #:shell-boolean-exit #:register-image-restore-hook #:register-image-dump-hook #:call-image-restore-hook #:call-image-dump-hook #:restore-image #:dump-image #:create-image )) (in-package :uiop/image) (with-upgradability () (defvar *lisp-interaction* t "Is this an interactive Lisp environment, or is it batch processing?") (defvar *command-line-arguments* nil "Command-line arguments") (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments "Is this a dumped image? As a standalone executable?") (defvar *image-restore-hook* nil "Functions to call (in reverse order) when the image is restored") (defvar *image-restored-p* nil "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") (defvar *image-prelude* nil "a form to evaluate, or string containing forms to read and evaluate when the image is restarted, but before the entry point is called.") (defvar *image-entry-point* nil "a function with which to restart the dumped image when execution is restored from it.") (defvar *image-postlude* nil "a form to evaluate, or string containing forms to read and evaluate before the image dump hooks are called and before the image is dumped.") (defvar *image-dump-hook* nil "Functions to call (in order) when before an image is dumped") (defvar *fatal-conditions* '(error) "conditions that cause the Lisp image to enter the debugger if interactive, or to die if not interactive")) ;;; Exiting properly or im- (with-upgradability () (defun quit (&optional (code 0) (finish-output t)) "Quits from the Lisp world, with the given exit status if provided. This is designed to abstract away the implementation specific quit forms." (when finish-output ;; essential, for ClozureCL, and for standard compliance. (finish-outputs)) #+(or abcl xcl) (ext:quit :status code) #+allegro (excl:exit code :quiet t) #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) #+(or cmu scl) (unix:unix-exit code) #+ecl (si:quit code) #+gcl (lisp:quit code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) (quit (find-symbol* :quit :sb-ext nil))) (cond (exit `(,exit :code code :abort (not finish-output))) (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun die (code format &rest arguments) "Die in error with some error message" (with-safe-io-syntax () (ignore-errors (format! *stderr* "~&~?~&" format arguments))) (quit code)) (defun raw-print-backtrace (&key (stream *debug-io*) count) "Print a backtrace, directly accessing the implementation" (declare (ignorable stream count)) #+abcl (let ((*debug-io* stream)) (top-level::backtrace-command count)) #+allegro (let ((*terminal-io* stream) (*standard-output* stream) (tpl:*zoom-print-circle* *print-circle*) (tpl:*zoom-print-level* *print-level*) (tpl:*zoom-print-length* *print-length*)) (tpl:do-command "zoom" :from-read-eval-print-loop nil :count t :all t)) #+clisp (system::print-backtrace :out stream :limit count) #+(or clozure mcl) (let ((*debug-io* stream)) #+clozure (ccl:print-call-history :count count :start-frame-number 1) #+mcl (ccl:print-call-history :detailed-p nil) (finish-output stream)) #+(or cmu scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace most-positive-fixnum stream)) #+ecl (si::tpl-backtrace) #+lispworks (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) (*debug-io* stream) (dbg:*debug-print-level* *print-level*) (dbg:*debug-print-length* *print-length*)) (dbg:bug-backtrace nil)) #+sbcl (sb-debug:backtrace #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) stream)) (defun print-backtrace (&rest keys &key stream count) "Print a backtrace" (declare (ignore stream count)) (with-safe-io-syntax (:package :cl) (let ((*print-readably* nil) (*print-circle* t) (*print-miser-width* 75) (*print-length* nil) (*print-level* nil) (*print-pretty* t)) (ignore-errors (apply 'raw-print-backtrace keys))))) (defun print-condition-backtrace (condition &key (stream *stderr*) count) "Print a condition after a backtrace triggered by that condition" ;; We print the condition *after* the backtrace, ;; for the sake of who sees the backtrace at a terminal. ;; It is up to the caller to print the condition *before*, with some context. (print-backtrace :stream stream :count count) (when condition (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" condition))) (defun fatal-condition-p (condition) "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*" (match-any-condition-p condition *fatal-conditions*)) (defun handle-fatal-condition (condition) "Handle a fatal CONDITION: depending on whether *LISP-INTERACTION* is set, enter debugger or die" (cond (*lisp-interaction* (invoke-debugger condition)) (t (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) (print-condition-backtrace condition :stream *stderr*) (die 99 "~A" condition)))) (defun call-with-fatal-condition-handler (thunk) "Call THUNK in a context where fatal conditions are appropriately handled" (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition)) (funcall thunk))) (defmacro with-fatal-condition-handler ((&optional) &body body) "Execute BODY in a context where fatal conditions are appropriately handled" `(call-with-fatal-condition-handler #'(lambda () ,@body))) (defun shell-boolean-exit (x) "Quit with a return code that is 0 iff argument X is true" (quit (if x 0 1)))) ;;; Using image hooks (with-upgradability () (defun register-image-restore-hook (hook &optional (call-now-p t)) "Regiter a hook function to be run when restoring a dumped image" (register-hook-function '*image-restore-hook* hook call-now-p)) (defun register-image-dump-hook (hook &optional (call-now-p nil)) "Register a the hook function to be run before to dump an image" (register-hook-function '*image-dump-hook* hook call-now-p)) (defun call-image-restore-hook () "Call the hook functions registered to be run when restoring a dumped image" (call-functions (reverse *image-restore-hook*))) (defun call-image-dump-hook () "Call the hook functions registered to be run before to dump an image" (call-functions *image-dump-hook*))) ;;; Proper command-line arguments (with-upgradability () (defun raw-command-line-arguments () "Find what the actual command line for this process was." #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! #+allegro (sys:command-line-arguments) ; default: :application t #+clisp (coerce (ext:argv) 'list) #+clozure (ccl::command-line-arguments) #+(or cmu scl) extensions:*command-line-strings* #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) "Extract user arguments from command-line invocation of current process. Assume the calling conventions of a generated script that uses -- if we are not called from a directly executable image." #+abcl arguments #-abcl (let* (#-(or sbcl allegro) (arguments (if (eq *image-dumped-p* :executable) arguments (member "--" arguments :test 'string-equal)))) (rest arguments))) (defun setup-command-line-arguments () (setf *command-line-arguments* (command-line-arguments))) (defun restore-image (&key ((:lisp-interaction *lisp-interaction*) *lisp-interaction*) ((:restore-hook *image-restore-hook*) *image-restore-hook*) ((:prelude *image-prelude*) *image-prelude*) ((:entry-point *image-entry-point*) *image-entry-point*) (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) "From a freshly restarted Lisp image, restore the saved Lisp environment by setting appropriate variables, running various hooks, and calling any specified entry point." (when *image-restored-p* (if if-already-restored (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) (return-from restore-image))) (with-fatal-condition-handler () (setf *image-restored-p* :in-progress) (call-image-restore-hook) (standard-eval-thunk *image-prelude*) (setf *image-restored-p* t) (let ((results (multiple-value-list (if *image-entry-point* (call-function *image-entry-point*) t)))) (if *lisp-interaction* (apply 'values results) (shell-boolean-exit (first results))))))) ;;; Dumping an image (with-upgradability () (defun dump-image (filename &key output-name executable ((:postlude *image-postlude*) *image-postlude*) ((:dump-hook *image-dump-hook*) *image-dump-hook*) #+clozure prepend-symbols #+clozure (purify t)) "Dump an image of the current Lisp environment at pathname FILENAME, with various options" (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) (setf *image-restored-p* :in-regress) (standard-eval-thunk *image-postlude*) (call-image-dump-hook) (setf *image-restored-p* nil) #-(or clisp clozure cmu lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) #+allegro (progn (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) #+clisp (apply #'ext:saveinitmem filename :quiet t :start-package *package* :keep-global-handlers nil :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x (when executable (list ;; :parse-options nil ;--- requires a non-standard patch to clisp. :norc t :script nil :init-function #'restore-image))) #+clozure (flet ((dump (prepend-kernel) (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify :toplevel-function (when executable #'restore-image)))) ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) (if prepend-symbols (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) (require 'elf) (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) (dump path)) (dump t))) #+(or cmu scl) (progn (ext:gc :full t) (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) (apply 'ext:save-lisp filename #+cmu :executable #+cmu t (when executable '(:init-function restore-image :process-command-line nil)))) #+gcl (progn (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) (si::save-system filename)) #+lispworks (if executable (lispworks:deliver 'restore-image filename 0 :interface nil) (hcl:save-image filename :environment nil)) #+sbcl (progn ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself (setf sb-ext::*gc-run-time* 0) (apply 'sb-ext:save-lisp-and-die filename :executable t ;--- always include the runtime that goes with the core (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) (defun create-image (destination object-files &key kind output-name prologue-code epilogue-code (prelude () preludep) (postlude () postludep) (entry-point () entry-point-p) build-args) (declare (ignorable destination object-files kind output-name prologue-code epilogue-code prelude preludep postlude postludep entry-point entry-point-p build-args)) "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. #-ecl (error "~S not implemented for your implementation (yet)" 'create-image) #+ecl (progn (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) (apply 'c::builder kind (pathname destination) :lisp-files object-files :init-name (c::compute-init-name (or output-name destination) :kind kind) :prologue-code prologue-code :epilogue-code `(progn ,epilogue-code ,@(when (eq kind :program) `((setf *image-dumped-p* :executable) (restore-image ;; default behavior would be (si::top-level) ,@(when preludep `(:prelude ',prelude)) ,@(when entry-point-p `(:entry-point ',entry-point)))))) build-args)))) ;;; Some universal image restore hooks (with-upgradability () (map () 'register-image-restore-hook '(setup-stdin setup-stdout setup-stderr setup-command-line-arguments setup-temporary-directory #+abcl detect-os))) cl-asdf-3.0.3/uiop/lisp-build.lisp000066400000000000000000001121511223164443400167430ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Support to build (compile and load) Lisp files (uiop/package:define-package :uiop/lisp-build (:nicknames :asdf/lisp-build) (:recycle :uiop/lisp-build :asdf/lisp-build :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) (:export ;; Variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*output-translation-function* #:*optimization-settings* #:*previous-optimization-settings* #:*base-build-directory* #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning #:check-lisp-compile-results #:check-lisp-compile-warnings #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* ;; Types #+sbcl #:sb-grovel-unknown-constant-condition ;; Functions & Macros #:get-optimization-settings #:proclaim-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions #:reify-simple-sexp #:unreify-simple-sexp #:reify-deferred-warnings #:unreify-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check #:current-lisp-file-pathname #:load-pathname #:lispize-pathname #:compile-file-type #:call-around-hook #:compile-file* #:compile-file-pathname* #:load* #:load-from-string #:combine-fasls) (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) (in-package :uiop/lisp-build) (with-upgradability () (defvar *compile-file-warnings-behaviour* (or #+clisp :ignore :warn) "How should ASDF react if it encounters a warning when compiling a file? Valid values are :error, :warn, and :ignore.") (defvar *compile-file-failure-behaviour* (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) when compiling a file, which includes any non-style-warning warning. Valid values are :error, :warn, and :ignore. Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") (defvar *base-build-directory* nil "When set to a non-null value, it should be an absolute directory pathname, which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE, what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it. This can help you produce more deterministic output for FASLs.")) ;;; Optimization settings (with-upgradability () (defvar *optimization-settings* nil "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") (defvar *previous-optimization-settings* nil "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" #-(or clisp clozure cmu ecl sbcl scl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) #+clozure (ccl:declaration-information 'optimize nil) #+(or clisp cmu ecl sbcl scl) (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) #.`(loop :for x :in settings ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity))) :for y = (or #+clisp (gethash x system::*optimize*) #+(or ecl) (symbol-value v) #+(or cmu scl) (funcall f c::*default-cookie*) #+sbcl (cdr (assoc x sb-c::*policy*))) :when y :collect (list x y)))) (defun proclaim-optimization-settings () "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" (proclaim `(optimize ,@*optimization-settings*)) (let ((settings (get-optimization-settings))) (unless (equal *previous-optimization-settings* settings) (setf *previous-optimization-settings* settings))))) ;;; Condition control (with-upgradability () #+sbcl (progn (defun sb-grovel-unknown-constant-condition-p (c) "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL" (and (typep c 'sb-int:simple-style-warning) (string-enclosed-p "Couldn't grovel for " (simple-condition-format-control c) " (unknown to the C compiler)."))) (deftype sb-grovel-unknown-constant-condition () '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) (defvar *usual-uninteresting-conditions* (append ;;#+clozure '(ccl:compiler-warning) #+cmu '("Deleting unreachable code.") #+lispworks '("~S being redefined in ~A (previously in ~A)." "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. #+sbcl '(sb-c::simple-compiler-note "&OPTIONAL and &KEY found in the same lambda list: ~S" #+sb-eval sb-kernel:lexical-environment-too-complex sb-kernel:undefined-alien-style-warning sb-grovel-unknown-constant-condition ; defined above. sb-ext:implicit-generic-function-warning ;; Controversial. sb-int:package-at-variance sb-kernel:uninteresting-redefinition ;; BEWARE: the below four are controversial to include here. sb-kernel:redefinition-with-defun sb-kernel:redefinition-with-defgeneric sb-kernel:redefinition-with-defmethod sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop "A suggested value to which to set or bind *uninteresting-conditions*.") (defvar *uninteresting-conditions* '() "Conditions that may be skipped while compiling or loading Lisp code.") (defvar *uninteresting-compiler-conditions* '() "Additional conditions that may be skipped while compiling Lisp code.") (defvar *uninteresting-loader-conditions* (append '("Overwriting already existing readtable ~S." ;; from named-readtables #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers #+clisp '(clos::simple-gf-replacing-method-warning)) "Additional conditions that may be skipped while loading Lisp code.")) ;;;; ----- Filtering conditions while building ----- (with-upgradability () (defun call-with-muffled-compiler-conditions (thunk) "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled" (call-with-muffled-conditions thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) (defmacro with-muffled-compiler-conditions ((&optional) &body body) "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS" `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) (defun call-with-muffled-loader-conditions (thunk) "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled" (call-with-muffled-conditions thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*))) (defmacro with-muffled-loader-conditions ((&optional) &body body) "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS" `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) ;;;; Handle warnings and failures (with-upgradability () (define-condition compile-condition (condition) ((context-format :initform nil :reader compile-condition-context-format :initarg :context-format) (context-arguments :initform nil :reader compile-condition-context-arguments :initarg :context-arguments) (description :initform nil :reader compile-condition-description :initarg :description)) (:report (lambda (c s) (format s (compatfmt "~@<~A~@[ while ~?~]~@:>") (or (compile-condition-description c) (type-of c)) (compile-condition-context-format c) (compile-condition-context-arguments c))))) (define-condition compile-file-error (compile-condition error) ()) (define-condition compile-warned-warning (compile-condition warning) ()) (define-condition compile-warned-error (compile-condition error) ()) (define-condition compile-failed-warning (compile-condition warning) ()) (define-condition compile-failed-error (compile-condition error) ()) (defun check-lisp-compile-warnings (warnings-p failure-p &optional context-format context-arguments) "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings, raise an error or warning as appropriate" (when failure-p (case *compile-file-failure-behaviour* (:warn (warn 'compile-failed-warning :description "Lisp compilation failed" :context-format context-format :context-arguments context-arguments)) (:error (error 'compile-failed-error :description "Lisp compilation failed" :context-format context-format :context-arguments context-arguments)) (:ignore nil))) (when warnings-p (case *compile-file-warnings-behaviour* (:warn (warn 'compile-warned-warning :description "Lisp compilation had style-warnings" :context-format context-format :context-arguments context-arguments)) (:error (error 'compile-warned-error :description "Lisp compilation had style-warnings" :context-format context-format :context-arguments context-arguments)) (:ignore nil)))) (defun check-lisp-compile-results (output warnings-p failure-p &optional context-format context-arguments) "Given the results of COMPILE-FILE, raise an error or warning as appropriate" (unless output (error 'compile-file-error :context-format context-format :context-arguments context-arguments)) (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))) ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. ;;; ;;; To support an implementation, three functions must be implemented: ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings ;;; See their respective docstrings. (with-upgradability () (defun reify-simple-sexp (sexp) "Given a simple SEXP, return a representation of it as a portable SEXP. Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells." (etypecase sexp (symbol (reify-symbol sexp)) ((or number character simple-string pathname) sexp) (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) (defun unreify-simple-sexp (sexp) "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents" (etypecase sexp ((or symbol number character simple-string pathname) sexp) (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) ((simple-vector 2) (unreify-symbol sexp)) ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) #+clozure (progn (defun reify-source-note (source-note) (when source-note (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note (declare (ignorable source)) (list :filename filename :start-pos start-pos :end-pos end-pos #|:source (reify-source-note source)|#)))) (defun unreify-source-note (source-note) (when source-note (destructuring-bind (&key filename start-pos end-pos source) source-note (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos :source (unreify-source-note source))))) (defun unsymbolify-function-name (name) (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) `(setf ,setfed) name)) (defun symbolify-function-name (name) (if (and (consp name) (eq (first name) 'setf)) (let ((setfed (second name))) (gethash setfed ccl::%setf-function-names%)) name)) (defun reify-function-name (function-name) (let ((name (or (first function-name) ;; defun: extract the name (let ((sec (second function-name))) (or (and (atom sec) sec) ; scoped method: drop scope (first sec)))))) ; method: keep gf name, drop method specializers (list name))) (defun unreify-function-name (function-name) function-name) (defun nullify-non-literals (sexp) (typecase sexp ((or number character simple-string symbol pathname) sexp) (cons (cons (nullify-non-literals (car sexp)) (nullify-non-literals (cdr sexp)))) (t nil))) (defun reify-deferred-warning (deferred-warning) (with-accessors ((warning-type ccl::compiler-warning-warning-type) (args ccl::compiler-warning-args) (source-note ccl:compiler-warning-source-note) (function-name ccl:compiler-warning-function-name)) deferred-warning (list :warning-type warning-type :function-name (reify-function-name function-name) :source-note (reify-source-note source-note) :args (destructuring-bind (fun &rest more) args (cons (unsymbolify-function-name fun) (nullify-non-literals more)))))) (defun unreify-deferred-warning (reified-deferred-warning) (destructuring-bind (&key warning-type function-name source-note args) reified-deferred-warning (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) 'ccl::compiler-warning) :function-name (unreify-function-name function-name) :source-note (unreify-source-note source-note) :warning-type warning-type :args (destructuring-bind (fun . more) args (cons (symbolify-function-name fun) more)))))) #+(or cmu scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" (list* (c::undefined-warning-kind warning) (c::undefined-warning-name warning) (c::undefined-warning-count warning) (mapcar #'(lambda (frob) ;; the lexenv slot can be ignored for reporting purposes `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob) :source ,(c::compiler-error-context-source frob) :original-source ,(c::compiler-error-context-original-source frob) :context ,(c::compiler-error-context-context frob) :file-name ,(c::compiler-error-context-file-name frob) ; a pathname :file-position ,(c::compiler-error-context-file-position frob) ; an integer :original-source-path ,(c::compiler-error-context-original-source-path frob))) (c::undefined-warning-warnings warning)))) #+sbcl (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" (list* (sb-c::undefined-warning-kind warning) (sb-c::undefined-warning-name warning) (sb-c::undefined-warning-count warning) (mapcar #'(lambda (frob) ;; the lexenv slot can be ignored for reporting purposes `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) :source ,(sb-c::compiler-error-context-source frob) :original-source ,(sb-c::compiler-error-context-original-source frob) :context ,(sb-c::compiler-error-context-context frob) :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) (sb-c::undefined-warning-warnings warning)))) (defun reify-deferred-warnings () "return a portable S-expression, portably readable and writeable in any Common Lisp implementation using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+allegro (list :functions-defined excl::.functions-defined. :functions-called excl::.functions-called.) #+clozure (mapcar 'reify-deferred-warning (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (ccl::deferred-warnings.warnings mdw)))) #+(or cmu scl) (when lisp::*in-compilation-unit* ;; Try to send nothing through the pipe if nothing needs to be accumulated `(,@(when c::*undefined-warnings* `((c::*undefined-warnings* ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*)))) ,@(loop :for what :in '(c::*compiler-error-count* c::*compiler-warning-count* c::*compiler-note-count*) :for value = (symbol-value what) :when (plusp value) :collect `(,what . ,value)))) #+sbcl (when sb-c::*in-compilation-unit* ;; Try to send nothing through the pipe if nothing needs to be accumulated `(,@(when sb-c::*undefined-warnings* `((sb-c::*undefined-warnings* ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* sb-c::*compiler-error-count* sb-c::*compiler-warning-count* sb-c::*compiler-style-warning-count* sb-c::*compiler-note-count*) :for value = (symbol-value what) :when (plusp value) :collect `(,what . ,value))))) (defun unreify-deferred-warnings (reified-deferred-warnings) "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT. Handle any warning that has been resolved already, such as an undefined function that has been defined since. One of three functions required for deferred-warnings support in ASDF." (declare (ignorable reified-deferred-warnings)) #+allegro (destructuring-bind (&key functions-defined functions-called) reified-deferred-warnings (setf excl::.functions-defined. (append functions-defined excl::.functions-defined.) excl::.functions-called. (append functions-called excl::.functions-called.))) #+clozure (let ((dw (or ccl::*outstanding-deferred-warnings* (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) (appendf (ccl::deferred-warnings.warnings dw) (mapcar 'unreify-deferred-warning reified-deferred-warnings))) #+(or cmu scl) (dolist (item reified-deferred-warnings) ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. ;; For *undefined-warnings*, the adjustment is a list of initargs. ;; For everything else, it's an integer. (destructuring-bind (symbol . adjustment) item (case symbol ((c::*undefined-warnings*) (setf c::*undefined-warnings* (nconc (mapcan #'(lambda (stuff) (destructuring-bind (kind name count . rest) stuff (unless (case kind (:function (fboundp name))) (list (c::make-undefined-warning :name name :kind kind :count count :warnings (mapcar #'(lambda (x) (apply #'c::make-compiler-error-context x)) rest)))))) adjustment) c::*undefined-warnings*))) (otherwise (set symbol (+ (symbol-value symbol) adjustment)))))) #+sbcl (dolist (item reified-deferred-warnings) ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. ;; For *undefined-warnings*, the adjustment is a list of initargs. ;; For everything else, it's an integer. (destructuring-bind (symbol . adjustment) item (case symbol ((sb-c::*undefined-warnings*) (setf sb-c::*undefined-warnings* (nconc (mapcan #'(lambda (stuff) (destructuring-bind (kind name count . rest) stuff (unless (case kind (:function (fboundp name))) (list (sb-c::make-undefined-warning :name name :kind kind :count count :warnings (mapcar #'(lambda (x) (apply #'sb-c::make-compiler-error-context x)) rest)))))) adjustment) sb-c::*undefined-warnings*))) (otherwise (set symbol (+ (symbol-value symbol) adjustment))))))) (defun reset-deferred-warnings () "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+allegro (setf excl::.functions-defined. nil excl::.functions-called. nil) #+clozure (if-let (dw ccl::*outstanding-deferred-warnings*) (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) (setf (ccl::deferred-warnings.warnings mdw) nil))) #+(or cmu scl) (when lisp::*in-compilation-unit* (setf c::*undefined-warnings* nil c::*compiler-error-count* 0 c::*compiler-warning-count* 0 c::*compiler-note-count* 0)) #+sbcl (when sb-c::*in-compilation-unit* (setf sb-c::*undefined-warnings* nil sb-c::*aborted-compilation-unit-count* 0 sb-c::*compiler-error-count* 0 sb-c::*compiler-warning-count* 0 sb-c::*compiler-style-warning-count* 0 sb-c::*compiler-note-count* 0))) (defun save-deferred-warnings (warnings-file) "Save forward reference conditions so they may be issued at a latter time, possibly in a different process." (with-open-file (s warnings-file :direction :output :if-exists :supersede :element-type *default-stream-element-type* :external-format *utf-8-external-format*) (with-safe-io-syntax () (write (reify-deferred-warnings) :stream s :pretty t :readably t) (terpri s)))) (defun warnings-file-type (&optional implementation-type) "The pathname type for warnings files on given IMPLEMENTATION-TYPE, where NIL designates the current one" (case (or implementation-type *implementation-type*) ((:acl :allegro) "allegro-warnings") ;;((:clisp) "clisp-warnings") ((:cmu :cmucl) "cmucl-warnings") ((:sbcl) "sbcl-warnings") ((:clozure :ccl) "ccl-warnings") ((:scl) "scl-warnings"))) (defvar *warnings-file-type* nil "Pathname type for warnings files, or NIL if disabled") (defun enable-deferred-warnings-check () "Enable the saving of deferred warnings" (setf *warnings-file-type* (warnings-file-type))) (defun disable-deferred-warnings-check () "Disable the saving of deferred warnings" (setf *warnings-file-type* nil)) (defun warnings-file-p (file &optional implementation-type) "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE? If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead." (if-let (type (if implementation-type (warnings-file-type implementation-type) *warnings-file-type*)) (equal (pathname-type file) type))) (defun check-deferred-warnings (files &optional context-format context-arguments) "Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS, re-intern and raise any warnings that are still meaningful." (let ((file-errors nil) (failure-p nil) (warnings-p nil)) (handler-bind ((warning #'(lambda (c) (setf warnings-p t) (unless (typep c 'style-warning) (setf failure-p t))))) (with-compilation-unit (:override t) (reset-deferred-warnings) (dolist (file files) (unreify-deferred-warnings (handler-case (safe-read-file-form file) (error (c) ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging (push c file-errors) nil)))))) (dolist (error file-errors) (error error)) (check-lisp-compile-warnings (or failure-p warnings-p) failure-p context-format context-arguments))) #| Mini-guide to adding support for deferred warnings on an implementation. First, look at what such a warning looks like: (describe (handler-case (and (eval '(lambda () (some-undefined-function))) nil) (t (c) c))) Then you can grep for the condition type in your compiler sources and see how to catch those that have been deferred, and/or read, clear and restore the deferred list. Also look at (macroexpand-1 '(with-compilation-unit () foo)) |# (defun call-with-saved-deferred-warnings (thunk warnings-file) "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK and save those warnings to the given file for latter use, possibly in a different process. Otherwise just call THUNK." (if warnings-file (with-compilation-unit (:override t) (unwind-protect (let (#+sbcl (sb-c::*undefined-warnings* nil)) (multiple-value-prog1 (funcall thunk) (save-deferred-warnings warnings-file))) (reset-deferred-warnings))) (funcall thunk))) (defmacro with-saved-deferred-warnings ((warnings-file) &body body) "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))) ;;; from ASDF (with-upgradability () (defun current-lisp-file-pathname () "Portably return the PATHNAME of the current Lisp source file being compiled or loaded" (or *compile-file-pathname* *load-pathname*)) (defun load-pathname () "Portably return the LOAD-PATHNAME of the current source file or fasl" *load-pathname*) ;; see magic for GCL in uiop/common-lisp (defun lispize-pathname (input-file) "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" (make-pathname :type "lisp" :defaults input-file)) (defun compile-file-type (&rest keys) "pathname TYPE for lisp FASt Loading files" (declare (ignorable keys)) #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) (defun call-around-hook (hook function) "Call a HOOK around the execution of FUNCTION" (call-function (or hook 'funcall) function)) (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" (let* ((keys (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format ,@(unless output-file '(:output-file))) keys))) (if (absolute-pathname-p output-file) ;; what cfp should be doing, w/ mp* instead of mp (let* ((type (pathname-type (apply 'compile-file-type keys))) (defaults (make-pathname :type type :defaults (merge-pathnames* input-file)))) (merge-pathnames* output-file defaults)) (funcall *output-translation-function* (apply 'compile-file-pathname input-file keys))))) (defun* (compile-file*) (input-file &rest keys &key compile-check output-file warnings-file #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl &allow-other-keys) "This function provides a portable wrapper around COMPILE-FILE. It ensures that the OUTPUT-FILE value is only returned and the file only actually created if the compilation was successful, even though your implementation may not do that, and including an optional call to an user-provided consistency check function COMPILE-CHECK; it will call this function if not NIL at the end of the compilation with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE where TMP-FILE is the name of a temporary output-file. It also checks two flags (with legacy british spelling from ASDF1), *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* with appropriate implementation-dependent defaults, and if a failure (respectively warnings) are reported by COMPILE-FILE with consider it an error unless the respective behaviour flag is one of :SUCCESS :WARN :IGNORE. If WARNINGS-FILE is defined, deferred warnings are saved to that file. On ECL or MKCL, it creates both the linkable object and loadable fasl files. On implementations that erroneously do not recognize standard keyword arguments, it will filter them appropriately." #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file))) (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" 'compile-file* output-file object-file) (rotatef output-file object-file)) (let* ((keywords (remove-plist-keys `(:output-file :compile-check :warnings-file #+clisp :lib-file #+(or ecl mkcl) :object-file #+gcl2.6 ,@'(:external-format :print :verbose)) keys)) (output-file (or output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))) #+ecl (object-file (unless (use-ecl-byte-compiler-p) (or object-file (compile-file-pathname output-file :type :object)))) #+mkcl (object-file (or object-file (compile-file-pathname output-file :fasl-p nil))) (tmp-file (tmpize-pathname output-file)) #+sbcl (cfasl-file (etypecase emit-cfasl (null nil) ((eql t) (make-pathname :type "cfasl" :defaults output-file)) (string (parse-namestring emit-cfasl)) (pathname emit-cfasl))) #+sbcl (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file))) #+clisp (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) (multiple-value-bind (output-truename warnings-p failure-p) (with-saved-deferred-warnings (warnings-file) (with-muffled-compiler-conditions () (with-enough-pathname (input-file :defaults *base-build-directory*) (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) #-sbcl keywords) #+ecl (apply 'compile-file input-file :output-file (if object-file (list* object-file :system-p t keywords) (list* tmp-file keywords))) #+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords))))) (cond ((and output-truename (flet ((check-flag (flag behaviour) (or (not flag) (member behaviour '(:success :warn :ignore))))) (and (check-flag failure-p *compile-file-failure-behaviour*) (check-flag warnings-p *compile-file-warnings-behaviour*))) (progn #+(or ecl mkcl) (when (and #+ecl object-file) (setf output-truename (compiler::build-fasl tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)))) (or (not compile-check) (apply compile-check input-file :output-file tmp-file keywords)))) (delete-file-if-exists output-file) (when output-truename #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) (rename-file-overwriting-target output-truename output-file) (setf output-truename (truename output-file))) #+clisp (delete-file-if-exists tmp-lib)) (t ;; error or failed check (delete-file-if-exists output-truename) #+clisp (delete-file-if-exists tmp-lib) #+sbcl (delete-file-if-exists tmp-cfasl) (setf output-truename nil))) (values output-truename warnings-p failure-p)))) (defun load* (x &rest keys &key &allow-other-keys) "Portable wrapper around LOAD that properly handles loading from a stream." (etypecase x ((or pathname string #-(or allegro clozure gcl2.6 genera) stream) (apply 'load x #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys))) ;; GCL 2.6, Genera can't load from a string-input-stream ;; ClozureCL 1.6 can only load from file input stream ;; Allegro 5, I don't remember but it must have been broken when I tested. #+(or allegro clozure gcl2.6 genera) (stream ;; make do this way (let ((*package* *package*) (*readtable* *readtable*) (*load-pathname* nil) (*load-truename* nil)) (eval-input x))))) (defun load-from-string (string) "Portably read and evaluate forms from a STRING." (with-input-from-string (s string) (load* s)))) ;;; Links FASLs together (with-upgradability () (defun combine-fasls (inputs output) "Combine a list of FASLs INPUTS into a single FASL OUTPUT" #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (error "~A does not support ~S~%inputs ~S~%output ~S" (implementation-type) 'combine-fasls inputs output) #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) #+lispworks (let (fasls) (unwind-protect (progn (loop :for i :in inputs :for n :from 1 :for f = (add-pathname-suffix output (format nil "-FASL~D" n)) :do (copy-file i f) (push f fasls)) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) (eval `(scm:defsystem :fasls-to-concatenate (:default-pathname ,(pathname-directory-pathname output)) :members ,(loop :for f :in (reverse fasls) :collect `(,(namestring f) :load-only t)))) (scm:concatenate-system output :fasls-to-concatenate)) (loop :for f :in fasls :do (ignore-errors (delete-file f))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) cl-asdf-3.0.3/uiop/os.lisp000066400000000000000000000400761223164443400153260ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Access to the Operating System (uiop/package:define-package :uiop/os (:nicknames :asdf/os) (:recycle :uiop/os :asdf/os :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features #:getenv #:getenvp ;; environment variables #:implementation-identifier ;; implementation identifier #:implementation-type #:*implementation-type* #:operating-system #:architecture #:lisp-version-string #:hostname #:getcwd #:chdir ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian #:parse-file-location-info #:parse-windows-shortcut)) (in-package :uiop/os) ;;; Features (with-upgradability () (defun featurep (x &optional (*features* *features*)) "Checks whether a feature expression X is true with respect to the *FEATURES* set, as per the CLHS standard for #+ and #-. Beware that just like the CLHS, we assume symbols from the KEYWORD package are used, but that unless you're using #+/#- your reader will not have magically used the KEYWORD package, so you need specify keywords explicitly." (cond ((atom x) (and (member x *features*) t)) ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) ((eq :or (car x)) (some #'featurep (cdr x))) ((eq :and (car x)) (every #'featurep (cdr x))) (t (error "Malformed feature specification ~S" x)))) (defun os-unix-p () "Is the underlying operating system some Unix variant?" (or #+abcl (featurep :unix) #+(and (not abcl) (or unix cygwin darwin)) t)) (defun os-macosx-p () "Is the underlying operating system MacOS X?" ;; OS-MACOSX is not mutually exclusive with OS-UNIX, ;; in fact the former implies the latter. (or #+allegro (featurep :macosx) #+clisp (featurep :macos) (featurep :darwin))) (defun os-windows-p () "Is the underlying operating system Microsoft Windows?" (or #+abcl (featurep :windows) #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) (defun os-genera-p () "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" (or #+genera t)) (defun os-oldmac-p () "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" (or #+mcl t)) (defun detect-os () "Detects the current operating system. Only needs be run at compile-time, except on ABCL where it might change between FASL compilation and runtime." (loop* :with o :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p) (:os-macosx . os-macosx-p) (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)) :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*) :else :do (setf *features* (remove feature *features*)) :finally (return (or o (error "Congratulations for trying ASDF on an operating system~%~ that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) (detect-os)) ;;;; Environment variables: getting them, and parsing them. (with-upgradability () (defun getenv (x) "Query the environment, as in C getenv. Beware: may return empty string if a variable is present but empty; use getenvp to return NIL in such a case." (declare (ignorable x)) #+(or abcl clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) #+cormanlisp (let* ((buffer (ct:malloc 1)) (cname (ct:lisp-string-to-c-string x)) (needed-size (win:getenvironmentvariable cname buffer 0)) (buffer1 (ct:malloc (1+ needed-size)))) (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) nil (ct:c-string-to-lisp-string buffer1)) (ct:free buffer) (ct:free buffer1))) #+gcl (system:getenv x) #+genera nil #+lispworks (lispworks:environment-variable x) #+mcl (ccl:with-cstrs ((name x)) (let ((value (_getenv name))) (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+sbcl (sb-ext:posix-getenv x) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) (defun getenvp (x) "Predicate that is true if the named variable is present in the libc environment, then returning the non-empty string value of the variable" (let ((g (getenv x))) (and (not (emptyp g)) g)))) ;;;; implementation-identifier ;; ;; produce a string to identify current implementation. ;; Initially stolen from SLIME's SWANK, completely rewritten since. ;; We're back to runtime checking, for the sake of e.g. ABCL. (with-upgradability () (defun first-feature (feature-sets) "A helper for various feature detection functions" (dolist (x feature-sets) (multiple-value-bind (short long feature-expr) (if (consp x) (values (first x) (second x) (cons :or (rest x))) (values x x x)) (when (featurep feature-expr) (return (values short long)))))) (defun implementation-type () "The type of Lisp implementation used, as a short UIOP-standardized keyword" (first-feature '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) (:cmu :cmucl :cmu) :ecl :gcl (:lwpe :lispworks-personal-edition) (:lw :lispworks) :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) (defvar *implementation-type* (implementation-type) "The type of Lisp implementation used, as a short UIOP-standardized keyword") (defun operating-system () "The operating system of the current host" (first-feature '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix :genera))) (defun architecture () "The CPU architecture of the current host" (first-feature '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) (: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 () "return a string that identifies the current Lisp implementation version" (let ((s (lisp-implementation-version))) (car ; as opposed to OR, this idiom prevents some unreachable code warning (list #+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 () "Return a string that identifies the ABI of the current implementation, suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." (substitute-if #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) (format nil "~(~a~@{~@[-~a~]~}~)" (or (implementation-type) (lisp-implementation-type)) (or (lisp-version-string) (lisp-implementation-version)) (or (operating-system) (software-type)) (or (architecture) (machine-type)))))) ;;;; Other system information (with-upgradability () (defun hostname () "return the hostname of the current host" ;; Note: untested on RMCL #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) #+gcl (system:gethostname))) ;;; Current directory (with-upgradability () #+cmu (defun parse-unix-namestring* (unix-namestring) "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" (multiple-value-bind (host device directory name type version) (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) (make-pathname :host (or host lisp::*unix-host*) :device device :directory directory :name name :type type :version version))) (defun getcwd () "Get the current working directory as per POSIX getcwd(3), as a pathname object" (or #+abcl (parse-namestring (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t) #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+ecl (ext:getcwd) #+gcl (parse-namestring ;; this is a joke. Isn't there a better way? (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines))) #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! #+lispworks (system:current-directory) #+mkcl (mk-ext:getcwd) #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) #+xcl (extensions:current-directory) (error "getcwd not supported on your implementation"))) (defun chdir (x) "Change current directory, as per POSIX chdir(2), to a given pathname object" (if-let (x (pathname x)) (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x)) #+allegro (excl:chdir x) #+clisp (ext:cd x) #+clozure (setf (ccl:current-directory) x) #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) (error "Could not set current directory to ~A" x)) #+ecl (ext:chdir x) #+genera (setf *default-pathname-defaults* x) #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)) (error "chdir not supported on your implementation"))))) ;;;; ----------------------------------------------------------------- ;;;; Windows shortcut support. Based on: ;;;; ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it (with-upgradability () (defparameter *link-initial-dword* 76) (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) (defun read-null-terminated-string (s) "Read a null-terminated string from an octet stream S" ;; note: doesn't play well with UNICODE (with-output-to-string (out) (loop :for code = (read-byte s) :until (zerop code) :do (write-char (code-char code) out)))) (defun read-little-endian (s &optional (bytes 4)) "Read a number in little-endian format from an byte (octet) stream S, the number having BYTES octets (defaulting to 4)." (loop :for i :from 0 :below bytes :sum (ash (read-byte s) (* 8 i)))) (defun parse-file-location-info (s) "helper to parse-windows-shortcut" (let ((start (file-position s)) (total-length (read-little-endian s)) (end-of-header (read-little-endian s)) (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) "From a .lnk windows shortcut, extract the pathname linked to" ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. (with-open-file (s pathname :element-type '(unsigned-byte 8)) (handler-case (when (and (= (read-little-endian s) *link-initial-dword*) (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))))) cl-asdf-3.0.3/uiop/package.lisp000066400000000000000000001132261223164443400162760ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; ;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; (defpackage :uiop/package ;; CAUTION: we must handle the first few packages specially for hot-upgrade. ;; This package definition MUST NOT change unless its name too changes; ;; if/when it changes, don't forget to add new functions missing from below. ;; Until then, uiop/package is frozen to forever ;; import and export the same exact symbols as for ASDF 2.27. ;; Any other symbol must be import-from'ed and re-export'ed in a different package. (:use :common-lisp) (:export #:find-package* #:find-symbol* #:symbol-call #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* #:symbol-shadowing-p #:home-package-p #:symbol-package-name #:standard-common-lisp-symbol-p #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol #:ensure-package-unused #:delete-package* #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away #:package-definition-form #:parse-define-package-form #:ensure-package #:define-package)) (in-package :uiop/package) ;;;; General purpose package utilities (eval-when (:load-toplevel :compile-toplevel :execute) (defun find-package* (package-designator &optional (error t)) (let ((package (find-package package-designator))) (cond (package package) (error (error "No package named ~S" (string package-designator))) (t nil)))) (defun find-symbol* (name package-designator &optional (error t)) "Find a symbol in a package of given string'ified NAME; unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax by letting you supply a symbol or keyword for the name; also works well when the package is not present. If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." (block nil (let ((package (find-package* package-designator error))) (when package ;; package error handled by find-package* already (multiple-value-bind (symbol status) (find-symbol (string name) package) (cond (status (return (values symbol status))) (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) (values nil nil)))) (defun symbol-call (package name &rest args) "Call a function associated with symbol of given name in given package, with given ARGS. Useful when the call is read before the package is loaded, or when loading the package is optional." (apply (find-symbol* name package) args)) (defun intern* (name package-designator &optional (error t)) (intern (string name) (find-package* package-designator error))) (defun export* (name package-designator) (let* ((package (find-package* package-designator)) (symbol (intern* name package))) (export (or symbol (list symbol)) package))) (defun import* (symbol package-designator) (import (or symbol (list symbol)) (find-package* package-designator))) (defun shadowing-import* (symbol package-designator) (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) (defun shadow* (name package-designator) (shadow (string name) (find-package* package-designator))) (defun make-symbol* (name) (etypecase name (string (make-symbol name)) (symbol (copy-symbol name)))) (defun unintern* (name package-designator &optional (error t)) (block nil (let ((package (find-package* package-designator error))) (when package (multiple-value-bind (symbol status) (find-symbol* name package error) (cond (status (unintern symbol package) (return (values symbol status))) (error (error "symbol ~A not present in package ~A" (string symbol) (package-name package)))))) (values nil nil)))) (defun symbol-shadowing-p (symbol package) (and (member symbol (package-shadowing-symbols package)) t)) (defun home-package-p (symbol package) (and package (let ((sp (symbol-package symbol))) (and sp (let ((pp (find-package* package))) (and pp (eq sp pp)))))))) (eval-when (:load-toplevel :compile-toplevel :execute) (defun symbol-package-name (symbol) (let ((package (symbol-package symbol))) (and package (package-name package)))) (defun standard-common-lisp-symbol-p (symbol) (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) (and (eq sym symbol) (eq status :external)))) (defun reify-package (package &optional package-context) (if (eq package package-context) t (etypecase package (null nil) ((eql (find-package :cl)) :cl) (package (package-name package))))) (defun unreify-package (package &optional package-context) (etypecase package (null nil) ((eql t) package-context) ((or symbol string) (find-package package)))) (defun reify-symbol (symbol &optional package-context) (etypecase symbol ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) (symbol (vector (symbol-name symbol) (reify-package (symbol-package symbol) package-context))))) (defun unreify-symbol (symbol &optional package-context) (etypecase symbol (symbol symbol) ((simple-vector 2) (let* ((symbol-name (svref symbol 0)) (package-foo (svref symbol 1)) (package (unreify-package package-foo package-context))) (if package (intern* symbol-name package) (make-symbol* symbol-name))))))) (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *all-package-happiness* '()) (defvar *all-package-fishiness* (list t)) (defun record-fishy (info) ;;(format t "~&FISHY: ~S~%" info) (push info *all-package-fishiness*)) (defmacro when-package-fishiness (&body body) `(when *all-package-fishiness* ,@body)) (defmacro note-package-fishiness (&rest info) `(when-package-fishiness (record-fishy (list ,@info))))) (eval-when (:load-toplevel :compile-toplevel :execute) #+(or clisp clozure) (defun get-setf-function-symbol (symbol) #+clisp (let ((sym (get symbol 'system::setf-function))) (if sym (values sym :setf-function) (let ((sym (get symbol 'system::setf-expander))) (if sym (values sym :setf-expander) (values nil nil))))) #+clozure (gethash symbol ccl::%setf-function-names%)) #+(or clisp clozure) (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) #+clisp (assert (member kind '(:setf-function :setf-expander))) #+clozure (assert (eq kind t)) #+clisp (cond ((null new-setf-symbol) (remprop symbol 'system::setf-function) (remprop symbol 'system::setf-expander)) ((eq kind :setf-function) (setf (get symbol 'system::setf-function) new-setf-symbol)) ((eq kind :setf-expander) (setf (get symbol 'system::setf-expander) new-setf-symbol)) (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" kind symbol new-setf-symbol))) #+clozure (progn (gethash symbol ccl::%setf-function-names%) new-setf-symbol (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) #+(or clisp clozure) (defun create-setf-function-symbol (symbol) #+clisp (system::setf-symbol symbol) #+clozure (ccl::construct-setf-function-name symbol)) (defun set-dummy-symbol (symbol reason other-symbol) (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) (defun make-dummy-symbol (symbol) (let ((dummy (copy-symbol symbol))) (set-dummy-symbol dummy 'replacing symbol) (set-dummy-symbol symbol 'replaced-by dummy) dummy)) (defun dummy-symbol (symbol) (get symbol 'dummy-symbol)) (defun get-dummy-symbol (symbol) (let ((existing (dummy-symbol symbol))) (if existing (values (cdr existing) (car existing)) (make-dummy-symbol symbol)))) (defun nuke-symbol-in-package (symbol package-designator) (let ((package (find-package* package-designator)) (name (symbol-name symbol))) (multiple-value-bind (sym stat) (find-symbol name package) (when (and (member stat '(:internal :external)) (eq symbol sym)) (if (symbol-shadowing-p symbol package) (shadowing-import* (get-dummy-symbol symbol) package) (unintern* symbol package)))))) (defun nuke-symbol (symbol &optional (packages (list-all-packages))) #+(or clisp clozure) (multiple-value-bind (setf-symbol kind) (get-setf-function-symbol symbol) (when kind (nuke-symbol setf-symbol))) (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) (defun rehome-symbol (symbol package-designator) "Changes the home package of a symbol, also leaving it present in its old home if any" (let* ((name (symbol-name symbol)) (package (find-package* package-designator)) (old-package (symbol-package symbol)) (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) (unless (eq package old-package) (let ((overwritten-symbol-shadowing-p (and overwritten-symbol-status (symbol-shadowing-p overwritten-symbol package)))) (note-package-fishiness :rehome-symbol name (when old-package (package-name old-package)) old-status (and shadowing t) (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) (when old-package (if shadowing (shadowing-import* shadowing old-package)) (unintern* symbol old-package)) (cond (overwritten-symbol-shadowing-p (shadowing-import* symbol package)) (t (when overwritten-symbol-status (unintern* overwritten-symbol package)) (import* symbol package))) (if shadowing (shadowing-import* symbol old-package) (import* symbol old-package)) #+(or clisp clozure) (multiple-value-bind (setf-symbol kind) (get-setf-function-symbol symbol) (when kind (let* ((setf-function (fdefinition setf-symbol)) (new-setf-symbol (create-setf-function-symbol symbol))) (note-package-fishiness :setf-function name (package-name package) (symbol-name setf-symbol) (symbol-package-name setf-symbol) (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) (when (symbol-package setf-symbol) (unintern* setf-symbol (symbol-package setf-symbol))) (setf (fdefinition new-setf-symbol) setf-function) (set-setf-function-symbol new-setf-symbol symbol kind)))) #+(or clisp clozure) (multiple-value-bind (overwritten-setf foundp) (get-setf-function-symbol overwritten-symbol) (when foundp (unintern overwritten-setf))) (when (eq old-status :external) (export* symbol old-package)) (when (eq overwritten-symbol-status :external) (export* symbol package)))) (values overwritten-symbol overwritten-symbol-status)))) (defun ensure-package-unused (package) (loop :for p :in (package-used-by-list package) :do (unuse-package package p))) (defun delete-package* (package &key nuke) (let ((p (find-package package))) (when p (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) (ensure-package-unused p) (delete-package package)))) (defun package-names (package) (cons (package-name package) (package-nicknames package))) (defun packages-from-names (names) (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) separator (index (random most-positive-fixnum))) (loop :for i :from index :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) :thereis (and (not (find-package n)) n))) (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) (let ((new-name (apply 'fresh-package-name :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) (record-fishy (list :rename-away (package-names p) new-name)) (rename-package p new-name)))) ;;; Communicable representation of symbol and package information (eval-when (:load-toplevel :compile-toplevel :execute) (defun package-definition-form (package-designator &key (nicknamesp t) (usep t) (shadowp t) (shadowing-import-p t) (exportp t) (importp t) internp (error t)) (let* ((package (or (find-package* package-designator error) (return-from package-definition-form nil))) (name (package-name package)) (nicknames (package-nicknames package)) (use (mapcar #'package-name (package-use-list package))) (shadow ()) (shadowing-import (make-hash-table :test 'equal)) (import (make-hash-table :test 'equal)) (export ()) (intern ())) (when package (loop :for sym :being :the :symbols :in package :for status = (nth-value 1 (find-symbol* sym package)) :do (ecase status ((nil :inherited)) ((:internal :external) (let* ((name (symbol-name sym)) (external (eq status :external)) (home (symbol-package sym)) (home-name (package-name home)) (imported (not (eq home package))) (shadowing (symbol-shadowing-p sym package))) (cond ((and shadowing imported) (push name (gethash home-name shadowing-import))) (shadowing (push name shadow)) (imported (push name (gethash home-name import)))) (cond (external (push name export)) (imported) (t (push name intern))))))) (labels ((sort-names (names) (sort names #'string<)) (table-keys (table) (loop :for k :being :the :hash-keys :of table :collect k)) (when-relevant (key value) (when value (list (cons key value)))) (import-options (key table) (loop :for i :in (sort-names (table-keys table)) :collect `(,key ,i ,@(sort-names (gethash i table)))))) `(defpackage ,name ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) (:use ,@(and usep (sort-names use))) ,@(when-relevant :shadow (and shadowp (sort-names shadow))) ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) ,@(import-options :import-from (and importp import)) ,@(when-relevant :export (and exportp (sort-names export))) ,@(when-relevant :intern (and internp (sort-names intern))))))))) ;;; ensure-package, define-package (eval-when (:load-toplevel :compile-toplevel :execute) (defun ensure-shadowing-import (name to-package from-package shadowed imported) (check-type name string) (check-type to-package package) (check-type from-package package) (check-type shadowed hash-table) (check-type imported hash-table) (let ((import-me (find-symbol* name from-package))) (multiple-value-bind (existing status) (find-symbol name to-package) (cond ((gethash name shadowed) (unless (eq import-me existing) (error "Conflicting shadowings for ~A" name))) (t (setf (gethash name shadowed) t) (setf (gethash name imported) t) (unless (or (null status) (and (member status '(:internal :external)) (eq existing import-me) (symbol-shadowing-p existing to-package))) (note-package-fishiness :shadowing-import name (package-name from-package) (or (home-package-p import-me from-package) (symbol-package-name import-me)) (package-name to-package) status (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) (shadowing-import* import-me to-package)))))) (defun ensure-imported (import-me into-package &optional from-package) (check-type import-me symbol) (check-type into-package package) (check-type from-package (or null package)) (let ((name (symbol-name import-me))) (multiple-value-bind (existing status) (find-symbol name into-package) (cond ((not status) (import* import-me into-package)) ((eq import-me existing)) (t (let ((shadowing-p (symbol-shadowing-p existing into-package))) (note-package-fishiness :ensure-imported name (and from-package (package-name from-package)) (or (home-package-p import-me from-package) (symbol-package-name import-me)) (package-name into-package) status (and status (or (home-package-p existing into-package) (symbol-package-name existing))) shadowing-p) (cond ((or shadowing-p (eq status :inherited)) (shadowing-import* import-me into-package)) (t (unintern* existing into-package) (import* import-me into-package)))))))) (values)) (defun ensure-import (name to-package from-package shadowed imported) (check-type name string) (check-type to-package package) (check-type from-package package) (check-type shadowed hash-table) (check-type imported hash-table) (multiple-value-bind (import-me import-status) (find-symbol name from-package) (when (null import-status) (note-package-fishiness :import-uninterned name (package-name from-package) (package-name to-package)) (setf import-me (intern* name from-package))) (multiple-value-bind (existing status) (find-symbol name to-package) (cond ((and imported (gethash name imported)) (unless (and status (eq import-me existing)) (error "Can't import ~S from both ~S and ~S" name (package-name (symbol-package existing)) (package-name from-package)))) ((gethash name shadowed) (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) (t (setf (gethash name imported) t)))) (ensure-imported import-me to-package from-package))) (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) (check-type name string) (check-type symbol symbol) (check-type to-package package) (check-type from-package package) (check-type mixp (member nil t)) ; no cl:boolean on Genera (check-type shadowed hash-table) (check-type imported hash-table) (check-type inherited hash-table) (multiple-value-bind (existing status) (find-symbol name to-package) (let* ((sp (symbol-package symbol)) (in (gethash name inherited)) (xp (and status (symbol-package existing)))) (when (null sp) (note-package-fishiness :import-uninterned name (package-name from-package) (package-name to-package) mixp) (import* symbol from-package) (setf sp (package-name from-package))) (cond ((gethash name shadowed)) (in (unless (equal sp (first in)) (if mixp (ensure-shadowing-import name to-package (second in) shadowed imported) (error "Can't inherit ~S from ~S, it is inherited from ~S" name (package-name sp) (package-name (first in)))))) ((gethash name imported) (unless (eq symbol existing) (error "Can't inherit ~S from ~S, it is imported from ~S" name (package-name sp) (package-name xp)))) (t (setf (gethash name inherited) (list sp from-package)) (when (and status (not (eq sp xp))) (let ((shadowing (symbol-shadowing-p existing to-package))) (note-package-fishiness :inherited name (package-name from-package) (or (home-package-p symbol from-package) (symbol-package-name symbol)) (package-name to-package) (or (home-package-p existing to-package) (symbol-package-name existing))) (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported) (unintern* existing to-package))))))))) (defun ensure-mix (name symbol to-package from-package shadowed imported inherited) (check-type name string) (check-type symbol symbol) (check-type to-package package) (check-type from-package package) (check-type shadowed hash-table) (check-type imported hash-table) (check-type inherited hash-table) (unless (gethash name shadowed) (multiple-value-bind (existing status) (find-symbol name to-package) (let* ((sp (symbol-package symbol)) (im (gethash name imported)) (in (gethash name inherited))) (cond ((or (null status) (and status (eq symbol existing)) (and in (eq sp (first in)))) (ensure-inherited name symbol to-package from-package t shadowed imported inherited)) (in (remhash name inherited) (ensure-shadowing-import name to-package (second in) shadowed imported)) (im (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]" name (package-name from-package) (home-package-p symbol from-package) (symbol-package-name symbol) (package-name to-package) (home-package-p existing to-package) (symbol-package-name existing))) (t (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) (defun recycle-symbol (name recycle exported) ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE ;; packages, and a hash-table of names (strings) of symbols scheduled to be ;; EXPORTED from the package being defined. It returns two values, the ;; symbol found (if any, or else NIL), and a boolean flag indicating whether ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the ;; re-homing of the symbol, etc. (check-type name string) (check-type recycle list) (check-type exported hash-table) (when (gethash name exported) ;; don't bother recycling private symbols (let (recycled foundp) (dolist (r recycle (values recycled foundp)) (multiple-value-bind (symbol status) (find-symbol name r) (when (and status (home-package-p symbol r)) (cond (foundp ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r))) (t (setf recycled symbol foundp r))))))))) (defun symbol-recycled-p (sym recycle) (check-type sym symbol) (check-type recycle list) (and (member (symbol-package sym) recycle) t)) (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) (check-type name string) (check-type package package) (check-type intern (member nil t)) ; no cl:boolean on Genera (check-type shadowed hash-table) (check-type imported hash-table) (check-type inherited hash-table) (unless (or (gethash name shadowed) (gethash name imported) (gethash name inherited)) (multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) (cond ((and status (eq existing recycled) (eq previous package))) (previous (rehome-symbol recycled package)) ((and status (eq package (symbol-package existing)))) (t (when status (note-package-fishiness :ensure-symbol name (reify-package (symbol-package existing) package) status intern) (unintern existing)) (when intern (intern* name package)))))))) (declaim (ftype function ensure-exported)) (defun ensure-exported-to-user (name symbol to-package &optional recycle) (check-type name string) (check-type symbol symbol) (check-type to-package package) (check-type recycle list) (assert (equal name (symbol-name symbol))) (multiple-value-bind (existing status) (find-symbol name to-package) (unless (and status (eq symbol existing)) (let ((accessible (or (null status) (let ((shadowing (symbol-shadowing-p existing to-package)) (recycled (symbol-recycled-p existing recycle))) (unless (and shadowing (not recycled)) (note-package-fishiness :ensure-export name (symbol-package-name symbol) (package-name to-package) (or (home-package-p existing to-package) (symbol-package-name existing)) status shadowing) (if (or (eq status :inherited) shadowing) (shadowing-import* symbol to-package) (unintern existing to-package)) t))))) (when (and accessible (eq status :external)) (ensure-exported name symbol to-package recycle)))))) (defun ensure-exported (name symbol from-package &optional recycle) (dolist (to-package (package-used-by-list from-package)) (ensure-exported-to-user name symbol to-package recycle)) (unless (eq from-package (symbol-package symbol)) (ensure-imported symbol from-package)) (export* name from-package)) (defun ensure-export (name from-package &optional recycle) (multiple-value-bind (symbol status) (find-symbol* name from-package) (unless (eq status :external) (ensure-exported name symbol from-package recycle)))) (defun ensure-package (name &key nicknames documentation use shadow shadowing-import-from import-from export intern recycle mix reexport unintern) #+(or gcl2.6 genera) (declare (ignore documentation)) (let* ((package-name (string name)) (nicknames (mapcar #'string nicknames)) (names (cons package-name nicknames)) (previous (packages-from-names names)) (discarded (cdr previous)) (to-delete ()) (package (or (first previous) (make-package package-name :nicknames nicknames))) (recycle (packages-from-names recycle)) (use (mapcar 'find-package* use)) (mix (mapcar 'find-package* mix)) (reexport (mapcar 'find-package* reexport)) (shadow (mapcar 'string shadow)) (export (mapcar 'string export)) (intern (mapcar 'string intern)) (unintern (mapcar 'string unintern)) (shadowed (make-hash-table :test 'equal)) ; string to bool (imported (make-hash-table :test 'equal)) ; string to bool (exported (make-hash-table :test 'equal)) ; string to bool ;; string to list home package and use package: (inherited (make-hash-table :test 'equal))) (when-package-fishiness (record-fishy package-name)) #-(or gcl2.6 genera) (when documentation (setf (documentation package t) documentation)) (loop :for p :in (set-difference (package-use-list package) (append mix use)) :do (note-package-fishiness :over-use name (package-names p)) (unuse-package p package)) (loop :for p :in discarded :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) (package-names p)) :do (note-package-fishiness :nickname name (package-names p)) (cond (n (rename-package p (first n) (rest n))) (t (rename-package-away p) (push p to-delete)))) (rename-package package package-name nicknames) (dolist (name unintern) (multiple-value-bind (existing status) (find-symbol name package) (when status (unless (eq status :inherited) (note-package-fishiness :unintern (package-name package) name (symbol-package-name existing) status) (unintern* name package nil))))) (dolist (name export) (setf (gethash name exported) t)) (dolist (p reexport) (do-external-symbols (sym p) (setf (gethash (string sym) exported) t))) (do-external-symbols (sym package) (let ((name (symbol-name sym))) (unless (gethash name exported) (note-package-fishiness :over-export (package-name package) name (or (home-package-p sym package) (symbol-package-name sym))) (unexport sym package)))) (dolist (name shadow) (setf (gethash name shadowed) t) (multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) (let ((shadowing (and status (symbol-shadowing-p existing package)))) (cond ((eq previous package)) (previous (rehome-symbol recycled package)) ((or (member status '(nil :inherited)) (home-package-p existing package))) (t (let ((dummy (make-symbol name))) (note-package-fishiness :shadow-imported (package-name package) name (symbol-package-name existing) status shadowing) (shadowing-import* dummy package) (import* dummy package))))))) (shadow* name package)) (loop :for (p . syms) :in shadowing-import-from :for pp = (find-package* p) :do (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) (loop :for p :in mix :for pp = (find-package* p) :do (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) (loop :for (p . syms) :in import-from :for pp = (find-package p) :do (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) (dolist (p (append use mix)) (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) (use-package p package)) (loop :for name :being :the :hash-keys :of exported :do (ensure-symbol name package t recycle shadowed imported inherited exported) (ensure-export name package recycle)) (dolist (name intern) (ensure-symbol name package t recycle shadowed imported inherited exported)) (do-symbols (sym package) (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) (map () 'delete-package* to-delete) package))) (eval-when (:load-toplevel :compile-toplevel :execute) (defun parse-define-package-form (package clauses) (loop :with use-p = nil :with recycle-p = nil :with documentation = nil :for (kw . args) :in clauses :when (eq kw :nicknames) :append args :into nicknames :else :when (eq kw :documentation) :do (cond (documentation (error "define-package: can't define documentation twice")) ((or (atom args) (cdr args)) (error "define-package: bad documentation")) (t (setf documentation (car args)))) :else :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else :when (eq kw :shadow) :append args :into shadow :else :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else :when (eq kw :import-from) :collect args :into import-from :else :when (eq kw :export) :append args :into export :else :when (eq kw :intern) :append args :into intern :else :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else :when (eq kw :mix) :append args :into mix :else :when (eq kw :reexport) :append args :into reexport :else :when (eq kw :unintern) :append args :into unintern :else :do (error "unrecognized define-package keyword ~S" kw) :finally (return `(,package :nicknames ,nicknames :documentation ,documentation :use ,(if use-p use '(:common-lisp)) :shadow ,shadow :shadowing-import-from ,shadowing-import-from :import-from ,import-from :export ,export :intern ,intern :recycle ,(if recycle-p recycle (cons package nicknames)) :mix ,mix :reexport ,reexport :unintern ,unintern))))) (defmacro define-package (package &rest clauses) "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form \(KEYWORD . ARGS\). DEFINE-PACKAGE supports the following keywords: USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE. RECYCLE -- Recycle the package's exported symbols from the specified packages, in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE, either through an :EXPORT option or a :REEXPORT option, if the symbol exists in one of the :RECYCLE packages, the first such symbol is re-homed to the package being defined. For the sake of idempotence, it is important that the package being defined should appear in first position if it already exists, and even if it doesn't, ahead of any package that is not going to be deleted afterwards and never created again. In short, except for special cases, always make it the first package on the list if the list is not empty. MIX -- Takes a list of package designators. MIX behaves like \(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to resolve conflicts in favor of the first found symbol. It may still yield an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol. REEXPORT -- Takes a list of package designators. For each package, p, in the list, export symbols with the same name as those exported from p. Note that in the case of shadowing, etc. the symbols with the same name may not be the same symbols. UNINTERN -- Remove symbols here from PACKAGE." (let ((ensure-form `(apply 'ensure-package ',(parse-define-package-form package clauses)))) `(progn #+clisp (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form) #+(or clisp ecl gcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form)))) ;;;; Final tricks to keep various implementations happy. ;; We want most such tricks in common-lisp.lisp, ;; but these need to be done before the define-package form there, ;; that we nevertheless want to be the very first form. (eval-when (:load-toplevel :compile-toplevel :execute) #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF. (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, ;; but can run ASDF 2.011. GCL 2.6 has even more issues. (cond ((or (< system::*gcl-major-version* 2) (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 6))) (error "GCL 2.6 or later required to use ASDF")) ((and (= system::*gcl-major-version* 2) (= system::*gcl-minor-version* 6)) (pushnew 'ignorable pcl::*variable-declarations-without-argument*) (pushnew :gcl2.6 *features*)) (t (pushnew :gcl2.7 *features*)))) ;; Compatibility with whoever calls asdf/package (define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) cl-asdf-3.0.3/uiop/pathname.lisp000066400000000000000000001077361223164443400165110ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp pathnames ;; This layer allows for portable manipulation of pathname objects themselves, ;; which all is necessary prior to any access the filesystem or environment. (uiop/package:define-package :uiop/pathname (:nicknames :asdf/pathname) (:recycle :uiop/pathname :asdf/pathname :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) (:export ;; Making and merging pathnames, portably #:normalize-pathname-directory-component #:denormalize-pathname-directory-component #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* #:make-pathname-component-logical #:make-pathname-logical #:merge-pathnames* #:nil-pathname #:*nil-pathname* #:with-pathname-defaults ;; Predicates #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p ;; Directories #:pathname-directory-pathname #:pathname-parent-directory-pathname #:directory-pathname-p #:ensure-directory-pathname ;; Parsing filenames #:component-name-to-pathname-components #:split-name-type #:parse-unix-namestring #:unix-namestring #:split-unix-namestring-directory-components ;; Absolute and relative pathnames #:subpathname #:subpathname* #:ensure-absolute-pathname #:pathname-root #:pathname-host-pathname #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname ;; Checking constraints #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints ;; Wildcard pathnames #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden ;; Translate a pathname #:relativize-directory-component #:relativize-pathname-directory #:directory-separator-for-host #:directorize-pathname-host-device #:translate-pathname* #:*output-translation-function*)) (in-package :uiop/pathname) ;;; Normalizing pathnames across implementations (with-upgradability () (defun normalize-pathname-directory-component (directory) "Convert the DIRECTORY component from a format usable by the underlying implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format that is a list and not a string." #+gcl2.6 (setf directory (substitute :back :parent directory)) (cond #-(or cmu sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) #+gcl2.6 ((and (consp directory) (eq :root (first directory))) `(:absolute ,@(rest directory))) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) #+gcl2.6 ((consp directory) `(:relative ,@directory)) (t (error (compatfmt "~@") directory)))) (defun denormalize-pathname-directory-component (directory-component) "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable by the underlying implementation's MAKE-PATHNAME and other primitives" #-gcl2.6 directory-component #+gcl2.6 (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) directory-component))) (cond ((and (consp d) (eq :relative (first d))) (rest d)) ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) (t d)))) (defun merge-pathname-directory-components (specified defaults) "Helper for MERGE-PATHNAMES* that handles directory components" (let ((directory (normalize-pathname-directory-component specified))) (ecase (first directory) ((nil) defaults) (:absolute specified) (:relative (let ((defdir (normalize-pathname-directory-component defaults)) (reldir (cdr directory))) (cond ((null defdir) directory) ((not (eq :back (first reldir))) (append defdir reldir)) (t (loop :with defabs = (first defdir) :with defrev = (reverse (rest defdir)) :while (and (eq :back (car reldir)) (or (and (eq :absolute defabs) (null defrev)) (stringp (car defrev)))) :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) ;; Giving :unspecific as :type argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp) host (device () #+allegro devicep) name type version defaults #+scl &allow-other-keys) "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and tries hard to make a pathname that will actually behave as documented, despite the peculiarities of each implementation" ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults. (declare (ignorable host device directory name type version defaults)) (apply 'make-pathname (append #+allegro (when (and devicep (null device)) `(:device :unspecific)) #+gcl2.6 (when directoryp `(:directory ,(denormalize-pathname-directory-component directory))) keys))) (defun make-pathname-component-logical (x) "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 pathname. This is what users want on a modern Unix or Windows operating system, unlike the MERGE-PATHNAMES behavior. Also, if either argument is NIL, then the other argument is returned unmodified; this is unlike MERGE-PATHNAMES which always merges with a pathname, by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) #+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 logical-pathname-p (x) "is X a logical-pathname?" (typep x 'logical-pathname)) (defun physical-pathname-p (x) "is X a pathname that is not a logical-pathname?" (and (pathnamep x) (not (logical-pathname-p x)))) (defun physicalize-pathname (x) "if X is a logical pathname, use translate-logical-pathname on it." ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP (let ((p (when x (pathname x)))) (if (logical-pathname-p p) (translate-logical-pathname p) p))) (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) "A pathname that is as neutral as possible for use as defaults when merging, making or parsing pathnames" ;; 19.2.2.2.1 says a NIL host can mean a default host; ;; see also "valid physical pathname host" in the CLHS glossary, that suggests ;; strings and lists of strings or :unspecific ;; But CMUCL decides to die on NIL. ;; MCL has issues with make-pathname, nil and defaulting (declare (ignorable defaults)) #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil :host (or #+cmu lisp::*unix-host*) #+scl ,@'(:scheme nil :scheme-specific-part nil :username nil :password nil :parameters nil :query nil :fragment nil) ;; the default shouldn't matter, but we really want something physical #-mcl ,@'(:defaults defaults))) (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) "A pathname that is as neutral as possible for use as defaults when merging, making or parsing pathnames") (defmacro with-pathname-defaults ((&optional defaults) &body body) "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible when merging, making or parsing pathnames" `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))) ;;; Some pathname predicates (with-upgradability () (defun pathname-equal (p1 p2) "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?" (when (stringp p1) (setf p1 (pathname p1))) (when (stringp p2) (setf p2 (pathname p2))) (flet ((normalize-component (x) (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) x))) (macrolet ((=? (&rest accessors) (flet ((frob (x) (reduce 'list (cons 'normalize-component accessors) :initial-value x :from-end t))) `(equal ,(frob 'p1) ,(frob 'p2))))) (or (and (null p1) (null p2)) (and (pathnamep p1) (pathnamep p2) (and (=? pathname-host) (=? pathname-device) (=? normalize-pathname-directory-component pathname-directory) (=? pathname-name) (=? pathname-type) (=? pathname-version))))))) (defun absolute-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname possessing an :ABSOLUTE directory component, return the (parsed) pathname. Otherwise return NIL" (and pathspec (typep pathspec '(or null pathname string)) (let ((pathname (pathname pathspec))) (and (eq :absolute (car (normalize-pathname-directory-component (pathname-directory pathname)))) pathname)))) (defun relative-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. Otherwise return NIL" (and pathspec (typep pathspec '(or null pathname string)) (let* ((pathname (pathname pathspec)) (directory (normalize-pathname-directory-component (pathname-directory pathname)))) (when (or (null directory) (eq :relative (car directory))) pathname)))) (defun hidden-pathname-p (pathname) "Return a boolean that is true if the pathname is hidden as per Unix style, i.e. its name starts with a dot." (and pathname (equal (first-char (pathname-name pathname)) #\.))) (defun file-pathname-p (pathname) "Does PATHNAME represent a file, i.e. has a non-null NAME component? Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. Note that this does _not_ check to see that PATHNAME points to an actually-existing file. Returns the (parsed) PATHNAME when true" (when pathname (let* ((pathname (pathname pathname)) (name (pathname-name pathname))) (when (not (member name '(nil :unspecific "") :test 'equal)) pathname))))) ;;; Directory pathnames (with-upgradability () (defun pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" (when pathname (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun pathname-parent-directory-pathname (pathname) "Returns a new pathname that corresponds to the parent of the current pathname's directory, i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is Unix pathname /foo/bar/baz/file.type then return /foo/bar/" (when pathname (make-pathname* :name nil :type nil :version nil :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname)) :defaults pathname))) (defun directory-pathname-p (pathname) "Does PATHNAME represent a directory? A directory-pathname is a pathname _without_ a filename. The three ways that the filename components can be missing are for it to be NIL, :UNSPECIFIC or the empty string. Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." (when pathname (let ((pathname (pathname pathname))) (flet ((check-one (x) (member x '(nil :unspecific "") :test 'equal))) (and (not (wild-pathname-p pathname)) (check-one (pathname-name pathname)) (check-one (pathname-type pathname)) t))))) (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) "Converts the non-wild pathname designator PATHSPEC to directory form." (cond ((stringp pathspec) (ensure-directory-pathname (pathname pathspec))) ((not (pathnamep pathspec)) (call-function on-error (compatfmt "~@") pathspec)) ((wild-pathname-p pathspec) (call-function on-error (compatfmt "~@") pathspec)) ((directory-pathname-p pathspec) pathspec) (t (make-pathname* :directory (append (or (normalize-pathname-directory-component (pathname-directory pathspec)) (list :relative)) (list (file-namestring pathspec))) :name nil :type nil :version nil :defaults pathspec))))) ;;; Parsing filenames (with-upgradability () (defun split-unix-namestring-directory-components (unix-namestring &key ensure-directory dot-dot) "Splits the path string UNIX-NAMESTRING, returning four values: A flag that is either :absolute or :relative, indicating how the rest of the values are to be interpreted. A directory path --- a list of strings and keywords, suitable for use with MAKE-PATHNAME when prepended with the flag value. Directory components with an empty name or the name . are removed. Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). A last-component, either a file-namestring including type extension, or NIL in the case of a directory pathname. A flag that is true iff the unix-style-pathname was just a file-namestring without / path specification. ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: the third return value will be NIL, and final component of the namestring will be treated as part of the directory path. An empty string is thus read as meaning a pathname object with all fields nil. Note that : characters will NOT be interpreted as host specification. Absolute pathnames are only appropriate on Unix-style systems. The intention of this function is to support structured component names, e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." (check-type unix-namestring string) (check-type dot-dot (member nil :back :up)) (if (and (not (find #\/ unix-namestring)) (not ensure-directory) (plusp (length unix-namestring))) (values :relative () unix-namestring t) (let* ((components (split-string unix-namestring :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") (if (equal (first-char unix-namestring) #\/) (values :absolute (cdr components)) (values :relative nil)) (values :relative components)) (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) (cond ((equal last-comp "") (values relative components nil nil)) ; "" already removed from components (ensure-directory (values relative components nil nil)) (t (values relative (butlast components) last-comp nil))))))) (defun split-name-type (filename) "Split a filename into two values NAME and TYPE that are returned. We assume filename has no directory component. The last . if any separates name and type from from type, except that if there is only one . and it is in first position, the whole filename is the NAME with an empty type. NAME is always a string. For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." (check-type filename string) (assert (plusp (length filename))) (destructuring-bind (name &optional (type *unspecific-pathname-type*)) (split-string filename :max 2 :separator ".") (if (equal name "") (values filename *unspecific-pathname-type*) (values name type)))) (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory &allow-other-keys) "Coerce NAME into a PATHNAME using standard Unix syntax. Unix syntax is used whether or not the underlying system is Unix; on such non-Unix systems it is only usable but for relative pathnames; but especially to manipulate relative pathnames portably, it is of crucial to possess a portable pathname syntax independent of the underlying OS. This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. When given a PATHNAME object, just return it untouched. When given NIL, just return NIL. When given a non-null SYMBOL, first downcase its name and treat it as a string. When given a STRING, portably decompose it into a pathname as below. #\\/ separates directory components. The last #\\/-separated substring is interpreted as follows: 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, the string is made the last directory component, and NAME and TYPE are NIL. if the string is empty, it's the empty pathname with all slots NIL. 2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE are separated by SPLIT-NAME-TYPE. 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. Directory components with an empty name the name . are removed. Any directory named .. is read as DOT-DOT, which must be one of :BACK or :UP and defaults to :BACK. HOST, DEVICE and VERSION components are taken from DEFAULTS, which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. No host or device can be specified in the string itself, which makes it unsuitable for absolute pathnames outside Unix. For relative pathnames, these components (and hence the defaults) won't matter if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, which is an important reason to always use MERGE-PATHNAMES*. Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME with those keys, removing TYPE DEFAULTS and DOT-DOT. When you're manipulating pathnames that are supposed to make sense portably even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T to throw an error if the pathname is absolute" (block nil (check-type type (or null string (eql :directory))) (when ensure-directory (setf type :directory)) (etypecase name ((or null pathname) (return name)) (symbol (setf name (string-downcase name))) (string)) (multiple-value-bind (relative path filename file-only) (split-unix-namestring-directory-components name :dot-dot dot-dot :ensure-directory (eq type :directory)) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) (values nil nil)) (type (values filename type)) (t (split-name-type filename))) (apply 'ensure-pathname (make-pathname* :directory (unless file-only (cons relative path)) :name name :type type :defaults (or #-mcl defaults *nil-pathname*)) (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) (defun unix-namestring (pathname) "Given a non-wild PATHNAME, return a Unix-style namestring for it. If the PATHNAME is NIL or a STRING, return it unchanged. This only considers the DIRECTORY, NAME and TYPE components of the pathname. This is a portable solution for representing relative pathnames, But unless you are running on a Unix system, it is not a general solution to representing native pathnames. An error is signaled if the argument is not NULL, a STRING or a PATHNAME, or if it is a PATHNAME but some of its components are not recognized." (etypecase pathname ((or null string) pathname) (pathname (with-output-to-string (s) (flet ((err () (error "Not a valid unix-namestring ~S" pathname))) (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) (name (pathname-name pathname)) (type (pathname-type pathname)) (type (and (not (eq type :unspecific)) type))) (cond ((eq dir ())) ((eq dir '(:relative)) (princ "./" s)) ((consp dir) (destructuring-bind (relabs &rest dirs) dir (or (member relabs '(:relative :absolute)) (err)) (when (eq relabs :absolute) (princ #\/ s)) (loop :for x :in dirs :do (cond ((member x '(:back :up)) (princ "../" s)) ((equal x "") (err)) ;;((member x '("." "..") :test 'equal) (err)) ((stringp x) (format s "~A/" x)) (t (err)))))) (t (err))) (cond (name (or (and (stringp name) (or (null type) (stringp type))) (err)) (format s "~A~@[.~A~]" name type)) (t (or (null type) (err))))))))))) ;;; Absolute and relative pathnames (with-upgradability () (defun subpathname (pathname subpath &key type) "This function takes a PATHNAME and a SUBPATH and a TYPE. If SUBPATH is already a PATHNAME object (not namestring), and is an absolute pathname at that, it is returned unchanged; otherwise, SUBPATH is turned into a relative pathname with given TYPE as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (or (and (pathnamep subpath) (absolute-pathname-p subpath)) (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) (pathname-directory-pathname pathname)))) (defun subpathname* (pathname subpath &key type) "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." (and pathname (subpathname (ensure-directory-pathname pathname) subpath :type type))) (defun pathname-root (pathname) "return the root directory for the host and device of given PATHNAME" (make-pathname* :directory '(:absolute) :name nil :type nil :version nil :defaults pathname ;; host device, and on scl, *some* ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun pathname-host-pathname (pathname) "return a pathname with the same host as given PATHNAME, and all other fields NIL" (make-pathname* :directory nil :name nil :type nil :version nil :device nil :defaults pathname ;; host device, and on scl, *some* ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun subpathp (maybe-subpath base-pathname) "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." (and (pathnamep maybe-subpath) (pathnamep base-pathname) (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) (with-pathname-defaults () (let ((enough (enough-namestring maybe-subpath base-pathname))) (and (relative-pathname-p enough) (pathname enough)))))) (defun enough-pathname (maybe-subpath base-pathname) "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." (check-type maybe-subpath (or null pathname)) (check-type base-pathname (or null pathname)) (when (pathnamep base-pathname) (assert (absolute-pathname-p base-pathname))) (or (and base-pathname (subpathp maybe-subpath base-pathname)) maybe-subpath)) (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH given DEFAULTS-PATHNAME as a base pathname." (let ((enough (enough-pathname maybe-subpath defaults-pathname)) (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) (funcall thunk enough))) (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) (defaults *default-pathname-defaults*)) &body body) "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))) (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) "Given a pathname designator PATH, return an absolute pathname as specified by PATH considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, with a format control-string and other arguments as arguments" (cond ((absolute-pathname-p path)) ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) (or (if (absolute-pathname-p default-pathname) (absolute-pathname-p (merge-pathnames* path default-pathname)) (call-function on-error "Default pathname ~S is not an absolute pathname" default-pathname)) (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" path default-pathname)))) (t (call-function on-error "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" path defaults))))) ;;; Wildcard pathnames (with-upgradability () (defparameter *wild* (or #+cormanlisp "*" :wild) "Wild component for use with MAKE-PATHNAME") (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild) "Wild directory component for use with MAKE-PATHNAME") (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors) "Wild-inferiors directory component for use with MAKE-PATHNAME") (defparameter *wild-file* (make-pathname :directory nil :name *wild* :type *wild* :version (or #-(or allegro abcl xcl) *wild*)) "A pathname object with wildcards for matching any file in a given directory") (defparameter *wild-directory* (make-pathname* :directory `(:relative ,*wild-directory-component*) :name nil :type nil :version nil) "A pathname object with wildcards for matching any subdirectory") (defparameter *wild-inferiors* (make-pathname* :directory `(:relative ,*wild-inferiors-component*) :name nil :type nil :version nil) "A pathname object with wildcards for matching any recursive subdirectory") (defparameter *wild-path* (merge-pathnames* *wild-file* *wild-inferiors*) "A pathname object with wildcards for matching any file in any recursive subdirectory") (defun wilden (path) "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory" (merge-pathnames* *wild-path* path))) ;;; Translate a pathname (with-upgradability () (defun relativize-directory-component (directory-component) "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component" (let ((directory (normalize-pathname-directory-component directory-component))) (cond ((stringp directory) (list :relative directory)) ((eq (car directory) :absolute) (cons :relative (cdr directory))) (t directory)))) (defun relativize-pathname-directory (pathspec) "Given a PATHNAME, return a relative pathname with otherwise the same components" (let ((p (pathname pathspec))) (make-pathname* :directory (relativize-directory-component (pathname-directory p)) :defaults p))) (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) "Given a PATHNAME, return the character used to delimit directory names on this host and device." (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl (defun directorize-pathname-host-device (pathname) "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components added to its DIRECTORY component. This is useful for output translations." #+(or unix abcl) (when (and #+abcl (os-unix-p) (physical-pathname-p pathname)) (return-from directorize-pathname-host-device pathname)) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) (absolute-pathname (merge-pathnames* pathname root)) (separator (directory-separator-for-host root)) (root-namestring (namestring root)) (root-string (substitute-if #\/ #'(lambda (x) (or (eql x #\:) (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) (split-unix-namestring-directory-components root-string :ensure-directory t) (declare (ignore relative filename)) (let ((new-base (make-pathname* :defaults root :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) #+scl (defun directorize-pathname-host-device (pathname) (let ((scheme (ext:pathname-scheme pathname)) (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) (flet ((specificp (x) (and x (not (eq x :unspecific))))) (if (or (specificp port) (and (specificp host) (plusp (length host))) (specificp scheme)) (let ((prefix "")) (when (specificp port) (setf prefix (format nil ":~D" port))) (when (and (specificp host) (plusp (length host))) (setf prefix (strcat host prefix))) (setf prefix (strcat ":" prefix)) (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) (make-pathname* :directory `(:absolute ,prefix ,@(rest directory)) :defaults pathname))) pathname))) (defun* (translate-pathname*) (path absolute-source destination &optional root source) "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. PATH is the pathname to be translated. ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE, or a relative pathname, to be merged with ROOT and used as destination for translate-pathname or an absolute pathname, to be used as destination for translate-pathname. In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE." (declare (ignore source)) (cond ((functionp destination) (funcall destination path absolute-source)) ((eq destination t) path) ((not (pathnamep destination)) (error "Invalid destination")) ((not (absolute-pathname-p destination)) (translate-pathname path absolute-source (merge-pathnames* destination root))) (root (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) (t (translate-pathname path absolute-source destination)))) (defvar *output-translation-function* 'identity "Hook for output translations. This function needs to be idempotent, so that actions can work whether their inputs were translated or not, which they will be if we are composing operations. e.g. if some create-lisp-op creates a lisp file from some higher-level input, you need to still be able to use compile-op on that lisp file.")) cl-asdf-3.0.3/uiop/run-program.lisp000066400000000000000000001244521223164443400171570ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. (uiop/package:define-package :uiop/run-program (:nicknames :asdf/run-program) (:recycle :uiop/run-program :asdf/run-program :xcvb-driver) (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export ;;; Escaping the command invocation madness #:easy-sh-character-p #:escape-sh-token #:escape-sh-command #:escape-windows-token #:escape-windows-command #:escape-token #:escape-command ;;; run-program #:slurp-input-stream #:vomit-output-stream #:run-program #:subprocess-error #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process )) (in-package :uiop/run-program) ;;;; ----- Escaping strings for the shell ----- (with-upgradability () (defun requires-escaping-p (token &key good-chars bad-chars) "Does this token require escaping, given the specification of either good chars that don't need escaping or bad chars that do need escaping, as either a recognizing function or a sequence of characters." (some (cond ((and good-chars bad-chars) (error "only one of good-chars and bad-chars can be provided")) ((functionp good-chars) (complement good-chars)) ((functionp bad-chars) bad-chars) ((and good-chars (typep good-chars 'sequence)) #'(lambda (c) (not (find c good-chars)))) ((and bad-chars (typep bad-chars 'sequence)) #'(lambda (c) (find c bad-chars))) (t (error "requires-escaping-p: no good-char criterion"))) token)) (defun escape-token (token &key stream quote good-chars bad-chars escaper) "Call the ESCAPER function on TOKEN string if it needs escaping as per REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, using STREAM as output (or returning result as a string if NIL)" (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars) (with-output (stream) (apply escaper token stream (when quote `(:quote ,quote)))) (output-string token stream))) (defun escape-windows-token-within-double-quotes (x &optional s) "Escape a string token X within double-quotes for use within a MS Windows command-line, outputing to S." (labels ((issue (c) (princ c s)) (issue-backslash (n) (loop :repeat n :do (issue #\\)))) (loop :initially (issue #\") :finally (issue #\") :with l = (length x) :with i = 0 :for i+1 = (1+ i) :while (< i l) :do (case (char x i) ((#\") (issue-backslash 1) (issue #\") (setf i i+1)) ((#\\) (let* ((j (and (< i+1 l) (position-if-not #'(lambda (c) (eql c #\\)) x :start i+1))) (n (- (or j l) i))) (cond ((null j) (issue-backslash (* 2 n)) (setf i l)) ((and (< j l) (eql (char x j) #\")) (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j))) (t (issue-backslash n) (setf i j))))) (otherwise (issue (char x i)) (setf i i+1)))))) (defun escape-windows-token (token &optional s) "Escape a string TOKEN within double-quotes if needed for use within a MS Windows command-line, outputing to S." (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil :escaper 'escape-windows-token-within-double-quotes)) (defun escape-sh-token-within-double-quotes (x s &key (quote t)) "Escape a string TOKEN within double-quotes for use within a POSIX Bourne shell, outputing to S; omit the outer double-quotes if key argument :QUOTE is NIL" (when quote (princ #\" s)) (loop :for c :across x :do (when (find c "$`\\\"") (princ #\\ s)) (princ c s)) (when quote (princ #\" s))) (defun easy-sh-character-p (x) "Is X an \"easy\" character that does not require quoting by the shell?" (or (alphanumericp x) (find x "+-_.,%@:/"))) (defun escape-sh-token (token &optional s) "Escape a string TOKEN within double-quotes if needed for use within a POSIX Bourne shell, outputing to S." (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p :escaper 'escape-sh-token-within-double-quotes)) (defun escape-shell-token (token &optional s) "Escape a token for the current operating system shell" (cond ((os-unix-p) (escape-sh-token token s)) ((os-windows-p) (escape-windows-token token s)))) (defun escape-command (command &optional s (escaper 'escape-shell-token)) "Given a COMMAND as a list of tokens, return a string of the spaced, escaped tokens, using ESCAPER to escape." (etypecase command (string (output-string command s)) (list (with-output (s) (loop :for first = t :then nil :for token :in command :do (unless first (princ #\space s)) (funcall escaper token s)))))) (defun escape-windows-command (command &optional s) "Escape a list of command-line arguments into a string suitable for parsing by CommandLineToArgv in MS Windows" ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx (escape-command command s 'escape-windows-token)) (defun escape-sh-command (command &optional s) "Escape a list of command-line arguments into a string suitable for parsing by /bin/sh in POSIX" (escape-command command s 'escape-sh-token)) (defun escape-shell-command (command &optional stream) "Escape a command for the current operating system's shell" (escape-command command stream 'escape-shell-token))) ;;;; Slurping a stream, typically the output of another program (with-upgradability () (defun call-stream-processor (fun processor stream) "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM, a PROCESSOR specification which is either an atom or a list specifying a processor an keyword arguments, call the specified processor with the given STREAM as input" (if (consp processor) (apply fun (first processor) stream (rest processor)) (funcall fun processor stream))) (defgeneric slurp-input-stream (processor input-stream &key) (:documentation "SLURP-INPUT-STREAM is a generic function with two positional arguments PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps) the contents of the INPUT-STREAM and processes them according to a method specified by PROCESSOR. Built-in methods include the following: * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument * if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the INPUT-STREAM and the rest of the list. That is (x . y) will be treated as \(APPLY x y\) * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream, per copy-stream-to-stream, with appropriate keyword arguments. * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM are returned as a string, as per SLURP-STREAM-STRING. * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES. * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE. * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS. * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM. * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned. Programmers are encouraged to define their own methods for this generic function.")) #-(or gcl2.6 genera) (defmethod slurp-input-stream ((function function) input-stream &key) (funcall function input-stream)) (defmethod slurp-input-stream ((list cons) input-stream &key) (apply (first list) input-stream (rest list))) #-(or gcl2.6 genera) (defmethod slurp-input-stream ((output-stream stream) input-stream &key linewise prefix (element-type 'character) buffer-size) (copy-stream-to-stream input-stream output-stream :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) (declare (ignorable x)) (slurp-stream-string stream :stripped stripped)) (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) (declare (ignorable x)) (slurp-stream-string stream :stripped stripped)) (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) (declare (ignorable x)) (slurp-stream-lines stream :count count)) (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) (declare (ignorable x)) (slurp-stream-line stream :at at)) (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) (declare (ignorable x)) (slurp-stream-forms stream :count count)) (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) (declare (ignorable x)) (slurp-stream-form stream :at at)) (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) (declare (ignorable x)) (apply 'slurp-input-stream *standard-output* stream keys)) (defmethod slurp-input-stream ((x null) stream &key) (declare (ignorable x stream)) nil) (defmethod slurp-input-stream ((pathname pathname) input &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :rename-and-delete) (if-does-not-exist :create) buffer-size linewise) (with-output-file (output pathname :element-type element-type :external-format external-format :if-exists if-exists :if-does-not-exist if-does-not-exist) (copy-stream-to-stream input output :element-type element-type :buffer-size buffer-size :linewise linewise))) (defmethod slurp-input-stream (x stream &key linewise prefix (element-type 'character) buffer-size) (declare (ignorable stream linewise prefix element-type buffer-size)) (cond #+(or gcl2.6 genera) ((functionp x) (funcall x stream)) #+(or gcl2.6 genera) ((output-stream-p x) (copy-stream-to-stream stream x :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (t (error "Invalid ~S destination ~S" 'slurp-input-stream x))))) (with-upgradability () (defgeneric vomit-output-stream (processor output-stream &key) (:documentation "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits) some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR. Built-in methods include the following: * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument * if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the OUTPUT-STREAM and the rest of the list. That is (x . y) will be treated as \(APPLY x y\) * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM, per copy-stream-to-stream, with appropriate keyword arguments. * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM. * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done. Programmers are encouraged to define their own methods for this generic function.")) #-(or gcl2.6 genera) (defmethod vomit-output-stream ((function function) output-stream &key) (funcall function output-stream)) (defmethod vomit-output-stream ((list cons) output-stream &key) (apply (first list) output-stream (rest list))) #-(or gcl2.6 genera) (defmethod vomit-output-stream ((input-stream stream) output-stream &key linewise prefix (element-type 'character) buffer-size) (copy-stream-to-stream input-stream output-stream :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri) (princ x stream) (when fresh-line (fresh-line stream)) (when terpri (terpri stream)) (values)) (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) (declare (ignorable x)) (apply 'vomit-output-stream *standard-input* stream keys)) (defmethod vomit-output-stream ((x null) stream &key) (declare (ignorable x stream)) (values)) (defmethod vomit-output-stream ((pathname pathname) input &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :rename-and-delete) (if-does-not-exist :create) buffer-size linewise) (with-output-file (output pathname :element-type element-type :external-format external-format :if-exists if-exists :if-does-not-exist if-does-not-exist) (copy-stream-to-stream input output :element-type element-type :buffer-size buffer-size :linewise linewise))) (defmethod vomit-output-stream (x stream &key linewise prefix (element-type 'character) buffer-size) (declare (ignorable stream linewise prefix element-type buffer-size)) (cond #+(or gcl2.6 genera) ((functionp x) (funcall x stream)) #+(or gcl2.6 genera) ((input-stream-p x) (copy-stream-to-stream x stream :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (t (error "Invalid ~S source ~S" 'vomit-output-stream x))))) ;;;; ----- Running an external program ----- ;;; Simple variant of run-program with no input, and capturing output ;;; On some implementations, may output to a temporary file... (with-upgradability () (define-condition subprocess-error (error) ((code :initform nil :initarg :code :reader subprocess-error-code) (command :initform nil :initarg :command :reader subprocess-error-command) (process :initform nil :initarg :process :reader subprocess-error-process)) (:report (lambda (condition stream) (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]" (subprocess-error-process condition) (subprocess-error-command condition) (subprocess-error-code condition))))) ;;; Internal helpers for run-program (defun %normalize-command (command) "Given a COMMAND as a list or string, transform it in a format suitable for the implementation's underlying run-program function" (etypecase command #+os-unix (string `("/bin/sh" "-c" ,command)) #+os-unix (list command) #+os-windows (string ;; NB: We do NOT add cmd /c here. You might want to. #+(or allegro clisp) command ;; On ClozureCL for Windows, we assume you are using ;; r15398 or later in 1.9 or later, ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 #+clozure (cons "cmd" (strcat "/c " command)) ;; NB: On other Windows implementations, this is utterly bogus ;; except in the most trivial cases where no quoting is needed. ;; Use at your own risk. #-(or allegro clisp clozure) (list "cmd" "/c" command)) #+os-windows (list #+allegro (escape-windows-command command) #-allegro command))) (defun %active-io-specifier-p (specifier) "Determines whether a run-program I/O specifier requires Lisp-side processing via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), or whether it's already taken care of by the implementation's underlying run-program." (not (typep specifier '(or null string pathname (member :interactive :output) #+(or cmu (and sbcl os-unix) scl) (or stream (eql t)) #+lispworks file-stream)))) ;; not a type!? comm:socket-stream (defun %normalize-io-specifier (specifier &optional role) "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent argument to pass to the internal RUN-PROGRAM" (declare (ignorable role)) (etypecase specifier (null (or #+(or allegro lispworks) (null-device-pathname))) (string (pathname specifier)) (pathname specifier) (stream specifier) ((eql :stream) :stream) ((eql :interactive) #+allegro nil #+clisp :terminal #+(or clozure cmu ecl sbcl scl) t) #+(or allegro clozure cmu ecl lispworks sbcl scl) ((eql :output) (if (eq role :error-output) :output (error "Wrong specifier ~S for role ~S" specifier role))))) (defun %interactivep (input output error-output) (member :interactive (list input output error-output))) #+clisp (defun clisp-exit-code (raw-exit-code) (typecase raw-exit-code (null 0) ; no error (integer raw-exit-code) ; negative: signal (t -1))) (defun %run-program (command &rest keys &key input (if-input-does-not-exist :error) output (if-output-exists :overwrite) error-output (if-error-output-exists :overwrite) directory wait #+allegro separate-streams &allow-other-keys) "A portable abstraction of a low-level call to the implementation's run-program or equivalent. It spawns a subprocess that runs the specified COMMAND (a list of program and arguments). INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer, to be normalized by %NORMALIZE-IO-SPECIFIER. It returns a process-info plist with possible keys: PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." ;; NB: these implementations have unix vs windows set at compile-time. (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists)) (assert (not (and wait (member :stream (list input output error-output))))) #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (progn command keys directory (error "run-program not available")) #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) (let* ((%command (%normalize-command command)) (%input (%normalize-io-specifier input :input)) (%output (%normalize-io-specifier output :output)) (%error-output (%normalize-io-specifier error-output :error-output)) #+(and allegro os-windows) (interactive (%interactivep input output error-output)) (process* #+allegro (multiple-value-list (apply 'excl:run-shell-command #+os-unix (coerce (cons (first %command) %command) 'vector) #+os-windows %command :input %input :output %output :error-output %error-output :directory directory :wait wait #+os-windows :show-window #+os-windows (if interactive nil :hide) :allow-other-keys t keys)) #-allegro (with-current-directory (#-sbcl directory) #+clisp (flet ((run (f &rest args) (multiple-value-list (apply f :input %input :output %output :allow-other-keys t `(,@args ,@keys))))) (assert (eq %error-output :terminal)) ;;; since we now always return a code, we can't use this code path, anyway! (etypecase %command #+os-windows (string (run 'ext:run-shell-command %command)) (list (run 'ext:run-program (car %command) :arguments (cdr %command))))) #+(or clozure cmu ecl sbcl scl) (#-ecl progn #+ecl multiple-value-list (apply '#+(or cmu ecl scl) ext:run-program #+clozure ccl:run-program #+sbcl sb-ext:run-program (car %command) (cdr %command) :input %input :output %output :error %error-output :wait wait :allow-other-keys t (append #+(or clozure cmu sbcl scl) `(:if-input-does-not-exist ,if-input-does-not-exist :if-output-exists ,if-output-exists :if-error-exists ,if-error-output-exists) #+sbcl `(:search t :if-output-does-not-exist :create :if-error-does-not-exist :create) #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys))))) #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case (multiple-value-list (apply 'system:run-shell-command (cons "/usr/bin/env" %command) ; lispworks wants a full path. :input %input :if-input-does-not-exist if-input-does-not-exist :output %output :if-output-exists if-output-exists :error-output %error-output :if-error-output-exists if-error-output-exists :wait wait :save-exit-status t :allow-other-keys t keys)))) (process-info-r ())) (flet ((prop (key value) (push key process-info-r) (push value process-info-r))) #+allegro (cond (wait (prop :exit-code (first process*))) (separate-streams (destructuring-bind (in out err pid) process* (prop :process pid) (when (eq input :stream) (prop :input-stream in)) (when (eq output :stream) (prop :output-stream out)) (when (eq error-output :stream) (prop :error-stream err)))) (t (prop :process (third process*)) (let ((x (first process*))) (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) (0) (1 (prop :input-stream x)) (2 (prop :output-stream x)) (3 (prop :bidir-stream x)))) (when (eq error-output :stream) (prop :error-stream (second process*))))) #+clisp (cond (wait (prop :exit-code (clisp-exit-code (first process*)))) (t (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) (0) (1 (prop :input-stream (first process*))) (2 (prop :output-stream (first process*))) (3 (prop :bidir-stream (pop process*)) (prop :input-stream (pop process*)) (prop :output-stream (pop process*)))))) #+(or clozure cmu sbcl scl) (progn (prop :process process*) (when (eq input :stream) (prop :input-stream #+clozure (ccl:external-process-input-stream process*) #+(or cmu scl) (ext:process-input process*) #+sbcl (sb-ext:process-input process*))) (when (eq output :stream) (prop :output-stream #+clozure (ccl:external-process-output-stream process*) #+(or cmu scl) (ext:process-output process*) #+sbcl (sb-ext:process-output process*))) (when (eq error-output :stream) (prop :error-output-stream #+clozure (ccl:external-process-error-stream process*) #+(or cmu scl) (ext:process-error process*) #+sbcl (sb-ext:process-error process*)))) #+ecl (destructuring-bind (stream code process) process* (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (cond ((zerop mode)) ((null process*) (prop :exit-code -1)) (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream)))) (when code (prop :exit-code code)) (when process (prop :process process))) #+lispworks (if wait (prop :exit-code (first process*)) (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (if (zerop mode) (prop :process (first process*)) (destructuring-bind (x err pid) process* (prop :process pid) (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x) (when (eq error-output :stream) (prop :error-stream err)))))) (nreverse process-info-r)))) (defun %wait-process-result (process-info) (or (getf process-info :exit-code) (let ((process (getf process-info :process))) (when process ;; 1- wait #+clozure (ccl::external-process-wait process) #+(or cmu scl) (ext:process-wait process) #+(and ecl os-unix) (ext:external-process-wait process) #+sbcl (sb-ext:process-wait process) ;; 2- extract result #+allegro (sys:reap-os-subprocess :pid process :wait t) #+clozure (nth-value 1 (ccl:external-process-status process)) #+(or cmu scl) (ext:process-exit-code process) #+ecl (nth-value 1 (ext:external-process-status process)) #+lispworks (system:pid-exit-status process :wait t) #+sbcl (sb-ext:process-exit-code process))))) (defun %check-result (exit-code &key command process ignore-error-status) (unless ignore-error-status (unless (eql exit-code 0) (cerror "IGNORE-ERROR-STATUS" 'subprocess-error :command command :code exit-code :process process))) exit-code) (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner &key element-type external-format &allow-other-keys) ;; handle redirection for run-program and system ;; SPEC is the specification for the subprocess's input or output or error-output ;; TVAL is the value used if the spec is T ;; GF is the generic function to call to handle arbitrary values of SPEC ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it) ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument ;; FUN is a function of the new reduced spec and an activity function to call with a stream ;; when the subprocess is active and communicating through that stream. ;; ACTIVEP is a boolean true if we will get to run code while the process is running ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open. ;; RETURNER is a function called with the value of the activity. ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way. (declare (ignorable stream-easy-p)) (let* ((actual-spec (if (eq spec t) tval spec)) (activity-spec (if (eq actual-spec :output) (ecase direction ((:input :output) (error "~S not allowed as a ~S ~S spec" :output 'run-program direction)) ((:error-output) nil)) actual-spec))) (labels ((activity (stream) (call-function returner (call-stream-processor gf activity-spec stream))) (easy-case () (funcall fun actual-spec nil)) (hard-case () (if activep (funcall fun :stream #'activity) (with-temporary-file (:pathname tmp) (ecase direction (:input (with-output-file (s tmp :if-exists :overwrite :external-format external-format :element-type element-type) (activity s)) (funcall fun tmp nil)) ((:output :error-output) (multiple-value-prog1 (funcall fun tmp nil) (with-input-file (s tmp :external-format external-format :element-type element-type) (activity s))))))))) (typecase activity-spec ((or null string pathname (eql :interactive)) (easy-case)) #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard (stream (if stream-easy-p (easy-case) (hard-case))) (t (hard-case)))))) (defmacro place-setter (place) (when place (let ((value (gensym))) `#'(lambda (,value) (setf ,place ,value))))) (defmacro with-program-input (((reduced-input-var &optional (input-activity-var (gensym) iavp)) input-form &key setf stream-easy-p active keys) &body body) `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p #'(lambda (,reduced-input-var ,input-activity-var) ,@(unless iavp `((declare (ignore ,input-activity-var)))) ,@body) :input ,input-form ,active (place-setter ,setf) ,keys)) (defmacro with-program-output (((reduced-output-var &optional (output-activity-var (gensym) oavp)) output-form &key setf stream-easy-p active keys) &body body) `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p #'(lambda (,reduced-output-var ,output-activity-var) ,@(unless oavp `((declare (ignore ,output-activity-var)))) ,@body) :output ,output-form ,active (place-setter ,setf) ,keys)) (defmacro with-program-error-output (((reduced-error-output-var &optional (error-output-activity-var (gensym) eoavp)) error-output-form &key setf stream-easy-p active keys) &body body) `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p #'(lambda (,reduced-error-output-var ,error-output-activity-var) ,@(unless eoavp `((declare (ignore ,error-output-activity-var)))) ,@body) :error-output ,error-output-form ,active (place-setter ,setf) ,keys)) (defun %use-run-program (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using %run-program #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) (error "Not implemented on this platform") (assert (not (member :stream (list input output error-output)))) (let* ((active-input-p (%active-io-specifier-p input)) (active-output-p (%active-io-specifier-p output)) (active-error-output-p (%active-io-specifier-p error-output)) (activity (cond (active-output-p :output) (active-input-p :input) (active-error-output-p :error-output) (t nil))) (wait (not activity)) output-result error-output-result exit-code) (with-program-output ((reduced-output output-activity) output :keys keys :setf output-result :stream-easy-p t :active (eq activity :output)) (with-program-error-output ((reduced-error-output error-output-activity) error-output :keys keys :setf error-output-result :stream-easy-p t :active (eq activity :error-output)) (with-program-input ((reduced-input input-activity) input :keys keys :stream-easy-p t :active (eq activity :input)) (let ((process-info (apply '%run-program command :wait wait :input reduced-input :output reduced-output :error-output (if (eq error-output :output) :output reduced-error-output) keys))) (labels ((get-stream (stream-name &optional fallbackp) (or (getf process-info stream-name) (when fallbackp (getf process-info :bidir-stream)))) (run-activity (activity stream-name &optional fallbackp) (if-let (stream (get-stream stream-name fallbackp)) (funcall activity stream) (error 'subprocess-error :code `(:missing ,stream-name) :command command :process process-info)))) (unwind-protect (ecase activity ((nil)) (:input (run-activity input-activity :input-stream t)) (:output (run-activity output-activity :output-stream t)) (:error-output (run-activity error-output-activity :error-output-stream))) (loop :for (() val) :on process-info :by #'cddr :when (streamp val) :do (ignore-errors (close val))) (setf exit-code (%check-result (%wait-process-result process-info) :command command :process process-info :ignore-error-status ignore-error-status)))))))) (values output-result error-output-result exit-code))) (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM (etypecase command (string command) (list (escape-shell-command (if (os-unix-p) (cons "exec" command) command))))) (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM (flet ((redirect (spec operator) (let ((pathname (typecase spec (null (null-device-pathname)) (string (pathname spec)) (pathname spec) ((eql :output) (assert (equal operator "2>")) (return-from redirect '(" 2>&1")))))) (when pathname (list " " operator " " (escape-shell-token (native-namestring pathname))))))) (multiple-value-bind (before after) (let ((normalized (%normalize-system-command command))) (if (os-unix-p) (values '("exec") (list " ; " normalized)) (values (list normalized) ()))) (reduce/strcat (append before (redirect in "<") (redirect out ">") (redirect err "2>") (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; ")) after))))) (defun %system (command &rest keys &key input output error-output directory &allow-other-keys) "A portable abstraction of a low-level call to libc's system()." (declare (ignorable input output error-output directory keys)) #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (%wait-process-result (apply '%run-program (%normalize-system-command command) :wait t keys)) #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) #-(and lispworks os-windows) (with-current-directory ((unless (os-unix-p) directory)) #+(or abcl xcl) (ext:run-shell-command %command) #+clisp (clisp-exit-code (ext:shell %command)) #+cormanlisp (win32:system %command) #+ecl (let ((*standard-input* *stdin*) (*standard-output* *stdout*) (*error-output* *stderr*)) (ext:system %command)) #+gcl (lisp:system %command) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) #+mkcl ;; PROBABLY BOGUS -- ask jcb (multiple-value-bind (io process exit-code) (mkcl:run-program #+windows %command #+windows () #-windows "/bin/sh" #-windows (list "-c" %command) :input t :output t))))) (defun %use-system (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using %system (let (output-result error-output-result exit-code) (with-program-output ((reduced-output) output :keys keys :setf output-result) (with-program-error-output ((reduced-error-output) error-output :keys keys :setf error-output-result) (with-program-input ((reduced-input) input :keys keys) (setf exit-code (%check-result (apply '%system command :input reduced-input :output reduced-output :error-output reduced-error-output keys) :command command :ignore-error-status ignore-error-status))))) (values output-result error-output-result exit-code))) (defun run-program (command &rest keys &key ignore-error-status force-shell (input nil inputp) (if-input-does-not-exist :error) output (if-output-exists :overwrite) (error-output nil error-output-p) (if-error-output-exists :overwrite) (element-type #-clozure *default-stream-element-type* #+clozure 'character) (external-format *utf-8-external-format*) &allow-other-keys) "Run program specified by COMMAND, either a list of strings specifying a program and list of arguments, or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows). Always call a shell (rather than directly execute the command when possible) if FORCE-SHELL is specified. Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), unless IGNORE-ERROR-STATUS is specified. If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device, the file at that path is used as output. If it's :INTERACTIVE, output is inherited from the current process. Otherwise, OUTPUT should be a value that is a suitable first argument to SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. In this case, RUN-PROGRAM will create a temporary stream for the program output. The program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). T designates the *STANDARD-OUTPUT* to be provided to SLURP-INPUT-STREAM. The primary value resulting from that call (or NIL if no call was needed) will be the first value returned by RUN-PROGRAM. E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. Also :OUTPUT means redirecting the error output to the output stream, and NIL is returned. INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, no value is returned, and T designates the *STANDARD-INPUT*. Use ELEMENT-TYPE and EXTERNAL-FORMAT to specify how streams are created. One and only one of the stream slurping or vomiting may or may not happen in parallel in parallel with the subprocess, depending on options and implementation. Other streams are completely produced or consumed before or after the subprocess is spawned, using temporary files. RUN-PROGRAM returns 3 values: 0- the result of the OUTPUT slurping if any, or NIL 1- the result of the ERROR-OUTPUT slurping if any, or NIL 2- either 0 if the subprocess exited with success status, or an indication of failure via the EXIT-CODE of the process" (declare (ignorable ignore-error-status)) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) (apply (if (or force-shell #+(or clisp ecl) (or (not ignore-error-status) t) #+clisp (eq error-output :interactive) #+(or abcl clisp) (eq :error-output :output) #+(and lispworks os-unix) (%interactivep input output error-output) #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t) '%use-system '%use-run-program) command :input (default input inputp output) :error-output (default error-output error-output-p output) :if-input-does-not-exist if-input-does-not-exist :if-output-exists if-output-exists :if-error-output-exists if-error-output-exists :element-type element-type :external-format external-format keys)))) cl-asdf-3.0.3/uiop/stream.lisp000066400000000000000000000721561223164443400162040ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams (uiop/package:define-package :uiop/stream (:nicknames :asdf/stream) (:recycle :uiop/stream :asdf/stream :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) (:export #:*default-stream-element-type* #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format #:*default-encoding* #:*utf-8-external-format* #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string #:with-output #:output-string #:with-input #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file #:null-device-pathname #:call-with-null-input #:with-null-input #:call-with-null-output #:with-null-output #:finish-outputs #:format! #:safe-format! #:copy-stream-to-stream #:concatenate-files #:copy-file #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line #:slurp-stream-forms #:slurp-stream-form #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line #:read-file-forms #:read-file-form #:safe-read-file-form #:eval-input #:eval-thunk #:standard-eval-thunk #:println #:writeln ;; Temporary files #:*temporary-directory* #:temporary-directory #:default-temporary-directory #:setup-temporary-directory #:call-with-temporary-file #:with-temporary-file #:add-pathname-suffix #:tmpize-pathname #:call-with-staging-pathname #:with-staging-pathname)) (in-package :uiop/stream) (with-upgradability () (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character #+lispworks 'lw:simple-char :default) "default element-type for open (depends on the current CL implementation)") (defvar *stdin* *standard-input* "the original standard input stream at startup") (defun setup-stdin () (setf *stdin* #.(or #+clozure 'ccl::*stdin* #+(or cmu scl) 'system:*stdin* #+ecl 'ext::+process-standard-input+ #+sbcl 'sb-sys:*stdin* '*standard-input*))) (defvar *stdout* *standard-output* "the original standard output stream at startup") (defun setup-stdout () (setf *stdout* #.(or #+clozure 'ccl::*stdout* #+(or cmu scl) 'system:*stdout* #+ecl 'ext::+process-standard-output+ #+sbcl 'sb-sys:*stdout* '*standard-output*))) (defvar *stderr* *error-output* "the original error output stream at startup") (defun setup-stderr () (setf *stderr* #.(or #+allegro 'excl::*stderr* #+clozure 'ccl::*stderr* #+(or cmu scl) 'system:*stderr* #+ecl 'ext::+process-error-output+ #+sbcl 'sb-sys:*stderr* '*error-output*))) ;; Run them now. In image.lisp, we'll register them to be run at image restart. (setup-stdin) (setup-stdout) (setup-stderr)) ;;; Encodings (mostly hooks only; full support requires asdf-encodings) (with-upgradability () (defparameter *default-encoding* ;; preserve explicit user changes to something other than the legacy default :default (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) (unless (eq previous :default) previous)) :utf-8) "Default encoding for source files. The default value :utf-8 is the portable thing. The legacy behavior was :default. If you (asdf:load-system :asdf-encodings) then you will have autodetection via *encoding-detection-hook* below, reading emacs-style -*- coding: utf-8 -*- specifications, and falling back to utf-8 or latin1 if nothing is specified.") (defparameter *utf-8-external-format* (if (featurep :asdf-unicode) (or #+clisp charset:utf-8 :utf-8) :default) "Default :external-format argument to pass to CL:OPEN and also CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. On modern implementations, this will decode UTF-8 code points as CL characters. 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) "Trivial function to use as *encoding-detection-hook*, always 'detects' the *default-encoding*" (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) "Detects the encoding of a specified file, going through user-configurable hooks" (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname)) (funcall *encoding-detection-hook* pathname) *default-encoding*)) (defun default-encoding-external-format (encoding) "Default, ignorant, function to transform a character ENCODING as a portable keyword to an implementation-dependent EXTERNAL-FORMAT specification. Load system ASDF-ENCODINGS to hook in a better one." (case encoding (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. (:utf-8 *utf-8-external-format*) (otherwise (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) :default))) (defvar *encoding-external-format-hook* #'default-encoding-external-format "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping from non-default encodings to and implementation-defined external-format's") (defun encoding-external-format (encoding) "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT, going through all the proper hooks." (funcall *encoding-external-format-hook* (or encoding *default-encoding*)))) ;;; Safe syntax (with-upgradability () (defvar *standard-readtable* (with-standard-io-syntax *readtable*) "The standard readtable, implementing the syntax specified by the CLHS. It must never be modified, though only good implementations will even enforce that.") (defmacro with-safe-io-syntax ((&key (package :cl)) &body body) "Establish safe CL reader options around the evaluation of BODY" `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) (defun call-with-safe-io-syntax (thunk &key (package :cl)) (with-standard-io-syntax (let ((*package* (find-package package)) (*read-default-float-format* 'double-float) (*print-readably* nil) (*read-eval* nil)) (funcall thunk)))) (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX" (with-safe-io-syntax (:package package) (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) ;;; Output to a stream or string, FORMAT-style (with-upgradability () (defun call-with-output (output function) "Calls FUNCTION with an actual stream argument, behaving like FORMAT with respect to how stream designators are interpreted: If OUTPUT is a stream, use it as the stream. If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. If OUTPUT is a string with a fill-pointer, use it as a string-output-stream. Otherwise, signal an error." (etypecase output (null (with-output-to-string (stream) (funcall function stream))) ((eql t) (funcall function *standard-output*)) (stream (funcall function output)) (string (assert (fill-pointer output)) (with-output-to-string (stream output) (funcall function stream))))) (defmacro with-output ((output-var &optional (value output-var)) &body body) "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR) as per FORMAT, and evaluate BODY within the scope of this binding." `(call-with-output ,value #'(lambda (,output-var) ,@body))) (defun output-string (string &optional output) "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" (if output (with-output (output) (princ string output)) string))) ;;; Input helpers (with-upgradability () (defun call-with-input (input function) "Calls FUNCTION with an actual stream argument, interpreting stream designators like READ, but also coercing strings to STRING-INPUT-STREAM. If INPUT is a STREAM, use it as the stream. If INPUT is NIL, use a *STANDARD-INPUT* as the stream. If INPUT is T, use *TERMINAL-IO* as the stream. As an extension, if INPUT is a string, use it as a string-input-stream. Otherwise, signal an error." (etypecase input (null (funcall function *standard-input*)) ((eql t) (funcall function *terminal-io*)) (stream (funcall function input)) (string (with-input-from-string (stream input) (funcall function stream))))) (defmacro with-input ((input-var &optional (value input-var)) &body body) "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." `(call-with-input ,value #'(lambda (,input-var) ,@body))) (defun call-with-input-file (pathname thunk &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-does-not-exist :error)) "Open FILE for input with given recognizes options, call THUNK with the resulting stream. Other keys are accepted but discarded." #+gcl2.6 (declare (ignore external-format)) (with-open-file (s pathname :direction :input :element-type element-type #-gcl2.6 :external-format #-gcl2.6 external-format :if-does-not-exist if-does-not-exist) (funcall thunk s))) (defmacro with-input-file ((var pathname &rest keys &key element-type external-format if-does-not-exist) &body body) (declare (ignore element-type external-format if-does-not-exist)) `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) (defun call-with-output-file (pathname thunk &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :error) (if-does-not-exist :create)) "Open FILE for input with given recognizes options, call THUNK with the resulting stream. Other keys are accepted but discarded." #+gcl2.6 (declare (ignore external-format)) (with-open-file (s pathname :direction :output :element-type element-type #-gcl2.6 :external-format #-gcl2.6 external-format :if-exists if-exists :if-does-not-exist if-does-not-exist) (funcall thunk s))) (defmacro with-output-file ((var pathname &rest keys &key element-type external-format if-exists if-does-not-exist) &body body) (declare (ignore element-type external-format if-exists if-does-not-exist)) `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))) ;;; Null device (with-upgradability () (defun null-device-pathname () "Pathname to a bit bucket device that discards any information written to it and always returns EOF when read from" (cond ((os-unix-p) #p"/dev/null") ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? (t (error "No /dev/null on your OS")))) (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist) (declare (ignore element-type external-format if-does-not-exist)) (apply 'call-with-input-file (null-device-pathname) fun keys)) (defmacro with-null-input ((var &rest keys &key element-type external-format if-does-not-exist) &body body) (declare (ignore element-type external-format if-does-not-exist)) "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device." `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) (defun call-with-null-output (fun &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :overwrite) (if-does-not-exist :error)) (call-with-output-file (null-device-pathname) fun :element-type element-type :external-format external-format :if-exists if-exists :if-does-not-exist if-does-not-exist)) (defmacro with-null-output ((var &rest keys &key element-type external-format if-does-not-exist if-exists) &body body) "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device." (declare (ignore element-type external-format if-exists if-does-not-exist)) `(call-with-null-output #'(lambda (,var) ,@body) ,@keys))) ;;; Ensure output buffers are flushed (with-upgradability () (defun finish-outputs (&rest streams) "Finish output on the main output streams as well as any specified one. Useful for portably flushing I/O before user input or program exit." ;; CCL notably buffers its stream output by default. (dolist (s (append streams (list *stdout* *stderr* *error-output* *standard-output* *trace-output* *debug-io* *terminal-io* *query-io*))) (ignore-errors (finish-output s))) (values)) (defun format! (stream format &rest args) "Just like format, but call finish-outputs before and after the output." (finish-outputs stream) (apply 'format stream format args) (finish-outputs stream)) (defun safe-format! (stream format &rest args) "Variant of FORMAT that is safe against both dangerous syntax configuration and errors while printing." (with-safe-io-syntax () (ignore-errors (apply 'format! stream format args)) (finish-outputs stream)))) ; just in case format failed ;;; Simple Whole-Stream processing (with-upgradability () (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) "Copy the contents of the INPUT stream into the OUTPUT stream. If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." (with-open-stream (input input) (if linewise (loop* :for (line eof) = (multiple-value-list (read-line input nil nil)) :while line :do (when prefix (princ prefix output)) (princ line output) (unless eof (terpri output)) (finish-output output) (when eof (return))) (loop :with buffer-size = (or buffer-size 8192) :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) :for end = (read-sequence buffer input) :until (zerop end) :do (write-sequence buffer output :end end) (when (< end buffer-size) (return)))))) (defun concatenate-files (inputs output) "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files." (with-open-file (o output :element-type '(unsigned-byte 8) :direction :output :if-exists :rename-and-delete) (dolist (input inputs) (with-open-file (i input :element-type '(unsigned-byte 8) :direction :input :if-does-not-exist :error) (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) (defun copy-file (input output) "Copy contents of the INPUT file to the OUTPUT file" ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) (concatenate-files (list input) output)) (defun slurp-stream-string (input &key (element-type 'character) stripped) "Read the contents of the INPUT stream as a string" (let ((string (with-open-stream (input input) (with-output-to-string (output) (copy-stream-to-stream input output :element-type element-type))))) (if stripped (stripln string) string))) (defun slurp-stream-lines (input &key count) "Read the contents of the INPUT stream as a list of lines, return those lines. Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR from the line-ending if the file or stream had CR+LF but Lisp only removed LF. Read no more than COUNT lines." (check-type count (or null integer)) (with-open-stream (input input) (loop :for n :from 0 :for l = (and (or (not count) (< n count)) (read-line input nil nil)) ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF :while l :collect (stripln l)))) (defun slurp-stream-line (input &key (at 0)) "Read the contents of the INPUT stream as a list of lines, then return the ACCESS-AT of that list of lines using the AT specifier. PATH defaults to 0, i.e. return the first line. PATH is typically an integer, or a list of an integer and a function. If PATH is NIL, it will return all the lines in the file. The stream will not be read beyond the Nth lines, where N is the index specified by path if path is either an integer or a list that starts with an integer." (access-at (slurp-stream-lines input :count (access-at-count at)) at)) (defun slurp-stream-forms (input &key count) "Read the contents of the INPUT stream as a list of forms, and return those forms. If COUNT is null, read to the end of the stream; if COUNT is an integer, stop after COUNT forms were read. BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (check-type count (or null integer)) (loop :with eof = '#:eof :for n :from 0 :for form = (if (and count (>= n count)) eof (read-preserving-whitespace input nil eof)) :until (eq form eof) :collect form)) (defun slurp-stream-form (input &key (at 0)) "Read the contents of the INPUT stream as a list of forms, then return the ACCESS-AT of these forms following the AT. AT defaults to 0, i.e. return the first form. AT is typically a list of integers. If AT is NIL, it will return all the forms in the file. The stream will not be read beyond the Nth form, where N is the index specified by path, if path is either an integer or a list that starts with an integer. BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (access-at (slurp-stream-forms input :count (access-at-count at)) at)) (defun read-file-string (file &rest keys) "Open FILE with option KEYS, read its contents as a string" (apply 'call-with-input-file file 'slurp-stream-string keys)) (defun read-file-lines (file &rest keys) "Open FILE with option KEYS, read its contents as a list of lines BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file 'slurp-stream-lines keys)) (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys) "Open input FILE with option KEYS (except AT), and read its contents as per SLURP-STREAM-LINE with given AT specifier. BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file #'(lambda (input) (slurp-stream-line input :at at)) (remove-plist-key :at keys))) (defun read-file-forms (file &rest keys &key count &allow-other-keys) "Open input FILE with option KEYS (except COUNT), and read its contents as per SLURP-STREAM-FORMS with given COUNT. BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file #'(lambda (input) (slurp-stream-forms input :count count)) (remove-plist-key :count keys))) (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys) "Open input FILE with option KEYS (except AT), and read its contents as per SLURP-STREAM-FORM with given AT specifier. BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file #'(lambda (input) (slurp-stream-form input :at at)) (remove-plist-key :at keys))) (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys) "Reads the specified line from the top of a file using a safe standardized syntax. Extracts the line using READ-FILE-LINE, within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." (with-safe-io-syntax (:package package) (apply 'read-file-line pathname (remove-plist-key :package keys)))) (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) "Reads the specified form from the top of a file using a safe standardized syntax. Extracts the form using READ-FILE-FORM, within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." (with-safe-io-syntax (:package package) (apply 'read-file-form pathname (remove-plist-key :package keys)))) (defun eval-input (input) "Portably read and evaluate forms from INPUT, return the last values." (with-input (input) (loop :with results :with eof ='#:eof :for form = (read input nil eof) :until (eq form eof) :do (setf results (multiple-value-list (eval form))) :finally (return (apply 'values results))))) (defun eval-thunk (thunk) "Evaluate a THUNK of code: If a function, FUNCALL it without arguments. If a constant literal and not a sequence, return it. If a cons or a symbol, EVAL it. If a string, repeatedly read and evaluate from it, returning the last values." (etypecase thunk ((or boolean keyword number character pathname) thunk) ((or cons symbol) (eval thunk)) (function (funcall thunk)) (string (eval-input thunk)))) (defun standard-eval-thunk (thunk &key (package :cl)) "Like EVAL-THUNK, but in a more standardized evaluation context." ;; Note: it's "standard-" not "safe-", because evaluation is never safe. (when thunk (with-safe-io-syntax (:package package) (let ((*read-eval* t)) (eval-thunk thunk)))))) (with-upgradability () (defun println (x &optional (stream *standard-output*)) "Variant of PRINC that also calls TERPRI afterwards" (princ x stream) (terpri stream) (values)) (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) "Variant of WRITE that also calls TERPRI afterwards" (apply 'write x keys) (terpri stream) (values))) ;;; Using temporary files (with-upgradability () (defun default-temporary-directory () "Return a default directory to use for temporary files" (or (when (os-unix-p) (or (getenv-pathname "TMPDIR" :ensure-directory t) (parse-native-namestring "/tmp/"))) (when (os-windows-p) (getenv-pathname "TEMP" :ensure-directory t)) (subpathname (user-homedir-pathname) "tmp/"))) (defvar *temporary-directory* nil "User-configurable location for temporary files") (defun temporary-directory () "Return a directory to use for temporary files" (or *temporary-directory* (default-temporary-directory))) (defun setup-temporary-directory () "Configure a default temporary directory to use." (setf *temporary-directory* (default-temporary-directory)) ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1 #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*)) (defun call-with-temporary-file (thunk &key (want-stream-p t) (want-pathname-p t) prefix keep (direction :io) (element-type *default-stream-element-type*) (external-format *utf-8-external-format*)) "Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file. The pathname will be based on appending a random suffix to PREFIX. This utility will KEEP the file past its extent if and only if explicitly requested. The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT." #+gcl2.6 (declare (ignorable external-format)) (check-type direction (member :output :io)) (assert (or want-stream-p want-pathname-p)) (loop :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory)) :with results = () :for counter :from (random (ash 1 32)) :for pathname = (pathname (format nil "~A~36R" prefix counter)) :for okp = nil :do ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. (unwind-protect (progn (with-open-file (stream pathname :direction direction :element-type element-type #-gcl2.6 :external-format #-gcl2.6 external-format :if-exists nil :if-does-not-exist :create) (when stream (setf okp pathname) (when want-stream-p (setf results (multiple-value-list (if want-pathname-p (funcall thunk stream pathname) (funcall thunk stream))))))) (when okp (if want-stream-p (return (apply 'values results)) (return (funcall thunk pathname))))) (when (and okp (not keep)) (ignore-errors (delete-file-if-exists okp)))))) (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) (pathname (gensym "PATHNAME") pathnamep) prefix keep direction element-type external-format) &body body) "Evaluate BODY where the symbols specified by keyword arguments STREAM and PATHNAME (if respectively specified) are bound corresponding to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. The STREAM will be closed if no binding is specified. Unless KEEP is specified, delete the file afterwards." (check-type stream symbol) (check-type pathname symbol) (assert (or streamp pathnamep)) `(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@body)) #-gcl (declare (dynamic-extent #'think)) (call-with-temporary-file #'think :want-stream-p ,streamp :want-pathname-p ,pathnamep ,@(when direction `(:direction ,direction)) ,@(when prefix `(:prefix ,prefix)) ,@(when keep `(:keep ,keep)) ,@(when element-type `(:element-type ,element-type)) ,@(when external-format `(:external-format ,external-format))))) (defun get-temporary-file (&key prefix) (with-temporary-file (:pathname pn :keep t :prefix prefix) pn)) ;; Temporary pathnames in simple cases where no contention is assumed (defun add-pathname-suffix (pathname suffix) "Add a SUFFIX to the name of a PATHNAME, return a new pathname" (make-pathname :name (strcat (pathname-name pathname) suffix) :defaults pathname)) (defun tmpize-pathname (x) "Return a new pathname modified from X by adding a trivial deterministic suffix" (add-pathname-suffix x "-ASDF-TMP")) (defun call-with-staging-pathname (pathname fun) "Calls fun with a staging pathname, and atomically renames the staging pathname to the pathname in the end. Note: this protects only against failure of the program, not against concurrent attempts. For the latter case, we ought pick random suffix and atomically open it." (let* ((pathname (pathname pathname)) (staging (tmpize-pathname pathname))) (unwind-protect (multiple-value-prog1 (funcall fun staging) (rename-file-overwriting-target staging pathname)) (delete-file-if-exists staging)))) (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) cl-asdf-3.0.3/uiop/uiop.asd000066400000000000000000000035651223164443400154630ustar00rootroot00000000000000;;; -*- mode: lisp -*- (in-package :asdf) (unless (or (member :asdf3 *features*) (and (member :asdf2 *features*) (version-satisfies (asdf:asdf-version) "2.11.4"))) (error "UIOP requires ASDF 2.011.4 or later.")) (defun call-without-redefinition-warnings (thunk) (handler-bind (((or #+allegro simple-warning #+clozure ccl:compiler-warning #+cmu kernel:simple-style-warning #-(or allegro clozure cmu) warning) #'muffle-warning)) (funcall thunk))) (defsystem :uiop :licence "MIT" #+asdf3 :long-name #+asdf3 "Utilities for Implementation- and OS- Portability" :description "Runtime support for Common Lisp programs" :long-description "Basic general-purpose utilities that are in such a need that you can't portably construct a complete program without using them. UIOP is also known as ASDF/DRIVER or ASDF-UTILS, being transcluded into asdf.lisp together with ASDF/DEFSYSTEM." #+asdf3 :version #+asdf3 (:read-file-form "version.lisp-expr") #+asdf-unicode :encoding #+asdf-unicode :utf-8 #+asdf3 :around-compile #+asdf3 call-without-redefinition-warnings :components ((:static-file "version.lisp-expr") (:static-file "contrib/debug.lisp") (:file "package") (:file "common-lisp" :depends-on ("package")) (:file "utility" :depends-on ("common-lisp")) (:file "os" :depends-on ("utility")) (:file "pathname" :depends-on ("utility" "os")) (:file "filesystem" :depends-on ("os" "pathname")) (:file "stream" :depends-on ("filesystem")) (:file "image" :depends-on ("stream")) (:file "run-program" :depends-on ("stream")) (:file "lisp-build" :depends-on ("image")) (:file "configuration" :depends-on ("image")) (:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration")) (:file "driver" :depends-on ("backward-driver")))) cl-asdf-3.0.3/uiop/utility.lisp000066400000000000000000000572771223164443400164230ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF (uiop/package:define-package :uiop/utility (:nicknames :asdf/utility) (:recycle :uiop/utility :asdf/utility :asdf) (:use :uiop/common-lisp :uiop/package) ;; import and reexport a few things defined in :uiop/common-lisp (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions #:if-let ;; basic flow control #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences #:+non-base-chars-exist-p+ ;; characters #:+max-character-type-index+ #:character-type-index #:+character-types+ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:earlier-stamp #:stamps-earliest #:earliest-stamp #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f #:list-to-hash-set #:ensure-gethash ;; hash-table #:ensure-function #:access-at #:access-at-count ;; functions #:call-function #:call-functions #:register-hook-function #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions #:lexicographic< #:lexicographic<= #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version (in-package :uiop/utility) ;;;; Defining functions in a way compatible with hot-upgrade: ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, ;; thus replacing the function without warning or error ;; even if the signature and/or generic-ness of the function has changed. ;; For a generic function, this invalidates any previous DEFMETHOD. (eval-when (:load-toplevel :compile-toplevel :execute) (defun undefine-function (function-spec) (cond ((symbolp function-spec) #+clisp (let ((f (and (fboundp function-spec) (fdefinition function-spec)))) (when (typep f 'clos:standard-generic-function) (loop :for m :in (clos:generic-function-methods f) :do (remove-method f m)))) (fmakunbound function-spec)) ((and (consp function-spec) (eq (car function-spec) 'setf) (consp (cdr function-spec)) (null (cddr function-spec))) #-gcl2.6 (fmakunbound function-spec)) (t (error "bad function spec ~S" function-spec)))) (defun undefine-functions (function-spec-list) (map () 'undefine-function function-spec-list)) (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) (destructuring-bind (name &key (supersede t)) (if (or (atom name) (eq (car name) 'setf)) (list name :supersede nil) name) (declare (ignorable supersede)) `(progn ;; undefining the previous function is the portable way ;; of overriding any incompatible previous gf, except on CLISP. ;; We usually try to do it only for the functions that need it, ;; which happens in asdf/upgrade - however, for ECL, we need this hammer ;; (which causes issues in clisp) ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) `((undefine-function ',name))) #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl `((declaim (notinline ,name)))) (,',def ,name ,formals ,@rest)))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) (defmacro with-upgradability ((&optional) &body body) `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(loop :for form :in body :collect (if (consp form) (destructuring-bind (car . cdr) form (case car ((defun) `(defun* ,@cdr)) ((defgeneric) (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr)))) `(defgeneric* ,@cdr))) (otherwise form))) form))))) ;;; Magic debugging help. See contrib/debug.lisp (with-upgradability () (defvar *uiop-debug-utility* '(or (ignore-errors (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp")) "form that evaluates to the pathname to your favorite debugging utilities") (defmacro uiop-debug (&rest keys) `(eval-when (:compile-toplevel :load-toplevel :execute) (load-uiop-debug-utility ,@keys))) (defun load-uiop-debug-utility (&key package utility-file) (let* ((*package* (if package (find-package package) *package*)) (keyword (read-from-string (format nil ":DBG-~:@(~A~)" (package-name *package*))))) (unless (member keyword *features*) (let* ((utility-file (or utility-file *uiop-debug-utility*)) (file (ignore-errors (probe-file (eval utility-file))))) (if file (load file) (error "Failed to locate debug utility file: ~S" utility-file))))))) ;;; Flow control (with-upgradability () (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria ;; bindings can be (var form) or ((var1 form1) ...) (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) (list bindings) bindings)) (variables (mapcar #'car binding-list))) `(let ,binding-list (if (and ,@variables) ,then-form ,else-form))))) ;;; List manipulation (with-upgradability () (defmacro while-collecting ((&rest collectors) &body body) "COLLECTORS should be a list of names for collections. A collector defines a function that, when applied to an argument inside BODY, will add its argument to the corresponding collection. Returns multiple values, a list for each collection, in order. E.g., \(while-collecting \(foo bar\) \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) \(foo \(first x\)\) \(bar \(second x\)\)\)\) Returns two values: \(A B C\) and \(1 2 3\)." (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) ,@body (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (define-modify-macro appendf (&rest args) append "Append onto list") ;; only to be used on short lists. (defun length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop :for l = x :then (cdr l) :for i :downfrom n :do (cond ((zerop i) (return (null l))) ((not (consp l)) (return nil))))) (defun ensure-list (x) (if (listp x) x (list x)))) ;;; remove a key from a plist, i.e. for keyword argument cleanup (with-upgradability () (defun remove-plist-key (key plist) "Remove a single key from a plist" (loop* :for (k v) :on plist :by #'cddr :unless (eq k key) :append (list k v))) (defun remove-plist-keys (keys plist) "Remove a list of keys from a plist" (loop* :for (k v) :on plist :by #'cddr :unless (member k keys) :append (list k v)))) ;;; Sequences (with-upgradability () (defun emptyp (x) "Predicate that is true for an empty sequence" (or (null x) (and (vectorp x) (zerop (length x)))))) ;;; Characters (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) (with-upgradability () (defparameter +character-types+ ;; assuming a simple hierarchy #(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character)) (defparameter +max-character-type-index+ (1- (length +character-types+)))) (with-upgradability () (defun character-type-index (x) (declare (ignorable x)) #.(case +max-character-type-index+ (0 0) (1 '(etypecase x (character (if (typep x 'base-char) 0 1)) (symbol (if (subtypep x 'base-char) 0 1)))) (otherwise '(or (position-if (etypecase x (character #'(lambda (type) (typep x type))) (symbol #'(lambda (type) (subtypep x type)))) +character-types+) (error "Not a character or character type: ~S" x)))))) ;;; Strings (with-upgradability () (defun base-string-p (string) "Does the STRING only contain BASE-CHARs?" (declare (ignorable string)) (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) (defun strings-common-element-type (strings) "What least subtype of CHARACTER can contain all the elements of all the STRINGS?" (declare (ignorable strings)) #.(if +non-base-chars-exist-p+ `(aref +character-types+ (loop :with index = 0 :for s :in strings :do (cond ((= index ,+max-character-type-index+) (return index)) ((emptyp s)) ;; NIL or empty string ((characterp s) (setf index (max index (character-type-index s)))) ((stringp s) (unless (>= index (character-type-index (array-element-type s))) (setf index (reduce 'max s :key #'character-type-index :initial-value index)))) (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))) :finally (return index))) ''character)) (defun reduce/strcat (strings &key key start end) "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. NIL is interpreted as an empty string. A character is interpreted as a string of length one." (when (or start end) (setf strings (subseq strings start end))) (when key (setf strings (mapcar key strings))) (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s))) :element-type (strings-common-element-type strings)) :with pos = 0 :for input :in strings :do (etypecase input (null) (character (setf (char output pos) input) (incf pos)) (string (replace output input :start1 pos) (incf pos (length input)))) :finally (return output))) (defun strcat (&rest strings) "Concatenate strings. NIL is interpreted as an empty string, a character as a string of length one." (reduce/strcat strings)) (defun first-char (s) "Return the first character of a non-empty string S, or NIL" (and (stringp s) (plusp (length s)) (char s 0))) (defun last-char (s) "Return the last character of a non-empty string S, or NIL" (and (stringp s) (plusp (length s)) (char s (1- (length s))))) (defun split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by any of the characters in the sequence SEPARATOR. If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." (block () (let ((list nil) (words 0) (end (length string))) (when (zerop end) (return nil)) (flet ((separatorp (char) (find char separator)) (done () (return (cons (subseq string 0 end) list)))) (loop :for start = (if (and max (>= words (1- max))) (done) (position-if #'separatorp string :end end :from-end t)) :do (when (null start) (done)) (push (subseq string (1+ start) end) list) (incf words) (setf end start)))))) (defun string-prefix-p (prefix string) "Does STRING begin with PREFIX?" (let* ((x (string prefix)) (y (string string)) (lx (length x)) (ly (length y))) (and (<= lx ly) (string= x y :end2 lx)))) (defun string-suffix-p (string suffix) "Does STRING end with SUFFIX?" (let* ((x (string string)) (y (string suffix)) (lx (length x)) (ly (length y))) (and (<= ly lx) (string= x y :start1 (- lx ly))))) (defun string-enclosed-p (prefix string suffix) "Does STRING begin with PREFIX and end with SUFFIX?" (and (string-prefix-p prefix string) (string-suffix-p string suffix)))) (defvar +cr+ (coerce #(#\Return) 'string)) (defvar +lf+ (coerce #(#\Linefeed) 'string)) (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string)) (defun stripln (x) "Strip a string X from any ending CR, LF or CRLF. Return two values, the stripped string and the ending that was stripped, or the original value and NIL if no stripping took place. Since our STRCAT accepts NIL as empty string designator, the two results passed to STRCAT always reconstitute the original string" (check-type x string) (block nil (flet ((c (end) (when (string-suffix-p x end) (return (values (subseq x 0 (- (length x) (length end))) end))))) (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) ;;; CLOS (with-upgradability () (defun find-class* (x &optional (errorp t) environment) (etypecase x ((or standard-class built-in-class) x) #+gcl2.6 (keyword nil) (symbol (find-class x errorp environment))))) ;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype stamp () '(or real boolean))) (with-upgradability () (defun stamp< (x y) (etypecase x (null (and y t)) ((eql t) nil) (real (etypecase y (null nil) ((eql t) t) (real (< x y)))))) (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) (defun stamp*< (&rest list) (stamps< list)) (defun stamp<= (x y) (not (stamp< y x))) (defun earlier-stamp (x y) (if (stamp< x y) x y)) (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) (defun earliest-stamp (&rest list) (stamps-earliest list)) (defun later-stamp (x y) (if (stamp< x y) y x)) (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) (defun latest-stamp (&rest list) (stamps-latest list)) (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)) ;;; Function designators (with-upgradability () (defun ensure-function (fun &key (package :cl)) "Coerce the object FUN into a function. If FUN is a FUNCTION, return it. If the FUN is a non-sequence literal constant, return constantly that, i.e. for a boolean keyword character number or pathname. Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. If FUN is a CONS, return the function that applies its CAR to the appended list of the rest of its CDR and the arguments, unless the CAR is LAMBDA, in which case the expression is evaluated. If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) and EVAL that in a (FUNCTION ...) context." (etypecase fun (function fun) ((or boolean keyword character number pathname) (constantly fun)) (symbol fun) (cons (if (eq 'lambda (car fun)) (eval fun) #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) (string (eval `(function ,(with-standard-io-syntax (let ((*package* (find-package package))) (read-from-string fun)))))))) (defun access-at (object at) "Given an OBJECT and an AT specifier, list of successive accessors, call each accessor on the result of the previous calls. An accessor may be an integer, meaning a call to ELT, a keyword, meaning a call to GETF, NIL, meaning identity, a function or other symbol, meaning itself, or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. As a degenerate case, the AT specifier may be an atom of a single such accessor instead of a list." (flet ((access (object accessor) (etypecase accessor (function (funcall accessor object)) (integer (elt object accessor)) (keyword (getf object accessor)) (null object) (symbol (funcall accessor object)) (cons (funcall (ensure-function accessor) object))))) (if (listp at) (dolist (accessor at object) (setf object (access object accessor))) (access object at)))) (defun access-at-count (at) "From an AT specification, extract a COUNT of maximum number of sub-objects to read as per ACCESS-AT" (cond ((integerp at) (1+ at)) ((and (consp at) (integerp (first at))) (1+ (first at))))) (defun call-function (function-spec &rest arguments) "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION, with the given ARGUMENTS" (apply (ensure-function function-spec) arguments)) (defun call-functions (function-specs) "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION" (map () 'call-function function-specs)) (defun register-hook-function (variable hook &optional call-now-p) "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE. When CALL-NOW-P is true, also call the function immediately." (pushnew hook (symbol-value variable) :test 'equal) (when call-now-p (call-function hook)))) ;;; Hash-tables (with-upgradability () (defun ensure-gethash (key table default) "Lookup the TABLE for a KEY as by gethash, but if not present, call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, set the corresponding entry to the result in the table, and return that result." (multiple-value-bind (value foundp) (gethash key table) (if foundp value (setf (gethash key table) (values (call-function default)))))) (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) "Convert a LIST into hash-table that has the same elements when viewed as a set, up to the given equality TEST" (dolist (x list h) (setf (gethash x h) t)))) ;;; Version handling (with-upgradability () (defun unparse-version (version-list) (format nil "~{~D~^.~}" version-list)) (defun parse-version (version-string &optional on-error) "Parse a VERSION-STRING as a series of natural integers separated by dots. Return a (non-null) list of integers if the string is valid; otherwise return NIL. When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, with format arguments explaining why the version is invalid. ON-ERROR is also called if the version is not canonical in that it doesn't print back to itself, but the list is returned anyway." (block nil (unless (stringp version-string) (call-function on-error "~S: ~S is not a string" 'parse-version version-string) (return)) (unless (loop :for prev = nil :then c :for c :across version-string :always (or (digit-char-p c) (and (eql c #\.) prev (not (eql prev #\.)))) :finally (return (and c (digit-char-p c)))) (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" 'parse-version version-string) (return)) (let* ((version-list (mapcar #'parse-integer (split-string version-string :separator "."))) (normalized-version (unparse-version version-list))) (unless (equal version-string normalized-version) (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) version-list))) (defun lexicographic< (< x y) (cond ((null y) nil) ((null x) t) ((funcall < (car x) (car y)) t) ((funcall < (car y) (car x)) nil) (t (lexicographic< < (cdr x) (cdr y))))) (defun lexicographic<= (< x y) (not (lexicographic< < y x))) (defun version< (version1 version2) (let ((v1 (parse-version version1 nil)) (v2 (parse-version version2 nil))) (lexicographic< '< v1 v2))) (defun version<= (version1 version2) (not (version< version2 version1))) (defun version-compatible-p (provided-version required-version) "Is the provided version a compatible substitution for the required-version? If major versions differ, it's not compatible. If they are equal, then any later version is compatible, with later being determined by a lexicographical comparison of minor numbers." (let ((x (parse-version provided-version nil)) (y (parse-version required-version nil))) (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))) ;;; Condition control (with-upgradability () (defparameter +simple-condition-format-control-slot+ #+abcl 'system::format-control #+allegro 'excl::format-control #+clisp 'system::$format-control #+clozure 'ccl::format-control #+(or cmu scl) 'conditions::format-control #+ecl 'si::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) "Compare received CONDITION to some pattern X: a symbol naming a condition class, a simple vector of length 2, arguments to find-symbol* with result as above, or a string describing the format-control of a simple-condition." (etypecase x (symbol (typep condition x)) ((simple-vector 2) (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))) (function (funcall x condition)) (string (and (typep condition 'simple-condition) ;; On SBCL, it's always set and the check triggers a warning #+(or allegro clozure cmu lispworks scl) (slot-boundp condition +simple-condition-format-control-slot+) (ignore-errors (equal (simple-condition-format-control condition) x)))))) (defun match-any-condition-p (condition conditions) "match CONDITION against any of the patterns of CONDITIONS supplied" (loop :for x :in conditions :thereis (match-condition-p x condition))) (defun call-with-muffled-conditions (thunk conditions) "calls the THUNK in a context where the CONDITIONS are muffled" (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) (muffle-warning c))))) (funcall thunk))) (defmacro with-muffled-conditions ((conditions) &body body) `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) cl-asdf-3.0.3/uiop/version.lisp-expr000077700000000000000000000000001223164443400230772../version.lisp-exprustar00rootroot00000000000000cl-asdf-3.0.3/upgrade.lisp000066400000000000000000000161611223164443400153560ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 (asdf/package:define-package :asdf/upgrade (:recycle :asdf/upgrade :asdf) (:use :uiop/common-lisp :uiop) (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:intern*) (:import-from :asdf/package #:intern* #:find-symbol*)) (in-package :asdf/upgrade) ;;; Special magic to detect if this is an upgrade (with-upgradability () (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")." (when (find-package :asdf) (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf)) (rev (and revsym (boundp revsym) (symbol-value revsym)))) (etypecase rev (string rev) (cons (format nil "~{~D~^.~}" rev)) (null "1.0")))))) (defvar *asdf-version* nil) (defvar *previous-asdf-versions* nil) (defvar *verbose-out* nil) (defun asdf-message (format-string &rest format-args) (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) (defvar *post-upgrade-cleanup-hook* ()) (defvar *post-upgrade-restart-hook* ()) (defun upgrading-p () (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*))))) (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body) `(with-upgradability () (when (and ,upgrading-p ,@(when when `(,when))) (handler-bind ((style-warning #'muffle-warning)) (eval '(progn ,@body)))))) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 ;; can help you do these changes in synch (look at the source for documentation). ;; Relying on its automation, the version is now redundantly present on top of this file. ;; "3.4" would be the general branch for major version 3, minor version 4. ;; "3.4.5" would be an official release in the 3.4 branch. ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 (asdf-version "3.0.3") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) (push existing-version *previous-asdf-versions*) (when (or *verbose-out* *load-verbose*) (format (or *verbose-out* *trace-output*) (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") existing-version asdf-version))))) (when-upgrading () (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. '(#:component-relative-pathname #:component-parent-pathname ;; component #:source-file-type #:find-system #:system-source-file #:system-relative-pathname ;; system #:find-component ;; find-component #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action #:component-depends-on #:operation-done-p #:component-depends-on #:traverse ;; backward-interface #:operate ;; operate #:parse-component-form ;; defsystem #:apply-output-translations ;; output-translations #:process-output-translations-directive #:inherit-source-registry #:process-source-registry ;; source-registry #:process-source-registry-directive #:trivial-system-p ;; bundle ;; NB: it's too late to do anything about uiop functions! )) (uninterned-symbols '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector #:do-dep #:do-one-dep #:component-self-dependencies #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function (declare (ignorable redefined-functions uninterned-symbols)) (loop :for name :in (append redefined-functions) :for sym = (find-symbol* name :asdf nil) :do (when sym ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. #-clisp (fmakunbound sym))) (loop :with asdf = (find-package :asdf) :for name :in uninterned-symbols :for sym = (find-symbol* name :asdf nil) :for base-pkg = (and sym (symbol-package sym)) :do (when sym (cond ((or (eq base-pkg asdf) (not base-pkg)) (unintern* sym asdf) (intern* sym asdf)) (t (unintern* sym base-pkg) (let ((new (intern* sym base-pkg))) (shadowing-import new asdf)))))))) ;;; Self-upgrade functions (with-upgradability () (defun asdf-upgrade-error () ;; Important notice for whom it concerns. The crux of the matter is that ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late. (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~ Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%")) (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) (let ((new-version (asdf-version))) (unless (equal old-version new-version) (push new-version *previous-asdf-versions*) (when old-version (if (version<= new-version old-version) (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version) (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version)) (call-functions (reverse *post-upgrade-cleanup-hook*)) t)))) (defun upgrade-asdf () "Try to upgrade of ASDF. If a different version was used, return T. We need do that before we operate on anything that may possibly depend on ASDF." (let ((*load-print* nil) (*compile-print* nil)) (handler-bind (((or style-warning) #'muffle-warning)) (symbol-call :asdf :load-system :asdf :verbose nil)))) (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) cl-asdf-3.0.3/user.lisp000066400000000000000000000003701223164443400147000ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; ASDF-USER, where the action happens. (asdf/package:define-package :asdf/user (:nicknames :asdf-user) (:use :asdf/common-lisp :asdf/package :asdf/interface)) cl-asdf-3.0.3/version.lisp-expr000066400000000000000000000000111223164443400163530ustar00rootroot00000000000000"3.0.3"