pax_global_header00006660000000000000000000000064136215511530014514gustar00rootroot0000000000000052 comment=082f4ed4952dbca0216b92f48fe52280a82c65ae asdf-3.3.4/000077500000000000000000000000001362155115300124405ustar00rootroot00000000000000asdf-3.3.4/.cl-source-registry.cache000066400000000000000000000001521362155115300172430ustar00rootroot00000000000000(:source-registry-cache "asdf.asd" "uiop/asdf-driver.asd" "uiop/uiop.asd" "tools/asdf-tools.asd") asdf-3.3.4/.gitattributes000066400000000000000000000000411362155115300153260ustar00rootroot00000000000000ext export-ignore * export-subst asdf-3.3.4/.gitignore000066400000000000000000000021311362155115300144250ustar00rootroot00000000000000?? build asdf.lisp doc/cmucl/ 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.tps doc/asdf.tp doc/asdf.tps doc/asdf.vr doc/asdf.vrs doc/asdf.t2d/ doc/asdf.dvi doc/version.texinfo doc/*.log *.tmp uiop/doc/uiop.html uiop/doc/uiop.info uiop/doc/uiop.pdf uiop/doc/uiop.texinfo LICENSE README.html tmp/ man/ lib/ *.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 test/test-include.asd test/test-multiple-too.asd build-stamp # Although there is no debian subdir/ in this repo any more, the # presence of these lines helps the debian package maintainers, so # please leave them here. 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 core # Hack: ignore the GNUmakefile here, so you can ln -s Makefile-lisp-scripting GNUmakefile GNUmakefile asdf-3.3.4/.gitmodules000066400000000000000000000026611362155115300146220ustar00rootroot00000000000000[submodule "ext/fare-utils"] path = ext/fare-utils url = https://gitlab.common-lisp.net/frideau/fare-utils.git [submodule "ext/fare-quasiquote"] path = ext/fare-quasiquote url = https://gitlab.common-lisp.net/frideau/fare-quasiquote.git [submodule "ext/fare-mop"] path = ext/fare-mop url = https://gitlab.common-lisp.net/frideau/fare-mop.git [submodule "ext/closer-closer-mop"] path = ext/closer-closer-mop url = https://github.com/pcostanza/closer-mop.git [submodule "ext/alexandria"] path = ext/alexandria url = https://gitlab.common-lisp.net/alexandria/alexandria.git [submodule "ext/optima"] path = ext/optima url = https://github.com/m2ym/optima.git [submodule "ext/named-readtables"] path = ext/named-readtables url = https://github.com/melisgl/named-readtables.git [submodule "ext/inferior-shell"] path = ext/inferior-shell url = https://gitlab.common-lisp.net/qitab/inferior-shell.git [submodule "ext/lisp-invocation"] path = ext/lisp-invocation url = https://gitlab.common-lisp.net/qitab/lisp-invocation.git [submodule "ext/cl-ppcre"] path = ext/cl-ppcre url = https://github.com/edicl/cl-ppcre [submodule "ext/asdf-encodings"] path = ext/asdf-encodings url = https://gitlab.common-lisp.net/asdf/asdf-encodings.git [submodule "ext/cl-scripting"] path = ext/cl-scripting url = https://github.com/fare/cl-scripting.git [submodule "ext/cl-launch"] path = ext/cl-launch url = https://gitlab.common-lisp.net/xcvb/cl-launch.git asdf-3.3.4/Makefile000066400000000000000000000251521362155115300141050ustar00rootroot00000000000000# Configuring this Makefile for your personal use: # Set environment variable ASDF_TEST_LISPS to a space-separated list of values # (see "defaultlisps" below, for an example). # If you have a special way to find libraries that are used in the build and # test process, you may bind ASDF_DEVEL_SOURCE_REGISTRY to a source registry to # use (using the environment variable syntax), or bind it to "override" to use # your normal CL source registry. Otherwise, it will use local copies of # everything. system := "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 dirname $(realpath $(lastword $(MAKEFILE_LIST)))) #### 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 defaultLisps = ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern gcl xcl mkcl ifdef ASDF_TEST_LISPS lisps ?= ${ASDF_TEST_LISPS} else lisps ?= ${defaultLisps} endif ifdef ASDF_UPGRADE_TEST_LISPS ulisps ?= ${ASDF_UPGRADE_TEST_LISPS} else ifdef ASDF_TEST_LISPS ulisps ?= ${ASDF_TEST_LISPS} else ulisps ?= ${defaultLisps} endif endif version := $(shell cat "version.lisp-expr") #$(info $$version is [${version}]) version := $(patsubst "%",%,$(version)) #$(info $$version is [${version}]) fullversion := $(shell git describe --tags --match "[0-9][.][0-9]*" 2> /dev/null || echo $(version)) ## grep for #+/#- features in the test/ directory to see plenty of disabled tests on some platforms ## NOT SUPPORTED BY OUR AUTOMATED TESTS: ## cormancl genera lispworks-personal-edition rmcl ## Some are manually tested once in a while. ifdef ASDF_TEST_SYSTEMS s ?= ${ASDF_TEST_SYSTEMS} endif ifdef ASDF_DEVEL_SOURCE_REGISTRY ifeq ($(ASDF_DEVEL_SOURCE_REGISTRY), override) # do nothing... Use the user's CL_SOURCE_REGISTRY else export CL_SOURCE_REGISTRY = ${ASDF_DEVEL_SOURCE_REGISTRY} endif else # no ASDF_DEVEL_SOURCE_REGISTRY export CL_SOURCE_REGISTRY = ${sourceDirectory}/:${sourceDirectory}/uiop/:${sourceDirectory}/ext// endif #$(error "CL_SOURCE_REGISTRY is ${CL_SOURCE_REGISTRY}") sys := $(shell uname -s) ifneq (,$(findstring CYGWIN,$(sys))) CL_SOURCE_REGISTRY := $(shell cygpath -pw "${CL_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 header_lisp := header.lisp driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) print-% : ; @echo $* = $($*) # Making ASDF itself should be our first, default, target: build/asdf.lisp: $(all_lisp) mkdir -p build rm -f $@ cat $(all_lisp) > $@ ext: git submodule update --init noext: git submodule deinit . # 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 git commit -a -m "Bump version to $$(eval a=$$(cat version.lisp-expr) ; echo $$a)" temp=$$(cat version.lisp-expr); temp="$${temp%\"}"; temp="$${temp#\"}"; git tag $$temp bump-version: build/asdf.lisp ./bin/bump-version ${v} driver-files: @echo $(driver_lisp) defsystem-files: @echo $(defsystem_lisp) # FIXME: needs rewrite #archive: build/asdf.lisp # ./bin/asdf-builder make-and-publish-archive archive: build/asdf.lisp $(eval UIOPDIR := "uiop-$(version)") mkdir -p build/$(UIOPDIR) # UIOP tarball cp -pHux uiop/README.md uiop/uiop.asd uiop/asdf-driver.asd ${driver_lisp} uiop/contrib/debug.lisp build/$(UIOPDIR) tar zcf "build/uiop-${version}.tar.gz" -C build $(UIOPDIR) rm -r build/$(UIOPDIR) $(eval ASDFDIR := "asdf-$(version)") mkdir -p build/$(ASDFDIR) # asdf-defsystem tarball cp -pHux build/asdf.lisp asdf.asd version.lisp-expr header.lisp README.md ${defsystem_lisp} build/$(ASDFDIR) tar zcf "build/asdf-defsystem-${version}.tar.gz" -C build $(ASDFDIR) rm -r build/$(ASDFDIR) git archive --worktree-attributes --prefix="asdf-$(version)/" --format=tar -o "build/asdf-${version}.tar" ${version} #asdf-all tarball gzip "build/asdf-${version}.tar" cp "build/asdf.lisp" "build/asdf-${version}.lisp" publish-archive: rsync --times --chmod=a+rX,ug+w "build/uiop-${version}.tar.gz" "build/asdf-defsystem-${version}.tar.gz" \ "build/asdf-${version}.tar.gz" "build/asdf-${version}.lisp" common-lisp.net:/project/asdf/public_html/archives/ ssh common-lisp.net "cd /project/asdf/public_html/archives/; ln -sf uiop-${version}.tar.gz uiop.tar.gz; ln -sf asdf-defsystem-${version}.tar.gz asdf-defsystem.tar.gz; ln -sf asdf-${version}.tar.gz asdf.tar.gz; ln -sf asdf-${version}.lisp asdf.lisp" ### 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 # don't have the toolchain to build docs installed... doc: ; website: ${MAKE} -C doc website ${MAKE} -C uiop/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/*"\" -delete; \ done; \ fi; \ echo "Cleaned $$dir"; \ done echo "Done with cleaning loop." rm -rf build/ LICENSE test/try-reloading-dependency.asd test/hello-world-example asdf.lisp rm -rf test/hello-world-example.exe test/mkcl_*.dll # needed only on MS-Windows ${MAKE} -C doc clean ${MAKE} -C uiop/doc clean mrproper: git clean -xfd test-upgrade: build/asdf.lisp show-version ./test/run-tests.sh -u ${l} u: test-upgrade test-clean-load: build/asdf.lisp show-version ./test/run-tests.sh -c ${l} show-version: @echo "Building and testing asdf $(fullversion)" # test-glob has been replaced by t, and lisp by l, easier to type test-lisp: build/asdf.lisp show-version @cd test; ./run-tests.sh ${l} ${t} t: test-lisp test: doc test-lisp test-clean-load test-load-systems test-load-systems: build/asdf.lisp show-version ./test/run-tests.sh -l ${l} ${s} test-all-lisps: test-load-systems test-all-clean-load test-all-lisp test-all-upgrade test-all-clean-load: @for lisp in ${lisps} ; do ${MAKE} test-clean-load l=$$lisp || exit 1 ; done test-all-lisp: @for lisp in ${lisps} ; do ${MAKE} test-lisp l=$$lisp || exit 1 ; done test-all-upgrade: @for lisp in ${ulisps} ; do ${MAKE} test-upgrade l=$$lisp || exit 1 ; done test-all-no-upgrade: doc test-load-systems test-all-clean-load test-all-lisp test-all: test-all-no-upgrade test-all-upgrade test-all-lisp-no-stop: @for lisp in ${lisps} ; do ${MAKE} test-lisp l=$$lisp ; done ; : test-all-upgrade-no-stop: @for lisp in ${ulisps} ; do ${MAKE} test-upgrade l=$$lisp ; done ; : test-all-no-upgrade-no-stop: doc test-load-systems test-all-clean-load test-all-lisp-no-stop make --quiet check-all-test-results test-all-no-stop: doc test-load-systems test-all-clean-load test-all-lisp-no-stop test-all-upgrade-no-stop make --quiet check-all-results check-all-test-results: @A="`grep -L '[5-9][0-9] passing and 0 failing' build/results/*-test.text`" ; \ if [ -n "$$A" ] ; then \ echo "Unexpected test failures on these implementations:" ; \ echo "$$A" ; \ exit 1 ; \ fi check-all-upgrade-results: @A="`grep -L 'Upgrade test succeeded for ' build/results/*-upgrade.text`" ; \ if [ -n "$$A" ] ; then \ echo "Unexpected upgrade failures on these implementations:" ; \ echo "$$A" ; \ exit 1 ; \ fi check-all-results: @r=0 ; \ make --quiet check-all-test-results || r=1 ; \ make --quiet check-all-upgrade-results || r=1 ; \ exit $r extract: extract-all-tagged-asdf extract-all-tagged-asdf: build/asdf.lisp ./test/run-tests.sh -H # 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 show-version \ 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 \ list-source-registry \ ext noext # debug the source registry that will be used to execute commands from this Makefile. #list-source-registry: # ${sourceDirectory}/bin/asdf-builder re '(uiop:writeln (sort (alexandria:hash-table-alist asdf::*source-registry*) `string< :key `car))' # 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 ... # make debian-package # git push # git push origin 3.0 # for example... # everything from here for RELEASE only # make release-push archive website debian-package # dput mentors ../*.changes # send debian mentors request # send announcement to asdf-announce, asdf-devel, etc. # Move all fixed bugs from Fix Committed -> Fix Released on launchpad # ## 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 asdf-3.3.4/Makefile-lisp-scripting000066400000000000000000000106001362155115300170420ustar00rootroot00000000000000# -*- Makefile -*- This minimal Makefile delegates most work to the asdf-tools script # # End-Users, all you need to do is: # make -f Makefile-lisp-scripting # # Vendors, you may want to test your implementation with: # make -f Makefile-lisp-scripting test l=sbcl # BUT you first need have installed the development-time external dependencies of ASDF; # this will be done automatically if you are using quicklisp; # you can do it manually with your favorite tools (e.g. clbuild or git); # or you can do it using `git submodule update` which is also available as: # make -f Makefile-lisp-scripting ext # To undo the `git submodule update` you can use: `make noext` # # Other targets are for maintainer use only. If you want a list of all of the targets, use # make -f Makefile-lisp-scripting help # ### Default fall back rule: delegate to asdf-tools. # Note that the l= L= etc. are the only way I (Faré) have found to # pass arguments from the Makefile to the underlying script: # l= overrides $ASDF_TEST_LISPS to specify which lisp implementations to use # L= overrides $ASDF_UPGRADE_TEST_LISPS (defaults to the former) to lisps during upgrade # s= overrides $ASDF_TEST_SYSTEMS to specify systems with which to test ASDF # t= overrides $ASDF_TESTS to specify test script patterns to use (default to *.script) # u= overrides $ASDF_UPGRADE_TEST_TAGS to specify versions to upgrade from (e.g. 3.0.3 or REQUIRE) # U= overrides $ASDF_UPGRADE_TEST_METHODS to specify upgrade methods # v= overrides the default next version for bump-version or bump. # see in tools/test-environment.lisp for details. # Note that because of how make and the shell quote arguments, # thou shalt not use the single-quote character in any of the short x= parameters # (but you may use them in the long variant in the exported environment variable). # To have a list of commands, see make help or ./tools/asdf-tools help # Note that when you call ./tools/asdf-tools directly, # you may have to use positional parameters instead (unless you use env as below), as in # ./tools/asdf-tools bump 3.2.1 # instead of # make -f Makefile-lisp-scripting bump v=3.2.1 # or # ./make-asdf.sh v=3.2.1 bump # or # ./tools/asdf-tools env v=3.2.1 bump # or # v=3.2.1 ./tools/asdf-tools bump ifeq ($(OS),Windows_NT) MAKE_SCRIPT := cmd /c make-asdf.bat else MAKE_SCRIPT := ./make-asdf.sh endif all ext noext driver_files defsystem_files build_asdf build_asdf_tools: force ${MAKE_SCRIPT} $@ build/asdf.lisp: build_asdf build/asdf-tools build/asdf-tools.exe: build_asdf_tools .PHONY: force all ext noext driver_files defsystem_files build_asdf build_asdf_tools # The text below was automaticaly generated by # make -f Makefile-lisp-scripting --silent makefile-targets # then manually inserted here to provide for completion: .PHONY: archive build-asdf build-asdf-tools bump bump-version check-all-results check-all-scripts-results check-all-upgrade-results clean debian-package doc ext-clear ext-init ext-reset ext-update extract extract-all-tagged-asdf extract-tagged-asdf fix-local-git-tags fix-remote-git-tags git-all-committed-p help install install-asdf link-archive load make-and-publish-archive make-archive makefile-targets merge-master-into-release publish-archive publish-debian-package push re show-commands show-version t test test-all test-all-basic test-all-clean-load test-all-no-stop test-all-no-upgrade test-all-no-upgrade-no-stop test-all-scripts test-all-scripts-no-stop test-all-upgrade test-all-upgrade-no-stop test-ascii test-basic test-clean-load test-load-systems test-scripts test-upgrade u wc website archive build-asdf build-asdf-tools bump bump-version check-all-results check-all-scripts-results check-all-upgrade-results clean debian-package doc ext-clear ext-init ext-reset ext-update extract extract-all-tagged-asdf extract-tagged-asdf fix-local-git-tags fix-remote-git-tags git-all-committed-p help install install-asdf link-archive load make-and-publish-archive make-archive makefile-targets merge-master-into-release publish-archive publish-debian-package push re show-commands show-version t test test-all test-all-basic test-all-clean-load test-all-no-stop test-all-no-upgrade test-all-no-upgrade-no-stop test-all-scripts test-all-scripts-no-stop test-all-upgrade test-all-upgrade-no-stop test-ascii test-basic test-clean-load test-load-systems test-scripts test-upgrade u wc website: force ${MAKE_SCRIPT} l='$l' L='$L' u='$u' U='$U' v='$v' s='$s' t='$t' $@ asdf-3.3.4/README.md000066400000000000000000000301731362155115300137230ustar00rootroot00000000000000ASDF: Another System Definition Facility ======================================== For general information about ASDF, consult the web page: For some reference documentation, read the manual: For a guide on how to use it, read our "best practices" document: Below is a guide for ASDF developers. It is not meant for ASDF users. [TOC] Building ASDF ------------- First, make sure ASDF is checked out under a path registered to the source-registry, if that isn't the case yet (see the [manual](http://common-lisp.net/project/asdf/asdf.html)). One place would be: ~/.local/share/common-lisp/source/asdf/ or, assuming your implementation provides ASDF 3.1 or later: ~/common-lisp/asdf/ If you cloned our git repository rather than extracted a tarball, bootstrap a copy of `build/asdf.lisp` with: make Building the documentation -------------------------- The manual is also in the [doc/](doc/) subdirectory, and can be prepared with: make -C doc Testing ASDF ------------ Before you may run tests, you need a few CL libraries. The simplest way to get them is as follows, but read below: make ext _NOTA BENE_: You may also need to run `make ext` again after you `git pull` or switch branch, to update the `ext/` directory. This unhappily is not automatic. If for some reason tests fail, particularly due to an error compiling, loading or running a library, then run `make ext` and try again. The above `make` target uses `git submodule update --init` to download all these libraries using git. If you don't otherwise maintain your own set of carefully controlled CL libraries, that's what you want to use. However, it is only available if you have a git checkout of ASDF; not if you used a tarball. If you use a tarball or otherwise do maintain your own set of carefully controlled CL libraries then you will want to use whichever tools you use (e.g. `quicklisp`, `clbuild`, or your own scripts around `git`) to download these libraries: `alexandria`, `asdf-encodings`, `cl-launch`, `closer-mop`, `cl-ppcre`, `cl-scripting`, `fare-mop`, `fare-quasiquote`, `fare-utils`, `inferior-shell`, `lisp-invocation`, `named-readtables`, `optima`. If you are a CL developer, you may already have them, or may want to use your own tools to download a version of them you control. If you use [Quicklisp](https://www.quicklisp.org/), you may let Quicklisp download those you don't have. In these cases, you may NOT want to use the git submodules from `make ext`; you may undo a `make ext` with `make noext`. Otherwise, if you want to let ASDF download known-working versions of its dependencies, you can do it with `make ext`. Once you have all the required libraries and the asdf-tools script can find a suitable Common Lisp implementation, you may run all the tests on a given Common Lisp implementation `$L`, with your favorite installed system `$S`, using: make t u l=$L s=$S To run only the regression test scripts, try simply: make l=$L test-scripts Lisp Scripting test system -------------------------- ASDF by default uses a shell script in `./test/run-tests.sh` to run the scripts that orchestrate its tests. An alternate build and test system is available that uses Common Lisp as a scripting language. It is disabled by default because the new maintainer is having trouble with it in some of his environments. It worked fine for the previous maintainer in his environments, and may be particularly useful on Windows if and when the shell-based test system fails or is not available. Its source code is in [tools/](tools/) and you can invoke it without going through GNU make, using the script [make-asdf.sh](make-asdf.sh), or, on Windows, [make-asdf.bat](make-asdf.bat). To use this alternate test system, pass to `make` the extra arguments `-f Makefile-lisp-scripting` as in for instance: make -f Makefile-lisp-scripting t l=sbcl Or you can make that your local default (assuming GNU make) using: echo "include Makefile-lisp-scripting" > GNUmakefile These Lisp tools by default use Clozure Common Lisp (CCL) to build and run a binary `build/asdf-tools` that will orchestrate the tests. By defining and exporting the variable `LISP` to be one of `ccl`, `sbcl` or `allegro`, you can have it use an alternate Common Lisp implementation instead. Install CCL (respectively SBCL or Allegro) and make sure an executable called `ccl` (respectively `sbcl` or `alisp`) is in your `PATH`, or that you export a variable `CCL` (respectively `SBCL` or `ALLEGRO`) that points to the executable. To use a further Common Lisp implementation, suitably edit the script [`tools/asdf-tools`](tools/asdf-tools), or, on Windows, the batch file [`tools/asdf-tools.bat`](tools/asdf-tools.bat). (Note that we recommend SBCL 1.3.13 or later when on Windows.) Note that the executable `build/asdf-tools` is built the first time you test ASDF. When you update ASDF, via e.g. `git pull` or a branch switch, you may have to update it, with: make -f Makefile-lisp-scripting build-asdf-tools The reason this is not done automatically every time is because building it depends on a working ASDF; but when you're modifying ASDF and testing it, you cannot rely on a working ASDF: indeed, a developer may not only make mistakes, but may deliberately introduce or re-introduce bugs at some place to test code in another place. Debugging ASDF -------------- To interactively debug ASDF, you may load it in such a way that `M-.` will work, by installing the source code, and running: (map () 'load (asdf:input-files :monolithic-concatenate-source-op "asdf/defsystem")) To interactively use the `asdf-tools`, you need to either have all its dependencies installed and configured. If you're using them through the `ext/` directory and `make ext`, then you may need to emulate what the script in [tools/asdf-tools](tools/asdf-tools) does with respect to initializing the source-registry. Note that it also declares a system for `cl-launch/dispatch`; you can either do something similar, or expand the source for `cl-launch` with `make -C ext/cl-launch source` so `cl-launch.asd` will be created. Using ASDF internals -------------------- If you have to use or extend internal functionality not currently exported by ASDF, please contact us and have us negotiate a proper, stable, tested interface that you can actually rely on. Also, please *DO NOT* refer to specific subpackages such as `asdf/find-system` from the outside of ASDF, because functions may occasionally be moved from one internal package to the other, without notification. They have in the past and will in the future. Instead, when refering to symbols in ASDF, we recommend you either have your package `:use` the package `:asdf` or `:import-from` it, or that you shall use `asdf:` or `asdf::` as a prefix to the symbols. And once again, please contact us if you have to use non-exported symbols. Also, the normal way of extending ASDF is to use our class hierarchies for `component` and `operation` and to define methods on `component-depends-on`, `perform`, `input-files`, `output-files`. A common mistake seems to be that some people define methods on `operate`, which usually is not at all what they think it is. How do I navigate this source tree? ----------------------------------- * [asdf.asd](asdf.asd) * The system definition for building ASDF with ASDF. * `*.lisp` * The source code files for `asdf/defsystem`. See [asdf.asd](asdf.asd) for the order in which they are loaded. All exported functions should have docstrings, and all internal functions should have comments. If any definition is insufficiently documented, please tell us: that's a bug. * [uiop/](uiop/) * Utilities of Implementation- and OS- Portability, the portability layer of ASDF. It has its own [README](uiop/README.md), and exported functions should all have docstrings and other ones comment, or once again it's a bug. * [Makefile](Makefile) * The classical `Makefile` used for development purposes. Regular users only need to call `make` with the default target. Developers will typically use the like of `make t l=sbcl` or `make u l=ccl`. * [bin/](bin/) * [bump-version](bin/bump-version) -- a script to bump the version of ASDF, used by the classic `Makefile`. Use it with e.g. `./bin/bump-version 3.4.5` to test with the next version number before you release. NB: ASDF's version number notably affects the behavior of ASDF with respect to deprecated functions. * [tools/](tools/) * `asdf-tools`, a system to build, test and release ASDF. It includes: * [asdf-tools](tools/asdf-tools) -- a shell script to run it as a shell command. * [asdf-tools.bat](tools/asdf-tools.bat) -- a Windows batch file to run the above. * [asdf-tools.asd](tools/asdf-tools.asd) -- system definition for asdf-tools * `*.lisp` -- the source code for the `asdf-tools` system, except for the few files below. Check the `.asd` file for the order in which to read them. * Also a couple scripts to help ASDF users: * [load-asdf.lisp](tools/load-asdf.lisp) -- a working example script to load, configure and use ASDF in a self-contained project * [install-asdf.lisp](install-asdf.lisp) -- replace and update an implementation's ASDF * [cl-source-registry-cache.lisp](cl-source-registry-cache.lisp) -- update a cache for the source-registry as a standalone script. * [Makefile-lisp-scripting](Makefile-lisp-scripting), [make-asdf.sh](make-asdf.sh) and [make-asdf.bat](make-asdf.bat) * Minimal Makefile and scripts to invoke the lisp scripting variants of the build system. * [version.lisp-expr](version.lisp-expr) * The current version. Bumped up every time the code changes, using: make bump * [doc/](doc/) * Documentation for ASDF, including: * [index.html](doc/index.html) -- the web page for * [asdf.texinfo](doc/asdf.texinfo) -- our manual * [Makefile](doc/Makefile) -- how to build the manual * [cclan.png](doc/cclan.png) [lisp-logo120x80.png](doc/lisp-logo120x80.png) [style.css](doc/style.css) [favicon.ico](doc/favicon.ico) -- auxiliaries of [index.html](doc/index.html) * [test/](test/) * Regression test scripts (and ancillary files) for developers to check that they don't unintentionally break any of the functionality of ASDF. They are far from covering all of ASDF, but they are a good start. * [script-support.lisp](test/script-support.lisp) -- the common test infrastructure used by our tests * [run-tests.sh](test/run-tests.sh) -- the shell script used by the classic `Makefile` to run tests. It is not used by the Lisp scripting variant of the `Makefile`. * [contrib/](contrib/) * A few contributed files that show case how to use ASDF or help with debugging it or debugging programs that use it. * [debian/](debian/) * Files for packaging on Debian, Ubuntu, etc. (now only present in the debian branch). * [build/](build/) * Where the `Makefile` and `asdf-tools` store their output files, including: * `asdf.lisp` -- the current one-file deliverable of ASDF * `asdf-*.lisp` -- for upgrade test purposes, old versions * `asdf-tools` -- the executable for asdf-tools (.exe on Windows) * `results/` -- logs of tests that have been run * `fasls/` -- output files while running tests * [ext/](ext/) * External dependencies, that can be populated with `make ext` or equivalently with `git submodule update --init`. Depopulate it with `make noext` or equivalently with: `submodule deinit .` * [README.md](README.md) * This file. * [TODO](TODO) * Plenty of ideas for how to further improve ASDF (not all of them guaranteed good ideas.) asdf-3.3.4/TODO000066400000000000000000000775371362155115300131530ustar00rootroot00000000000000* Decree that versions older than 2 years are not supported; yet, keep supporting an upgrade from whatever vendors provide — so push them to provide recent stuff. ** Already, swank-asdf doesn't support anything older than 2.014.6 (as provided by the first 2011 iteration of Quicklisp), and I (fare) am pushing for swank-asdf to not support anything older than 3.1.2 (since no maintained implementation has anything older, with the LispWorks 7.0 release being last to upgrade, in May 2015; or CLISP hg in May 2016, though it hasn't been released since 2010). ** Maybe remove old versions from upgrade tests; or maybe not: if we support old versions in any way, it should be for upgrade only, and "punt" is acceptable. ** Upgrade tests might be split in two test sets: short and long. ** Make tests stateless and/or make any modifications private, so that they can be run in parallel. * Have a better story for linking C static or dynamic libraries. ** Some groundwork has been done in cffi-toolchain, but an interface must be designed. ** Then you'll have to migrate all the code in Quicklisp to use your new interface. ** See commonqt's qt.asd and qtools's qt-libs.asd for instances of ugliness. * Testing support ** Replace test-op with run-test-op and test-report-op ? * Implement a style-checker, that will issue STYLE-WARNINGs when you don't follow all the recommended guidelines. * Moving toward cross-compilation (ASDF 3.4? 4?) This would allow to get most of the benefits of XCVB (reproducibility, scalability, applicability to mobile platforms, etc.), except without the backward incompatibility of XCVB. NB: the MOCL author would benefit a lot, and might chip in. ** Need to further split asdf:perform in two parts: A part that runs on the host and specifies (as SEXP or string to read) forms that must be evaluated on the target machine, not the host: (asdf:perform-forms target operation component &key input-files output-files) The default implementation can fallback to running the (asdf:perform operation component) on the target. To ensure isolation, it would run in an isolated process in which just the specially crafted operation and component objects are defined, though the defsystem-depends-on dependencies are also loaded; the action would be run in a temporary directory, that would contain only a read-only copy of the declared input-files, and some writable output directory for the output files, that would afterwards be copied to their actual destination. ;; null means the target is the current host. ;; Or should the base class be plan-traversal or such? (defmethod perform-form ((target null) operation component) ;; :host means execute on the host. () is empty options. `(:host () (asdf:perform ',op ',comp))) ;; external-target means a cross compiler that we spawn. (defmethod perform-form ((target external-target) operation component) `(:target ;; who is to execute that? the target Lisp. ;; options for the performing system: (:depends-on ,(defsystem-dependencies (component-system component))) ;; The actual forms to evaluate (asdf:perform ,(fake-operation-form operation) ,(fake-component-form component)))) By specifying :host-common-lisp you can have forms run on the host. By specifying :run-program, you can spawn a subprocess without having to first spawn a Lisp that will call run-program. etc. The other way around the default perform method could be: (defmethod perform ((o t) (c t)) (let ((forms (perform-forms nil o c))) (if (equal forms `((asdf:perform ',o ',c))) (error "Missing perform method on ..." ...) (map () 'eval-thunk forms)))) Note that in the general case, there are multiple forms, that must be provided on the command line somehow (see the lisp-invocation system and also how cl-launch does it), with packages necessary to read latter forms being created by former forms, so you cannot read everything in one go. ASDF or at least UIOP should probably be provided in the target image by default, anyway, without needing to be explicitly specified. A more declarative interface to needing the defsystem-deps is probably useful. ** A real cross-compiling backend that works the way of XCVB would need to compute a complete graph for the plan, which could be achieved by inheriting from the code in POIU. Thinking about it, the cross-compiling target object could actually be the same as the plan object. The basic case of in-image execution would need to be in ASDF, while the actual cross-compilation case would be in an extension. ** Audit all the current specializers of perform, and offer them a new way; they can keep the perform method to run on older versions of ASDF. ** Modify SBCL and other implementations so they provide UIOP independently from ASDF? ** The default perform-plan method could iterate over pre-computed forms, in a way that does not involve the ASDF object model anymore, making ASDF friendlier to self-upgrades. Then, ASDF wouldn't need to be concatenated during upgrade — but should still concatenate for bootstrap purposes, when require'ing it as an implementation-provided module, compiling from ASDF 2, or otherwise distributing as a single file. * Implementation bugs ** CMUCL has bugs: *** In ASDF 2.32.13, sibling-dependencies is renamed to sideway-dependencies in defclass component, a superclass of system, and upgrade from 2.32 or earlier thus fails with Error in function KERNEL:CLASS-TYPEP: Class is currently invalid: # in a direct call from ASDF/FIND-SYSTEM:LOCATE-SYSTEM, which suggests CMUCL's PCL fails to finalize classes properly. *** Non-default optimize settings may or may not subtly break PCL. For the longest time (from 2.26.136 to 3.1.0.42), ASDF had: (declaim (optimize (speed 1) (safety 3) (debug 3))) This form may or may not work around that breakage in some cases: (setf c::top-level-lambda-max 0) *** At some point there was massive breakage due to uninitialized slots as revealed in 3.1.0.37 with make t l=cmucl t=test-encodings.script which was a different PCL bug from the above (without same workaround) but possibly also triggered by the non-standard declaim. *** `#5(1 ,@\`(2 3)))` returns `#(1 2 3)`, rather than `#(1 2 3 2 3 2 3 2 3)` or even better `#(1 2 3 3 3)`. *** It purports to support Unicode, but it has only 16-bit characters. Note that (subtypep 'character 'base-char) says T -- everything is a base char(!) *** In general, running upgrade tests triggers massive CLOS breakage on CMUCL. ** SCL has bugs: *** it doesn't like run-program from a modified directory? *** it somehow pushes `:non-base-chars-exist-p` even though `+non-base-chars-exist-p+` is `NIL`??? ** XCL has bad bugs: *** make-pathname doesn't handle :type nil properly and has massive lossage in logical-pathname support. *** If using block () and return in search-for-system-definition instead of return-from, XCL mistakenly has the return jump to the end of the try function or something. *** It also takes a long time for errors to propagate into a debugging REPL — Maybe O(n^3) behavior or worse in walking the C++ stack? *** The backtrace frames may contains unprintable objects. *** make-pathname fails to copy the version from the defaults. *** (make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name nil :type nil) fails to handle the logical-pathname-ness of ASDFTEST. *** `#5(1 ,@`(2 3)))` returns #(1 2 3), rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3). *** XCL recognizes :unspecific for a pathname type, but prints the namestring with a dot separator! (make-pathname :name "foo" :type :unspecific) ==> #P"foo." If bug is ever fixed, upgrade *unspecific-pathname-type* in uiop/pathname. *** XCL doesn't properly process files the name of which contains a * *** XCL fails to recognize that specialized method parameters are implicitly ignorable. ** GCL is almost working again; but implementation bugs remain. See Francois-Rene Rideau's messages on gcl-devel starting November 2013. *** Missing support for many UIOP functions: combine-fasls, get-optimization-settings... *** ASDF may now be included for (require "asdf") and (require "ASDF"), but how to compile it properly? *** GCL fails to properly compile ASDF with the default compilation settings, but works with those in script-support.lisp. Symptoms when trying to load asdf.o: Signalled by "AN ANONYMOUS FUNCTION". INTERNAL-SIMPLE-ERROR: The package named ASDF/INTERFACE, does not exist *** Another GCL compiler bug: when I changed the definition of getcwd from `(let ((*default-pathname-defaults* #p"")) (truename #p""))` to `(let ((*default-pathname-defaults* *nil-pathname*)) (truename *nil-pathname*))` to guard against e.g. a logical-pathname context while loading asdf and parsing `#p""`, calls to `getcwd` result in a segfault. *** An another bug: gcl refuses dynamic-extent declaration on functions. ```uiop/stream.lisp: #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))``` *** `(typep p 'logical-pathname)` should be T if p has a logical-pathname host. *** `apropos` is case-sensitive and returns a same symbol many times (presumably once per package where it is present, instead of just once for its home package) *** `compile-file` fails to return proper secondary values in case of non-style `WARNING`. *** `(pathname-directory #p"foo/")` is incorrectly `("foo")` instead of `(:RELATIVE "foo")` *** Do whatever it takes to pass the asdf tests, add the above? *** Trying to `uiop:slurp-stream-forms` from a stream with `#+(or) :foo` (or `read-file-forms` from an file with same) results in an error, rather than `nil`. This is probably a bug in `#+` processing. Unhappily, debian creates such a file in `/etc/common-lisp/asdf-output-translations.conf.d/01-common-lisp-controller.conf` *** Tests that try to catch an error fail (but catching a warning succeeds), which suggests brokenness in handler-bind and/or error. *** `COMPILE-FILE*` fails due to handler-bind error in `with-muffled-compiler-conditions` or so. *** `#5(1 ,@`(2 3)))` returns `#(1 2 3)`, rather than `#(1 2 3 2 3 2 3 2 3)` or even better `#(1 2 3 3 3)`. *** `(DIRECTORY #p"*.*")` fails to match files with pathname-type `NIL`. *** GCL doesn't properly process files the name of which contains a `*` ** ABCL has a few bugs. *** ABCL fails the timestamp propagation test. *** `#5(1 ,@`(2 3)))` returns #(1 2 3), rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3). *** ABCL doesn't properly process files the name of which contains a * ** ECL has issues with its bundles. On MacOS X, test-bundle.script fails. *** ECL doesn't properly process files the name of which contains a * ** Allegro fails to parse argv the correct Windows way wrt C++ escaping conventions. Is this (still) the case? What about LispWorks? Other implementations? * Design & Implement some out-of-line configuration mechanism for various options? i.e. let configuration files override some variables around some actions. ** Could be used to override new backward-incompatible defaults (e.g. for operation propagation, deferred warnings, etc.) ** Use the above to bind variable around performing of actions. * Improve robustness ** Fix bugs on http://bugs.launchpad.net/asdf/+bugs *** fix directory-files to not return directories on CCL, etc. Add tests. *** 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. ** Include tests for prebuilt-system in test-bundle and in test-program. ** Test that a package-system secondary system is properly superseded when the primary system is redefined. * Learn to use cl-grid-test ** So we can easily make sure ASDF changes don't break stuff, and that breakage gets fixed quickly. * Diagnostics ** have a mode to explain WHY a component needs to be recompiled. ** A ``dry run'' of an operation can be made with the following form: (let ((asdf:*verbose-out* *standard-output*)) (loop :for (op . comp) :in (asdf/plan:plan-actions (asdf/plan:make-plan nil ' ' :force t)) :do (asdf:explain op comp))) What would be a nice interface for this functionality? * have with-input-file use the encodings mechanism? ** Import asdf-encodings into UIOP? Sounds a lot of code for no users. * have a single test .asd that tests as many features as possible, use it for upgrade test. * operation cleanup? ** Refactor operation classes in action.lisp to not use slots for metadata *** See commit message for 8e68ac229c19b7b611caf942a7f0998c88047a79 *** The problem: slots will NOT get properly upgraded with new initform. *** Bad solution: A U-I-F-R-C method might do but would be much more complex to maintain, not just for ASDF but potentially for anyone who defines extensions to ASDF. *** The solution: use defmethod self-operation, not a self-operation slot. This solution is trivially backward-compatible with older variants of ASDF. *** Migration: find everyone on Quicklisp that defines an operation, and have them use defmethod. Document all that in asdf.texinfo. Yet, unless noone is affected in Quicklisp, don't modify ASDF classes themselves until a year or two afterwards, for compatibility purposes; and/or when ASDF classes themselves need to be modified for the sake of some fix. ** To allow semantically distinct operations of the same class: You'd need to have a protocol to canonicalize them in the *OPERATIONS* memoization table, not by class name, but by CONS of the class name and some CANONICAL-OPERATION-INITARGS. The latter would be a generic function called on the initargs, where any parasite initargs such as FORCE and FORCE-NOT have been removed, since they below to the PLAN, not the OPERATION: the OPERATE protocol would be refined to explicit split arguments to be passed to MAKE-PLAN or to MAKE-OPERATION. The default method for CANONICAL-OPERATION-INITARGS would SORT (a plist->alist of) the initargs, and that would replace the current ORIGINAL-INITARGS slot. For this scheme to work even in presence of undisciplined users using MAKE-INSTANCE on an operation class, the OPERATION class would have an extra slot EFFECTIVE-OPERATION, uninitialized by default (nil or unbound), whose accessor initializes it if it's uninitialized, by looking up a canonical instance in *OPERATIONS*, and if unfound registering the current operation as canonical. Then, each component's COMPONENT-OPERATION-TIME hash-table would be indexed by canonicalized operation object rather than by operation class, and POIU would have to be changed accordingly. Of course, this entire cleanup is incompatible with how SWANK and GBBopen currently abuse slots of operation, so these would have to be fixed first. And that's why I didn't do it. It looks like SWANK can be fixed soon, though, so we'll see. * Hunt systems that use obsolete APIs * 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 com.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 * ASDF4: search for this tag, rename things (incompatibly, thus) and cleanup code. ** Migrate from component-depends-on to action-depends-on *** I contend a future version of ASDF will replace `(component-depends-on operation component)` with `(action-depends-on plan operation component)`. This allows for different normalization strategies for dependencies (including strategies that avoid resolving things to NIL), a reified context for featurep checks, etc. *** Easy but long backward-compatible transition: **** get all users to use the new gf and keep extending both new and old gf, meanwhile the new gf has an around method that actually calls the old gf except in testing mode and/or if we can check that they're using the new convention **** when everyone has migrated, remove the old mode and the short-circuit. *** However, we cannot deprecate component-depends-on yet — not until we have some transition in place to a better interface. * Documentation ** See message from 2014-01-27 05:26:44 GMT for stuff to document. http://thread.gmane.org/gmane.lisp.asdf.devel/3675/focus=3695 ** style guide for .asd files * UIOP ** deferred-warnings support probably needs to be redone better. *** implement deferred warnings support on lispworks *** turn undefined function style-warnings into full warnings(?) *** work with cl-test-grid to eliminate deferred warnings from quicklisp libraries *** https://www.mail-archive.com/asdf-devel@common-lisp.net/msg03608.html *** czak@google.com rewrote part of deferred warnings support. Ask him to release the code he implemented at Google under QITAB. ** Ensure all run-program issues on Windows are solved. *** SBCL cannot do raw CMD.EXE command-lines *** We don't seem to properly escape CRLF in escape-windows-token, or maybe it is, but CMD.EXE does the wrong thing in them, so the semantics depend on whether it's used, or maybe it's CCL eating them while parsing, or maybe not, etc. In any case, this requires clarification. ** define-package cannot deal with symbols moving "forward". *** document that THOU SHALT NOT USE :RECYCLE with packages previously defined by define-package when building from scratch. *** Maybe add a check? But how to tell whether you're building from scratch? *** Add some :moved-to directive to define-package, such that (:moved-to forward-package symbols...) will declare symbols as moved forward: when the symbol already exists, it is moved to the forward package if that package already exists, after the package created if it doesn't exist yet (!) *** There again, a check that a forward-package is not backward would be very nice. * Faster source-registry: ** In addition and/or as a substitute to the .cl-source-registry.cache, that is meant to be semi-automatically managed, there could be a cl-source-registry.conf meant for manual management: when recursing into a source-registry :tree, if such file is present (or if not, if a hidden .cl-source-registry.conf is present instead?), its contents is read as a (:source-registry ...) specification, and replaces the actual or notional (:tree ...) for the current directory; it may then include :file entries as well as :directory and :tree entries, whereby the programmer can explicitly give a definitive list of systems exported by his software, while excluding any test system that he doesn't want to export. This means that developers have both a way of speeding up the build of their software and of avoiding pollution by test systems that should remain private, and that they can otherwise explicitly enable when they need them. ** The .cl-source-registry.cache should avoid recursing into directories that themselves already have a cache or a .conf file, but instead store the name of these directories, so these files will be read recursively by asdf, allowing for semi-modular updates. * Properly deprecate all that needs to go ** Get lisa, readable, bourbaki to NOT include ASDF 1 anymore in their sources. ** Identify all the things in ASDF that we want to deprecate, and make sure we deprecate them all in 3.4. ** Implement support for deprecating old packages, by having all functions and macros under the old package name be proxies to those in the new package name? (Exception: special variables can't be proxies, have to be imported.) ** Delete asdf-driver.asd, nobody has used it in years ** Eradicate Quicklisp systems that depend on asdf-package-system, make them depend on asdf3.1 instead. ** Deprecate and remove asdf-binary-locations (ABL) compatibility altogether. No one has been using ASDF1 for years. There is no ABL to be compatible with — is anyone still using the compatibility mode? Maybe issue a warning, then a cerror, before to remove the code? * Fix plan ** Goal: Implement proper incrementality for defsystem-depends-on. Fix the bug wherein ASDF fails to properly handle incrementality for `defsystem-depends-on`. https://bugs.launchpad.net/asdf/+bug/1500578 Some discussion about ASDF at http://ccl.clozure.com/irc-logs/lisp/lisp-2016-10.txt ** DONE Items *** Add `DEFINE-OP` for loading system definitions. *** A `DEFINE-OP` will depend on other `DEFINE-OP`s *** A `DEFINE-OP` depends on all `LOAD-OP` in the file. Whether via defsystem-depends-on or manual `LOAD-OP`s. *** Store timestamps in `DEFINE-OP` entries, not `*DEFINED-SYSTEMS*`. *** In find-system, add condition that all dependencies are up-to-date. *** This necessitates another layer of visit states, that do not plan, just check planning... *** `LOAD-ASD` calls `PERFORM DEFINE-OP` (not the other way around) *** Systems probably need depend on `(DEFINE-OP . PRIMARY-SYSTEM)` *** These dynamically-discovered dependencies are stored in a slot of `SYSTEM`. *** Have a special kind of definition-depends-on dependency. Before we reuse a node from a previous session, we must make sure it is still properly defined. This matters because we do reuse (at least *some* nodes, e.g. system nodes) from previous sessions, and the control structure may have changed (i.e. the system hasn't been redefined, but one of its defsystem-depends-on dependencies has changed). *** Handle incomplete definitions properly Don't just let the incompletely parsed system be registered in a false positive success as if it were an empty system. Solution: It is registered, but considered out-of-date, so next attempt to use it will cause a refresh attempt. https://bugs.launchpad.net/asdf/+bug/1515372 *** Handle nested calls to `OPERATE` We must accept that ASDF isn't really plan-then-perform, as the ASDF1 model claimed to be. It's an arbitrary nesting of plan-and-perform, like a parenthesization with plan (steps) as left parenthesis and perform (steps) as right parenthesis, and with operate being a maximal balanced span of plan and perform steps. *** What goes in a shared dynamic `*SESSION*`, what in a private lexical `PLAN`? Memoization CACHE of various functions, Status of VISITED-NODES, FORCING parameters. The session will contain not just the current `*CACHE*`, but also all or most of the graph traversal, thus the `:force` options, etc. The `*PLAN*` may or may not contain some work queueing. But even, e.g. a table of "nodes still directly blocking us" is shared at the shared traversal level. *** It is an error for a nested `OPERATE` to contradict session flags. This raises the question of `:force` and `:force-not` flags. An actual operate cannot contradict them and cause things to be performed with a wrong subset of dependencies loaded. Yet, `REQUIRED-COMPONENTS` (that does cause anything to be performed — except via nested `OPERATE` from `defsystem-depends-on`) must be able to skip some dependencies (though maybe only _in addition_ to the global ones). *** What timestamp for `forced` and `forced-not` actions? If an action is forced-not, it should be returned with an action stamp from this cache, and not with `nil` as is currently wrongly done (unless of course the cache entry is missing, at which point `nil` is the correct answer). Conversely, a force means the stamp should be `t` (indicating it needs to be done in the future) (that part asdf gets right). *** Handle planning things that are now done but were done in a previous phase of the build, so dependency on them should trigger the build. *** Protocol to not re-perform an action twice In PERFORM-PLAN, check that an action wasn't already DONE-P due to being needed in a previous phase of recursively calling OPERATE, before to PERFORM it. To correctly propagate timestamps in across nested calls, the graph traversal and timestamp propagation is shared at the session level between all nested calls to `OPERATE`. During a session and across phases, every action has a status made of a stamp and three bits: KEEP-P, DONE-P, NEED-P. The stamp also survives across sessions, in `COMPONENT-OPERATION-TIMES`. *** Detect circularities across nested calls to `OPERATE` This means the circularity detection data is part of the session. Notably, the visiting list and set. The top of the list can also serve to record the dependencies from `OPERATE` to `DEPEND-OP`. *** In UIOP, RECORD-DEPENDENCY must not cross to an upper plan and/or it should record the dependency in said upper plan (that matters because parallel plans doing extra checking, and this is a problem whereby some links to extra actions are left unresolved). Maybe in the future, record the dependency in the session, not in a plan. ** TODO items *** find-system should probably cause a dependency on define-op, especially inside another define-op *** Is it worth it trying to optimize away a dependency on a define-op when an action already depends on another operation that "obviously" depends on that define-op? *** Document DEFINE-OP and the design in asdf.texinfo and/or in some article. ** Future developments *** Grovel all .asd files in Quicklisp and collect all violations of declarativeness, where declarativeness is having only defsystem forms. Specially classify in-package, maybe also defpackage. Then we can assess the impact of requiring declarativeness. *** Also grovel Quicklisp for all extensions to ASDF: see if there are new methods on perform, input-files, output-files, operate, etc. *** To allow defsystem-depends-on to another secondary system within the same file, I can imagine some system to dynamically create a separate action (DEFINE-OP foo/x) for each form defsystem foo/x, and have it depend on all the preceding actions operated in the .asd file. Plus a last action for dangling load-system or operate statements? Or one action for every operate statement? There would be no action of the entire load-asd, but a separate mechanism to detect circularity? What about dangling statements? They would be a bit like xcvb weakly-ordered run-time dependencies that CAN have circularities? Ouch. Really ugly. Each statement would need its own action? Ouch. *** Have load-asd clear any invalidated previous secondary system before loading, which supposes remembering what these systems are. Then, you're not allowed to forward-reference a secondary system that hasn't been defined yet while you're loading the .asd, whereas you can load the asd if you aren't loading it yet. *** Maybe split DEFINE-OP into PREPARE-DEFINE-OP and DEFINE-OP, so that secondary systems can be properly loaded? *** Add mapping from files to action that creates it and/or uses it? Then we can detect conflict between multiple actions creating one file. Forbid direct use of files not listed as inputs? What about transitive inputs? Build in a container that has only the proper files... *** What data structure for scheduling planned actions? A doubly-linked to remove entire chunks of the plan after a sub-operate? That won't do, because later-discovered defsystem dependency can refer to systems that were planned but not performed, so there need be no contiguity in the chunks that are performed by subcalls to operate. Actually, if we otherwise forbid reference to another system from non-system components, then we could move things with system granularity, which is one thing; but we still need a general mechanism at the system level. So, whether it's an explicit queue or an implicit traversal of the dependency graph, we must check whether an action has already been done before we try to perform it. And an implicit traversal has the advantage that you can avoid entire subtrees when you find that the current node has already been performed during a previous phase of the plan. In conclusion: "just" traverse the graph at the last minute, and perform things serially, and/or if you want some parallelism, build a queue dynamically at the last minute for the "now" jobs while keeping most of the plan as graph structures. *** Merging in parts of POIU? ASDF internals are nothing to be proud of: ASDF1 was optimized for "smallest code that kind of works in the usual case", and ASDF3 was optimized for "smallest code that fixes ASDF1 in the general case while mostly maintaining backward compatibility". Because of its optimization constraint, ASDF1 was using and abusing lists a lot, rather than defining nice data structures. ASDF3 uses somewhat more structured data, with a few more classes, and algorithms that are O(n) instead of O(n**3) in simple cases and exponential in carefully crafted examples; yet it has shunned any definition of more advanced or general data structures. By contrast, POIU has a dequeue to represent queued compilation jobs, and a general graph representation for the action graph (though the original POIU was also O(n**3) because it lacked PREPARE-OP). I could import the POIU queue and graph representations into ASDF, and that would add about 100 lines of code to UIOP for the queue, and 200 lines to ASDF for the graph, maybe a bit more if the code is generalized, commented and largely put in UIOP. Then, there's the support for actual forking and using forks, that would be about 400 lines added to UIOP, and the using it in ASDF to consume the plan, which would be under 200 lines. But those parts are probably better left out of ASDF itself. That said, it all was a lot when ASDF was < 1000 lines of code, but isn't all that much now that it is > 12000 lines of code. asdf-3.3.4/action.lisp000066400000000000000000000631431362155115300146150ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Actions (uiop/package:define-package :asdf/action (:nicknames :asdf-action) (:recycle :asdf/action :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation) (:import-from :asdf/operation #:check-operation-constructor) (:import-from :asdf/component #:%additional-input-files) (:export #:action #:define-convenience-action-methods #:action-description #:format-action #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation #:component-depends-on #:input-files #:output-files #:output-file #:operation-done-p #:action-operation #:action-component #:make-action #:component-operation-time #:mark-operation-done #:compute-action-stamp #:perform #:perform-with-restarts #:retry #:accept #:action-path #:find-action #:operation-definition-warning #:operation-definition-error ;; condition #:action-valid-p #:circular-dependency #:circular-dependency-actions #:call-while-visiting-action #:while-visiting-action #:additional-input-files)) (in-package :asdf/action) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning (deftype action () "A pair of operation and component uniquely identifies a node in the dependency graph of steps to be performed while building a system." '(cons operation component)) (deftype operation-designator () "An operation designates itself. NIL designates a context-dependent current operation, and a class-name or class designates the canonical instance of the designated class." '(or operation null symbol class))) ;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan ;;; actions. (with-upgradability () (defun make-action (operation component) (cons operation component)) (defun action-operation (action) (car action)) (defun action-component (action) (cdr action))) ;;;; Reified representation for storage or debugging. Note: an action is identified by its class. (with-upgradability () (defun action-path (action) "A readable data structure that identifies the action." (when action (let ((o (action-operation action)) (c (action-component action))) (cons (type-of o) (component-find-path c))))) (defun find-action (path) "Reconstitute an action from its action-path" (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) ;;;; Convenience methods (with-upgradability () ;; A macro that defines convenience methods for a generic function (gf) that ;; dispatches on operation and component. The convenience methods allow users ;; to call the gf with operation and/or component designators, that the ;; methods will resolve into actual operation and component objects, so that ;; the users can interact using readable designators, but developers only have ;; to write methods that handle operation and component objects. ;; FUNCTION is the generic function name ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT. ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found. ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found. (defmacro define-convenience-action-methods (function formals &key if-no-operation if-no-component) (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 string) ,component ,@suffix ,@more-args) (declare (notinline ,function)) (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component))) (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args) (declare (notinline ,function)) (if ,operation ,(next-method `(make-operation ,operation) `(or (find-component () ,component) ,if-no-component)) ,if-no-operation)) (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args) (declare (notinline ,function)) (if (typep ,component 'component) (error "No defined method for ~S on ~/asdf-action:format-action/" ',function (make-action ,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~@:>") operation component)) (defun format-action (stream action &optional colon-p at-sign-p) "FORMAT helper to display an action's action-description. Use it in FORMAT control strings as ~/asdf-action:format-action/" (assert (null colon-p)) (assert (null at-sign-p)) (destructuring-bind (operation . component) action (princ (action-description operation component) stream)))) ;;;; Detection of circular dependencies (with-upgradability () (defun (action-valid-p) (operation component) "Is this action valid to include amongst dependencies?" ;; If either the operation or component was resolved to nil, the action is invalid. ;; :if-feature will invalidate actions on components for which the features don't apply. (and operation component (if-let (it (component-if-feature component)) (featurep it) t))) (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))))) (defun call-while-visiting-action (operation component fun) "Detect circular dependencies" (with-asdf-session () (with-accessors ((action-set visiting-action-set) (action-list visiting-action-list)) *asdf-session* (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)))))) ;; Syntactic sugar for call-while-visiting-action (defmacro while-visiting-action ((o c) &body body) `(call-while-visiting-action ,o ,c #'(lambda () ,@body)))) ;;;; 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 ; [Note: an is an operation designator -- it can be either an operation name or an operation object. Similarly, a may be a component name or a component object. Also note that, the degenerate case of () is a no-op.] 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)))) ;;;; upward-operation, downward-operation, sideway-operation, selfward-operation ;; These together handle actions that propagate along the component hierarchy or operation universe. (with-upgradability () (defclass downward-operation (operation) ((downward-operation :initform nil :reader downward-operation :type operation-designator :allocation :class)) (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy. I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M. The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself. E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP.")) (defun downward-operation-depends-on (o c) `((,(or (downward-operation o) o) ,@(component-children c)))) (defmethod component-depends-on ((o downward-operation) (c parent-component)) `(,@(downward-operation-depends-on o c) ,@(call-next-method))) (defclass upward-operation (operation) ((upward-operation :initform nil :reader upward-operation :type operation-designator :allocation :class)) (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy. I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U, then the action (O . C) of O on a component C that has the parent P will depends on (U . P). The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself. E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT must first be prepared for loading or compiling with PREPARE-OP.")) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF4: remove that. (defun upward-operation-depends-on (o c) (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p)))) (defmethod component-depends-on ((o upward-operation) (c child-component)) `(,@(upward-operation-depends-on o c) ,@(call-next-method))) (defclass sideway-operation (operation) ((sideway-operation :initform nil :reader sideway-operation :type operation-designator :allocation :class)) (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot designates operation S (where NIL designates O itself), then the action (O . C) of O on component C depends on each of (S . D) where D is a declared dependency of C. E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, each of its declared dependencies must first be loaded as by LOAD-OP.")) (defun sideway-operation-depends-on (o c) `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c)))) (defmethod component-depends-on ((o sideway-operation) (c component)) `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) (defclass selfward-operation (operation) ((selfward-operation ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which :type (or operation-designator list) :reader selfward-operation :allocation :class)) (:documentation "A SELFWARD-OPERATION depends on another operation on the same component. I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L, then the action (O . C) of O on component C depends on each (S . C) for S in L. E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP. A operation-designator designates a singleton list of the designated operation; a list of operation-designators designates the list of designated operations; NIL is not a valid operation designator in that context. Note that any dependency ordering between the operations in a list of SELFWARD-OPERATION should be specified separately in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly.")) (defun selfward-operation-depends-on (o c) (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c))) (defmethod component-depends-on ((o selfward-operation) (c component)) `(,@(selfward-operation-depends-on o c) ,@(call-next-method))) (defclass non-propagating-operation (operation) () (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates no dependencies whatsoever. It is supplied in order that the programmer be able to specify that s/he is intentionally specifying an operation which invokes no dependencies."))) ;;;--------------------------------------------------------------------------- ;;; Help programmers catch obsolete OPERATION subclasses ;;;--------------------------------------------------------------------------- (with-upgradability () (define-condition operation-definition-warning (simple-warning) () (:documentation "Warning condition related to definition of obsolete OPERATION objects.")) (define-condition operation-definition-error (simple-error) () (:documentation "Error condition related to definition of incorrect OPERATION objects.")) (defmethod initialize-instance :before ((o operation) &key) (check-operation-constructor) (unless (typep o '(or downward-operation upward-operation sideway-operation selfward-operation non-propagating-operation)) (warn 'operation-definition-warning :format-control "No dependency propagating scheme specified for operation class ~S. The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins." :format-arguments (list (type-of o))))) (defmethod initialize-instance :before ((o non-propagating-operation) &key) (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation)) (error 'operation-definition-error :format-control "Inconsistent class: ~S NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses." :format-arguments (list (type-of o))))) (defun backward-compatible-depends-on (o c) "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION. The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that don't. In the future this functionality will be removed, and the default will be no propagation." (uiop/version::notify-deprecated-function (version-deprecation *asdf-version* :style-warning "3.2") `(backward-compatible-depends-on :for-operation ,o)) `(,@(sideway-operation-depends-on o c) ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))) (defmethod component-depends-on ((o operation) (c component)) `(;; Normal behavior, to allow user-specified in-order-to dependencies ,@(cdr (assoc (type-of o) (component-in-order-to c))) ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation ;; or non-propagation through an appropriate mixin will be downward and sideway. ,@(unless (typep o '(or downward-operation upward-operation sideway-operation selfward-operation non-propagating-operation)) (backward-compatible-depends-on o c)))) (defmethod downward-operation ((o operation)) nil) (defmethod sideway-operation ((o operation)) nil)) ;;;--------------------------------------------------------------------------- ;;; End of OPERATION class checking ;;;--------------------------------------------------------------------------- ;;;; Inputs, Outputs, and invisible dependencies (with-upgradability () (defgeneric output-files (operation component) (:documentation "Methods for this function return two values: a list of output files corresponding to this action, and a boolean indicating if they have already been subjected to relevant output translations and should not be further translated. Methods on PERFORM *must* call this function to determine where their outputs are to be located. They may rely on the order of the files to discriminate between outputs. ")) (defgeneric input-files (operation component) (:documentation "A list of input files corresponding to this action. Methods on PERFORM *must* call this function to determine where their inputs are located. They may rely on the order of the files to discriminate between inputs. ")) (defgeneric operation-done-p (operation component) (:documentation "Returns a boolean which is NIL if the action must 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)) t) ;; Translate output files, unless asked not to. Memoize the result. (defmethod output-files :around ((operation t) (component t)) (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)) 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))) (defgeneric additional-input-files (operation component) (:documentation "Additional input files for the operation on this component. These are files that are inferred, rather than explicitly specified, and these are typically NOT files that undergo operations directly. Instead, they are files that it is important for ASDF to know about in order to compute operation times,etc.")) (define-convenience-action-methods additional-input-files (operation component)) (defmethod additional-input-files ((op operation) (comp component)) (cdr (assoc op (%additional-input-files comp)))) ;; Memoize input files. (defmethod input-files :around (operation component) (do-asdf-cache `(input-files ,operation ,component) ;; get the additional input files, if any (append (call-next-method) ;; must come after the first, for other code that ;; assumes the first will be the "key" file (additional-input-files operation component)))) ;; By default an action has no input-files. (defmethod input-files ((o operation) (c component)) nil) ;; An action with a selfward-operation by default gets its input-files from the output-files of ;; the actions using selfward-operations it depends on (and the same component), ;; or if there are none, on the component-pathname of the component if it's a file ;; -- and then on the results of the next-method. (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 () ;; ASDF4: hide it behind plan-action-stamp (defgeneric component-operation-time (operation component) (:documentation "Return the timestamp for when an action was last performed")) (defgeneric (setf component-operation-time) (time operation component) (:documentation "Update the timestamp for when an action was last performed")) (define-convenience-action-methods component-operation-time (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp) (defgeneric mark-operation-done (operation component) (:documentation "Mark a action as having been just done. Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP using the JUST-DONE flag.")) (defgeneric compute-action-stamp (plan- operation component &key just-done) ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!) (:documentation "Has this action been successfully done already, and at what known timestamp has it been done at or will it be done at? * PLAN is a plan object modelling future effects of actions, or NIL to denote what actually happened. * OPERATION and COMPONENT denote the action. Takes keyword JUST-DONE: * 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. Returns two values: * a STAMP saying when it was done or will be done, or T if the action 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.")) (defmethod component-operation-time ((o operation) (c component)) (gethash o (component-operation-times c))) (defmethod (setf component-operation-time) (stamp (o operation) (c component)) (assert stamp () "invalid null stamp for ~A" (action-description o c)) (setf (gethash o (component-operation-times c)) stamp)) (defmethod mark-operation-done ((o operation) (c component)) (let ((stamp (compute-action-stamp nil o c :just-done t))) (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1 (setf (component-operation-time o c) stamp)))) ;;;; Perform (with-upgradability () (defgeneric perform (operation component) (:documentation "PERFORM an action, consuming its input-files and building its output-files")) (define-convenience-action-methods perform (operation component)) (defmethod perform :around ((o operation) (c component)) (while-visiting-action (o c) (call-next-method))) (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)) nil) (defmethod perform ((o operation) (c source-file)) ;; For backward compatibility, don't error on operations that don't specify propagation. (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation non-propagating-operation)) (sysdef-error (compatfmt "~@") 'perform (make-action o c)))) ;; The restarts of the perform-with-restarts variant matter in an interactive context. ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build ;; may call perform directly rather than call p-w-r. (defgeneric perform-with-restarts (operation component) (:documentation "PERFORM an action in a context where suitable restarts are in place.")) (defmethod perform-with-restarts (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)))))) asdf-3.3.4/asdf.asd000066400000000000000000000122301362155115300140440ustar00rootroot00000000000000;;; -*- mode: lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Free Software available under an MIT-style license. ;;; ;;; ;;; ;;; Copyright (c) 2001-2019 Daniel Barlow and contributors ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :asdf) ;; We can't rely on it being defined in uiop.asd, since that file isn't loaded. (defun call-without-redefinition-warnings (thunk) (handler-bind (((or #+allegro simple-warning #+clozure ccl:compiler-warning #+cmucl kernel:simple-style-warning #-(or allegro clozure cmucl) warning) #'muffle-warning)) (funcall thunk))) ;; Note that it's polite to sort the defsystem forms in dependency order, ;; and compulsory to sort them in defsystem-depends-on order. #+asdf3 (defsystem "asdf/prelude" :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" ;; Since ASDF 3.3, asdf.asd can't afford to depend on reading uiop.asd, ;; which would cause circularity, since everything depends on reading asdf.asd. ;; Therefore, we can't "just" :depends-on ("uiop") like we used to do, and instead ;; we transclude the list of uiop component into this secondary system. :pathname "uiop" :around-compile call-without-redefinition-warnings ;; we need be the same as uiop :components #.(getf (read-file-form (subpathname *load-pathname* "uiop/uiop.asd") :at 2) :components)) #+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 uiop :depends-on ("asdf/prelude" "asdf/driver") :encoding :utf-8 :components ((:file "upgrade") (:file "session" :depends-on ("upgrade")) (:file "component" :depends-on ("session")) (:file "operation" :depends-on ("session")) (:file "system" :depends-on ("component")) (:file "system-registry" :depends-on ("system")) (:file "action" :depends-on ("session" "system" "operation")) (:file "lisp-action" :depends-on ("action")) (:file "find-component" :depends-on ("component")) (:file "forcing" :depends-on ("operation" "system-registry")) (:file "plan" :depends-on ("lisp-action" "find-component" "forcing")) (:file "operate" :depends-on ("plan")) (:file "find-system" :depends-on ("system-registry" "operate")) (:file "parse-defsystem" :depends-on ("system-registry" "lisp-action" "operate" "find-system")) (:file "bundle" :depends-on ("lisp-action" "parse-defsystem")) (:file "concatenate-source" :depends-on ("bundle")) (:file "package-inferred-system" :depends-on ("parse-defsystem")) (:file "output-translations" :depends-on ("operate")) (:file "source-registry" :depends-on ("find-system")) (:file "backward-internals" :depends-on ("find-system" "parse-defsystem")) (:file "backward-interface" :depends-on ("output-translations")) (:file "interface" :depends-on ("parse-defsystem" "concatenate-source" "output-translations" "source-registry" "package-inferred-system" "backward-interface" "backward-internals")) (:file "user" :depends-on ("interface")) (:file "footer" :depends-on ("user")))) (defsystem "asdf" :author ("Daniel Barlow") :maintainer ("Robert Goldman") :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." :version "3.3.4" ;; to be automatically updated by make bump-version :depends-on () :components ((:module "build" :components ((:file "asdf")))) . #-asdf3 () #+asdf3 (:encoding :utf-8 :class #+asdf3.1 package-inferred-system #-asdf3.1 system ;; 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. :builtin-system-p t :in-order-to ((prepare-op (monolithic-concatenate-source-op "asdf/defsystem"))))) asdf-3.3.4/backward-interface.lisp000066400000000000000000000351661362155115300170600ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces (uiop/package:define-package :asdf/backward-interface (:recycle :asdf/backward-interface :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle) (: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-on-failure #:operation-on-warnings #:on-failure #:on-warnings #:component-property #:run-shell-command #:system-definition-pathname #:system-registered-p #:require-system #:explain #+ecl #:make-build)) (in-package :asdf/backward-interface) ;; NB: the warning status of these functions may have to be distinguished later, ;; as some get removed faster than the others in client code. (with-asdf-deprecation (:style-warning "3.2" :warning "3.4") ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition ;; that do not involve ASDF actions. ;; TODO: find the offenders and stop them. (progn (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) ())) ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26 "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better, define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION, or define methods on PREPARE-OP, etc." ;; Old deprecated name for the same thing. Please update your software. (component-sideway-dependencies component)) ;; These old interfaces from ASDF1 have never been very meaningful ;; but are still used in obscure places. ;; In Quicklisp 2015-05, still used by cl-protobufs and clx. (defgeneric operation-on-warnings (operation) (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) (defgeneric operation-on-failure (operation) (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) (defgeneric (setf operation-on-warnings) (x operation) (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) (defgeneric (setf operation-on-failure) (x operation) (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) (progn (defmethod operation-on-warnings ((o operation)) *compile-file-warnings-behaviour*) (defmethod operation-on-failure ((o operation)) *compile-file-failure-behaviour*) (defmethod (setf operation-on-warnings) (x (o operation)) (setf *compile-file-warnings-behaviour* x)) (defmethod (setf operation-on-failure) (x (o operation)) (setf *compile-file-failure-behaviour* x))) ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat, ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject, ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel, ;; cl-glfw, cffi, jwacs, montezuma (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. "DEPRECATED. This function 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)) ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2. ;; It was never officially exposed but some people still used it. (defgeneric traverse (operation component &key &allow-other-keys) (:documentation "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS, or some other supported interface instead. 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.")) (progn (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. ;; We suspect there are no more legacy users in 2016. (defun enable-asdf-binary-locations-compatibility (&key (centralize-lisp-binaries nil) (default-toplevel-directory ;; Use ".cache/common-lisp/" instead ??? (subpathname (user-homedir-pathname) ".fasls/")) (include-per-user-information nil) (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) (source-to-target-mappings nil) (file-types `(,(compile-file-type) "build-report" #+clasp (compile-file-type :output-type :object) #+ecl (compile-file-type :type :object) #+mkcl (compile-file-type :fasl-p nil) #+clisp "lib" #+sbcl "cfasl" #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) "DEPRECATED. Use asdf-output-translations instead." #+(or clasp 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)))) (progn (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) (declare (ignore operation-class system args)) (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. In case you insist on preserving your previous A-B-L configuration, but do not know how to achieve the same effect with A-O-T, you may use function ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; call that function where you would otherwise have loaded and configured A-B-L.")))) ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die! (defun run-shell-command (control-string &rest args) "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional. Please use UIOP:RUN-PROGRAM instead." #-(and ecl os-windows) (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)))) #+(and ecl os-windows) (not-implemented-error "run-shell-command" "for ECL on Windows.")) ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning? ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version. (progn (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. ;; Do NOT use in new code. NOT SUPPORTED. ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT. ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy. ;; See TODO for further cleanups required before to get rid of it. (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) ;; This method survives from ASDF 1, but really it is superseded by action-description. (defgeneric explain (operation component) (:documentation "Display a message describing an action. DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) (progn (define-convenience-action-methods explain (operation component))) (defmethod explain ((o operation) (c component)) (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) (with-asdf-deprecation (:style-warning "3.3") (defun system-registered-p (name) "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already. NAME is a system designator, to be normalized by COERCE-NAME. The value returned if true is a pair of a timestamp and a system object." (if-let (system (registered-system name)) (cons (if-let (primary-system (registered-system (primary-system-name name))) (component-operation-time 'define-op primary-system)) system))) (defun require-system (system &rest keys &key &allow-other-keys) "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the system or its dependencies if it has already been loaded." (declare (ignore keys)) (unless (component-loaded-p system) (load-system system)))) ;;; This function is for backward compatibility with ECL only. #+ecl (with-asdf-deprecation (:style-warning "3.2" :warning "9999") (defun make-build (system &rest args &key (monolithic nil) (type :fasl) (move-here nil move-here-p) prologue-code epilogue-code no-uiop prefix-lisp-object-files postfix-lisp-object-files extra-object-files &allow-other-keys) (let* ((operation (asdf/bundle::select-bundle-operation type monolithic)) (move-here-path (if (and move-here (typep move-here '(or pathname string))) (ensure-pathname move-here :namestring :lisp :ensure-directory t) (system-relative-pathname system "asdf-output/"))) (extra-build-args (remove-plist-keys '(:monolithic :type :move-here :prologue-code :epilogue-code :no-uiop :prefix-lisp-object-files :postfix-lisp-object-files :extra-object-files) args)) (build-system (if (subtypep operation 'image-op) (eval `(defsystem "asdf.make-build" :class program-system :source-file nil :pathname ,(system-source-directory system) :build-operation ,operation :build-pathname ,(subpathname move-here-path (file-namestring (first (output-files operation system)))) :depends-on (,(coerce-name system)) :prologue-code ,prologue-code :epilogue-code ,epilogue-code :no-uiop ,no-uiop :prefix-lisp-object-files ,prefix-lisp-object-files :postfix-lisp-object-files ,postfix-lisp-object-files :extra-object-files ,extra-object-files :extra-build-args ,extra-build-args)) system)) (files (output-files operation build-system))) (operate operation build-system) (if (or move-here (and (null move-here-p) (member operation '(program-op image-op)))) (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)))) asdf-3.3.4/backward-internals.lisp000066400000000000000000000012021362155115300170770ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;; Internal hacks for backward-compatibility (uiop/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) (:export #:load-sysdef)) (in-package :asdf/backward-internals) (with-asdf-deprecation (:style-warning "3.2" :warning "3.4") (defun load-sysdef (name pathname) (declare (ignore name pathname)) ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. (error "Use asdf:load-asd instead of asdf::load-sysdef"))) asdf-3.3.4/bin/000077500000000000000000000000001362155115300132105ustar00rootroot00000000000000asdf-3.3.4/bin/bump-version000077500000000000000000000051231362155115300155650ustar00rootroot00000000000000#! /usr/bin/env perl use FindBin; use Getopt::Long; our $old; our $new; our $usage = 0; &GetOptions("help"=>\$usage, "usage"=>\$usage); if ($usage) { print "$0 [old-version] [new-version]\n"; print "\tIf only one argument, treat it as the new version argument.\n"; print "\tIf two arguments treat the first as old version number and second as new.\n"; print "\n\tBumps the version numbers in all the relevant files.\n"; exit 0; } our $asdf_dir = $FindBin::RealBin . "/../"; our $file = $asdf_dir . "version.lisp-expr"; our @transform_ref = ( [ "version.lisp-expr", "\"", "\"" ], [ "uiop/version.lisp", "(defparameter *uiop-version* \"", "\")" ], [ "asdf.asd", " :version \"", "\" ;; to be automatically updated by make bump-version" ], [ "header.lisp", "This is ASDF ", ": Another System Definition Facility." ], [ "upgrade.lisp", "(asdf-version \"", "\")" ], [ "doc/asdf.texinfo", "Manual for Version ", "" ], ); if ($#ARGV == 1) { $old = $ARGV[0]; $new = $ARGV[1]; } elsif ($#ARGV == 0) { $new = $ARGV[0]; $old = read_asdf_version(); } else { $old = read_asdf_version(); $new = bump_asdf_version($old); } print STDERR "Bumping from $old to $new\n"; transform_files(); sub read_asdf_version { open(FILE, $file); my $str = ; chomp $str; print STDERR "Read version string $str from $file\n"; close FILE; $str =~ s/"//g; return $str; } sub bump_asdf_version { my $oldver = shift; my @fields = split/\./, $oldver; $fields[$#fields]++; return join('.', @fields); } sub transform_files { foreach my $entryptr (@transform_ref) { my @entry = @{$entryptr}; my $file = $entry[0]; print STDERR "Modifying file $file\n"; print STDERR "Prefix is $entry[1], suffix is $entry[2]\n"; my $regex = "(" . quotemeta($entry[1]) . ")" . "((\\d+\\.)+\\d+)" . "(" . quotemeta($entry[2]) .")"; my $filename = $asdf_dir . $file; my $data = read_text($filename); my $count = ($data =~ s/$regex/$1$new$4/g); if ($count == 0) { die "Unable to replace $regex with $1$new$4"; } # print STDERR "Writing $data to $filename\n"; write_text($filename, $data); } } # can't reliably find File::Slurper, or File::Slurp, so do it # old school. sub read_text ($) { my $fn = shift; local $/ = undef; open READFILE, $fn or die "Couldn't open file: $fn"; binmode READFILE; my $string = ; close READFILE; return $string; } sub write_text ($$) { my $fn = shift; my $data = shift; open WRITEFILE, "> $fn" or die "Couldn't open $fn for writing."; print WRITEFILE $data; close WRITEFILE; return 1; } asdf-3.3.4/bundle.lisp000066400000000000000000000713211362155115300146060ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; ASDF-Bundle (uiop/package:define-package :asdf/bundle (:recycle :asdf/bundle :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/operation :asdf/find-component ;; used by ECL :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem) (:export #:bundle-op #:bundle-type #:program-system #:bundle-system #:bundle-pathname-type #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op #:lib-op #:monolithic-lib-op #:dll-op #:monolithic-dll-op #:deliver-asd-op #:monolithic-deliver-asd-op #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (with-upgradability () (defclass bundle-op (operation) () (:documentation "base class for operations that bundle outputs from multiple components")) (defgeneric bundle-type (bundle-op)) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its dependencies*. So, for example, a monolithic concatenate operation will concatenate together a system's components and all of its dependencies, but a simple concatenate operation will concatenate only the components of the system itself.")) (defclass monolithic-bundle-op (bundle-op monolithic-op) ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation. ;; DEPRECATED. Supported replacement: Define slots on program-system instead. ((prologue-code :initform nil :accessor prologue-code) (epilogue-code :initform nil :accessor epilogue-code)) (:documentation "operations that are both monolithic-op and bundle-op")) (defclass program-system (system) ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) (prefix-lisp-object-files :initarg :prefix-lisp-object-files :initform nil :accessor prefix-lisp-object-files) (postfix-lisp-object-files :initarg :postfix-lisp-object-files :initform nil :accessor postfix-lisp-object-files) (extra-object-files :initarg :extra-object-files :initform nil :accessor extra-object-files) (extra-build-args :initarg :extra-build-args :initform nil :accessor extra-build-args))) (defmethod prologue-code ((x system)) nil) (defmethod epilogue-code ((x system)) nil) (defmethod no-uiop ((x system)) nil) (defmethod prefix-lisp-object-files ((x system)) nil) (defmethod postfix-lisp-object-files ((x system)) nil) (defmethod extra-object-files ((x system)) nil) (defmethod extra-build-args ((x system)) nil) (defclass link-op (bundle-op) () (:documentation "Abstract operation for linking files together")) (defclass gather-operation (bundle-op) () (:documentation "Abstract operation for gathering many input files from a system")) (defgeneric gather-operation (gather-operation)) (defmethod gather-operation ((o gather-operation)) nil) (defgeneric gather-type (gather-operation)) (defun operation-monolithic-p (op) (typep op 'monolithic-op)) ;; Dependencies of a gather-op are the actions of the dependent operation ;; for all the (sorted) required components for loading the system. ;; Monolithic operations typically use lib-op as the dependent operation, ;; and all system-level dependencies as required components. ;; Non-monolithic operations typically use compile-op as the dependent operation, ;; and all transitive sub-components as required components (excluding other systems). (defmethod component-depends-on ((o gather-operation) (s system)) (let* ((mono (operation-monolithic-p o)) (go (make-operation (or (gather-operation o) 'compile-op))) (bundle-p (typep go 'bundle-op)) ;; In a non-mono operation, don't recurse to other systems. ;; In a mono operation gathering bundles, don't recurse inside systems. (component-type (if mono (if bundle-p 'system t) '(not system))) ;; In the end, only keep system bundles or non-system bundles, depending. (keep-component (if bundle-p 'system '(not system))) (deps ;; Required-components only looks at the dependencies of an action, excluding the action ;; itself, so it may be safely used by an action recursing on its dependencies (which ;; may or may not be an overdesigned API, since in practice we never use it that way). ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks ;; cleaner, we will miss the load-op on the requested system itself, which doesn't ;; matter for a regular system, but matters, a lot, for a package-inferred-system. ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works ;; for our needs of gathering all the files we want to include in a bundle. ;; Note that we use basic-compile-op rather than compile-op so it will still work on ;; systems that would somehow load dependencies with load-bundle-op. (required-components s :other-systems mono :component-type component-type :keep-component keep-component :goal-operation 'load-op :keep-operation 'basic-compile-op))) `((,go ,@deps) ,@(call-next-method)))) ;; Create a single fasl for the entire library (defclass basic-compile-bundle-op (bundle-op basic-compile-op) () (:documentation "Base class for compiling into a bundle")) (defmethod bundle-type ((o basic-compile-bundle-op)) :fasb) (defmethod gather-type ((o basic-compile-bundle-op)) #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object) ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op (defclass prepare-bundle-op (sideway-operation) ((sideway-operation :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op :allocation :class)) (:documentation "Operation class for loading the bundles of a system's dependencies")) (defclass lib-op (link-op gather-operation non-propagating-operation) () (:documentation "Compile the system and produce a linkable static library (.a/.lib) for all the linkable object files associated with the system. Compare with DLL-OP. On most implementations, these object files only include extensions to the runtime written in C or another language with a compiler producing linkable object files. On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files themselves. In any case, this operation will produce what you need to further build a static runtime for your system, or a dynamic library to load in an existing runtime.")) (defmethod bundle-type ((o lib-op)) :lib) (defmethod gather-type ((o lib-op)) :object) ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so; ;; on other implementations, we combine (usually concatenate) the .fasl files into one. (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation #+(or clasp ecl mkcl) link-op) ((selfward-operation :initform '(prepare-bundle-op) :allocation :class)) (:documentation "This operator is an alternative to COMPILE-OP. Build a system and all of its dependencies, but build only a single (\"monolithic\") FASL, instead of one per source file, which may be more resource efficient. That monolithic FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) (defclass load-bundle-op (basic-load-op selfward-operation) ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) (:documentation "This operator is an alternative to LOAD-OP. Build a system and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with respect to LOAD-OP is that it builds only a single FASL, which may be faster and more resource efficient.")) ;; NB: since the monolithic-op's can't be sideway-operation's, ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, ;; we'd have to have the monolithic-op not inherit from the main op, ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. (defclass dll-op (link-op gather-operation non-propagating-operation) () (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) for all the linkable object files associated with the system. Compare with LIB-OP.")) (defmethod bundle-type ((o dll-op)) :dll) (defmethod gather-type ((o dll-op)) :object) (defclass deliver-asd-op (basic-compile-op selfward-operation) ((selfward-operation ;; TODO: implement link-op on all implementations, and make that ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class)) (:documentation "produce an asd file for delivering the system as a single fasl")) (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op) ((selfward-operation ;; TODO: implement link-op on all implementations, and make that ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) (defclass monolithic-compile-bundle-op (basic-compile-bundle-op monolithic-bundle-op #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation) () (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op) ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) (:documentation "Load a single fasl for the system and its dependencies.")) (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) () (:documentation "Compile the system and produce a linkable static library (.a/.lib) for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) () (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) for all the linkable object files associated with the system or its dependencies. See LIB-OP")) (defclass image-op (monolithic-bundle-op selfward-operation #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation) ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) (defmethod bundle-type ((o image-op)) :image) #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op) #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library) (defclass program-op (image-op) () (:documentation "create an executable file from the system and its dependencies")) (defmethod bundle-type ((o program-op)) :program) ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type. (defun bundle-pathname-type (bundle-type) (etypecase bundle-type ((or null string) ;; pass through nil or string literal bundle-type) ((eql :no-output-file) ;; marker for a bundle-type that has NO output file (error "No output file, therefore no pathname type")) ((eql :fasl) ;; the type of a fasl (compile-file-type)) ; on image-based platforms, used as input and output ((eql :fasb) ;; the type of a fasl #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image") ;; NB: on CLASP and ECL these implementations, we better agree with ;; (compile-file-type :type bundle-type)) ((eql :object) ;; the type of a linkable object file (os-cond ((os-unix-p) "o") ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) ((member :lib :static-library) ;; the type of a linkable library (os-cond ((os-unix-p) "a") ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) ((member :dll :shared-library) ;; the type of a shared library (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) ((eql :program) ;; the type of an executable program (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) ;; Compute the output-files for a given bundle action (defun bundle-output-files (o c) (let ((bundle-type (bundle-type o))) (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) (let ((name (or (component-build-pathname c) (let ((suffix (unless (typep o 'program-op) ;; "." is no good separator for Logical Pathnames, so we use "--" (if (operation-monolithic-p o) "--all-systems" ;; These use a different type .fasb or .a instead of .fasl #-(or clasp ecl mkcl) "--system")))) (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix)))) (type (bundle-pathname-type bundle-type))) (values (list (subpathname (component-pathname c) name :type type)) (eq (class-of o) (coerce-class (component-build-operation c) :package :asdf/interface :super 'operation :error nil))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) #-(or clasp ecl mkcl) (progn (defmethod perform ((o image-op) (c system)) (dump-image (output-file o c) :executable (typep o 'program-op))) (defmethod perform :before ((o program-op) (c system)) (setf *image-entry-point* (ensure-function (component-entry-point c))))) (defclass compiled-file (file-component) ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")) (:documentation "Class for a file that is already compiled, e.g. as part of the implementation, of an outer build system that calls into ASDF, or of opaque libraries shipped along the source code.")) (defclass precompiled-system (system) ((build-pathname :initarg :fasb :initarg :fasl)) (:documentation "Class For a system that is delivered as a precompiled fasl")) (defclass prebuilt-system (system) ((build-pathname :initarg :static-library :initarg :lib :accessor prebuilt-system-static-library)) (:documentation "Class for a system delivered with a linkable static library (.a/.lib)"))) ;;; ;;; BUNDLE-OP ;;; ;;; This operation takes all components from one or more systems and ;;; creates a single output file, which may be ;;; a FASL, a statically linked library, a shared library, etc. ;;; The different targets are defined by specialization. ;;; (when-upgrading (:version "3.2.0") ;; Cancel any previously defined method (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys) (declare (ignore initargs)))) (with-upgradability () (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 () (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) ;; This function selects output files from direct dependencies; ;; your component-depends-on method must gather 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)))))) (defun pathname-type-equal-function (type) #'(lambda (p) (equalp (pathname-type p) type))) (defmethod input-files ((o gather-operation) (c system)) (unless (eq (bundle-type o) :no-output-file) (direct-dependency-files o c :key 'output-files :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) ;; Find the operation that produces a given bundle-type (defun select-bundle-operation (type &optional monolithic) (ecase type ((:dll :shared-library) (if monolithic 'monolithic-dll-op 'dll-op)) ((:lib :static-library) (if monolithic 'monolithic-lib-op 'lib-op)) ((:fasb) (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) ((:image) 'image-op) ((:program) 'program-op)))) ;;; ;;; LOAD-BUNDLE-OP ;;; ;;; This is like ASDF's LOAD-OP, but using bundle fasl files. ;;; (with-upgradability () (defmethod component-depends-on ((o load-bundle-op) (c system)) `((,o ,@(component-sideway-dependencies c)) (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) ,@(call-next-method))) (defmethod input-files ((o load-bundle-op) (c system)) (when (user-system-p c) (output-files (find-operation o 'compile-bundle-op) c))) (defmethod perform ((o load-bundle-op) (c system)) (when (input-files o c) (perform-lisp-load-fasl o c))) (defmethod mark-operation-done :after ((o load-bundle-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 input-files ((o operation) (c compiled-file)) (list (component-pathname c))) (defmethod perform ((o load-op) (c compiled-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-source-op) (c compiled-file)) (perform (find-operation o 'load-op) c)) (defmethod perform ((o operation) (c compiled-file)) nil)) ;;; ;;; Pre-built systems ;;; (with-upgradability () (defmethod trivial-system-p ((s prebuilt-system)) t) (defmethod perform ((o link-op) (c prebuilt-system)) nil) (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system)) nil) (defmethod perform ((o lib-op) (c prebuilt-system)) nil) (defmethod perform ((o dll-op) (c prebuilt-system)) nil) (defmethod component-depends-on ((o gather-operation) (c prebuilt-system)) nil) (defmethod output-files ((o lib-op) (c prebuilt-system)) (values (list (prebuilt-system-static-library c)) t))) ;;; ;;; PREBUILT SYSTEM CREATOR ;;; (with-upgradability () (defmethod output-files ((o deliver-asd-op) (s system)) (list (make-pathname :name (coerce-filename (component-name s)) :type "asd" :defaults (component-pathname s)))) ;; because of name collisions between the output files of different ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to ;; tell us if the output file is up-to-date, so just treat the ;; operation as never being done. (defmethod operation-done-p ((o deliver-asd-op) (s system)) (declare (ignorable o s)) nil) (defmethod perform ((o deliver-asd-op) (s system)) "Write an ASDF system definition for loading S as a delivered system." (let* ((inputs (input-files o s)) (fasl (first inputs)) (library (second inputs)) (asd (output-file o s)) (name (if (and fasl asd) (pathname-name asd) (return-from perform))) (version (component-version s)) (dependencies (if (operation-monolithic-p o) ;; We want only dependencies, and we use basic-load-op rather than load-op so that ;; this will keep working on systems that load dependencies with load-bundle-op (remove-if-not 'builtin-system-p (required-components s :component-type 'system :keep-operation 'basic-load-op)) (while-collecting (x) ;; resolve the sideway-dependencies of s (map-direct-dependencies 'prepare-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) ;; this can cause bugs in cases where one of the functions returns a multi-line ;; string (let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A" (lisp-implementation-type) (lisp-implementation-version) (software-type) (machine-type) (software-version)))) ;; ensure the whole thing is on one line (print (remove-if #'(lambda (x) (member x (list #\newline #\return))) description-string) s) (terpri s)) (let ((*package* (find-package :asdf-user))) (pprint `(defsystem ,name :class prebuilt-system :version ,version :depends-on ,depends-on :components ((:compiled-file ,(pathname-name fasl))) ,@(when library `(:lib ,(file-namestring library)))) s) (terpri s))))) #-(or clasp ecl mkcl) (defmethod perform ((o basic-compile-bundle-op) (c system)) (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL (output-file (first output-files))) (assert (eq (not input-files) (not output-files))) (when input-files (when non-fasl-files (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S" (implementation-type) non-fasl-files)) (when (or (prologue-code c) (epilogue-code c)) (error "prologue-code and epilogue-code are not supported on ~A" (implementation-type))) (with-staging-pathname (output-file) (combine-fasls fasl-files output-file))))) (defmethod input-files ((o load-op) (s precompiled-system)) (bundle-output-files (find-operation o 'compile-bundle-op) s)) (defmethod perform ((o load-op) (s precompiled-system)) (perform-lisp-load-fasl o s)) (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system)) `((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 clasp ecl mkcl) (with-upgradability () (defun system-module-pathname (module) (let ((name (coerce-name module))) (some 'file-exists-p (list #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object) #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib) #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib) #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object) #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:") #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;"))))) (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name))) "Creates a prebuilt-system if PATHNAME isn't NIL." (when pathname (make-instance 'prebuilt-system :name (coerce-name name) :static-library (resolve-symlinks* pathname)))) (defun linkable-system (x) (or ;; If the system is available as source, use it. (if-let (s (find-system x)) (and (output-files 'lib-op s) s)) ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that, ;; then use the asdf/driver system instead of ;; the UIOP that was disabled by check-not-old-asdf-system. (if-let (s (and (equal (coerce-name x) "uiop") (output-files 'lib-op "asdf") (find-system "asdf/driver"))) (and (output-files 'lib-op s) s)) ;; If there was no source upgrade, look for modules provided by the implementation. (if-let (p (system-module-pathname (coerce-name x))) (make-prebuilt-system x p)))) (defmethod component-depends-on :around ((o image-op) (c system)) (let* ((next (call-next-method)) (deps (make-hash-table :test 'equal)) (linkable (loop* :for (do . dcs) :in next :collect (cons do (loop :for dc :in dcs :for dep = (and dc (resolve-dependency-spec c dc)) :when dep :do (setf (gethash (coerce-name (component-system dep)) deps) t) :collect (or (and (typep dep 'system) (linkable-system dep)) dep)))))) `((lib-op ,@(unless (no-uiop c) (list (linkable-system "cmp") (unless (or (and (gethash "uiop" deps) (linkable-system "uiop")) (and (gethash "asdf" deps) (linkable-system "asdf"))) (or (linkable-system "uiop") (linkable-system "asdf") "asdf"))))) ,@linkable))) (defmethod perform ((o link-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) (bundle (first output)) (programp (typep o 'program-op)) (kind (bundle-type o))) (when output (apply 'create-image bundle (append (when programp (prefix-lisp-object-files c)) object-files (when programp (postfix-lisp-object-files c))) :kind kind :prologue-code (when programp (prologue-code c)) :epilogue-code (when programp (epilogue-code c)) :build-args (when programp (extra-build-args c)) :extra-object-files (when programp (extra-object-files c)) :no-uiop (no-uiop c) (when programp `(:entry-point ,(component-entry-point c)))))))) asdf-3.3.4/component.lisp000066400000000000000000000410471362155115300153410ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Components (uiop/package:define-package :asdf/component (:recycle :asdf/component :asdf/find-component :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) (:export #:component #:component-find-path #:find-component ;; methods defined in find-component #: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 #: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 #:source-file #:defsystem-depends-on ; This symbol retained for backward compatibility. #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods #:relative-pathname #:absolute-pathname #:operation-times #:around-compile #:%encoding #:properties #:component-properties #:parent)) (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 "Top-level system containing the COMPONENT")) (defgeneric component-pathname (component) (:documentation "Pathname of the COMPONENT if any, or NIL.")) (defgeneric component-relative-pathname (component) ;; in ASDF4, rename that to component-specified-pathname ? (:documentation "Specified pathname of the COMPONENT, intended to be merged with the pathname of that component's parent if any, using merged-pathnames*. Despite the function's name, the return value can be an absolute pathname, in which case the merge will leave it unmodified.")) (defgeneric component-external-format (component) (:documentation "The external-format of the COMPONENT. By default, deduced from the COMPONENT-ENCODING.")) (defgeneric component-encoding (component) (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported. Use asdf-encodings to support more encodings.")) (defgeneric version-satisfies (component version) (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL.")) (defgeneric component-version (component) (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated natural numbers, or NIL.")) (defgeneric (setf component-version) (new-version component) (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated natural numbers, or NIL.")) (defgeneric component-parent (component) (:documentation "The parent of a child COMPONENT, or NIL for top-level components (a.k.a. systems)")) ;; NIL is a designator for the absence of a component, in which case the parent is also absent. (defmethod component-parent ((component null)) nil) ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. (with-asdf-deprecation (:style-warning "3.4") (defgeneric source-file-type (component system) (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))) (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)))))) (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: ;; we store them here so we can delete them when the system is re-evaluated. (inline-methods :accessor component-inline-methods :initform nil) ;; 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) ;; Cache for ADDITIONAL-INPUT-FILES function. (additional-input-files :accessor %additional-input-files :initform nil)) (:documentation "Base class for all components of a build")) (defgeneric find-component (base path &key registered) (:documentation "Find a component by resolving the PATH starting from BASE parent. If REGISTERED is true, only search currently registered systems.")) (defun component-find-path (component) "Return a path from a root system to the COMPONENT. The return value is a list of component NAMES; a list of strings." (check-type component (or null component)) (reverse (loop :for c = component :then (component-parent c) :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) () (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of a PARENT-COMPONENT.")) (defclass file-component (child-component) ((type :accessor file-type :initarg :type)) ; no default (:documentation "a COMPONENT that represents a file")) (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)) (:documentation "Component for a file to be included as is in the build output")) (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)) (:documentation "A PARENT-COMPONENT is a component that may have children."))) (with-upgradability () ;; (Private) Function that given a PARENT component, ;; the list of children of which has been initialized, ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name. ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated. (defun compute-children-by-name (parent &key only-if-needed-p) (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) (let ((hash (make-hash-table :test 'equal))) (setf (component-children-by-name parent) hash) (loop :for c :in (component-children parent) :for name = (component-name c) :for previous = (gethash name hash) :do (when previous (error 'duplicate-names :name name)) (setf (gethash name hash) c)) hash)))) (with-upgradability () (defclass module (child-component parent-component) (#+clisp (components)) ;; backward compatibility during upgrade only (:documentation "A module is a intermediate component with both a parent and children, typically but not necessarily representing the files in a subdirectory of the build source."))) ;;;; component pathnames (with-upgradability () (defgeneric component-parent-pathname (component) (:documentation "The pathname of the COMPONENT's parent, if any, or NIL")) (defmethod component-parent-pathname (component) (component-pathname (component-parent component))) ;; The default method for component-pathname tries to extract a cached precomputed ;; absolute-pathname from the relevant slot, and if not, computes it by merging the ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute) ;; with the directory of the component-parent-pathname. (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))) ;; Default method for component-relative-pathname: ;; combine the contents of slot relative-pathname (from specified initarg :pathname) ;; with the appropriate source-file-type, which defaults to the file-type of the component. (defmethod component-relative-pathname ((component component)) ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1. ;; We ought to be able to extract this from the component alone with FILE-TYPE. ;; TODO: track who uses it in Quicklisp, and have them not use it anymore; ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge? (parse-unix-namestring (or (and (slot-boundp component 'relative-pathname) (slot-value component 'relative-pathname)) (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 parent-component)) :directory) (defmethod source-file-type ((component file-component) (system parent-component)) (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) (:documentation "An optional hook function that will be called with one argument, a thunk. The hook function must call the thunk, that will compile code from the component, and may or may not also evaluate the compiled results. The hook function may establish dynamic variable bindings around this compilation, or check its results, etc.")) (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 () ;; short-circuit testing of null version specifications. ;; this is an all-pass, without warning (defmethod version-satisfies :around ((c t) (version null)) t) (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version) (component-version c)) (when version (warn "Requested version ~S but ~S has no version" version c)) (return-from version-satisfies nil)) (version-satisfies (component-version c) version)) (defmethod version-satisfies ((cver string) version) (version<= version cver))) ;;; all sub-components (of a given type) (with-upgradability () (defun sub-components (component &key (type t)) "Compute the transitive sub-components of given COMPONENT that are of given TYPE" (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))))) asdf-3.3.4/concatenate-source.lisp000066400000000000000000000132411362155115300171140ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Concatenate-source (uiop/package:define-package :asdf/concatenate-source (:recycle :asdf/concatenate-source :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system :asdf/action :asdf/lisp-action :asdf/plan :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 () ;; Base classes for both regular and monolithic concatenate-source operations (defclass basic-concatenate-source-op (bundle-op) ()) (defmethod bundle-type ((o basic-concatenate-source-op)) "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) ()) ;; Regular concatenate-source operations (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) () (:documentation "Operation to concatenate all sources in a system into a single file")) (defclass load-concatenated-source-op (basic-load-concatenated-source-op) ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) (:documentation "Operation to load the result of concatenate-source-op as source")) (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) (:documentation "Operation to compile the result of concatenate-source-op")) (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)) (:documentation "Operation to load the result of compile-concatenated-source-op")) (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) () (:documentation "Operation to concatenate all sources in a system and its dependencies into a single file")) (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) (:documentation "Operation to load the result of monolithic-concatenate-source-op as source")) (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) (:documentation "Operation to compile the result of 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 :allocation :class)) (:documentation "Operation to load the result of 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 ;; see note about similar call to required-components s :goal-operation 'load-op ;; in bundle.lisp :keep-operation 'basic-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* ((ins (input-files o s)) (out (output-file o s)) (tmp (tmpize-pathname out))) (concatenate-files ins tmp) (rename-file-overwriting-target tmp out))) (defmethod perform ((o basic-load-concatenated-source-op) (s system)) (perform-lisp-load-source o s)) (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) (perform-lisp-compilation o s)) (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) (perform-lisp-load-fasl o s))) asdf-3.3.4/contrib/000077500000000000000000000000001362155115300141005ustar00rootroot00000000000000asdf-3.3.4/contrib/debug-plan.lisp000066400000000000000000000177341362155115300170230ustar00rootroot00000000000000(defpackage :asdf/contrib/plan (:use :cl)) ;; dummy, for use as package-inferred-system (in-package :asdf/plan) ;; NB: Whenever compute-action-stamp is changed, this file must be updated ;; to insert the let-and-DBG statements in the current version of the function. ;; So if you find this file not working, it might be out of date. (uiop:uiop-debug) (progn (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) ;; Given an action, figure out at what time in the past it has been done, ;; or if it has just been done, return the time that it has. ;; Returns two values: ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, ;; or NIL is either hasn't been done or is out of date. ;; (An ASDF extension could use a cryptographic digest instead.) ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done ;; in the current image, or NIL if it hasn't. ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp, ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, ;; i.e. that of the input-files. ;; If just-done is NIL, these values return are the notional fields of ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error). ;; If just-done is T, they are the notional fields of DONE status ;; (or, if something went wrong, TODO). (nest (block ()) (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date) (reduce-direct-dependencies o c #'(lambda (do dc status) ;; out-of-date dependency: don't bother looking further (let ((action-status (action-status plan do dc))) (cond ((and action-status (or (status-keep-p action-status) (and just-done (status-stamp action-status)))) (merge-action-status action-status status)) (just-done ;; It's OK to lose some ASDF action stamps during self-upgrade (unless (equal "asdf" (primary-system-name dc)) (warn "Computing just-done stamp in plan ~S for action ~S, but dependency ~S wasn't done yet!" plan (action-path (make-action o c)) (action-path (make-action do dc)))) status) (t (DBG "compute-action-stamp: forced by out of date dependency" (action-path (make-action o c)) (action-path (make-action do dc)) action-status) (return (values nil nil)))))) +status-good+)) (dep-stamp (status-stamp dep-status))) ;; DBG (when (null dep-stamp) (let* ((action-path (action-path (cons o c))) (dep-statuses (loop for action in (direct-dependencies o c) for (o . c) = action collect (list (action-path action) (action-status plan o c))))) (DBG :nds action-path dep-statuses)))) (let* (;; collect timestamps from inputs, and exit early if any is missing (in-files (input-files o c)) (in-stamps (mapcar #'get-file-stamp in-files)) (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (latest-in (timestamps-latest (cons dep-stamp in-stamps)))) (when (and missing-in (not just-done)) (DBG "compute-action-stamp: missing inputs" (cons o c) missing-in) (return (values nil nil)))) (let* (;; collect timestamps from outputs, and exit early if any is missing (out-files (remove-if 'null (output-files o c))) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (earliest-out (timestamps-earliest out-stamps))) (when (and missing-out (not just-done)) (DBG "compute-action-stamp: missing outputs" (cons o c) missing-out) (return (values nil nil)))) (let (;; Time stamps from the files at hand, and whether any is missing (all-present (not (or missing-in missing-out))) ;; Has any input changed since we last generated the files? ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files. ;; Any race condition is intrinsic to the limited timestamp resolution. (up-to-date-p (timestamp<= latest-in earliest-out)) ;; If everything is up to date, the latest of inputs and outputs is our stamp (done-stamp (timestamps-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)) ;; Shouldn't that be an error instead? (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)))) (let (;; There are three kinds of actions: (out-op (and out-files t)) ; those that create files on the filesystem ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing )) ;; Status of the action as previously performed in the image (progn ;; DBG (multiple-value-bind (perform-stamp perform-done-p) (if just-done (values done-stamp t) (component-operation-time o c)) (let* ((forced (action-forced-p (forcing (or plan *asdf-session*)) o c)) (already-done-p (and all-present up-to-date-p (operation-done-p o c) (not forced))) (matching-stamp-p (and perform-done-p (eql perform-stamp done-stamp))) (action-path (action-path (cons o c)))) (DBG "compute-action-stamp" action-path in-files in-stamps dep-stamp out-files out-stamps latest-in earliest-out up-to-date-p perform-stamp perform-done-p done-stamp all-present forced already-done-p just-done out-op matching-stamp-p)))) (if (or just-done ;; The done-stamp is valid: if we're just done, or (and all-present ;; if all filesystem effects are up-to-date up-to-date-p (operation-done-p o c) ;; and there's no invalidating reason. (not (action-forced-p (forcing (or plan *asdf-session*)) 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. ;; An image-effecting operation is done when (and (status-done-p dep-status) ;; all the dependencies were done, and (multiple-value-bind (perform-stamp perform-done-p) (component-operation-time o c) (and perform-done-p ;; the op was actually run, (equal perform-stamp done-stamp)))))) ;; with a matching stamp. ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet (values nil nil))))) asdf-3.3.4/contrib/debug.lisp000077700000000000000000000000001362155115300226602../uiop/contrib/debug.lispustar00rootroot00000000000000asdf-3.3.4/contrib/detect-multiply-used-files.lisp000066400000000000000000000023541362155115300221600ustar00rootroot00000000000000(uiop:define-package :detect-multiply-used-files (:nicknames :asdf/contrib/detect-multiply-used-files) (:use :asdf/component :asdf/system-registry :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 *registered-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: (asdf:load-systems system1 system2 ...) (detect-multiply-used-files:find-fishy-components) |# asdf-3.3.4/contrib/fasl-op.lisp000066400000000000000000000023361362155115300163360ustar00rootroot00000000000000(uiop:define-package :asdf/contrib/fasl-op (:use :common-lisp :uiop :asdf :asdf/component :asdf/operation :asdf/lisp-action :asdf/bundle)) (in-package :asdf/contrib/fasl-op) ;;; Backward compatibility with pre-3.1.2 names (eval-when (:compile-toplevel :load-toplevel :execute) (defun frob-symbol (sym) (loop :for dest :in '(:asdf/bundle :asdf/interface) :do (uiop/package::ensure-import (symbol-name sym) (find-package dest) (symbol-package sym) (make-hash-table :test 'equal) (make-hash-table :test 'equal))))) (defmacro declare-ops (&rest ops) `(progn ,@(loop :for (compat-name current-name) :in ops :append `((defclass ,compat-name (selfward-operation) ((selfward-operation :initform ',current-name :allocation :class))) (defmethod output-files ((o ,compat-name) (c component)) (output-files (find-operation o ',current-name) c)) (frob-symbol ',compat-name))))) (declare-ops (fasl-op compile-bundle-op) (load-fasl-op load-bundle-op) (binary-op deliver-asd-op) (monolithic-fasl-op monolithic-compile-bundle-op) (monolithic-load-fasl-op monolithic-load-bundle-op) (monolithic-binary-op monolithic-deliver-asd-op)) asdf-3.3.4/contrib/fast-compile-op.lisp000066400000000000000000000023351362155115300177730ustar00rootroot00000000000000;; fast-compile-op: compile just one file in the current process, ;; loading all dependencies as source. ;; How to use it: ;; (1) your build system compiles all your system's dependencies as bundle. ;; (2) For each component in the system, invoke a process that ;; (a) loads all the transitive dependencies as bundles ;; (b) use register-preloaded-system ;; to tell ASDF the direct dependencies are loaded ;; (c) use fast-compile-op on each of the components in the system ;; (3) when they are all done, combine the fasls in a bundle. #+sbcl (setf sb-ext:*evaluator-mode* :interpret) (defclass fast-compile-op (basic-compile-op selfward-operation) ((selfward-operation :initform 'prepare-source-op))) (defmethod action-description ((o fast-compile-op) (c component)) (declare (ignorable o)) (format nil (compatfmt "~@") c)) (defmethod perform ((o fast-compile-op) (c component)) (let (#+sbcl (sb-ext:*evaluator-mode* :compile)) (perform (make-operation 'compile-op) c))) (defmethod output-files ((o fast-compile-op) (c component)) (output-files (make-operation 'compile-op) c)) (defmethod input-files ((o fast-compile-op) (c component)) (input-files (make-operation 'compile-op) c)) asdf-3.3.4/contrib/fiveam-asdf/000077500000000000000000000000001362155115300162625ustar00rootroot00000000000000asdf-3.3.4/contrib/fiveam-asdf/code.lisp000066400000000000000000000111601362155115300200640ustar00rootroot00000000000000(in-package :asdf) (defclass fiveam-tester-system (system) ((test-names :initarg :test-names :reader test-names :documentation "A list whose elements are either cons cells of symbol and package designators or simply a symbol designator. In the latter case, the symbols will be interned in the package designated by the TEST-PACKAGE slot, which must be bound.") (test-package :initarg :default-test-package :initarg :test-package :documentation "If all the tests are in one package, you can just have a list of test names in test-names, and get the package name from here.") (num-checks :initarg :num-checks :reader num-checks :type (or null (integer 0)) :initform nil :documentation "How many tests do you expect to run when you invoke the test-op on this system. For backwards compatibility, this slot is ignored if it's NIL. If bound, then when running the test-op, we will fail if the expected number of checks are not run.") )) (define-condition fiveam-asdf-failure (error) ((failed-asdf-component :initarg :failed-asdf-component :reader failed-asdf-component )) (:documentation "Superclass of error conditions that indicate that an ASDF test-op has failed.")) (define-condition fiveam-test-fail (fiveam-asdf-failure) ((failed :initarg :failed :reader failed )) (:report (lambda (x s) (format s "Tests on system ~a failed: ~{~t~a~%~}" (component-name (failed-asdf-component x)) (failed x))))) (define-condition fiveam-wrong-number-of-checks (fiveam-asdf-failure) ((expected-num-checks :initarg :expected :initarg :expected-num-checks :reader expected-num-checks ) (actual-num-checks :initarg :actual-num-checks :initarg :actual :reader actual-num-checks )) (:report (lambda (x s) (format s "Unexpected number of tests on system ~a: Expected ~d got ~d." (component-name (failed-asdf-component x)) (expected-num-checks x) (actual-num-checks x))))) (defgeneric test-package (x) (:method ((x fiveam-tester-system)) (if (slot-boundp x 'test-package) (slot-value x 'test-package) (error "If package is not specified with each test-name, system's TEST-PACKAGE slot must be set.")))) (defmethod perform ((op test-op) (sys fiveam-tester-system)) (let* ((test-syms (loop for x in (test-names sys) with test-name and package-name and test-sym and package if (symbolp x) do (setf test-name x package-name (test-package sys)) else do (assert (and (consp x) (or (symbolp (car x)) (stringp (car x))) (or (symbolp (cdr x)) (stringp (cdr x))))) (setf test-name (car x) package-name (cdr x)) do (setf package (or (find-package package-name) (error "Unable to find package ~a" package-name))) (setf test-sym (intern (etypecase test-name (string test-name) (symbol (symbol-name test-name))) package)) collect test-sym)) (runner (intern (symbol-name '#:run) :fiveam)) (tester (intern (symbol-name '#:results-status) :fiveam)) (explainer (intern (symbol-name '#:explain!) :fiveam)) (results (loop for test in test-syms appending (funcall runner test)))) (funcall explainer results) ;; if there's an expected number of checks, verify that we have run ;; exactly that number. (when (num-checks sys) (let ((actual-num-checks (length results))) (unless (= actual-num-checks (num-checks sys)) (error 'fiveam-wrong-number-of-checks :failed-asdf-component sys :actual actual-num-checks :expected (num-checks sys))))) (multiple-value-bind (success failures) (funcall tester results) (unless success (error 'fiveam-test-fail :failed-asdf-component sys :failed failures))))) (defmethod component-depends-on ((op load-op) (sys fiveam-tester-system)) (cons '(load-op "fiveam") (call-next-method))) (defmethod component-depends-on ((op compile-op) (sys fiveam-tester-system)) (cons '(load-op "fiveam") (call-next-method))) (eval-when (:compile-toplevel :load-toplevel :execute) (export 'fiveam-tester-system :asdf)) asdf-3.3.4/contrib/fiveam-asdf/fiveam-asdf.asd000066400000000000000000000025011362155115300211330ustar00rootroot00000000000000;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2012-2018 Smart Information Flow Technologies, d/b/a SIFT, LLC and ;;; Robert P. Goldman ;;; All rights reserved. ;;; ;;; The developers make this software available according to the terms ;;; of the Lisp Lesser GNU Public License (LLGPL): ;;; http://opensource.franz.com/preamble.html. ;;; See the accompanying file, license.txt ;;; ;;;--------------------------------------------------------------------------- ;;; ;;; This system provides functionality to support integrating FiveAM tests with ;;; an ASDF system definition in such a way that invocation of the ;;; ASDF:TEST-SYSTEM function will cause the FiveAM tests to run. An error will ;;; be raised if there are test failures. ;;; ;;;--------------------------------------------------------------------------- (defpackage :fiveam-asdf-asd (:use :common-lisp :asdf) ) (in-package :fiveam-asdf-asd) (defsystem fiveam-asdf :long-description "System that defines a new system class FIVEAM-TESTER that provides functionality for running tests using FIVEAM and raising an error if the tests fail \(useful for incorporation in a Jenkins or Hudson build\)." :depends-on (:asdf) :components ((:file "code")) :author "Robert P. Goldman" :version "2.0" :license "Lisp LGPL" ) asdf-3.3.4/contrib/fiveam-asdf/license.txt000066400000000000000000000010361362155115300204450ustar00rootroot00000000000000FIVEAM-ASDF is a library enabling suites of FiveAM tests to be associated with ASDF systems in such a way that ASDF:TEST-SYSTEM will cause the tests to be run and will raise an exception if something unexpected happens. FIVEAM-ASDF is licensed under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. The LLGPL consists of a preamble (see above URL) and the LGPL. Where these conflict, the preamble takes precedence. FIVEAM-ASDF is referenced in the preamble as the "LIBRARY." asdf-3.3.4/contrib/wild-modules.lisp000066400000000000000000000027331362155115300174030ustar00rootroot00000000000000(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))) (defmethod input-files ((o compile-op) (c wild-module)) ()) (defmethod input-files ((o load-op) (c wild-module)) ()) (export 'wild-module) asdf-3.3.4/doc/000077500000000000000000000000001362155115300132055ustar00rootroot00000000000000asdf-3.3.4/doc/.htaccess000066400000000000000000000001211362155115300147750ustar00rootroot00000000000000Redirect /project/asdf/manual.html http://common-lisp.net/project/asdf/asdf.html asdf-3.3.4/doc/Changelog000066400000000000000000002263271362155115300150330ustar00rootroot00000000000000cl-asdf (2:3.3.4-1) unstable; urgency=low Bug fix release: * SBCL compatibility: support local nicknames in package-inferred-system, address upgrade issues in SBCL 2.x (thanks to Eric Timmons). * Clasp compatibility: fixes from Karsten Poeck. * Lispworks compatibility: fixes from Martin Simmons. * Documentation: multiple user-contributed fixes: Jan Moringen and Rommel Martinez. * Bundle bug fixes: thanks to Guillaume Le Vaillant and François-René Rideau. * Miscellaneous bug fixes. * Tests: miscellaneous fixes and improvements. -- Robert P. Goldman Thu, 13 Feb 2020 17:09:39 -0600 cl-asdf (2:3.3.3-1) unstable; urgency=low Bug fix release: * Dependency tracking: fix bugs in handling misnamed secondary systems. We now distinguish between "syntactic" and "semantic" primariness, properly warn in case a secondary system is misnamed, yet properly recompile or avoid spurious recompilation depending on whether there or not is a conflict or redefinition. Similarly handle package-inferred-system (thanks to Eric Timmons). Better warning in a fishy case of compute-action-stamp. * UIOP: Fix loading, allow the user to specify UIOP location from which to load. * SBCL compatibility: Fix issue with deferred warnings on SBCL. * Allegro compatibility: Fix issue detecting "modern" lisp. * Genera compatibility: Fix minor issues. Not fully tested. * ECL compatibility: Bundling fixes. * Fiveam-ASDF: Added to contrib/ example system for integrating FiveAM tests with ASDF's test-op. * Miscellaneous fixes: Avoid an infinite loop parsing :perform options, quash warnings for known bad system names that won't be fixed. * Documentation: Multiple user-contributed documentation fixes. * Tests: Miscellaneous improvements. -- Francois-Rene Rideau Wed, 27 Mar 2019 17:33:42 -0400 cl-asdf (2:3.3.2-1) unstable; urgency=low Bug fix release: * Dependency tracking: fix bugs in handling misnamed secondary systems. We now distinguish between "syntactic" and "semantic" primariness, properly warn in case a secondary system is misnamed, yet properly recompile or avoid spurious recompilation depending on whether there or not is a conflict or redefinition. Similarly handle package-inferred-system (thanks to Eric Timmons). Better warning in a fishy case of compute-action-stamp. * UIOP: Add package location information to define-package on SBCL. * Upgrade: fix issue with asdf/bundle. * Portability: add support for Mezzano (thanks to E. Housel, H. Harrington) * Documentation: add discussion of best practices. * Package-inferred system: Improve source file handling. * Test and documentation improvements. -- Francois-Rene Rideau Thu, 03 May 2018 22:46:19 -0400 cl-asdf (2:3.3.1-1) unstable; urgency=low New milestone: * UIOP compatibility fix: Introduced new replacement "timestamp" comparison functions, because of inadvertent change in the API. Functions that are compatible with the old semantics are retained as "stamp" comparison functions, but will eventually be deprecated. * Upgrade fix: Upgrade from 3.2.1 needed repair. * Syntax manipulation: Fix for bugs that could be introduced when the default readtable was manipulated during the loading of a defsystem-depends-on system. * Tests: tests for new capabilities and bugs * Documentation: a number of improvements and clarifications. -- Robert P. Goldman Sun, 12 Nov 2017 17:39:04 -0600 cl-asdf (2:3.3.0-1) unstable; urgency=low New milestone: * Build-plan: Extensively revised the build plan process so that :DEFSYSTEM-DEPENDS-ON would work correctly, even when depended on systems change (which didn't work before). See our ELS demonstration about it: "Delivering Common Lisp Applications with ASDF 3.3" < https://github.com/fare/asdf2017 > * Internals: to support the above, many ASDF internals have changed. ASDF now has the notion of multiple build phases to a common build session (which generalizes the previous build cache). ASDF considers loading a .asd file as an operation DEFINE-OP, and tracks as dependencies files mentioned during in :LOAD-FILE-FORM statements, etc. Some code has moved to new files or among old files, and between packages. Actions are now uniformly represented as a CONS of an OPERATION and a COMPONENT, where in some cases previously only the class of the operation was preserved. Forcing is constrained to be uniform across all phases of a top level ASDF operation invocation. Fixed the protocol for resetting systems being (re)defined, allowing subclasses to define default slot values. Remove *LOAD-SYSTEM-OPERATION*, as the current maintainer of ECL, for which it was originally designed, decided that it could never be made to work properly, after all. * ASDF&UIOP: Tweak dependencies between ASDF and UIOP. To avoid DEFINE-OP circularity, asdf.asd with no longer causes uiop.asd to be loaded. A standalone UIOP won't be loaded at all unless it's strictly more recent than ASDF. * Tests: tests for new capabilities and bugs. Test backtraces can be disabled. * Documentation: a number of improvements and clarifications. * Feature: a new feature :asdf3.3 * ECL: restored the deprecated function MAKE-BUILD, removed in 3.2.0, in a way that works on top of supported APIs (we still recommend you migrate to these supported APIs). Also stop using the deprecated COMPUTE-INIT-NAME. * Deprecation: starting to emit STYLE-WARNINGs for deprecated functions. Will gradually escalate to true WARNINGs and then ERRORs. -- Robert P. Goldman Sun, 20 August 2017 21:00:00 -0500 cl-asdf (2:3.2.1-1) unstable; urgency=low New release: * source-registry: resolve conflicts in a way compatible with Quicklisp. * Upgrade: make the upgrade logic more robust, especially on CCL. * Require-system: better normalize module vs system names on CMUCL MKCL SBCL. * Logical pathnames: fix bad-system-name warning behavior when using LPNs. * XDG: skip empty entries, for compatibility with Ubuntu * Bundles: numerous fixes for bundles especially so for ECL and MKCL. Don't try to combine .a's as it's not portable; only ever combine but .o's. Getting rid of the *load-system-operation*, now it's always load-op. * launch-program: more fixes, notably for ECL, clasp. * Deprecation: fix issues with the deprecation schedule of some functions. * Test and Release: fixes to the release process and to a few tests. * Documentation: a document describing best practices when using ASDF. -- Francois-Rene Rideau Sun, 03 Avril 2017 14:49:29 +0100 cl-asdf (2:3.2.0-1) unstable; urgency=low New milestone: * launch-program: new UIOP API for asynchronous subprocesses, now available on: abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl. Big thanks to Elias Pipping for this significant contribution! * parameter-error, not-implemented-error: new UIOP functions to better signal abuse of parameters in function calls, or lack of function implementation. * with-deprecation macro in UIOP signals style-warnings, then warnings, then errors when deprecated functions are used. This macro is now used for all deprecated functions in ASDF. * require-system, component-loaded-p fixed to not reload .asd files, and to work in presence of preloaded-systems, that are now eagerly loaded. * registered-system added as an abstraction for internals and extensions. * make-operation is now the only supported way to create an operation; calling make-instance directly will raise an error. Update your software! * Removal of several obsolete backward-compatible internals: if-component-dep-fails, operation-forced. Update SLIME! * Robustness and portability fixes all around uiop, notably dealing with directory access, bundles on ECL and MKCL or with cffi-toolchain, dealing with a fatal-condition, surviving use of "logical" pathnames, etc. * Tests improved and extensively run on Linux, macOS and, notably, Windows, with recent versions of all the maintained CL implementations. * Internals of ASDF systematically cleaned up and documented. * Build, test, release infrastructure improved, both classic and asdf-tools. * Documentation updated. -- Francois-Rene Rideau Sun, 08 Jan 2017 20:45:29 -0500 cl-asdf (2:3.1.7-1) unstable; urgency=low Bug fix and portability release: * Fix compilation on Genera. * Fix UIOP:FILE-EXISTS-P for dotfiles on CCL. * Fix infinite loop in source registry configuration that can occur when there are cycles in the filesystem (typically caused by symlinks) on some CL implementations. * Miscellaneous bug fixes. * Documentation improvements. * Restore original Makefile. -- Robert P. Goldman Wed, 23 Mar 2016 09:34:14 -0500 cl-asdf (2:3.1.6-1) unstable; urgency=low Bug fix and portability release: * Fix backtrace on SBCL. * Fix RUN-PROGRAM of string (shell command) on Windows SBCL (ticket #1501373). * Fix a number of issues with bundle operations (especially on non-C-compiler-based implementations). * Fix component-finding in package-inferred-system. * Fix race condition between multiple concurrent lisp processes doing ASDF builds (ticket #1483948). * Fix misplaced fasl cache on Windows. * Miscellaneous bug fixes. * Documentation improvements. -- Robert P. Goldman Sat, 17 Oct 2015 15:01:34 -0500 cl-asdf (2:3.1.5-1) unstable; urgency=low Bug fix and portability release: * Add immutable-system support (thanks to Dave Cooper). This support should be regarded as preliminary and subject to change. * Substantially improved operation on Windows: many bugfixes and improve- ments to UIOP functions that interface with the operating system. * Add CLASP support. * Many miscellaneous fixes for issues on individual implementations, notably UIOP incompatibility introduced by SBCL 1.2.12, support for LispWorks 7 character types, fixes to chdir on ABCL, improvements to run-program on Windows. * Added OS-COND to UIOP to paper over some incompatibilities about when and how operating system can be detected on different implementations. Made OS predicates run test at runtime so you can bind *features* from a target system and determine its OS. * Fixes to XDG configuration directory handling. Try to stick to the XDG spec, rather than guessing what it should be on different platforms. To recognize this, change UIOP functions about XDG files to "XDG-" prefixes. * Documentation improvements. -- François-René Rideau Sat, 18 Jul 2015 16:51:50 -0500 cl-asdf (2:3.1.4-1) unstable; urgency=low [ Robert P. Goldman ] Bug fix release: * Remove compatibility stubs for old bundle classes (not working properly, anyway), these are now available in a contrib. * Add INPUT-STRING function to UIOP. * For developer and tester convenience, bring all the external dependencies into the git repo as submodules. See target make ext * Optionally speed up registry search by providing a cache for the SOURCE-REGISTRY. See the cache-generating script in: asdf/tools/cl-source-registry-cache.lisp * Fixes to tests and documentation. * Many minor bugfixes. -- François-René Rideau Thu, 09 Oct 2014 21:18:21 -0400 cl-asdf (2:3.1.3-1) unstable; urgency=low Bug fix release: * A bug in 3.1.2 caused errors when hot-upgrading from 3.1.2 ASDF. * Fix bugs in ASDF component search caching. In some circumstances, aggressive caching (particularly of negative results) interfered with error-handling through restarts. Also, in some cases use of caching interfered with error-checking. Some of these issues are discussed in ticket #1335323 on launchpad. * Miscellaneous bug fixes and tweaks to UIOP. * Documentation improvements. -- Francois-Rene Rideau Mon, 14 Jul 2014 16:54:49 -0400 cl-asdf (2:3.1.2-2) unstable; urgency=low New release: * ~/common-lisp/ is now present by default in the source-registry, so you don't need to configure anything if you put source code there. * package-inferred-system implements the one-file, one-package, one-system paradigm of quick-build and faslpath as an extension to ASDF 3. * non-propagating-operation replaces OPERATION for operations as a base class to inherit from for operations that do not propagate, whereas for backward compatibility with ASDF 1 and 2, subclasses of OPERATION implicitly propagate DOWNWARD and SIDEWAYs. Failure to explicitly inherit from one of the explicitly propagating or non-propagating classes will result in a WARNING for now. * Accept strings as operation class designators in DEFSYSTEM, which provides better integration of ASDF extensions loaded using DEFSYSTEM-DEPENDS-ON. * force-not now takes precedence over force, and systems named in the *immutable-systems* set (represented as an equal hash-table) are always forced-not, and even their .asd is not refreshed from the filesystem. * portability is much improved, with support for the latest GCL, and fixes for ABCL, CLISP, ECL, LispWorks, MKCL, SBCL, XCL, etc. * bundle support was refactored, with many fixes to previously uncommon cases. ECL support is fixed, MKCL added, with a common extension to build programs without pulling in UIOP and with it the compiler. image-op was added to create heap images for use with e.g. cl-launch. load-fasl-op was renamed to load-bundle-op, fasl-op to compile-bundle-op, binary-op to deliver-asd-op, and so forth for the monolithic- variants; previous names remain available for backward compatibility. * robustness: Test improvements and new tests. Added missing dependencies in asdf.asd itself(!). Fixes to version-satisfies (thanks to stassats), to the file-stamp cache. Fix to regression from 3.0.2.12 whereby ASDF failed to avoid downgrading. Many cleanups. Many explanatory updates to source code comments. * run-program tweaked again, notably on Windows, on CLISP, and on implementations without a native run-program. On Windows, we punt on trying to ensure no final space is ever echo'ed by CMD.EXE " ". * provide both "asdf" and "ASDF" to play nicer with various Lisps. * upgrading from a sufficiently forward-compatible version (currently: 2.33) will be less disruptive of ASDF data and enhancements in the current image: previously loaded systems will not be cleared anymore, variables defined with defparameter* will not be reset. Punting on upgrades from ASDF 1 for more robust behavior. * make is the new name for build-system, as an experimental alternative interface to building software with ASDF — it operates with build-op, which itself delegates to *load-system-operation* by default. Prepare-op also delegates to *load-system-operation* on systems. You might bind that variable to load-bundle-op instead of load-op. * uiop much improved so as to be used with Google's build system blaze: with-temporary-file, dump-image / restore-image, ensure-pathname, compile-file*, with-saved-deferred-warnings. * Added portable API to optimization settings. * Refine detection of operating systems. os-macosx-p and os-unix-p no longer mutually exclusive. * asdf3.1 feature pushed, to signal the slew of significant improvements in over a year since initial ASDF 3.0 pre-release (i.e. version 2.27). * Substantially rewritten, updated, and expanded manual. * TODO updated. -- Francois-Rene Rideau Mon, 19 May 2014 20:07:40 -0400 cl-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 * Separate 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 asdf-3.3.4/doc/Makefile000066400000000000000000000023601362155115300146460ustar00rootroot00000000000000#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 asdf.tps all: asdf.html asdf.info asdf.pdf manual-html manual-html: asdf.texinfo makeinfo --html asdf.texinfo \ 2>&1 > manual-html.log || { echo "failed. See log in manual-html.log" ; exit 1 ;} asdf.html: asdf.texinfo makeinfo --html --no-split --no-headers -o asdf.html asdf.texinfo \ 2>&1 > asdf.html.log || { echo "failed. See log in asdf.html.log" ; exit 1 ;} asdf.info: asdf.texinfo makeinfo asdf.texinfo asdf.pdf: asdf.texinfo texi2pdf asdf.texinfo \ 2>&1 > asdf.pdf.log || { echo "failed. See log in asdf.pdf.log" ; exit 1 ;} website: all rsync -lt --no-g ${webfiles} ${website} rsync --recursive --no-g --delete asdf ${website} rsync -lt --no-g Changelog ${website}/changelog .PHONY: clean intermediate-clean manual-html intermediate-clean: rm -f ${intermediate} clean: intermediate-clean rm -f asdf.html asdf.pdf asdf.info rm -rf asdf/ asdf.t2d/ asdf-3.3.4/doc/asdf.texinfo000066400000000000000000010365211362155115300155300ustar00rootroot00000000000000\input texinfo @c -*- mode: texinfo; coding: utf-8 -*- @c %**start of header @documentencoding UTF-8 @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{https://common-lisp.net/project/asdf/asdf.html}. ASDF Copyright @copyright{} 2001-2019 Daniel Barlow and contributors. This manual Copyright @copyright{} 2001-2019 Daniel Barlow and contributors. This manual revised @copyright{} 2009-2019 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 @subtitle Manual for Version 3.3.4 @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 @ifnottex Manual for Version 3.3.4 @end ifnottex @insertcopying @menu * Introduction:: * Quick start summary:: * Loading ASDF:: * Configuring ASDF:: * Using ASDF:: * Defining systems with defsystem:: * The object model of ASDF:: * Controlling where ASDF searches for systems:: * Controlling where ASDF saves compiled files:: * Error handling:: * Miscellaneous additional functionality:: * Getting the latest version:: * FAQ:: * Ongoing Work:: * Bibliography:: * Concept Index:: * Function and Macro Index:: * Variable Index:: @c @detailmenu * Class and Type Index:: @c @detailmenu --- The Detailed Node Listing --- Loading ASDF * Loading a pre-installed ASDF:: * Checking whether ASDF is loaded:: * Upgrading ASDF:: * Replacing your implementation's ASDF:: * Loading ASDF from source:: Configuring ASDF * Configuring ASDF to find your systems:: * Configuring ASDF to find your systems --- old style:: * Configuring where ASDF stores object files:: * Resetting the ASDF configuration:: Using ASDF * Loading a system:: * Convenience Functions:: * Moving on:: Defining systems with defsystem * The defsystem form:: * A more involved example:: * The defsystem grammar:: * Other code in .asd files:: * The package-inferred-system extension:: The Object model of ASDF * Operations:: * Components:: * Dependencies:: * Functions:: Operations * Predefined operations of ASDF:: * Creating new operations:: Components * Common attributes of components:: * Pre-defined subclasses of component:: * Creating new component types:: properties * Pre-defined subclasses of component:: * Creating new component types:: Controlling where ASDF searches for systems * Configurations:: * Truenames and other dangers:: * XDG base directory:: * Backward Compatibility:: * Configuration DSL:: * Configuration Directories:: * Shell-friendly syntax for configuration:: * Search Algorithm:: * Caching Results:: * Configuration API:: * Introspection:: * Status:: * Rejected ideas:: * TODO:: * Credits for the source-registry:: Configuration Directories * The here directive:: Introspection * *source-registry-parameter* variable:: * Information about system dependencies:: Controlling where ASDF saves compiled files * Output Configurations:: * Output Backward Compatibility:: * Output Configuration DSL:: * Output Configuration Directories:: * Output Shell-friendly syntax for configuration:: * Semantics of Output Translations:: * Output Caching Results:: * Output location API:: * Credits for output translations:: Miscellaneous additional functionality * Controlling file compilation:: * Controlling source file character encoding:: * Miscellaneous Functions:: * Some Utility Functions:: FAQ * Where do I report a bug?:: * Mailing list:: * What has changed between ASDF 1 ASDF 2 and ASDF 3?:: * Issues with installing the proper version of ASDF:: * Issues with configuring ASDF:: * Issues with using and extending ASDF to define systems:: * ASDF development FAQs:: ``What has changed between ASDF 1, ASDF 2, and ASDF 3?'' * What are ASDF 1 2 3?:: * How do I detect the ASDF version?:: * ASDF can portably name files in subdirectories:: * Output translations:: * Source Registry Configuration:: * Usual operations are made easier to the user:: * Many bugs have been fixed:: * ASDF itself is versioned:: * ASDF can be upgraded:: * Decoupled release cycle:: * Pitfalls of the transition to ASDF 2:: * Pitfalls of the upgrade to ASDF 3:: * What happened to the bundle operations:: Issues with installing the proper version of ASDF * My Common Lisp implementation comes with an outdated version of ASDF. What to do?:: * I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?:: * After upgrading ASDF, ASDF (and Quicklisp) can't find my systems: After upgrading ASDF. Issues with configuring ASDF * How can I customize where fasl files are stored?:: * How can I wholly disable the compiler output cache?:: * How can I debug problems finding ASDF systems:: Issues with using and extending ASDF to define systems * How can I cater for unit-testing in my system?:: * How can I cater for documentation generation in my system?:: * How can I maintain non-Lisp (e.g. C) source files?:: * I want to put my module's files at the top level. How do I do this?:: * How do I create a system definition where all the source files have a .cl extension?:: * How do I mark a source file to be loaded only and not compiled?:: * How do I work with readtables?:: * How can I capture ASDF's output?:: * LOAD-PATHNAME has a weird value:: ASDF development FAQs * How do I run the tests interactively in a REPL?:: @end detailmenu @end menu @end ifnottex @c ------------------- @node Introduction, Quick start summary, Top, Top @comment node-name, next, previous, up @chapter Introduction @cindex ASDF-related features @vindex *features* @cindex Testing for ASDF @cindex ASDF versions @cindex :asdf @cindex :asdf2 @cindex :asdf3 ASDF, or Another System Definition Facility, is a @emph{build system}: a tool for specifying how systems of Common Lisp software are made up of components (sub-systems and files), and how to operate on these components in the right order so that they can be compiled, loaded, tested, etc. If you are new to ASDF, @pxref{Quick start summary,,the quick start guide}. ASDF presents three faces: one for users of Common Lisp software who want to reuse other people's code, one for writers of Common Lisp software who want to specify how to build their systems, and one for implementers of Common Lisp extensions who want to extend the build system. For more specifics, @pxref{Using ASDF}, to learn how to use ASDF to load a system. @xref{Defining systems with defsystem}, to learn how to define a system of your own. @xref{The object model of ASDF}, for a description of the ASDF internals and how to extend ASDF. Note that ASDF is @emph{not} a tool for library and system @emph{installation}; it plays a role like @code{make} or @code{ant}, not like a package manager. In particular, ASDF should not to be confused with Quicklisp or ASDF-Install, that attempt to find and download ASDF systems for you. Despite what the name might suggest, ASDF-Install was never a part of ASDF; it was always a separate piece of software. ASDF-Install has also been unmaintained and obsolete for a very long time. We recommend you use Quicklisp (@uref{http://www.quicklisp.org/}) instead, a Common Lisp package manager which works well and is being actively maintained. If you want to download software from version control instead of tarballs, so you may more easily modify it, we recommend clbuild (@uref{http://common-lisp.net/project/clbuild/}). As for where on your filesystem to install Common Lisp software, we recommend subdirectories of @file{~/common-lisp/}: starting with ASDF 3.1.2 (2014), this hierarchy is included in the default source-registry configuration. Finally, note that this manual is incomplete. All the bases are covered, but many advanced topics are only barely alluded to, and there is not much in terms of examples. The source code remains the ultimate source of information, free software systems in Quicklisp remain the best source of examples, and the mailing-list the best place to ask for help. @node Quick start summary, Loading ASDF, Introduction, Top @chapter Quick start summary @itemize @item To load an ASDF system: @itemize @item Load ASDF itself into your Lisp image, using @code{(require "asdf")}. Check that you have a recent version using @code{(asdf:asdf-version)}. For more details, or if any of the above fails, @pxref{Loading ASDF}. @item Make sure software is installed where ASDF can find it. The simplest way is to put all your Lisp code in subdirectories of @file{~/common-lisp/} (starting with ASDF 3.1.2), or @file{~/.local/share/common-lisp/source/} (for ASDF 2 and later, or if you want to keep source in a hidden directory). For more details, @pxref{Configuring ASDF to find your systems}. @item Load your system with @code{(asdf:load-system "@var{my-system}")}. @xref{Using ASDF}. @end itemize @item To make your own ASDF system: @itemize @item As above, load and configure ASDF. @item Make a new directory for your system, @code{@var{my-system}/}, again in a location where ASDF can find it. All else being equal, the easiest location is probably @file{~/common-lisp/my-system/}. @xref{Configuring ASDF to find your systems}. @item Create an ASDF system definition listing the dependencies of your system, its components, and their interdependencies, and put it in @file{@var{my-system}.asd}. This file must have the same name as your system, all lowercase. @xref{Defining systems with defsystem}. @item Use @code{(asdf:load-system "@var{my-system}")} to make sure it's all working properly. @xref{Using ASDF}. @end itemize @end itemize @c FIXME: (1) add a sample project that the user can cut and paste to @c get started. (2) discuss the option of starting with Quicklisp. @node Loading ASDF, Configuring ASDF, Quick start summary, Top @comment node-name, next, previous, up @chapter Loading ASDF @menu * Loading a pre-installed ASDF:: * Checking whether ASDF is loaded:: * Upgrading ASDF:: * Replacing your implementation's ASDF:: * Loading ASDF from source:: @end menu @node Loading a pre-installed ASDF, Checking whether ASDF is loaded, Loading ASDF, Loading ASDF @section Loading a pre-installed ASDF The recommended way to load ASDF is via: @lisp (require "asdf") @end lisp All actively maintained Lisp implementations now include a copy of ASDF 3 that you can load this way using Common Lisp's @code{require} function.@footnote{ NB: all implementations except GNU CLISP also accept @code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}. For portability's sake, you should use @code{(require "asdf")}. } If the implementation you are using doesn't provide a recent ASDF 3, we recommend you upgrade it. If for some reason you would rather not upgrade it, we recommend you replace your implementation's ASDF. @xref{Replacing your implementation's ASDF}. If all else fails, see @pxref{Loading ASDF from source} below. If you use an actively maintained implementation that fails to provide an up-to-date enough stable release of ASDF, you may also send a bug report to your Lisp vendor and complain about it --- or you may fix the issue yourself if it's free software. As of the writing of this manual, the following implementations provide ASDF 3 this way: ABCL, Allegro CL, CLASP, Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL. The following implementations only provide ASDF 2: MOCL, XCL. The following implementations don't provide ASDF: Corman CL, GCL, Genera, MCL, SCL. The latter implementations are not actively maintained (except maybe GCL); if some of them are ever released again, they probably will include ASDF 3. 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. SLIME notably sports a @code{slime-asdf} contrib that makes life easier with ASDF. @node Checking whether ASDF is loaded, Upgrading ASDF, Loading a pre-installed ASDF, Loading ASDF @section Checking whether ASDF is loaded To check that ASDF is properly loaded, 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 that version is suitably recent (say, 3.1.2 or later), then you can skip directly to next chapter: @xref{Configuring ASDF}. If it raises an error, then either ASDF is not loaded, or you are using a very old version of ASDF, and need to install ASDF 3. For more precision in detecting versions old and new, @pxref{How do I detect the ASDF version?}. 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. @node Upgrading ASDF, Replacing your implementation's ASDF, Checking whether ASDF is loaded, Loading ASDF @section Upgrading ASDF @c FIXME: tighten this up a bit -- there's a lot of stuff here that @c doesn't matter to almost anyone. Move discussion of updating antique @c versions of ASDF down, or encapsulate it. If your implementation already provides ASDF 3 or later (and it should), but you want a more recent ASDF version than your implementation provides, then you just need to ensure the more recent ASDF is installed in a configured path, like any other system. We recommend you download an official tarball or checkout a release from git into @file{~/common-lisp/asdf/}. (@pxref{Configuring ASDF to find your systems}). Once the source code for ASDF is installed, you don't need any extra step to load it beyond the usual @code{(require "asdf")}: ASDF 3 will automatically look whether an updated version of itself is available amongst the regularly configured systems, before it compiles anything else. If your implementation fails to provide ASDF 3 or later, @pxref{Replacing your implementation's ASDF}. @node Replacing your implementation's ASDF, Loading ASDF from source, Upgrading ASDF, Loading ASDF @section Replacing your implementation's ASDF All maintained implementations now provide ASDF 3 in their latest release. If yours doesn't, we recommend you upgrade it. Now, if you insist on using an old implementation that didn't provide ASDF or provided an old version, we recommend installing a recent ASDF, as explained below, into your implementation's installation directory. Thus your modified implementation will now provide ASDF 3. This requires proper write permissions and may necessitate execution as a system administrator. The ASDF source repository contains a tool to help you upgrade your implementation's ASDF. You can invoke it from the shell command-line as @code{tools/asdf-tools install-asdf lispworks} (where you can replace @code{lispworks} by the name of the relevant implementation), or you can @code{(load "tools/install-asdf.lisp")} from your Lisp REPL. This script works on Allegro CL, Clozure CL, CMU CL, ECL, GCL, GNU CLISP, LispWorks, MKCL, SBCL, SCL, XCL. It doesn't work on ABCL, Corman CL, Genera, MCL, MOCL. Happily, ABCL is usually pretty up to date and shouldn't need that script. GCL requires a very recent version, and hasn't been tested much. Corman CL, Genera, MCL are obsolete anyway. MOCL is incomplete. @node Loading ASDF from source, , Replacing your implementation's ASDF, Loading ASDF @section Loading ASDF from source If you write build scripts that must remain portable to old machines with old implementations that you cannot ensure have been upgraded or modified to provide a recent ASDF, you may 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{https://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 scripts that try to use ASDF simply via @code{require} at first, and make heroic attempts to load it the hard way if at first they don't succeed, see @file{tools/load-asdf.lisp} distributed with the ASDF source repository, or the code of @url{https://cliki.net/cl-launch,@code{cl-launch}}. @node Configuring ASDF, Using ASDF, Loading ASDF, Top @comment node-name, next, previous, up @chapter Configuring ASDF For standard use cases, ASDF should work pretty much out of the box. We recommend you skim the sections on configuring ASDF to find your systems and choose the method of installing Lisp software that works best for you. Then skip directly to @xref{Using ASDF}. That will probably be enough. You are unlikely to have to worry about the way ASDF stores object files, and resetting the ASDF configuration is usually only needed in corner cases. @menu * Configuring ASDF to find your systems:: * Configuring ASDF to find your systems --- old style:: * Configuring where ASDF stores object files:: * Resetting the ASDF configuration:: @end menu @node Configuring ASDF to find your systems, Configuring ASDF to find your systems --- old style, Configuring ASDF, Configuring ASDF @section Configuring ASDF to find your systems In order to compile and load your systems, ASDF must be configured to find the @file{.asd} files that contain system definitions. There are a number of different techniques for setting yourself up with ASDF, starting from easiest to the most complex: @itemize @bullet @item Put all of your systems in one of the standard locations, subdirectories of @itemize @item @file{~/common-lisp/} or @item @file{~/.local/share/common-lisp/source/}. @end itemize If you install software there, you don't need further configuration.@footnote{ @file{~/common-lisp/} is only included in the default configuration starting with ASDF 3.1.2 or later. If your implementation provides an earlier variant of ASDF, you may need to explicitly configure it to use this path, as further explained. } You can then skip to the next section. @xref{Loading a system}. @item If you're using some tool to install software (e.g. Quicklisp), the authors of that tool should already have configured ASDF. @item If you have more specific desires about how to lay out your software on disk, the preferred way to configure where ASDF finds your systems is the @code{source-registry} facility, fully described in its own chapter of this manual. @xref{Controlling where ASDF searches for systems}. Here is a quick recipe for getting started. First create the directory @file{~/.config/common-lisp/source-registry.conf.d/}@footnote{ For Windows users, and starting with ASDF 3.1.5, start from your @file{%LOCALAPPDATA%}, which is usually @file{~/AppData/Local/} (but you can ask in a @code{CMD.EXE} terminal @code{echo %LOCALAPPDATA%} to make sure) and underneath create a subpath @file{config/common-lisp/source-registry.conf.d/}. }; there create a file with any name of your choice but with the type @file{conf}@footnote{ By requiring the @file{.conf} extension, and ignoring other files, ASDF allows you to have disabled files, editor backups, etc. in the same directory with your active configuration files. ASDF will also ignore files whose names start with a @file{.} character. It is customary to start the filename with two digits, to control the sorting of the @code{conf} files in the source registry directory, and thus the order in which the directories will be scanned. }, for instance @file{50-luser-lisp.conf}; in this file, add the following line to tell ASDF to recursively scan all the subdirectories under @file{/home/luser/lisp/} for @file{.asd} files: @kbd{(:tree "/home/luser/lisp/")} That's enough. You may replace @file{/home/luser/lisp/} by wherever you want to install your source code. You don't actually need to specify anything if you use the default @file{~/common-lisp/} as above and your implementation provides ASDF 3.1.2 or later. If your implementation provides an earlier variant of ASDF 3, you might want to specify @kbd{(:tree (:home "common-lisp/"))} for bootstrap purposes, then install a recent source tree of ASDF under @file{~/common-lisp/asdf/}. If you prefer to use a ``link farm'', which is faster to use but costlier to manage than a recursive traversal, say at @file{/home/luser/.asd-link-farm/}, then you may instead (or additionally) create a file @file{42-asd-link-farm.conf}, containing the line: @kbd{(:directory "/home/luser/.asd-link-farm/")} ASDF will automatically read your configuration the first time you try to find a system. If necessary, you can reset the source-registry configuration with: @lisp (asdf:clear-source-registry) @end lisp @item In earlier versions of ASDF, the system source registry was configured using a global variable, @code{asdf:*central-registry*}. For more details about this, see the following section, @ref{Configuring ASDF to find your systems --- old style}. Unless you need to understand this, skip directly to @ref{Configuring where ASDF stores object files}. @end itemize Note that your Operating System distribution or your system administrator may already have configured system-managed libraries for you. @node Configuring ASDF to find your systems --- old style, Configuring where ASDF stores object files, Configuring ASDF to find your systems, Configuring ASDF @section Configuring ASDF to find your systems --- old style @c FIXME: this section should be moved elsewhere. The novice user @c should not be burdened with it. [2014/02/27:rpg] Novices may skip this section. Please @emph{do not} use the central-registry if you are a novice, and @emph{do not} instruct novices to use the central-registry. @c ``Experts may read it then proceed to ...'' @c some better section explaining @c *central-registry* vs source-registry vs *system-definition-search-functions*, @c and .../asdf/tools/cl-source-registry-cache.lisp 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 @emph{must} configure this variable @emph{after} you load ASDF 3 or later, yet @emph{before} the first time you try to use it. This loading and configuring of ASDF must happen as part of some initialization script: typically, either a script you maintain that builds your project, or your implementation's initialization script (e.g. @file{~/.sbclrc} for SBCL). Also, if you are using an ancient ASDF 2 or earlier to load ASDF 3 or later, then after it loads the ancient ASDF, your script @emph{must} configure the central-registry a first time to tell ASDF 1 or 2 where to find ASDF 3, then load ASDF 3 with e.g. @code{(asdf:operate 'asdf:load-op "asdf")}, then configure the central-registry again, because ASDF 3 will not preserve the central-registry from ASDF 2 when upgrading. You should probably be using the source-registry instead, which will be preserved (unless you manually called @code{asdf:initialize-source-registry} with an argument, in which case you will have to do it again indeed). However, if you are using an ancient ASDF 2 or earlier, we @emph{strongly} recommend that you should instead upgrade your implementation, or overwrite the ancient ASDF installation with a more recent one: @xref{Replacing your implementation's ASDF}. 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 example, let's say you want ASDF to find the @file{.asd} file @file{/home/me/src/foo/foo.asd}. In your Lisp initialization file, you could have the following: @lisp (require "asdf") (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 skip entries that evaluate to @code{nil}. Strings and pathname objects are self-evaluating, in which case the @code{eval} step does nothing; but you may push arbitrary s-expressions onto the central registry. These s-expressions may be evaluated to compute context-dependent entries, e.g. things that depend on the value of shell variables or the identity of the user. The variable @code{asdf:*central-registry*} is thus a list of ``system directory designators''. A @dfn{system directory designator} is a form which will be evaluated whenever a system is to be found, and must evaluate to a directory to look in (or @code{nil}). By ``directory'', we mean ``designator for a pathname with a non-empty DIRECTORY component''. } The trailing directory name separator is necessary to tell Lisp that you're discussing a directory rather than a file. If you leave it out, ASDF is likely to look in @code{/home/me/src/} instead of @code{/home/me/src/foo/} as you intended, and fail to find your system definition. Modern versions of ASDF will issue an error and offer you to remove such entries from the central-registry. Typically there are a lot of @file{.asd} files, and a common idiom was to put @emph{symbolic links} to all of one's @file{.asd} files in a common directory and push @emph{that} directory (the ``link farm'') onto @code{asdf:*central-registry*}, instead of pushing each individual system directory. ASDF knows to follow @emph{symlinks} to the actual location of the systems.@footnote{ On Windows, you can use Windows shortcuts instead of POSIX symlinks. if you try aliases under MacOS, we are curious to hear about your experience. } For example, if @code{#p"/home/me/cl/systems/"} is an element of @code{*central-registry*}, you could set up the system @var{foo} as follows: @example $ cd /home/me/cl/systems/ $ ln -s ~/src/foo/foo.asd . @end example This old style for configuring ASDF is not recommended for new users, but it is supported for old users, and for users who want a simple way to programmatically control what directories are added to the ASDF search path. @node Configuring where ASDF stores object files, Resetting the ASDF configuration, Configuring ASDF to find your systems --- old style, Configuring ASDF @section Configuring where ASDF stores object files @findex clear-output-translations ASDF lets you configure where object files will be stored. Sensible defaults are provided and you shouldn't normally have to worry about it. This allows the same source code repository to be shared between several versions of several Common Lisp implementations, between several users using different compilation options, with users who lack write privileges on shared source directories, etc. This also keeps source directories from being cluttered with object/fasl files. Starting with ASDF 2, the @code{asdf-output-translations} facility was added to ASDF itself. This facility controls where object files will be stored. This facility is fully described in a chapter of this manual, @ref{Controlling where ASDF saves compiled files}. @c FIXME: possibly this should be moved elsewhere. It's redundant here, @c and makes this section of the manual too long and daunting for the @c new user. [2014/02/27:rpg] @c The simplest way to add a translation to your search path, @c say from @file{/foo/bar/baz/quux/} @c to @file{/where/i/want/my/fasls/} @c is to create the directory @c @file{~/.config/common-lisp/asdf-output-translations.conf.d/} @c and there create a file with any name of your choice and the type @file{conf}, @c for instance @file{42-bazquux.conf} @c containing the line: @c @kbd{("/foo/bar/baz/quux/" "/where/i/want/my/fasls/")} @c To disable output translations for source under a given directory, @c say @file{/toto/tata/} @c you can create a file @file{40-disable-toto.conf} @c with the line: @c @kbd{("/toto/tata/")} @c To wholly disable output translations for all directories, @c you can create a file @file{00-disable.conf} @c with the line: @c @kbd{(t t)} @c Note that your Operating System distribution or your system administrator @c may already have configured translations for you. @c In absence of any configuration, the default is to redirect everything @c under an implementation-dependent subdirectory of @file{~/.cache/common-lisp/}. @c @xref{Controlling where ASDF searches for systems}, for full details. @c The required @file{.conf} extension allows you to have disabled files @c or editor backups (ending in @file{~}), and works portably @c (for instance, it is a pain to allow both empty and non-empty extension on CLISP). @c Excluded are files the name of which start with a @file{.} character. @c It is customary to start the filename with two digits @c that specify the order in which the directories will be scanned. @c ASDF will automatically read your configuration @c the first time you try to find a system. @c You can reset the source-registry configuration with: @c @lisp @c (asdf:clear-output-translations) @c @end lisp @c And you probably should do so before you dump your Lisp image, @c if the configuration may change @c between the machine where you save it at the time you save it @c and the machine you resume it at the time you resume it. @c (Once again, you should use @code{(asdf:clear-configuration)} @c before you dump your Lisp image, which includes the above.) Note that before ASDF 2, other ASDF add-ons offered the same functionality, each in subtly different and incompatible ways: ASDF-Binary-Locations, cl-launch, common-lisp-controller. ASDF-Binary-Locations is now not needed anymore and should not be used. cl-launch 3.000 and common-lisp-controller 7.2 have been updated to delegate object file placement to ASDF. @node Resetting the ASDF configuration, , Configuring where ASDF stores object files, Configuring ASDF @section Resetting the ASDF configuration @c FIXME: this should probably be moved out of the "quickstart" part of @c the manual. [2014/02/27:rpg] When you dump and restore an image, or when you tweak your configuration, you may want to reset the ASDF configuration. For that you may use the following function: @defun clear-configuration Undoes any ASDF configuration regarding source-registry or output-translations. @end defun @vindex *image-dump-hook* This function is pushed onto the @code{uiop:*image-dump-hook*} by default, which means that if you save an image using @code{uiop:dump-image}, or via @code{asdf:image-op} and @code{asdf:program-op}, it will be automatically called to clear your configuration. If for some reason you prefer to call your implementation's underlying functionality, be sure to call @code{clear-configuration} manually, or push it into your implementation's equivalent of @code{uiop:*image-dump-hook*}, e.g. @code{sb-ext:*save-hooks*} on SBCL, or @code{ext:*before-save-initializations*} on CMUCL and SCL, etc. @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top @chapter Using ASDF @menu * Loading a system:: * Convenience Functions:: * Moving on:: @end menu @node Loading a system, Convenience Functions, Using ASDF, 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 (@pxref{Convenience Functions}), ASDF hooks into the @code{cl:require} facility and you can just use: @example (require :@var{foo}) @end example Note that the canonical name of a system is a string, in @emph{lowercase}. System names can also be specified as symbols (including keyword symbols). If a symbol is given as argument, its package is ignored, its @code{symbol-name} is taken, and converted to lowercase. 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. Using lowercase as canonical is unconventional, but was selected after some consideration. The type of file systems we support either have lowercase as customary case (Unix, Mac, Windows) or silently convert lowercase to uppercase (lpns). @c so this makes more sense than attempting to use @code{:case :common}, @c which is reported not to work on some implementations @node Convenience Functions, Moving on, Loading a system, Using ASDF @section Convenience Functions @c I believe thes are all unnecessary because of the function macros @c below [2016/01/30:rpg] @c @findex load-system @c @findex compile-system @c @findex test-system @c @findex require-system @c @findex make ASDF provides three commands for the most common system operations: @code{load-system}, @code{compile-system}, and @code{test-system}. ASDF also provides @code{require-system}, a variant of @code{load-system} that skips loading systems that are already loaded. This is sometimes useful, for example, in order to avoid re-loading libraries that come pre-loaded into your lisp implementation. ASDF also provides @code{make}, a way of allowing system developers to choose a default operation for their systems. For example, a developer who has created a system intended to format a specific document, might make document-formatting the default operation invoked by @code{make}, instead of loading. If the system developer doesn't specify in the system definition, the default operation will be loading. @c FIXME: We seem to export @findex bundle-system also, that some ECL users seem to rely on. @c But it's probably better that bundle operations have their own manual chapter at some point. @c FIXME: There should be a @defun for OPERATE, but there isn't. Not @c sure where it belongs... The discussion here is just confusing if @c the reader doesn't understand how ASDF works. [2016/01/30:rpg] @findex operate @findex oos Because ASDF is an extensible system for defining @emph{operations} on @emph{components}, it also provides a generic function @code{operate}, so you may arbitrarily operate on your systems beyond the default operations. (At the interactive REPL, users often use its shorter alias @code{oos}, which stands for operate-on-system, a name inherited from @code{mk-defsystem}.) You'll use @code{operate} whenever you want to do something beyond compiling, loading and testing. @c Reminder: before ASDF can operate on a system, however, @c it must be able to find and load that system's definition. @c @xref{Configuring ASDF to find your systems}. @c FIXME: the following is too complicated for here, especially since @c :force hasn't been defined yet. Move it. [2014/02/27:rpg] @defun load-system system @Arest{} keys @Akey{} force force-not verbose version @AallowOtherKeys{} Apply @code{operate} with the operation @code{load-op}, the @var{system}, and any provided keyword arguments. Calling @code{load-system} is the regular, recommended way to load a system into the current image. @end defun @defun compile-system system @Arest{} keys @Akey{} force force-not verbose version @AallowOtherKeys{} Apply @code{operate} with the operation @code{compile-op}, the @var{system}, and any provided keyword arguments. This will make sure all the files in the system are compiled, but not necessarily load any of them in the current image; on most systems, it will @emph{not} load all compiled files in the current image. This function exists for symmetry with @code{load-system} but is not recommended unless you are writing build scripts and know what you're doing. But then, you might be interested in @code{program-op} rather than @code{compile-op}. @end defun @defun test-system system @Arest{} keys @Akey{} force force-not verbose version @AallowOtherKeys{} Apply @code{operate} with the operation @code{test-op}, the @var{system}, and any provided keyword arguments. @xref{test-op}. @end defun @defun make system @Arest{} keys @Akey{} @AallowOtherKeys{} Do ``The Right Thing'' with your system. Starting with ASDF 3.1, this function @code{make} is also available. The default behaviour is to load the system as if by @code{load-system}; but system authors can override this default in their system definition they may specify an alternate operation as the intended use of their system, with a @code{:build-operation} option in the @code{defsystem} form (@pxref{Build-operation}), and an intended output pathname for that operation with @code{:build-pathname}. @c Document :build-operation in the defsystem section. @c Document in the extension section that for richer programmatic access, you may instead use an overriding @c @code{(defmethod component-depends-on ((o build-op) (s system)) @c ...)}. This function is experimental and largely untested. Use at your own risk. @end defun @cindex build-operation @defun require-system system @Arest{} keys @Akey{} @AallowOtherKeys{} @code{require-system} skips any update to systems that have already been loaded, in the spirit of @code{cl:require}. It does it by calling @code{load-system} with a keyword option excluding already loaded systems.@footnote{ For the curious, the option is @code{:force-not (already-loaded-systems)}. }. On actively maintained free software implementations (namely recent versions of ABCL, Clozure CL, CMUCL, ECL, GNU CLISP, MKCL and SBCL), once ASDF itself is loaded, @code{cl:require} too can load ASDF systems, by falling back on @code{require-system} for module names not recognized by the implementation. (Note however that @code{require-system} does @emph{not} fall back on @code{cl:require}; that would introduce an ``interesting'' potential infinite loop to break somehow.) @code{cl:require} and @code{require-system} are appropriate to load code that is not being modified during the current programming session. @code{cl:require} will notably load the implementation-provided extension modules; @code{require-system} won't, unless they are also defined as systems somehow, which SBCL and MKCL do. @code{require-system} may also be used to load any number of ASDF systems that the user isn't either developing or debugging, for which a previously installed version is deemed to be satisfactory; @code{cl:require} on the above-mentioned implementations will delegate to @code{require-system} and may load them as well. But for code that you are actively developing, debugging, or otherwise modifying, you should use @code{load-system}, so ASDF will pick on your modifications and transitively re-build the modified files and everything that depends on them (that the requested @var{system} itself depends on --- ASDF itself never builds anything unless it's an explicitly requested system or the dependencies thereof). @end defun @defun already-loaded-systems Returns a list of names of the systems that have been successfully loaded so far. @end defun @node Moving on, , Convenience Functions, Using ASDF @section Moving on That's all you need to know to use ASDF to load systems written by others. The rest of this manual deals with writing system definitions for Common Lisp software you write yourself, including how to extend ASDF to define new operation and component types. @node Defining systems with defsystem, The object model of ASDF, Using ASDF, Top @comment node-name, next, previous, up @chapter Defining systems with defsystem This chapter describes how to use ASDF to define systems and develop software. @menu * The defsystem form:: * A more involved example:: * The defsystem grammar:: * Other code in .asd files:: * The package-inferred-system extension:: @end menu @node 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 @findex defsystem @cindex asdf-user @findex load-asd 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 should be saved as @file{hello-lisp.asd} (in order that ASDF can find it when ordered to operate on the system named @code{"hello-lisp"}). @lisp ;; Usual Lisp comments are allowed here (defsystem "hello-lisp" :description "hello-lisp: a sample Lisp system." :version "0.0.1" :author "Joe User " :licence "Public Domain" :depends-on ("optima.ppcre" "command-line-arguments") :components ((:file "packages") (:file "macros" :depends-on ("packages")) (:file "hello" :depends-on ("macros")))) @end lisp Some notes about this example: @itemize @item The @code{defsystem} form defines a system named @code{hello-lisp} that contains three source files: @file{packages.lisp}, @file{macros.lisp} and @file{hello.lisp}. @item The @file{.lisp} suffix is implicit for Lisp source files. The source files are located in the same directory as the @code{.asd} file with the system definition. @c FIXME: the following should live somewhere, but not in the quickstart @c page. [2014/05/03:rpg] @c ASDF resolves symbolic links (or Windows shortcuts) @c before loading the system definition file and @c stores its location in the resulting system@footnote{ @c It is possible, though almost never necessary, to override this behaviour.}. @c This is a good thing because the user can move the system sources @c without having to edit the system definition. @c FIXME: The first example system should probably use just :serial T. @item The file @file{macros} depends on @file{packages} (presumably because the package it's in is defined in @file{packages}), and the file @file{hello} depends on @file{macros} (and hence, transitively on @file{packages}). This means that ASDF will compile and load @file{packages} then @file{macros} before starting the compilation of file @file{hello}. @item This example system has external dependencies on two other systems, @code{optima.ppcre} (that provides a friendly interface to matching regular expressions), and @code{command-line-arguments} (that provides a way to parse arguments passed from the shell command line). To use this system, ASDF must be configured to find installed copies of these systems; it will load them before it tries to compile and load @code{hello-lisp}. @item This system also defines a bunch of metadata. While it is optional to define these fields (and other fields like @code{:bug-tracker}, @code{:mailto}, @code{:long-name}, @code{:long-description}, @code{:source-control}), it is strongly recommended to define the fields @code{:description}, @code{:version}, @code{:author}, and @code{:licence}, especially if you intend your software to be eventually included in Quicklisp. @c FIXME: Should have cross-reference to "Version specifiers" in the @c defsystem grammar, but the cross-referencing is so broken by @c insufficient node breakdown that I have not put one in. @c FIXME: this is way too detailed for the first example! @c move it! @item Make sure you know how the @code{:version} numbers will be parsed! Only period-separated non-negative integers are accepted at present. @xref{Version specifiers}. @item This file contains a single form, the @code{defsystem} declaration. No @code{in-package} form, no @code{asdf:} package prefix, no nothing. Just the one naked @code{defsystem} form. This is what we recommend. More complex system definition files are possible with arbitrary Lisp code, but we recommend that you keep it simple if you can. This will make your system definitions more robust and more future-proof. @cindex :version @end itemize This is all you need to know to define simple systems. The next example is much more involved, to give you a glimpse of how you can do more complex things. However, since it's ultimately arbitrary Lisp code, there is no bottom to the rabbit hole. @c FIXME: divide the next example into many examples, to introduce fewer concepts at once. @node A more involved example, The defsystem grammar, The defsystem form, Defining systems with defsystem @comment node-name, next, previous, up @section A more involved example @findex defsystem Let's illustrate some more involved uses of @code{defsystem} via a slightly convoluted example: @lisp (in-package :asdf-user) (defsystem "foo" :version (:read-file-form "variables" :at (3 2)) :components ((:file "package") (:file "variables" :depends-on ("package")) (:module "mod" :depends-on ("package") :serial t :components ((:file "utils") (:file "reader") (:file "cooker") (:static-file "data.raw")) :output-files (compile-op (o c) (list "data.cooked")) :perform (compile-op :after (o c) (cook-data :in (component-pathname (find-component c "data.raw")) :out (first (output-files o c))))) (:file "foo" :depends-on ("mod")))) (defmethod action-description ((o compile-op) (c (eql (find-component "foo" "mod")))) "cooking data") @end lisp Here are some notes about this example: @itemize @item The main thing this file does is define a system @code{foo}. It also contains other Lisp forms, which we'll examine below. @item Besides Lisp source files, this system contains a @code{:module} component named @code{"mod"}, which is a collection of three Lisp source files @file{utils.lisp}, @file{reader.lisp}, @file{cooker.lisp} and @file{data.raw} @item Note that the @code{:static-file} does not have an implicit file type, unlike the Lisp source files. @item This files will be located in a subdirectory of the main code directory named @file{mod/} (this location could have been overridden to be in the same directory, or in a different subdirectory; see the discussion of the @code{:pathname} option in @ref{The defsystem grammar}). @item The @code{:serial t} says that each sub-component of @code{mod} depends on the previous components, so that @file{cooker.lisp} depends-on @file{reader.lisp}, which depends-on @file{utils.lisp}. Also @file{data.raw} depends on all of them, but that doesn't matter since it's a static file; on the other hand, if it appeared first, then all the Lisp files would be recompiled when the data is modified, which is probably not what is desired in this case. @item The method-form tokens provide a shorthand for defining methods on particular components. This part @lisp :output-files (compile-op (o c) (list "data.cooked")) :perform (compile-op :after (o c) (cook-data :in (component-pathname (find-component c "data.raw")) :out (first (output-files o c)))) @end lisp has the effect of @lisp (defmethod output-files ((o compile-op) (c (eql ...))) (list "data.cooked")) (defmethod perform :after ((o compile-op) (c (eql ...))) (cook-data :in (component-pathname (find-component c "data.raw")) :out (first (output-files o 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, @pxref{The defsystem grammar}. For more details on what these methods do, @pxref{Operations} in @ref{The object model of ASDF}. @item There is an additional @code{defmethod} with a similar effect, because ASDF (as of ASDF 3.1.5) fails to accept inline-methods as above for @code{action-description}, instead only supporting the deprecated @code{explain} interface. @c FIXME: The following plunge into detail weeds is not appropriate in this @c location. [2010/10/03:rpg] @c note that although this also supports @code{:before} methods, @c they may not do what you want them to --- @c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))} @c will run after all the dependencies and sub-components have been processed, @c but before the component in question has been compiled. @item In this case, these methods describe how this module defines code that it then uses to cook some data. @item Importantly, ASDF is told about the input and output files used by the data cooker, and to make sure everyone agrees, the cooking function explicitly uses ASDF to access pathnames to the input and output data. @c FIXME: move most of this package discussion to its own section, @c and leave only a reference here. @item The file starts with a form @code{(in-package :asdf-user)}, but it is actually redundant, not necessary and not recommended. But yet more complex cases (also not recommended) may usefully use an @code{in-package} form. @item Indeed, ASDF does not load @file{.asd} files simply with @code{cl:load}, and neither should you. You should let ASDF find and load them when you operate on systems. If you somehow @emph{must} load a @file{.asd} file, use the same function @code{asdf:load-asd} that ASDF uses. Among other things, it already binds the @code{*package*} to @code{asdf-user}. Recent versions of SLIME (2013-02 and later) know to do that when you @kbd{C-c C-k} when you use the @code{slime-asdf} contrib. @item You shouldn't use an @code{in-package} form if you're keeping things simple. You should only use @code{in-package} (and before it, a @code{defpackage}) when you're going to define new classes, functions, variables, macros, etc., in the @code{.asd} file, and want to thereby avoid name clashes. Manuals for old versions of ASDF recommended use of such an idiom in @file{.asd} files, but as of ASDF 3, we recommend that you don't do that anymore, and instead define any ASDF extensions in their own system, on which you can then declare a dependency using @code{:defsystem-depends-on}. @xref{The defsystem grammar}. @item More generally, you can always rely on symbols from packages @code{asdf}, @code{common-lisp} and @code{uiop} being available in @code{.asd} files --- most importantly including @code{defsystem}. It is therefore redundant and in bad taste to use a package-prefixed @code{asdf:defsystem} symbol in a @file{.asd} file. Just use @code{(defsystem ...)}. Only package-prefix it when somehow dynamically generating system definitions from a package that doesn't already use the ASDF package. @item @code{asdf-user} is actually only available starting since ASDF 3, but then again, ASDF 1 and 2 did crazy things with packages that ASDF 3 has stopped doing@footnote{ ASDF 1 and 2 (up until 2.26) used to dynamically create and delete temporary packages @code{asdf@emph{N}}, one for each @file{.asd} file, in a misguided attempt to thereby reduce name clashes; but it failed at that goal and only made things more complex. ASDF 3 just uses a shared package @code{asdf-user} instead, and relies on the usual Common Lisp conventions to avoid clashes. As far as package oddities go, you may just notice that the @code{asdf-user} package also uses @code{uiop/common-lisp}, a variant of the @code{common-lisp} package that papers over deficiencies in more obscure Common Lisp implementations; but unless you care about Corman Lisp, GCL, Genera or MCL, you shouldn't be concerned. }, and since all implementations provide ASDF 3, you shouldn't care about compatibility with ASDF 2. We do not support ASDF 2 anymore, and we recommend that neither should you. @item Starting with ASDF 3.1, @code{asdf-user} uses @code{uiop}, whereas in earlier variants of ASDF 3 it only used @code{uiop/package}. We recommend you either prefix use of UIOP functions with the package prefix @code{uiop:}, or make sure your system @code{:depends-on ((:version "asdf" "3.1.2"))} or has a @code{#-asdf3.1 (error "MY-SYSTEM requires ASDF 3.1.2")}. @item Finally, we elided most metadata, but showed how you can have ASDF automatically extract the system's version from a source file. In this case, the 3rd subform of the 4th form (note that Lisp uses 0-based indexing, English uses 1-based indexing). Presumably, the 4th form looks like @code{(defparameter *foo-version* "5.6.7")}. @end itemize @node The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem @comment node-name, next, previous, up @section The defsystem grammar @findex defsystem @cindex DEFSYSTEM grammar @macro defrule {NAME} @anchor{rule-\NAME\}\NAME\ := @end macro @ifhtml @macro refrule {NAME} @ref{rule-\NAME\,\NAME\} @end macro @end ifhtml @ifinfo @macro refrule {NAME} @ref{rule-\NAME\,\NAME\,\NAME\,\NAME\} @end macro @end ifinfo @ifnothtml @ifnotinfo @macro refrule {NAME} \NAME\ @end macro @end ifnotinfo @end ifnothtml @example @defrule{system-definition} ( defsystem @refrule{system-designator} @refrule{system-option}* ) @defrule{system-designator} @refrule{simple-component-name} | @refrule{complex-component-name} # NOTE: Underscores are not permitted. # @pxref{Simple component names,Simple component names,Simple component names} @defrule{simple-component-name} @var{lower-case string} | @var{symbol} # @pxref{Complex component names,Complex component names,Complex component names} @defrule{complex-component-name} @var{string} | @var{symbol} @defrule{system-option} :defsystem-depends-on @refrule{system-list} | :weakly-depends-on @refrule{system-list} | :class @var{class-name} # @pxref{System class names} | :build-pathname @refrule{pathname-specifier} | :build-operation @refrule{operation-name} | @refrule{system-option/asdf3} | @refrule{module-option} | @refrule{option} # These are only available since ASDF 3 (actually its alpha release # 2.27) @defrule{system-option/asdf3} :homepage @var{string} | :bug-tracker @var{string} | :mailto @var{string} | :long-name @var{string} | :source-control @refrule{source-control} | :version @refrule{version-specifier} | :entry-point @var{object} # @pxref{Entry point} @defrule{source-control} ( @var{keyword} @var{string} ) @defrule{module-option} :components @refrule{component-list} | :serial [ t | nil ] @defrule{option} :description @var{string} | :long-description @var{string} | :author @refrule{person-or-persons} | :maintainer @refrule{person-or-persons} | :pathname @refrule{pathname-specifier} | :default-component-class @var{class-name} | :perform @refrule{method-form} | :explain @refrule{method-form} | :output-files @refrule{method-form} | :operation-done-p @refrule{method-form} | :if-feature @refrule{feature-expression} | :depends-on ( @refrule{dependency-def}* ) | :in-order-to ( @refrule{dependency}+ ) @defrule{person-or-persons} @var{string} | ( @var{string}+ ) @defrule{system-list} ( @refrule{simple-component-name}* ) @defrule{component-list} ( @refrule{component-def}* ) @defrule{component-def} ( @refrule{component-type} @refrule{simple-component-name} @refrule{option}* ) @defrule{component-type} :module | :file | :static-file | @refrule{other-component-type} @defrule{other-component-type} symbol-by-name # @pxref{Component types} # This is used in :depends-on, as opposed to "dependency", which is used # in :in-order-to @defrule{dependency-def} @refrule{simple-component-name} | ( :feature @refrule{feature-expression} @refrule{dependency-def} ) # @pxref{Feature dependencies} | ( :version @refrule{simple-component-name} @refrule{version-specifier} ) | ( :require @var{module-name} ) # "dependency" is used in :in-order-to, as opposed to "dependency-def" @defrule{dependency} ( @refrule{dependent-op} @refrule{requirement}+ ) @defrule{requirement} ( @refrule{required-op} @var{required-component}+ ) @defrule{dependent-op} @refrule{operation-name} @defrule{required-op} @refrule{operation-name} # NOTE: pathnames should be all lower case, and have no underscores, # although hyphens are permitted. @defrule{pathname-specifier} @var{pathname} | @var{string} | @var{symbol} @defrule{version-specifier} @var{string} | ( :read-file-form @refrule{pathname-specifier} @refrule{form-specifier}? ) | ( :read-file-line @refrule{pathname-specifier} @refrule{line-specifier}? ) @defrule{line-specifier} :at @var{integer} # base zero @defrule{form-specifier} :at [ @var{integer} | ( @var{integer}+ ) ] @defrule{method-form} ( @refrule{operation-name} @refrule{qual} @var{lambda-list} @Arest{} @var{body} ) @defrule{qual} @refrule{method-qualifier}? @defrule{method-qualifier} :before | :after | :around @defrule{feature-expression} @var{keyword} | ( :and @refrule{feature-expression}* ) | ( :or @refrule{feature-expression}* ) | ( :not @refrule{feature-expression} ) @defrule{operation-name} @var{symbol} @end example @subsection System designators System designators are either simple component names, or complex (``slashy'') component names. @subsection Simple component names (@code{simple-component-name}) @anchor{Simple component names} Simple component names may be written as either strings or symbols. When using strings, use lower case exclusively. Symbols will be interpreted as convenient shorthand for the string that is their @code{symbol-name}, converted to lower case. Put differently, a symbol may be a simple component name @emph{designator}, but the simple component name itself is the string. @strong{Never} use underscores in component names, whether written as strings or symbols. @strong{Never} use slashes (``/'') in simple component names. A slash indicates a @emph{complex} component name; see below. Using a slash improperly will cause ASDF to issue a warning. Violating these constraints by mixing case, or including underscores in component names, may lead to systems or components being impossible to find, because component names are interpreted as file names. These problems will @emph{definitely} occur for users who have configured ASDF using logical pathnames. @subsection Complex component names @anchor{Complex component names} A complex component name is a master name followed by a slash, followed by a subsidiary name. This allows programmers to put multiple system definitions in a single @code{.asd} file, while still allowing ASDF to find these systems. The master name of a complex system @strong{must} be the same as the name of the @code{.asd} file. The file @code{foo.asd} will contain the definition of the system @code{"foo"}. However, it may @emph{also} contain definitions of subsidiary systems, such as @code{"foo/test"}, @code{"foo/docs"}, and so forth. ASDF will ``know'' that if you ask it to load system @code{"foo/test"} it should look for that system's definition in @code{foo.asd}. @subsection Component types @anchor{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 @anchor{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 Build-operation @cindex :build-operation @anchor{Build-operation} The @code{:build-operation} option to @code{defsystem} allows the programmer to specify an operation that will be applied, in place of @code{load-op} when @code{make} (@pxref{Convenience Functions, make}) is run on the system. The option value should be the name of an operation. E.g., @code{:build-operation doc-op} This feature is experimental and largely untested. Use at your own risk. @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 behaviour; 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 behaviour may be removed without warning. @c Finally, you might look into the @code{asdf-system-connections} extension, @c that will let you define additional code to be loaded @c when two systems are simultaneously loaded. @c It may or may not be considered good style, but at least it can be used @c in a way that has deterministic behaviour independent of load order, @c unlike @code{weakly-depends-on}. @subsection Pathname specifiers @cindex pathname specifiers @anchor{Pathname specifiers} A pathname specifier (@code{pathname-specifier}) may be a pathname, a string or a symbol. When no pathname specifier is given for a component, which is the usual case, the component name itself is used. If a string is given, which is the usual case, the string will be interpreted as a Unix-style pathname where @code{/} characters will be interpreted as directory separators. Usually, Unix-style relative pathnames are used (i.e. not starting with @code{/}, as opposed to absolute pathnames); they are relative to the path of the parent component. Finally, depending on the @code{component-type}, the pathname may be interpreted as either a file or a directory, and if it's a file, a file type may be added corresponding to the @code{component-type}, or else it will be extracted from the string itself (if applicable). For instance, the @code{component-type} @code{:module} wants a directory pathname, and so a string @code{"foo/bar"} will be interpreted as the pathname @file{#p"foo/bar/"}. On the other hand, the @code{component-type} @code{:file} wants a file of type @code{lisp}, and so a string @code{"foo/bar"} will be interpreted as the pathname @file{#p"foo/bar.lisp"}, and a string @code{"foo/bar.quux"} will be interpreted as the pathname @file{#p"foo/bar.quux.lisp"}. Finally, the @code{component-type} @code{:static-file} wants a file without specifying a type, and so a string @code{"foo/bar"} will be interpreted as the pathname @file{#p"foo/bar"}, and a string @code{"foo/bar.quux"} will be interpreted as the pathname @file{#p"foo/bar.quux"}. ASDF interprets the string @code{".."} as the pathname directory component word @code{:back}, which when merged, goes back one level in the directory hierarchy. If a symbol is given, it will be translated into a string, and downcased in the process. The downcasing of symbols is unconventional, but was selected after some consideration. The file systems we 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. Please avoid using underscores in system names, or component (module or file) names, since underscores are not compatible with logical pathnames (@pxref{Using logical pathnames}). 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 behaviour of @code{parse-namestring} is completely non-portable, unless you are using Common Lisp @code{logical-pathname}s, which themselves involve other non-portable behaviour (@pxref{Using logical pathnames}). Pathnames made with @code{#.(make-pathname ...)} can usually be done more easily with the string syntax above. The only case that you really need a pathname object is to override the component-type default file type for a given component. Therefore, pathname objects should only rarely be used. Unhappily, ASDF 1 used not to properly support parsing component names as strings specifying paths with directories, and the cumbersome @code{#.(make-pathname ...)} syntax had to be used. An alternative to @code{#.} read-time evaluation is to use @code{(eval `(defsystem ... ,pathname ...))}. Note that when specifying pathname objects, ASDF does not do any special interpretation of the pathname influenced by the component type, unlike the procedure for pathname-specifying strings. On the one hand, you have to be careful to provide a pathname that correctly fulfills whatever constraints are required from that component type (e.g. naming a directory or a file with appropriate type); on the other hand, you can circumvent the file type that would otherwise be forced upon you if you were specifying a string. @subsection Version specifiers @cindex version specifiers @cindex :version @anchor{Version specifiers} Version specifiers are strings to be parsed as period-separated lists of integers. I.e., in the example, @code{"0.2.1"} is to be interpreted, roughly speaking, as @code{(0 2 1)}. In particular, version @code{"0.2.1"} is interpreted the same as @code{"0.0002.1"}, though the latter is not canonical and may lead to a warning being issued. Also, @code{"1.3"} and @code{"1.4"} are both strictly @code{uiop:version<} to @code{"1.30"}, quite unlike what would have happened had the version strings been interpreted as decimal fractions. Instead of a string representing the version, the @code{:version} argument can be an expression that is resolved to such a string using the following trivial domain-specific language: in addition to being a literal string, it can be an expression of the form @code{(:read-file-form [:at ])}, or @code{(:read-file-line [:at ])}. As the name suggests, the former 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), and the latter by reading a line. You may use a @code{uiop:access-at} specifier with the @code{:at} keyword, by default the specifier is @code{0}, meaning the first form/line is returned. For @code{:read-file-form}, subforms can also be specified, with e.g. @code{(1 2 2)} specifying ``the third subform (index 2) of the third subform (index 2) of the second form (index 1)'' in the file (mind the off-by-one error in the English language). System definers are encouraged to use version identifiers of the form @var{x}.@var{y}.@var{z} for major version, minor version and patch level, where significant API incompatibilities are signaled by an increased major number. @xref{Common attributes of components}. @subsection Require @cindex :require dependencies Use the implementation's own @code{require} to load the @var{module-name}. It is good taste to use @code{(:feature @emph{:implementation-name} (:require @var{module-name}))} rather than @code{#+@emph{implementation-name} (:require @var{module-name})} to only depend on the specified module on the specific implementation that provides it. @xref{Feature dependencies}. @subsection Feature dependencies @cindex :feature dependencies @anchor{Feature dependencies} A feature dependency is of the form @code{(:feature @var{feature-expression} @var{dependency})} If the @var{feature-expression} is satisfied by the running lisp at the time the system definition is parsed, then the @var{dependency} will be added to the system's dependencies. If the @var{feature-expression} is @emph{not} satisfied, then the feature dependency form is ignored. Note that this means that @code{:feature} @strong{cannot} be used to enforce a feature dependency for the system in question. I.e., it cannot be used to require that a feature hold in order for the system definition to be loaded. E.g., one cannot use @code{(:feature :sbcl)} to require that a system only be used on SBCL. Feature dependencies are not to be confused with the obsolete feature requirement (@pxref{feature requirement}), or with @code{if-feature}. @subsection Using logical pathnames @cindex logical pathnames @anchor{Using logical pathnames} We do not generally recommend the use of logical pathnames, especially not so to newcomers to Common Lisp. However, we do support the use of logical pathnames by old timers, when such is their preference. To use logical pathnames, you will have to provide a pathname object as a @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 @emph{before} they are used, (2) logical pathnames are limited to only portably use a single character case, digits and hyphens. While you can solve the first issue on your own, describing how to do it on each of fifteen implementations supported by ASDF is more than we can document. As for the second issue, mind that the limitation is notably enforced on SBCL, and that you therefore can't portably violate the limitations but must instead define some encoding of your own and add individual mappings to name physical pathnames that do not fit the restrictions. This can notably be a problem when your Lisp files are part of a larger project in which it is common to name files or directories in a way that includes the version numbers of supported protocols, or in which files are shared with software written in different programming languages where conventions include the use of underscores, dots or CamelCase in pathnames. @subsection Serial dependencies @cindex serial dependencies If the @code{:serial t} option is specified for a module, ASDF will add dependencies for each child component, on all the children textually preceding it. This is done as if by @code{:depends-on}. @lisp :serial t :components ((:file "a") (:file "b") (:file "c")) @end lisp is equivalent to @lisp :components ((:file "a") (:file "b" :depends-on ("a")) (:file "c" :depends-on ("a" "b"))) @end lisp @subsection Source location (@code{:pathname}) The @code{:pathname} option is optional in all cases for systems defined via @code{defsystem}, and generally is unnecessary. In the simple case, source files will be found in the same directory as the system or, in the case of modules, in a subdirectory with the same name as the module. @c FIXME: This should be moved elsewhere -- it's too much detail for the @c grammar section. More specifically, ASDF follows a hairy set of rules that are designed so that @enumerate @item @code{find-system} will load a system from disk and have its pathname default to the right place. @item This pathname information will not be overwritten with @code{*default-pathname-defaults*} (which could be somewhere else altogether) if the user loads up the @file{.asd} file into his editor and interactively re-evaluates that form. @end enumerate If a system is being loaded for the first time, its top-level pathname will be set to: @itemize @item The host/device/directory parts of @code{*load-truename*}, if it is bound. @item @code{*default-pathname-defaults*}, otherwise. @end itemize If a system is being redefined, the top-level pathname will be @itemize @item changed, if explicitly supplied or obtained from @code{*load-truename*} (so that an updated source location is reflected in the system definition) @item changed if it had previously been set from @code{*default-pathname-defaults*} @item left as before, if it had previously been set from @code{*load-truename*} and @code{*load-truename*} is currently unbound (so that a developer can evaluate a @code{defsystem} form from within an editor without clobbering its source location) @end itemize @subsection if-feature option @cindex :if-feature component option @anchor{if-feature option} @c redo if this ever becomes a node in @c its own right... This option allows you to specify a feature expression to be evaluated as if by @code{#+} to conditionally include a component in your build. If the expression is false, the component is dropped as well as any dependency pointing to it. As compared to using @code{#+} which is expanded at read-time, this allows you to have an object in your component hierarchy that can be used for manipulations beside building your project, and that is accessible to outside code that wishes to reason about system structure. Programmers should be careful to consider @strong{when} the @code{:if-feature} is evaluated. Recall that ASDF first computes a build plan, and then executes that plan. ASDF will check to see whether or not a feature is present @strong{at planning time}, not during the build. It follows that one cannot use @code{:if-feature} to check features that are set during the course of the build. It can only be used to check the state of features before any build operations have been performed. This option was added in ASDF 3. For more information, @xref{required-features, Required features}. @subsection Entry point @cindex :entry-point @anchor{Entry point} The @code{:entry-point} option allows a developer to specify the entry point of an executable program created by @code{program-op}. When @code{program-op} is invoked, the form passed to this option is converted to a function by @code{uiop:ensure-function} and bound to @code{uiop:*image-entry-point*}. Typically one will specify a string, e.g. @code{"foo:main"}, so that the executable starts with the @code{foo:main} function. Note that using the symbol @code{foo:main} instead might not work because the @code{foo} package doesn't necessarily exist when ASDF reads the @code{defsystem} form. For more information on @code{program-op}, @pxref{Predefined operations of ASDF}. @subsection feature requirement @anchor{feature requirement} This requirement was removed in ASDF 3.1. Please do not use it. In most cases, @code{:if-feature} (@pxref{if-feature option}) will provide an adequate substitute. The @code{feature} requirement used to ensure that a chain of component dependencies would fail when a key feature was absent. Used in conjunction with @code{:if-component-dep-fails} this provided a roundabout way to express conditional compilation. @node Other code in .asd files, The package-inferred-system extension, The defsystem grammar, Defining systems with defsystem @section Other code in .asd files Files containing @code{defsystem} forms are regular Lisp files that are executed by @code{load}. Consequently, you can put whatever Lisp code you like into these files. However, it is recommended to keep such forms to a minimal, and to instead define @code{defsystem} extensions that you use with @code{:defsystem-depends-on}. If however, you might insist on including code in the @file{.asd} file itself, e.g., to examine and adjust the compile-time environment, possibly adding appropriate features to @code{*features*}. If so, here are some conventions we recommend you follow, so that users can control certain details of execution of the Lisp in @file{.asd} files: @itemize @item Any informative output (other than warnings and errors, which are the condition system's to dispose of) should be sent to the standard CL stream @code{*standard-output*}, so that users can easily control the disposition of output from ASDF operations. @end itemize @node The package-inferred-system extension, , Other code in .asd files, Defining systems with defsystem @section The package-inferred-system extension @codequoteundirected on @cindex Package inferred systems @cindex Packages, inferring dependencies from @findex package-inferred-system @cindex One package per file systems Starting with release 3.1.2, ASDF supports a one-package-per-file style of programming, in which each file is its own system, and dependencies are deduced from the @code{defpackage} form or its variant, @code{uiop:define-package}. In this style of system definition, package names map to systems with the same name (in lower case letters), and if a system is defined with @code{:class package-inferred-system}, then system names that start with that name (using the slash @code{/} separator) refer to files under the filesystem hierarchy where the system is defined. For instance, if system @code{my-lib} is defined in @file{/foo/bar/my-lib/my-lib.asd}, then system @code{my-lib/src/utility} will be found in file @file{/foo/bar/my-lib/src/utility.lisp}. One package per file style was made popular by @code{faslpath} and @code{quick-build}, and at the cost of stricter package discipline, may yield more maintainable code. This style is used in ASDF itself (starting with ASDF 3), by @code{lisp-interface-library}, and a few other libraries. To use this style, choose a toplevel system name, e.g. @code{my-lib}, and create a file @file{my-lib.asd}. Define @code{my-lib} using the @code{:class :package-inferred-system} option in its @code{defsystem}. For instance: @example ;; This example is based on lil.asd of LISP-INTERFACE-LIBRARY. #-asdf3.1 (error "MY-LIB requires ASDF 3.1 or later.") (defsystem "my-lib" :class :package-inferred-system :depends-on ("my-lib/interface/all" "my-lib/src/all" "my-lib/extras/all") :in-order-to ((test-op (load-op "my-lib/test/all"))) :perform (test-op (o c) (symbol-call :my-lib/test/all :test-suite))) (defsystem "my-lib/test" :depends-on ("my-lib/test/all")) (register-system-packages "my-lib/interface/all" '(:my-lib-interface)) (register-system-packages "my-lib/src/all" '(:my-lib-implementation)) (register-system-packages "my-lib/test/all" '(:my-lib-test)) (register-system-packages "closer-mop" '(:c2mop :closer-common-lisp :c2cl :closer-common-lisp-user :c2cl-user)) @end example @noindent In the code above, the first form checks that we are using ASDF 3.1 or later, which provides @code{package-inferred-system}. This is probably no longer necessary, since none of the major lisp implementations provides an older version of ASDF. @findex register-system-packages The function @code{register-system-packages} must be called to register packages used or provided by your system when the name of the system/file that provides the package is not the same as the package name (converted to lower case). Each file under the @code{my-lib} hierarchy will start with a package definition. @findex define-package @findex uiop:define-package The form @code{uiop:define-package} is supported as well as @code{defpackage}. ASDF will compute dependencies from the @code{:use}, @code{:mix}, and other importation clauses of this package definition. Take the file @file{interface/order.lisp} as an example: @example (uiop:define-package :my-lib/interface/order (:use :closer-common-lisp :my-lib/interface/definition :my-lib/interface/base) (:mix :fare-utils :uiop :alexandria) (:export ...)) @end example ASDF can tell that this file/system depends on system @code{closer-mop} (registered above), @code{my-lib/interface/definition}, and @code{my-lib/interface/base}. How can ASDF find the file @file{interface/order.lisp} from the toplevel system @code{my-lib}, however? In the example above, @file{interface/all.lisp} (and other @file{all.lisp}) reexport all the symbols exported from the packages at the same or lower levels of the hierarchy. This can be easily done with @code{uiop:define-package}, which has many options that prove useful in this context. For example: @example (uiop:define-package :my-lib/interface/all (:nicknames :my-lib-interface) (:use :closer-common-lisp) (:mix :fare-utils :uiop :alexandria) (:use-reexport :my-lib/interface/definition :my-lib/interface/base :my-lib/interface/order :my-lib/interface/monad/continuation)) @end example Thus the top level system need only depend on the @code{my-lib/.../all} systems because ASDF detects @file{interface/order.lisp} and all other dependencies from @code{all} systems' @code{:use-reexport} clauses, which effectively allow for ``inheritance'' of symbols being exported. ASDF also detects dependencies from @code{:import-from} clauses. You may thus import a well-defined set of symbols from an existing package, and ASDF will know to load the system that provides that package. In the following example, ASDF will infer that the current system depends on @code{foo/baz} from the first @code{:import-from}. If you prefer to use any such symbol fully qualified by a package prefix, you may declare a dependency on such a package and its corresponding system via an @code{:import-from} clause with an empty list of symbols. For example, if we preferred to use the name `foo/quux:bletch`, the second, empty, @code{:import-from} form would cause ASDF to load @code{foo/quux}. @example (defpackage :foo/bar (:use :cl) (:import-from :foo/baz #:sym1 #:sym2) (:import-from :foo/quux) (:export ...)) @end example Note that starting with ASDF 3.1.5.6 only, ASDF will look for source files under the @code{component-pathname} (specified via the @code{:pathname} option), whereas earlier versions ignore this option and use the @code{system-source-directory} where the @file{.asd} file resides. @c See this blog post about it: @c @url{http://davazp.net/2014/11/26/modern-library-with-asdf-and-package-inferred-system.html} @codequoteundirected off @node The object model of ASDF, Controlling where ASDF searches for systems, Defining systems with defsystem, Top @comment node-name, next, previous, up @chapter The Object model of ASDF @tindex component @tindex operation ASDF is designed in an object-oriented way from the ground up. Both a system's structure and the operations that can be performed on systems follow an extensible protocol, allowing programmers to add new behaviours to ASDF. For example, @code{cffi} adds support for special FFI description files that interface with C libraries and for wrapper files that embed C code in Lisp. @code{asdf-jar} supports creating Java JAR archives in ABCL. @code{poiu} supports compiling code in parallel using background processes. The key classes in ASDF are @code{component} and @code{operation}. A @code{component} represents an individual source file or a group of source files, and the products (e.g., fasl files) produced from it. An @code{operation} represents a transformation that can be performed on a component, turning them from source files to intermediate results to final outputs. Components are related by @emph{dependencies}, specified in system definitions. When ordered to @code{operate} with some operation on a component (usually a system), ASDF will first compute a @emph{plan} by traversing the dependency graph using function @code{make-plan}.@footnote{ Historically, the function that built a plan was called @code{traverse}, and returned a list of actions; it was deprecated in favor of @code{make-plan} (that returns a plan object) when the @code{plan} objects were introduced with ASDF 3; the old function is kept for backward compatibility and debugging purposes only, and may be removed in the near future. } The resulting plan object contains an ordered list of @emph{actions}. An action is a pair of an @code{operation} and a @code{component}, representing a particular build step to be @code{perform}ed. The ordering of the plan ensures that no action is performed before all its dependencies have been fulfilled.@footnote{ The term @emph{action} was used by Kent Pitman in his article, ``The Description of Large Systems,'' (@pxref{Bibliography}), and we suspect might be traced to @code{make}. Although the term was only used by ASDF hackers starting with ASDF 2, the concept was there since the very beginning of ASDF 1, just not clearly articulated. } In this chapter, we describe ASDF's object-oriented protocol, the classes that make it up, and the generic functions on those classes. These generic functions often take both an operation and a component as arguments: much of the power and configurability of ASDF is provided by this use of CLOS's multiple dispatch. We will describe the built-in component and operation classes, and explain how to extend the ASDF protocol by defining new classes and methods for ASDF's generic functions. We will also describe the many @emph{hooks} that can be configured to customize the behaviour of existing @emph{functions}. @c FIXME: Swap operations and components. @c FIXME: Possibly add a description of the PLAN object. @c Not critical, since the user isn't expected to interact with it. @menu * Operations:: * Components:: * Dependencies:: * Functions:: @end menu @node Operations, Components, The object model of ASDF, The object model of ASDF @comment node-name, next, previous, up @section Operations @cindex operation An @dfn{operation} object of the appropriate type is instantiated whenever the user wants to do something with a system like @itemize @item compile all its files @item load the files into a running lisp environment @item copy its source files somewhere else @end itemize Operations can be invoked directly, or examined to see what their effects would be without performing them. There are a bunch of methods specialised on operation and component type that actually do the grunt work. Operations are invoked on systems via @code{operate} (@pxref{operate}). ASDF contains a number of pre-defined @t{operation} classes for common, and even fairly uncommon tasks that you might want to do with it. In addition, ASDF contains ``abstract'' @t{operation} classes that programmers can use as building blocks to define ASDF extensions. We discuss these in turn below. @c The operation object contains whatever state is relevant for this purpose @c (perhaps a list of visited nodes, for example) @c but primarily is a nice thing to specialise operation methods on @c and easier than having them all be @code{EQL} methods. @menu * Predefined operations of ASDF:: * Creating new operations:: @end menu Operations are invoked on systems via @code{operate}. @anchor{operate} @deffn {Generic function} operate @var{operation} @var{component} @Arest{} @var{initargs} @Akey{} @code{force} @code{force-not} @code{verbose} @AallowOtherKeys @deffnx {Generic function} oos @var{operation} @var{component} @Arest{} @var{initargs} @Akey{} @AallowOtherKeys{} @code{operate} invokes @var{operation} on @var{system}. @code{oos} is a synonym for @code{operate} (it stands for operate-on-system). @var{operation} is an operation designator: it can be an operation object itself, or, typically, a symbol that is passed to @code{make-operation} (which will call @code{make-instance}), to create the operation object. @var{component} is a component designator: it can be a component object itself, or, typically, a string or symbol (to be @code{string-downcase}d) that names a system, more rarely a list of strings or symbols that designate a subcomponent of a system. The ability to pass @var{initargs} to @code{make-operation} is now deprecated, and will be removed. For more details, @pxref{make-operation}. Note that dependencies may cause the operation to invoke other operations on the system or its components: the new operations may or may not be created with the same @var{initargs} as the original one (for the moment). If @var{force} is @code{:all}, then all systems are forced to be recompiled even if not modified since last compilation. If @var{force} is @code{t}, then only the system being loaded is forced to be recompiled even if not modified since last compilation, but other systems are not affected. If @var{force} is a list, then it specifies a list of systems that are forced to be recompiled even if not modified since last compilation. If @var{force-not} is @code{:all}, then all systems are forced not to be recompiled even if modified since last compilation. If @var{force-not} is @code{t}, then all systems but the system being loaded are forced not to be recompiled even if modified since last compilation (note: this was changed in ASDF 3.1.2). 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. @findex register-immutable-system @cindex immutable systems Both @var{force} and @var{force-not} apply to systems that are dependencies and were already compiled. @var{force-not} takes precedences over @var{force}, as it should, really, but unhappily only since ASDF 3.1.2. Moreover, systems which have been registered as immutable by @code{register-immutable-system} (since ASDF 3.1.5) are always considered @var{forced-not}, and even their @file{.asd} are not refreshed from the filesystem. @xref{Miscellaneous Functions}. @findex traverse To see what @code{operate} would do, you can use: @example (asdf:traverse operation-class system-name) @end example @end deffn @defun make-operation @var{operation-class} @Arest{} @var{initargs} @anchor{make-operation} The @var{initargs} are passed to @code{make-instance} call when creating the operation object. @strong{Note:}@var{initargs} for @code{operation}s are now deprecated, and will be removed from ASDF in the near future. @strong{Note:} @code{operation} instances must @strong{never} be created using @code{make-instance} directly: only through @code{make-operation}. Attempts to directly make @code{operation} instances will cause a run-time error. @end defun @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 @deftp Operation 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 deftp @deftp Operation load-op This operation loads the compiled code for a specified component. A @code{cl-source-file} will have its compiled fasl @code{load}ed, which fasl is the output of @code{compile-op} that @code{load-op} depends on. @code{load-op} will recursively load all the children of a system or module. @code{load-op} also depends on @code{prepare-op} which itself depends on a @code{load-op} of all of a component's dependencies, as well as of its parent's dependencies. @end deftp @deftp Operation 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 deftp @deftp Operation load-source-op @deftpx Operation prepare-source-op @code{load-source-op} will load the source for the files in a module rather than the compiled fasl output. It has a @code{prepare-source-op} analog to @code{prepare-op}, that ensures the dependencies are themselves loaded via @code{load-source-op}. @end deftp @anchor{test-op} @deftp Operation test-op This operation will perform some tests on the module. The default method will do nothing. The default dependency is to require @code{load-op} to be performed on the module first. Its default @code{operation-done-p} method returns @code{nil}, which means that the operation is @emph{never} done -- we assume that if you invoke the @code{test-op}, you want to test the system, even if you have already done so. The results of this operation are not defined by ASDF. It has proven difficult to define how the test operation should signal its results to the user in a way that is compatible with all of the various test libraries and test techniques in use in the community, and given the fact that ASDF operations do not return a value indicating success or failure. For those willing to go to the effort, we suggest defining conditions to signal when a @code{test-op} fails, and storing in those conditions information that describes which tests fail. People typically define a separate test @emph{system} to hold the tests. Doing this avoids unnecessarily adding a test framework as a dependency on a library. For example, one might have @lisp (defsystem "foo" :in-order-to ((test-op (test-op "foo/test"))) ...) (defsystem "foo/test" :depends-on ("foo" "fiveam") ; fiveam is a test framework library ...) @end lisp Then one defines @code{perform} methods on @code{test-op} such as the following: @lisp (defsystem "foo/test" :depends-on ("foo" "fiveam") ; fiveam is a test framework library :perform (test-op (o s) (uiop:symbol-call :fiveam '#:run! (uiop:find-symbol* '#:foo-test-suite :foo-tests))) ...) @end lisp @end deftp @deftp Operation compile-bundle-op @deftpx Operation monolithic-compile-bundle-op @deftpx Operation load-bundle-op @deftpx Operation monolithic-load-bundle-op @deftpx Operation deliver-asd-op @deftpx Operation monolithic-deliver-asd-op @deftpx Operation lib-op @deftpx Operation monolithic-lib-op @deftpx Operation dll-op @deftpx Operation monolithic-dll-op @deftpx Operation image-op @deftpx Operation program-op These are ``bundle'' operations, that can create a single-file ``bundle'' for all the contents of each system in an application, or for the entire application. @code{compile-bundle-op} will create a single fasl file for each of the systems needed, grouping all its many fasls in one, so you can deliver each system as a single fasl. @code{monolithic-compile-bundle-op} will create a single fasl file for the target system and all its dependencies, so you can deliver your entire application as a single fasl. @code{load-bundle-op} will load the output of @code{compile-bundle-op}. Note that if the output is not up-to-date, @code{compile-bundle-op} may load the intermediate fasls as a side-effect. Bundling fasls together matters a lot on ECL, where the dynamic linking involved in loading tens of individual fasls can be noticeably more expensive than loading a single one. NB: @code{compile-bundle-op}, @code{monolithic-compile-bundle-op}, @code{load-bundle-op}, @code{monolithic-load-bundle-op}, @code{deliver-asd-op}, @code{monolithic-deliver-asd-op} were respectively called @code{fasl-op}, @code{monolithic-fasl-op}, @code{load-fasl-op}, @code{monolithic-load-fasl-op}, @code{binary-op}, @code{monolithic-binary-op} before ASDF 3.1. The old names still exist for backward compatibility, though they poorly label what is going on. Once you have created a fasl with @code{compile-bundle-op}, you can use @code{precompiled-system} to deliver it in a way that is compatible with clients having dependencies on your system, whether it is distributed as source or as a single binary; the @file{.asd} file to be delivered with the fasl will look like this: @example (defsystem :mysystem :class :precompiled-system :fasl (some expression that will evaluate to a pathname)) @end example Or you can use @code{deliver-asd-op} to let ASDF create such a system for you as well as the @code{compile-bundle-op} output, or @code{monolithic-deliver-asd-op}. This allows you to deliver code for your systems or applications as a single file. Of course, if you want to test the result in the current image, @emph{before} you try to use any newly created @file{.asd} files, you should not forget to @code{(asdf:clear-configuration)} or at least @code{(asdf:clear-source-registry)}, so it re-populates the source-registry from the filesystem. The @code{program-op} operation will create an executable program from the specified system and its dependencies. You can use UIOP for its pre-image-dump hooks, its post-image-restore hooks, and its access to command-line arguments. And you can specify an entry point @code{my-app:main} by specifying in your @code{defsystem} the option @code{:entry-point "my-app:main"}. Depending on your implementation, running @code{(asdf:operate 'asdf:program-op :my-app)} may quit the current Lisp image upon completion. See the example in @file{test/hello-world-example.asd} and @file{test/hello.lisp}, as built and tested by @file{test/test-program.script} and @file{test/make-hello-world.lisp}. @code{image-op} will dump an image that may not be standalone and does not start its own function, but follows the usual execution convention of the underlying Lisp, just with more code pre-loaded, for use as an intermediate build result or with a wrapper invocation script. There is also @code{lib-op} for building a linkable @file{.a} file (Windows: @file{.lib}) from all linkable object dependencies (FFI files, and on ECL, Lisp files too), and its monolithic equivalent @code{monolithic-lib-op}. And there is also @code{dll-op} (respectively its monolithic equivalent @code{monolithic-dll-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 behaviour is not very satisfactory and may change in the future. Maybe you have suggestions on how to better configure it? @end deftp @deftp Operation concatenate-source-op @deftpx Operation monolithic-concatenate-source-op @deftpx Operation load-concatenated-source-op @deftpx Operation compile-concatenated-source-op @deftpx Operation load-compiled-concatenated-source-op @deftpx Operation monolithic-load-concatenated-source-op @deftpx Operation monolithic-compile-concatenated-source-op @deftpx Operation monolithic-load-compiled-concatenated-source-op These operations, as their respective names indicate, will concatenate all the @code{cl-source-file} source files in a system (or in a system and all its dependencies, if monolithic), in the order defined by dependencies, then load the result, or compile and then load the result. These operations are useful to deliver a system or application as a single source file, and for testing that said file loads properly, or compiles and then loads properly. ASDF itself is delivered as a single source file this way, using @code{monolithic-concatenate-source-op}, prepending a prelude and the @code{uiop} library before the @code{asdf/defsystem} system itself. @end deftp @node Creating new operations, , Predefined operations of ASDF, Operations @comment node-name, next, previous, up @subsection Creating new operations ASDF was designed to be extensible in an object-oriented fashion. To teach ASDF new tricks, a programmer can implement the behaviour he wants by creating a subclass of @code{operation}. ASDF's pre-defined operations are in no way ``privileged'', but it is requested that developers never use the @code{asdf} package for operations they develop themselves. The rationale for this rule is that we don't want to establish a ``global asdf operation name registry'', but also want to avoid name clashes. Your operation @emph{must} usually provide methods for one or more of the following generic functions: @itemize @findex perform @item @code{perform} Unless your operation, like @code{prepare-op}, is for dependency propagation only, the most important function for which to define a method is usually @code{perform}, which will be called to perform the operation on a specified component, after all dependencies have been performed. The @code{perform} method must call @code{input-files} and @code{output-files} (see below) to locate its inputs and outputs, because the user is allowed to override the method or tweak the output-translation mechanism. Perform should only use the primary value returned by @code{output-files}. If one and only one output file is expected, it can call @code{output-file} that checks that this is the case and returns the first and only list element. @findex output-files @item @code{output-files} If your perform method has any output, you must define a method for this function. for ASDF to determine where the outputs of performing operation lie. Your method may return two values, a list of pathnames, and a boolean. If the boolean is @code{nil} (or you fail to return multiple values), then enclosing @code{:around} methods may translate these pathnames, e.g. to ensure object files are somehow stored in some implementation-dependent cache. If the boolean is @code{t} then the pathnames are marked not be translated by the enclosing @code{:around} method. @findex component-depends-on @item @code{component-depends-on} If the action of performing the operation on a component has dependencies, you must define a method on @code{component-depends-on}. Your method will take as specialized arguments an operation and a component which together identify an action, and return a list of entries describing actions that this action depends on. The format of entries is described below. It is @emph{strongly} advised that you should always append the results of @code{(call-next-method)} to the results of your method, or ``interesting'' failures will likely occur, unless you're a true specialist of ASDF internals. It is unhappily too late to compatibly use the @code{append} method combination, but conceptually that's the protocol that is being manually implemented. Each entry returned by @code{component-depends-on} is itself a list. The first element of an entry is an operation designator: either an operation object designating itself, or a symbol that names an operation class (that ASDF will instantiate using @code{make-operation}). For instance, @code{load-op}, @code{compile-op} and @code{prepare-op} are common such names, denoting the respective operations. @c FIXME COERCE-NAME is referenced, but not defined. @findex coerce-name @findex find-component The rest of each entry is a list of component designators: either a component object designating itself, or an identifier to be used with @code{find-component}. @code{find-component} will be called with the current component's parent as parent, and the identifier as second argument. The identifier is typically a string, a symbol (to be downcased as per @code{coerce-name}), or a list of strings or symbols. In particular, the empty list @code{nil} denotes the parent itself. @end itemize An operation @emph{may} provide methods for the following generic functions: @itemize @item @code{input-files} @findex input-files A method for this function is often not needed, since ASDF has a pretty clever default @code{input-files} mechanism. You only need create a method if there are multiple ultimate input files. Most operations inherit from @code{selfward-operation}, which appropriately sets the input-files to include the source file itself. @c FIXME: Add documentation of built-in operation types. @defun input-files operation component Return a list of pathnames that represent the input to @var{operation} performed on @var{component}. @end defun @item @code{operation-done-p} @findex operation-done-p You only need to define a method on that function if you can detect conditions that invalidate previous runs of the operation, even though no filesystem timestamp has changed, in which case you return @code{nil} (the default is @code{t}). For instance, the method for @code{test-op} always returns @code{nil}, so that tests are always run afresh. Of course, the @code{test-op} for your system could depend on a deterministically repeatable @code{test-report-op}, and just read the results from the report files, in which case you could have this method return @code{t}. @end itemize Operations that print output should send that output to the standard CL stream @code{*standard-output*}, as the Lisp compiler and loader do. @node Components, Dependencies, Operations, The object model of ASDF @comment node-name, next, previous, up @section Components @cindex component @cindex system @cindex system designator @cindex component designator @vindex *system-definition-search-functions* A @code{component} represents an individual source file or a group of source files, and the things that get transformed into. A @code{system} is a component at the top level of the component hierarchy, that can be found via @code{find-system}. A @code{source-file} is a component representing a single source-file and the successive output files into which it is transformed. A @code{module} is an intermediate component itself grouping several other components, themselves source-files or further modules. A @dfn{system designator} is a system itself, or a string or symbol that behaves just like any other component name (including with regard to the case conversion rules for component names). A @dfn{component designator}, relative to a base component, is either a component itself, or a string or symbol, or a list of designators. @defun find-system system-designator @Aoptional{} (error-p t) Given a system designator, @code{find-system} finds and returns a system. If no system is found, an error of type @code{missing-component} is thrown, or @code{nil} is returned if @code{error-p} is false. To find and update systems, @code{find-system} funcalls each element in the @code{*system-definition-search-functions*} list, expecting a pathname to be returned, or a system object, from which a pathname may be extracted, and that will be registered. The resulting pathname (if any) is loaded if one of the following conditions is true: @itemize @item there is no system of that name in memory @item the pathname is different from that which was previously loaded @item the file's @code{last-modified} time exceeds the @code{last-modified} time of the system in memory @end itemize @cindex ASDF-USER package When system definitions are loaded from @file{.asd} files, they are implicitly loaded into the @code{ASDF-USER} package, which uses @code{ASDF}, @code{UIOP} and @code{UIOP/COMMON-LISP}@footnote{ Note that between releases 2.27 and 3.0.3, only @code{UIOP/PACKAGE}, not all of @code{UIOP}, was used; if you want your code to work with releases earlier than 3.1.2, you may have to explicitly define a package that uses @code{UIOP}, or use proper package prefix to your symbols, as in @code{uiop:version<}.} Programmers who do anything non-trivial in a @file{.asd} file, such as defining new variables, functions or classes, should include @code{defpackage} and @code{in-package} forms in this file, so they will not overwrite each others' extensions. Such forms might also help the files behave identically if loaded manually with @code{cl:load} for development or debugging, though we recommend you use the function @code{asdf::load-asd} instead, which the @code{slime-asdf} contrib knows about. The default value of @code{*system-definition-search-functions*} is a list of three 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}, but searches the filesystem only once and caches its results. The third function makes the @code{package-inferred-system} extension work, @pxref{The package-inferred-system extension}. Because of the way these search functions are defined, you should put the definition for a system @var{foo} in a file named @file{foo.asd}, in a directory that is in the central registry or which can be found using the source registry configuration. @c FIXME: Move this discussion to the system definition grammar, or somewhere else. @anchor{System names} @cindex System names @cindex Primary system name @findex primary-system-name It is often useful to define multiple systems in a same file, but ASDF can only locate a system's definition file based on the system name. For this reason, ASDF 3's system search algorithm has been extended to allow a file @file{foo.asd} to contain secondary systems named @var{foo/bar}, @var{foo/baz}, @var{foo/quux}, etc., in addition to the primary system named @var{foo}. The first component of a system name, separated by the slash character, @code{/}, is called the primary name of a system. The primary name may be extracted by function @code{asdf::primary-system-name}; when ASDF 3 is told to find a system whose name has a slash, it will first attempt to load the corresponding primary system, and will thus see any such definitions, and/or any definition of a @code{package-inferred-system}.@footnote{ ASDF 2.26 and earlier versions do not support this primary system name convention. With these versions of ASDF you must explicitly load @file{foo.asd} before you can use system @var{foo/bar} defined therein, e.g. using @code{(asdf:find-system "foo")}. We do not support ASDF 2, and recommend that you should upgrade to ASDF 3. } If your file @file{foo.asd} also defines systems that do not follow this convention, e.g., a system named @var{foo-test}, ASDF will not be able to automatically locate a definition for these systems, and will only see their definition if you explicitly find or load the primary system using e.g. @code{(asdf:find-system "foo")} before you try to use them. We strongly recommend against this practice, though it is currently supported for backward compatibility. @end defun @defun primary-system-name name Internal (not exported) function, @code{asdf::primary-system-name}. Returns the primary system name (the portion before the slash, @code{/}, in a secondary system name) from @var{name}. @end defun @defun locate-system name This function should typically @emph{not} be invoked directly. It is exported as part of the API only for programmers who wish to provide their own @code{*system-definition-search-functions*}. Given a system @var{name} designator, try to locate where to load the system definition from. @c (This does not include the loading of the system definition, @c which is done by @code{find-system}, @c or the loading of the system itself, which is done by @code{load-system}; @c however, for systems the definition of which has already been loaded, @c @code{locate-system} may return an object of class @code{system}.) Returns five values: @var{foundp}, @var{found-system}, @var{pathname}, @var{previous}, and @var{previous-time}. @var{foundp} is true when a system was found, either a new as yet unregistered one, or a previously registered one. The @var{found-system} return value will be a @code{system} object, if a system definition is found in your source registry. @c This system may be registered (by @code{register-system}) or may not, if @c it's preloaded code. Fare writes: @c In the case of preloaded code, as for "asdf", "uiop", etc., @c themselves, the system objects are not registered until after they are @c initially located by sysdef-preloaded-system-search as a fallback when @c no source code was found. The system definition will @emph{not} be loaded if it hasn't been loaded already. @var{pathname} when not null is a path from which to load the system, either associated with @var{found-system}, or with the @var{previous} system. If @var{previous} is not null, it will be a @emph{previously loaded} @code{system} object of the same name (note that the system @emph{definition} is previously-loaded: the system itself may or may not be). @var{previous-time} when not null is the timestamp of the previous system definition file, at the time when the @var{previous} system definition was loaded. For example, if your current registry has @file{foo.asd} in @file{/current/path/to/foo.asd}, but system @code{foo} was previously loaded from @file{/previous/path/to/foo.asd} then @var{locate-system} will return the following values: @enumerate @item @var{foundp} will be @code{t}, @item @var{found-system} will be @code{nil}, @item @var{pathname} will be @code{#p"/current/path/to/foo.asd"}, @item @var{previous} will be an object of type @code{SYSTEM} with @code{system-source-file} slot value of @code{#p"/previous/path/to/foo.asd"} @item @var{previous-time} will be the timestamp of @code{#p"/previous/path/to/foo.asd"} at the time it was loaded. @end enumerate @end defun @defun find-component base path Given a @var{base} component (or designator for such), and a @var{path}, find the component designated by the @var{path} starting from the @var{base}. If @var{path} is a component object, it designates itself, independently from the base. @findex coerce-name If @var{path} is a string, or symbol denoting a string via @code{coerce-name}, then @var{base} is resolved to a component object, which must be a system or module, and the designated component is the child named by the @var{path}. If @var{path} is a @code{cons} cell, @code{find-component} with the base and the @code{car} of the @var{path}, and the resulting object is used as the base for a tail call to @code{find-component} with the @code{car} of the @var{path}. If @var{base} is a component object, it designates itself. If @var{base} is null, then @var{path} is used as the base, with @code{nil} as the path. If @var{base} is a string, or symbol denoting a string via @code{coerce-name}, it designates a system as per @code{find-system}. If @var{base} is a @code{cons} cell, it designates the component found by @code{find-component} with its @code{car} as base and @code{cdr} as path. @end defun @menu * Common attributes of components:: * Pre-defined subclasses of component:: * Creating new component types:: @end menu @node Common attributes of components, Pre-defined subclasses of component, Components, Components @comment node-name, next, previous, up @subsection Common attributes of components All components, regardless of type, have the following attributes. All attributes except @code{name} are optional. @subsubsection Name @findex coerce-name A component name is a string or a symbol. If a symbol, its name is taken and lowercased. This translation is performed by the exported function @code{coerce-name}. Unless overridden by a @code{:pathname} attribute, the name will be interpreted as a pathname specifier according to a Unix-style syntax. @xref{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}. @xref{Version specifiers}. A version may then be queried by the generic function @code{version-satisfies}, to see if @code{:version} dependencies are satisfied, and when specifying dependencies, a constraint of minimal version to satisfy can be specified using e.g. @code{(:version "mydepname" "1.0.11")}. Note that in the wild, we typically see version numbering only on components of type @code{system}. Presumably it is much less useful within a given system, wherein the library author is responsible to keep the various files in synch. @subsubsection Required features @anchor{required-features} Traditionally defsystem users have used @code{#+} reader conditionals to include or exclude specific per-implementation files. For example, CFFI, the portable C foreign function interface contained lines like: @lisp #+sbcl (:file "cffi-sbcl") @end lisp An unfortunate side effect of this approach is that no single implementation can read the entire system. This causes problems if, for example, one wished to design an @code{archive-op} that would create an archive file containing all the sources, since for example the file @code{cffi-sbcl.lisp} above would be invisible when running the @code{archive-op} on any implementation other than SBCL. Starting with ASDF 3, components may therefore have an @code{:if-feature} option. The value of this option should be a feature expression using the same syntax as @code{#+} does. If that feature expression evaluates to false, any reference to the component will be ignored during compilation, loading and/or linking. Since the expression is read by the normal reader, you must explicitly prefix your symbols with @code{:} so they be read as keywords; this is as contrasted with the @code{#+} syntax that implicitly reads symbols in the keyword package by default. For instance, @code{:if-feature (:and :x86 (:or :sbcl :cmu :scl))} specifies that the given component is only to be compiled and loaded when the implementation is SBCL, CMUCL or Scieneer CL on an x86 machine. You cannot write it as @code{:if-feature (and x86 (or sbcl cmu scl))} since the symbols would not be read as keywords. @xref{if-feature option}. @subsubsection Dependencies This attribute specifies dependencies of the component on its siblings. It is optional but often necessary. There is an excitingly complicated relationship between the initarg and the method that you use to ask about dependencies Dependencies are between (operation component) pairs. In your initargs for the component, you can say @lisp :in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) (load-op (load-op "foo"))) @end lisp This means the following things: @itemize @item before performing compile-op on this component, we must perform load-op on @var{a} and @var{b}, and compile-op on @var{c}, @item before performing @code{load-op}, we have to load @var{foo} @end itemize The syntax is approximately @verbatim (this-op @{(other-op required-components)@}+) simple-component-name := string | symbol required-components := simple-component-name | (required-components required-components) component-name := simple-component-name | (:version simple-component-name minimum-version-object) @end verbatim Side note: This is on a par with what ACL defsystem does. mk-defsystem is less general: it has an implied dependency @verbatim for all source file x, (load x) depends on (compile x) @end verbatim and using a @code{:depends-on} argument to say that @var{b} depends on @var{a} @emph{actually} means that @verbatim (compile b) depends on (load a) @end verbatim This is insufficient for e.g. the McCLIM system, which requires that all the files are loaded before any of them can be compiled ] End side note In ASDF, the dependency information for a given component and operation can be queried using @code{(component-depends-on operation component)}, which returns a list @lisp ((load-op "a") (load-op "b") (compile-op "c") ...) @end lisp @code{component-depends-on} can be subclassed for more specific component/operation types: these need to @code{(call-next-method)} and append the answer to their dependency, unless they have a good reason for completely overriding the default dependencies. 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{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}. To find the CL pathname corresponding to a component, use @defun component-pathname component Returns the pathname corresponding to @var{component}. For components such as source files, this will be a filename pathname. For example: @lisp CL-USER> (asdf:component-pathname (asdf:find-system "xmls")) #P"/Users/rpg/lisp/xmls/" @end lisp and @lisp CL-USER> (asdf:component-pathname (asdf:find-component (asdf:find-system "xmls") "xmls")) #P"/Users/rpg/lisp/xmls/xmls.lisp" @end lisp @end defun @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 @deftp 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 deftp @deftp Component module A module is a collection of sub-components. A module component has the following extra initargs: @itemize @item @code{:components} the components contained in this module @item @code{:default-component-class} All children components which don't specify their class explicitly are inferred to be of this type. @item @code{:if-component-dep-fails} This attribute was removed in ASDF 3. Do not use it. Use @code{:if-feature} instead (@pxref{required-features}, and @pxref{if-feature option}). @item @code{:serial} When this attribute is set, each subcomponent of this component is assumed to depend on all subcomponents before it in the list given to @code{:components}, i.e. all of them are loaded before a compile or load operation is performed on it. @end itemize The default operation knows how to traverse a module, so most operations will not need to provide methods specialised on modules. @code{module} may be subclassed to represent components such as foreign-language linked libraries or archive files. @end deftp @deftp 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 deftp @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. @c FIXME: this should perhaps be explained more thoroughly, @c not only by example ... As an example, suppose we have some implementation-dependent functionality that we want to isolate in one subdirectory per Lisp implementation our system supports. We create a subclass of @code{cl-source-file}: @lisp (defclass unportable-cl-source-file (cl-source-file) ()) @end lisp Function @code{asdf:implementation-type} (exported since 2.014.14) gives us the name of the subdirectory. All that's left is to define how to calculate the pathname of an @code{unportable-cl-source-file}. @lisp (defmethod component-pathname ((component unportable-cl-source-file)) (merge-pathnames* (parse-unix-namestring (format nil "~(~A~)/" (asdf:implementation-type))) (call-next-method))) @end lisp The new component type is used in a @code{defsystem} form in this way: @lisp (defsystem :foo :components ((:file "packages") ... (:unportable-cl-source-file "threads" :depends-on ("packages" ...)) ... ) @end lisp @node Dependencies, Functions, Components, The object model of ASDF @section Dependencies @c FIXME: Moved this material here, but it isn't very comfortable @c here.... Also needs to be revised to be coherent. To be successfully build-able, this graph of actions must be acyclic. If, as a user, extender or implementer of ASDF, you introduce a cycle into the dependency graph, ASDF will fail loudly. To clearly distinguish the direction of dependencies, ASDF 3 uses the words @emph{requiring} and @emph{required} as applied to an action depending on the other: the requiring action @code{depends-on} the completion of all required actions before it may itself be @code{perform}ed. Using the @code{defsystem} syntax, users may easily express direct dependencies along the graph of the object hierarchy: between a component and its parent, its children, and its siblings. By defining custom CLOS methods, you can express more elaborate dependencies as you wish. Most common operations, such as @code{load-op}, @code{compile-op} or @code{load-source-op} are automatically propagate ``downward'' the component hierarchy and are ``covariant'' with it: to act the operation on the parent module, you must first act it on all the children components, with the action on the parent being parent of the action on each child. Other operations, such as @code{prepare-op} and @code{prepare-source-op} (introduced in ASDF 3) are automatically propagated ``upward'' the component hierarchy and are ``contravariant'' with it: to perform the operation of preparing for compilation of a child component, you must perform the operation of preparing for compilation of its parent component, and so on, ensuring that all the parent's dependencies are (compiled and) loaded before the child component may be compiled and loaded. Yet other operations, such as @code{test-op} or @code{load-bundle-op} remain at the system level, and are not propagated along the hierarchy, but instead do something global on the system. @node Functions, , Dependencies, The object model of ASDF @comment node-name, next, previous, up @section Functions @c FIXME: this does not belong here.... @defun version-satisfies @var{version} @var{version-spec} Does @var{version} satisfy the @var{version-spec}. A generic function. ASDF provides built-in methods for @var{version} being a @code{component} or @code{string}. @var{version-spec} should be a string. If it's a component, its version is extracted as a string before further processing. A version string satisfies the version-spec if after parsing, the former is no older than the latter. Therefore @code{"1.9.1"}, @code{"1.9.2"} and @code{"1.10"} all satisfy @code{"1.9.1"}, but @code{"1.8.4"} or @code{"1.9"} do not. For more information about how @code{version-satisfies} parses and interprets version strings and specifications, @pxref{Version specifiers} and @ref{Common attributes of components}. Note that in versions of ASDF prior to 3.0.1, including the entire ASDF 1 and ASDF 2 series, @code{version-satisfies} would also require that the version and the version-spec have the same major version number (the first integer in the list); if the major version differed, the version would be considered as not matching the spec. But that feature was not documented, therefore presumably not relied upon, whereas it was a nuisance to several users. Starting with ASDF 3.0.1, @code{version-satisfies} does not treat the major version number specially, and returns T simply if the first argument designates a version that isn't older than the one specified as a second argument. If needs be, the @code{(:version ...)} syntax for specifying dependencies could be in the future extended to specify an exclusive upper bound for compatible versions as well as an inclusive lower bound. @end defun @node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top @comment node-name, next, previous, up @chapter Controlling where ASDF searches for systems @menu * Configurations:: * Truenames and other dangers:: * XDG base directory:: * Backward Compatibility:: * Configuration DSL:: * Configuration Directories:: * Shell-friendly syntax for configuration:: * Search Algorithm:: * Caching Results:: * Configuration API:: * Introspection:: * Status:: * Rejected ideas:: * TODO:: * Credits for the source-registry:: @end menu @node Configurations, Truenames and other dangers, Controlling where ASDF searches for systems, Controlling where ASDF searches for systems @section Configurations Configurations specify paths where to find system files. @enumerate @item The search registry may use some hardcoded wrapping registry specification. This allows some implementations (notably SBCL) to specify where to find some special implementation-provided systems that need to precisely match the version of the implementation itself. @item An application may explicitly initialize the source-registry configuration using the configuration API (@pxref{Controlling where ASDF searches for systems,Configuration API,Configuration API}, below) in which case this takes precedence. It may itself compute this configuration from the command-line, from a script, from its own configuration file, etc. @item The source registry will be configured from the environment variable @code{CL_SOURCE_REGISTRY} if it exists. @item The source registry will be configured from user configuration file @file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf} (which defaults to @file{~/.config/common-lisp/source-registry.conf}) if it exists. @item The source registry will be configured from user configuration directory @file{$XDG_CONFIG_DIRS/common-lisp/source-registry.conf.d/} (which defaults to @file{~/.config/common-lisp/source-registry.conf.d/}) if it exists. @item The source registry will be configured from default user configuration trees @file{~/common-lisp/} (since ASDF 3.1.2 only), @file{~/.sbcl/systems/} (on SBCL only), @file{$XDG_DATA_HOME/common-lisp/systems/} (no recursion, link farm) @file{$XDG_DATA_HOME/common-lisp/source/}. The @code{XDG_DATA_HOME} directory defaults to @file{~/.local/share/}. On Windows, the @code{local-appdata} and @code{appdata} directories are used instead. @item The source registry will be configured from system configuration file @file{/etc/common-lisp/source-registry.conf} if it exists. @item The source registry will be configured from system configuration directory @file{/etc/common-lisp/source-registry.conf.d/} if it exists. @item The source registry will be configured from a default configuration. This configuration may allow for implementation-specific systems to be found, for systems to be found the current directory (at the time that the configuration is initialized) as well as @code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and @code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}, where @code{XDG_DATA_DIRS} defaults to @file{/usr/local/share} and @file{/usr/share} on Unix, and the @code{common-appdata} directory on Windows. @item The source registry may include implementation-dependent directories that correspond to implementation-provided extensions. @end enumerate Each of these configurations is specified as an s-expression in a trivial domain-specific language (defined below). Additionally, a more shell-friendly syntax is available for the environment variable (defined yet below). Each of these configurations is only used if the previous configuration explicitly or implicitly specifies that it includes its inherited configuration. Additionally, some implementation-specific directories may be automatically prepended to whatever directories are specified in configuration files, no matter if the last one inherits or not. @node Truenames and other dangers, XDG base directory, Configurations, Controlling where ASDF searches for systems @section Truenames and other dangers One great innovation of the original ASDF was its ability to leverage @code{CL:TRUENAME} to locate where your source code was and where to build it, allowing for symlink farms as a simple but effective configuration mechanism that is easy to control programmatically. ASDF 3 still supports this configuration style, and it is enabled by default; however we recommend you instead use our source-registry configuration mechanism described below, because it is easier to setup in a portable way across users and implementations. Additionally, some people dislike truename, either because it is very slow on their system, or because they are using content-addressed storage where the truename of a file is related to a digest of its individual contents, and not to other files in the same intended project. For these people, ASDF 3 allows to eschew the @code{TRUENAME} mechanism, by setting the variable @var{asdf:*resolve-symlinks*} to @code{nil}. PS: Yes, if you haven't read Vernor Vinge's short but great classic ``True Names... and Other Dangers'' then you're in for a treat. @node XDG base directory, Backward Compatibility, Truenames and other dangers, Controlling where ASDF searches for systems @section XDG base directory Note that we purport to respect the XDG base directory specification as to where configuration files are located, where data files are located, where output file caches are located. Mentions of XDG variables refer to that document. @url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} This specification allows the user to specify some environment variables to customize how applications behave to his preferences. On Windows platforms, even when not using Cygwin, and starting with ASDF 3.1.5, we still do a best effort at following the XDG base directory specification, even though it doesn't exactly fit common practice for Windows applications. However, we replace the fixed Unix paths @file{~/.local}, @file{/usr/local} and @file{/usr} with their rough Windows equivalent @file{Local AppData}, @file{AppData}, @file{Common AppData}, etc. 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, and are hopefully in synch with the Windows registry. If you care about the details, see @file{uiop/configuration.lisp} and don't hesitate to suggest improvements. @node Backward Compatibility, Configuration DSL, XDG base directory, Controlling where ASDF searches for systems @section Backward Compatibility For backward compatibility as well as to provide a practical backdoor for hackers, ASDF will first search for @file{.asd} files in the directories specified in @code{asdf:*central-registry*} before it searches in the source registry above. @xref{Configuring ASDF,,Configuring ASDF to find your systems --- old style}. By default, @code{asdf:*central-registry*} will be empty. This old mechanism will therefore not affect you if you don't use it, but will take precedence over the new mechanism if you do use it. @node Configuration DSL, Configuration Directories, Backward Compatibility, Controlling where ASDF searches for systems @section Configuration DSL @cindex :inherit-configuration source config directive @cindex inherit-configuration source config directive @cindex :ignore-invalid-entries source config directive @cindex ignore-invalid-entries source config directive @cindex :directory source config directive @cindex directory source config directive @cindex :tree source config directive @cindex tree source config directive @cindex :exclude source config directive @cindex exclude source config directive @cindex :also-exclude source config directive @cindex also-exclude source config directive @cindex :include source config directive @cindex include source config directive @cindex :default-registry source config directive @cindex default-registry source config directive Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration: @c FIXME: This is too wide for happy compilation into pdf. @example ;; A configuration is a single SEXP starting with the keyword ;; :source-registry followed by a list of directives. CONFIGURATION := (:source-registry DIRECTIVE ...) ;; A directive is one of the following: DIRECTIVE := ;; INHERITANCE DIRECTIVE: ;; Your configuration expression MUST contain ;; exactly one of the following: :inherit-configuration | ;; splices inherited configuration (often specified last) or :ignore-inherited-configuration | ;; drop inherited configuration (specified anywhere) ;; forward compatibility directive (since ASDF 2.011.4), useful when ;; you want to use new configuration features but have to bootstrap ;; the newer required ASDF from an older release that doesn't ;; support said features: :ignore-invalid-entries | ;; add a single directory to be scanned (no recursion) (:directory DIRECTORY-PATHNAME-DESIGNATOR) | ;; add a directory hierarchy, recursing but ;; excluding specified patterns (:tree DIRECTORY-PATHNAME-DESIGNATOR) | ;; override the defaults for exclusion patterns (:exclude EXCLUSION-PATTERN ...) | ;; augment the defaults for exclusion patterns (:also-exclude EXCLUSION-PATTERN ...) | ;; Note that the scope of a an exclude pattern specification is ;; the rest of the current configuration expression or file. ;; splice the parsed contents of another config file (:include REGULAR-FILE-PATHNAME-DESIGNATOR) | ;; This directive specifies that some default must be spliced. :default-registry REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ; interpreted as a file DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ; interpreted as a directory PATHNAME-DESIGNATOR := NIL | ;; Special: skip this entry. ABSOLUTE-COMPONENT-DESIGNATOR ;; see pathname DSL EXCLUSION-PATTERN := a string without wildcards, that will be matched exactly against the name of a any subdirectory in the directory component of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} @end example Pathnames are designated using another DSL, shared with the output-translations configuration DSL below. The DSL is resolved by the function @code{asdf::resolve-location}, to be documented and exported at some point in the future. @example ABSOLUTE-COMPONENT-DESIGNATOR := (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | STRING | ;; namestring (better be absolute or bust, directory assumed where ;; applicable). In output-translations, directory is assumed and ;; **/*.*.* added if it's last. On MCL, a MacOSX-style POSIX ;; namestring (for MacOS9 style, use #p"..."); Note that none of the ;; above applies to strings used in *central-registry*, which ;; doesn't use this DSL: they are processed as normal namestrings. ;; however, you can compute what you put in the *central-registry* ;; based on the results of say ;; (asdf::resolve-location "/Users/fare/cl/cl-foo/") PATHNAME | ;; pathname (better be an absolute path, or bust) ;; In output-translations, unless followed by relative components, ;; it better have appropriate wildcards, as in **/*.*.* :HOME | ; designates the user-homedir-pathname ~/ :USER-CACHE | ; designates the default location for the user cache :HERE | ;; designates the location of the configuration file ;; (or *default-pathname-defaults*, if invoked interactively) :ROOT ;; magic, for output-translations source only: paths that are relative ;; to the root of the source host and device They keyword :SYSTEM-CACHE is not accepted in ASDF 3.1 and beyond: it was a security hazard. RELATIVE-COMPONENT-DESIGNATOR := (RELATIVE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) | STRING | ;; relative directory pathname as interpreted by ;; parse-unix-namestring. ;; In output translations, if last component, **/*.*.* is added PATHNAME | ; pathname; unless last component, directory is assumed. :IMPLEMENTATION | ;; directory based on implementation, e.g. sbcl-1.0.45-linux-x64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :DEFAULT-DIRECTORY | ;; a relativized version of the default directory :*/ | ;; any direct subdirectory (since ASDF 2.011.4) :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4) :*.*.* | ;; any file (since ASDF 2.011.4) The keywords :UID and :USERNAME are no longer supported. @end example For instance, as a simple case, my @file{~/.config/common-lisp/source-registry.conf}, which is the default place ASDF looks for this configuration, once contained: @example (:source-registry (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" :inherit-configuration) @end example @node Configuration Directories, Shell-friendly syntax for configuration, Configuration DSL, Controlling where ASDF searches for systems @section Configuration Directories Configuration directories consist in files each containing a list of directives without any enclosing @code{(:source-registry ...)} form. The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included at the @emph{end} of the list. System-wide or per-user Common Lisp software distributions such as Debian packages or some future version of @code{clbuild} may then include files such as @file{/etc/common-lisp/source-registry.conf.d/10-foo.conf} or @file{~/.config/common-lisp/source-registry.conf.d/10-foo.conf} to easily and modularly register configuration information about software being distributed. The convention is that, for sorting purposes, the names of files in such a directory begin with two digits that determine the order in which these entries will be read. Also, the type of these files must be @file{.conf}, which not only simplifies the implementation by allowing for more portable techniques in finding those files, but also makes it trivial to disable a file, by renaming it to a different file type. Directories may be included by specifying a directory pathname or namestring in an @code{:include} directive, e.g.: @example (:include "/foo/bar/") @end example Hence, to achieve the same effect as my example @file{~/.config/common-lisp/source-registry.conf} above, I could simply create a file @file{~/.config/common-lisp/source-registry.conf.d/33-home-fare-cl.conf} alone in its directory with the following contents: @example (:tree "/home/fare/cl/") @end example @menu * The here directive:: @end menu @node The here directive, , Configuration Directories, Configuration Directories @subsection The :here directive The @code{:here} directive is an absolute pathname designator that refers to the directory containing the configuration file currently being processed. The @code{:here} directive is intended to simplify the delivery of complex CL systems, and for easy configuration of projects shared through revision control systems, in accordance with our design principle that each participant should be able to provide all and only the information available to him or her. Consider a person X who has set up the source code repository for a complex project with a master directory @file{dir/}. Ordinarily, one might simply have the user add a directive that would look something like this: @example (:tree "path/to/dir") @end example But what if X knows that there are very large subtrees under dir that are filled with, e.g., Java source code, image files for icons, etc.? All of the asdf system definitions are contained in the subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and these are the only directories that should be searched. In this case, X can put into @file{dir/} a file @file{asdf.conf} that contains the following: @example (:source-registry (:tree (:here "src/lisp/")) (:tree (:here "extlib/lisp")) (:directory (:here "outlier/"))) @end example Then when someone else (call her Y) checks out a copy of this repository, she need only add @example (:include "/path/to/my/checkout/directory/asdf.conf") @end example to one of her previously-existing asdf source location configuration files, or invoke @code{initialize-source-registry} with a configuration form containing that s-expression. ASDF will find the .conf file that X has provided, and then set up source locations within the working directory according to X's (relative) instructions. @node Shell-friendly syntax for configuration, Search Algorithm, Configuration Directories, Controlling where ASDF searches for systems @section Shell-friendly syntax for configuration When considering environment variable @code{CL_SOURCE_REGISTRY} ASDF will skip to next configuration if it's an empty string. It will @code{READ} the string as a SEXP in the DSL if it begins with a paren @code{(}, otherwise it will be interpreted much like @code{TEXINPUTS}, as a list of paths, where @itemize @item paths are separated by a @code{:} (colon) on Unix platforms (including cygwin), by a @code{;} (semicolon) on other platforms (mainly, Windows). @item each entry is a directory to add to the search path. @item if the entry ends with a double slash @code{//} then it instead indicates a tree in the subdirectories of which to recurse. @item if the entry is the empty string (which may only appear once), then it indicates that the inherited configuration should be spliced there. @end itemize @node Search Algorithm, Caching Results, Shell-friendly syntax for configuration, Controlling where ASDF searches for systems @section Search Algorithm @vindex *default-source-registry-exclusions* In case that isn't clear, the semantics of the configuration is that when searching for a system of a given name, directives are processed in order. When looking in a directory, if the system is found, the search succeeds, otherwise it continues. When looking in a tree, if one system is found, the search succeeds. If multiple systems are found, the consequences are unspecified: the search may succeed with any of the found systems, or an error may be raised. ASDF 3.2.1 or later returns the pathname whose normalized directory component has the shortest length (as a list), and breaks ties by choosing the system with the smallest @code{unix-namestring} when compared with @code{string<}. Earlier versions of ASDF return ASDF return the first system found, which is implementation-dependent, and may or may not be the pathname with the smallest @code{unix-namestring} when compared with @code{string<}. XCVB raises 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{Configurations} above). @node Caching Results, Configuration API, Search Algorithm, Controlling where ASDF searches for systems @section Caching Results The implementation is allowed to either eagerly compute the information from the configurations and file system, or to lazily re-compute it every time, or to cache any part of it as it goes. In practice, the recommended @code{source-registry} eagerly collects and caches results and you need to explicitly flush the cache for change to be taken into account, whereas the old-style @code{*central-registry*} mechanism queries the filesystem every time. To explicitly flush any information cached by the system after a change was made in the filesystem, @xref{Configuration API}, and e.g. call @code{asdf:clear-source-registry}. Starting with ASDF 3.1.4, you can also explicitly build a persistent cache of the @file{.asd} files found under a tree: when recursing into a directory declared by @code{:tree} and its transitive subdirectories, if a file @file{.cl-source-registry.cache} exists containing a form that is a list starting with @code{:source-registry-cache} followed by a list of strings, as in @code{(:source-registry-cache @emph{"foo/bar.asd" "path/to/more.asd" ...})}, then the strings are assumed to be @code{unix-namestring}s designating the available asd files under that tree, and the recursion otherwise stops. The list can also be empty, allowing to stop a costly recursion in a huge directory tree. To update such a cache after you install, update or remove source repositories, you can run a script distributed with ASDF: @code{tools/cl-source-registry-cache.lisp @emph{/path/to/directory}}. To wholly invalidate the cache, you can delete the file @file{.cl-source-registry.cache} in that directory. In either case, for an existing Lisp process to see this change, it needs to clear its own cache with e.g. @code{(asdf:clear-source-registry)}. Developers may safely create a cache in their development tree, and we recommend they do it at the top of their source tree if it contains more than a small number of files and directories; they only need update it when they create, remove or move @file{.asd} files. Software distribution managers may also safely create such a cache, but they must be careful to update it every time they install, update or remove a software source repository or installation package. Finally, advanced developers who juggle with a lot of code in their @code{source-registry} may manually manage such a cache, to allow for faster startup of Lisp programs. This persistence cache can help you reduce startup latency. For instance, on one machine with hundreds of source repositories, such a cache shaves half a second at the startup of every @code{#!/usr/bin/cl} script using SBCL, more on other implementations; this makes a notable difference as to their subjective interactivity and usability. The speedup will only happen if the implementation-provided ASDF is recent enough (3.1.3.7 or later); it is not enough for a recent ASDF upgrade to be present, since the upgrade will itself be found but after the old version has scanned the directories without heeding such a cache. To upgrade the implementation-provided ASDF, @pxref{Replacing your implementation's ASDF}. @node Configuration API, Introspection, Caching Results, Controlling where ASDF searches for systems @section Configuration API The specified functions are exported from your build system's package. Thus for ASDF the corresponding functions are in package ASDF, and for XCVB the corresponding functions are in package XCVB. @defun initialize-source-registry @Aoptional{} PARAMETER will read the configuration and initialize all internal variables. You may extend or override configuration from the environment and configuration files with the given @var{PARAMETER}, which can be @code{nil} (no configuration override), or a SEXP (in the SEXP DSL), a string (as in the string DSL), a pathname (of a file or directory with configuration), or a symbol (fbound to function that when called returns one of the above). @end defun @defun clear-source-registry undoes any source registry configuration and clears any cache for the search algorithm. You might want to call this function (or better, @code{clear-configuration}) before you dump an image that would be resumed with a different configuration, and return an empty configuration. Note that this does not include clearing information about systems defined in the current image, only about where to look for systems not yet defined. @end defun @defun ensure-source-registry @Aoptional{} PARAMETER checks whether a source registry has been initialized. If not, initialize it with the given @var{PARAMETER}. @end defun Every time you use ASDF's @code{find-system}, or anything that uses it (such as @code{operate}, @code{load-system}, etc.), @code{ensure-source-registry} is called with parameter @code{nil}, which the first time around causes your configuration to be read. If you change a configuration file, you need to explicitly @code{initialize-source-registry} again, or maybe simply to @code{clear-source-registry} (or @code{clear-configuration}) which will cause the initialization to happen next time around. @node Introspection, Status, Configuration API, Controlling where ASDF searches for systems @section Introspection @menu * *source-registry-parameter* variable:: * Information about system dependencies:: @end menu @node *source-registry-parameter* variable, Information about system dependencies, Introspection, Introspection @subsection *source-registry-parameter* variable @vindex *source-registry-parameter* We have made available the variable @code{*source-registry-parameter*} that can be used by code that wishes to introspect about the (past) configuration of ASDF's source registry. @strong{This variable should never be set!} It will be set as a side-effect of calling @code{initialize-source-registry}; user code should treat it as read-only. @node Information about system dependencies, , *source-registry-parameter* variable, Introspection @subsection Information about system dependencies ASDF makes available three functions to read system interdependencies. These are intended to aid programmers who wish to perform dependency analyses. @defun system-defsystem-depends-on system @end defun @defun system-depends-on system @end defun @defun system-weakly-depends-on system Returns a list of names of systems that are weakly depended on by @var{system}. Weakly depended on systems are optionally loaded only if ASDF can find them; failure to find such systems does @emph{not} cause an error in loading. Note that the return value for @code{system-weakly-depends-on} is simpler than the return values of the other two system dependency introspection functions. @end defun @node Status, Rejected ideas, Introspection, Controlling where ASDF searches for systems @section Status This mechanism is vastly successful, and we have declared that @code{asdf:*central-registry*} is not recommended anymore, though we will continue to support it. All hooks into implementation-specific search mechanisms have been integrated in the @code{wrapping-source-registry} that everyone uses implicitly. @node Rejected ideas, TODO, Status, Controlling where ASDF searches for systems @section Rejected ideas Alternatives I (FRR) considered and rejected while developing ASDF 2 included: @enumerate @item Keep @code{asdf:*central-registry*} as the master with its current semantics, and somehow the configuration parser expands the new configuration language into a expanded series of directories of subdirectories to lookup, pre-recursing through specified hierarchies. This is kludgy, and leaves little space of future cleanups and extensions. @item Keep @code{asdf:*central-registry*} as the master but extend its semantics in completely new ways, so that new kinds of entries may be implemented as a recursive search, etc. This seems somewhat backwards. @item Completely remove @code{asdf:*central-registry*} and break backwards compatibility. Hopefully this will happen in a few years after everyone migrate to a better ASDF and/or to XCVB, but it would be very bad to do it now. @item Replace @code{asdf:*central-registry*} by a symbol-macro with appropriate magic when you dereference it or setf it. Only the new variable with new semantics is handled by the new search procedure. Complex and still introduces subtle semantic issues. @end enumerate I've been suggested the below features, but have rejected them, for the sake of keeping ASDF no more complex than strictly necessary. @itemize @item More syntactic sugar: synonyms for the configuration directives, such as @code{(:add-directory X)} for @code{(:directory X)}, or @code{(:add-directory-hierarchy X)} or @code{(:add-directory X :recurse t)} for @code{(:tree X)}. @item The possibility to register individual files instead of directories. @item Integrate Xach Beane's tilde expander into the parser, or something similar that is shell-friendly or shell-compatible. I'd rather keep ASDF minimal. But maybe this precisely keeps it minimal by removing the need for evaluated entries that ASDF has? i.e. uses of @code{USER-HOMEDIR-PATHNAME} and @code{$SBCL_HOME} Hopefully, these are already superseded by the @code{:default-registry} @item Using the shell-unfriendly syntax @code{/**} instead of TEXINPUTS-like @code{//} to specify recursion down a filesystem tree in the environment variable. It isn't that Lisp friendly either. @end itemize @node TODO, Credits for the source-registry, Rejected ideas, Controlling where ASDF searches for systems @section TODO @itemize @item Add examples @end itemize @node Credits for the source-registry, , TODO, Controlling where ASDF searches for systems @section Credits for the source-registry Thanks a lot to Stelian Ionescu for the initial idea. Thanks to Rommel Martinez for the initial implementation attempt. All bad design ideas and implementation bugs are mine, not theirs. But so are good design ideas and elegant implementation tricks. --- Francois-Rene Rideau @email{fare@@tunes.org}, Mon, 22 Feb 2010 00:07:33 -0500 @node Controlling where ASDF saves compiled files, Error handling, Controlling where ASDF searches for systems, Top @comment node-name, next, previous, up @chapter Controlling where ASDF saves compiled files @cindex asdf-output-translations @vindex ASDF_OUTPUT_TRANSLATIONS Each Common Lisp implementation has its own format for compiled files or fasls.@footnote{``FASL'' is short for ``FASt Loading.''} If you use multiple implementations (or multiple versions of the same implementation), you'll soon find your source directories littered with various @file{fasl}s, @file{dfsl}s, @file{cfsl}s and so on. Worse yet, multiple implementations use the same file extension and some implementations maintain the same file extension while changing formats from version to version (or platform to platform). This can lead to many errors and much confusion as you switch from one implementation to the next. Finally, this requires write access to the source directory, and therefore precludes sharing of a same source code directory between multiple users. Since ASDF 2, ASDF includes the @code{asdf-output-translations} facility to mitigate the problem. @menu * Output Configurations:: * Output Backward Compatibility:: * Output Configuration DSL:: * Output Configuration Directories:: * Output Shell-friendly syntax for configuration:: * Semantics of Output Translations:: * Output Caching Results:: * Output location API:: * Credits for output translations:: @end menu @node Output Configurations, Output Backward Compatibility, Controlling where ASDF saves compiled files, Controlling where ASDF saves compiled files @section Configurations @c FIXME: Explain how configurations work: can't expect reader will have @c looked at previous chapter. Probably cut and paste will do. Configurations specify mappings from input locations to output locations. Once again we rely on the XDG base directory specification for configuration. @xref{Controlling where ASDF searches for systems,,XDG base directory}. @enumerate @item Some hardcoded wrapping output translations configuration may be used. This allows special output translations (or usually, invariant directories) to be specified corresponding to the similar special entries in the source registry. @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 trivial domain-specific language (@pxref{Configuration DSL}). Additionally, a more shell-friendly syntax is available for the environment variable (@pxref{Shell-friendly syntax for configuration}). When processing an entry in the above list of configuration methods, ASDF will stop unless that entry explicitly or implicitly specifies that it includes its inherited configuration. Note that by default, a per-user cache is used for output files. This allows the seamless use of shared installations of software between several users, and takes files out of the way of the developers when they browse source code, at the expense of taking a small toll when developers have to clean up output files and find they need to get familiar with output-translations first.@footnote{A @code{CLEAN-OP} would be a partial solution to this problem.} @node Output Backward Compatibility, Output Configuration DSL, Output Configurations, Controlling where ASDF saves compiled files @section Backward Compatibility @cindex ASDF-BINARY-LOCATIONS compatibility @c FIXME: Demote this section -- the typical reader doesn't care about @c backwards compatibility. We purposely do @emph{not} provide backward compatibility with earlier versions of @code{ASDF-Binary-Locations} (8 Sept 2009), @code{common-lisp-controller} (7.0) or @code{cl-launch} (2.35), each of which had similar general capabilities. The APIs of these programs were not designed for easy user configuration through configuration files. Recent versions of @code{common-lisp-controller} (7.2) and @code{cl-launch} (3.000) use the new @code{asdf-output-translations} API as defined below. @code{ASDF-Binary-Locations} is fully superseded and not to be used anymore. This incompatibility shouldn't inconvenience many people. Indeed, few people use and customize these packages; these few people are experts who can trivially adapt to the new configuration. Most people are not experts, could not properly configure these features (except inasmuch as the default configuration of @code{common-lisp-controller} and/or @code{cl-launch} might have been doing the right thing for some users), and yet will experience software that ``just works'', as configured by the system distributor, or by default. Nevertheless, if you are a fan of @code{ASDF-Binary-Locations}, we provide a limited emulation mode: @defun enable-asdf-binary-locations-compatibility @Akey{} centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings This function will initialize the new @code{asdf-output-translations} facility in a way that emulates the behaviour 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)}. @node Output Configuration DSL, Output Configuration Directories, Output Backward Compatibility, Controlling where ASDF saves compiled files @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 have ;; said features: :ignore-invalid-entries | ;; include a configuration file or directory (:include PATHNAME-DESIGNATOR) | ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ ;; or something. :enable-user-cache | ;; Disable global cache. Map / to / :disable-cache | ;; add a single directory to be scanned (no recursion) (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR) ;; use a function to return the translation of a directory designator (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION)) DIRECTORY-DESIGNATOR := NIL | ; As source: skip this entry. As destination: same as source T | ; as source matches anything, as destination ; maps pathname to itself. ABSOLUTE-COMPONENT-DESIGNATOR ; same as in the source-registry language TRANSLATION-FUNCTION := SYMBOL | ;; symbol naming a function that takes two arguments: ;; the pathname to be translated and the matching ;; DIRECTORY-DESIGNATOR LAMBDA ;; A form which evaluates to a function taking two arguments: ;; 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. @c FIXME: the following assumes that the reader is familiar with the use @c of this pattern in logical pathnames, which may not be a reasonable @c assumption. Expand. The last component, if not a pathname, is notionally completed by @file{/**/*.*}. You can specify more fine-grained patterns by using a pathname object as the last component e.g. @file{#p"some/path/**/foo*/bar-*.fasl"} You may use @code{#+features} to customize the configuration file. The second designator of a mapping may be @code{nil}, indicating that files are not mapped to anything but themselves (same as if the second designator was the same as the first). When the first designator is @code{t}, the mapping always matches. When the first designator starts with @code{:root}, the mapping matches any host and device. In either of these cases, if the second designator isn't @code{t} and doesn't start with @code{:root}, then strings indicating the host and pathname are somehow copied in the beginning of the directory component of the source pathname before it is translated. When the second designator is @code{t}, the mapping is the identity. When the second designator starts with @code{:root}, the mapping preserves the host and device of the original pathname. Notably, this allows you to map files to a subdirectory of the whichever directory the file is in. Though the syntax is not quite as easy to use as we'd like, you can have an (source destination) mapping entry such as follows in your configuration file, or you may use @code{enable-asdf-binary-locations-compatibility} with @code{:centralize-lisp-binaries nil} which will do the same thing internally for you: @lisp #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors))) (wild-file (make-pathname :name :wild :version :wild :type :wild))) `((:root ,wild-subdir ,wild-file) (:root ,wild-subdir :implementation ,wild-file))) @end lisp Starting with ASDF 2.011.4, you can use the simpler: @code{`(:root (:root :**/ :implementation :*.*.*))} @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 algorithm. Such a translation function is specified by supplying a list as the second @code{directory-designator} the first element of which is the keyword @code{:function}, and the second element of which is either a symbol which designates a function or a lambda expression. The function designated by the second argument must take two arguments, the first being the pathname of the source file, the second being the wildcard that was matched. When invoked, the function should return the translated pathname. An @code{:inherit-configuration} statement causes the search to recurse with the path specifications from the next configuration in the bulleted list. @xref{Controlling where ASDF saves compiled files,,Configurations}, above. @vindex asdf::*user-cache* @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)}. @end itemize @node Output Configuration Directories, Output Shell-friendly syntax for configuration, Output Configuration DSL, Controlling where ASDF saves compiled files @section Configuration Directories Configuration directories consist of files, each of which contains a list of directives without any enclosing @code{(:output-translations ...)} form. The files will be sorted by namestring as if by @code{string<} and the lists of directives of these files with be concatenated in order. An implicit @code{:inherit-configuration} will be included at the @emph{end} of the list. System-wide or per-user Common Lisp software distributions such as Debian packages or some future version of @code{clbuild} may then include files such as @file{/etc/common-lisp/asdf-output-translations.conf.d/10-foo.conf} or @file{~/.config/common-lisp/asdf-output-translations.conf.d/10-foo.conf} to easily and modularly register configuration information about software being distributed. The convention is that, for sorting purposes, the names of files in such a directory begin with two digits that determine the order in which these entries will be read. Also, the type of these files must be @file{.conf}, which not only simplifies the implementation by allowing for more portable techniques in finding those files, but also makes it trivial to disable a file, by renaming it to a different file type. Directories may be included by specifying a directory pathname or namestring in an @code{:include} directive, e.g.: @verbatim (:include "/foo/bar/") @end verbatim @node Output Shell-friendly syntax for configuration, Semantics of Output Translations, Output Configuration Directories, Controlling where ASDF saves compiled files @section Shell-friendly syntax for configuration When processing the environment variable @code{ASDF_OUTPUT_TRANSLATIONS}: @itemize @item ASDF will skip to the next configuration if it's an empty string. @item ASDF will @code{READ} the string as an SEXP in the DSL, if it begins with a parenthesis @code{(}. @item Otherwise ASDF will interpret the value as a list of directories (see below). @end itemize In the directory list format, directories should come in pairs, each pair indicating a mapping directive. Entries are separated by a @code{:} (colon) on Unix platforms (including Mac and cygwin), and 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; the next entry (if any) then starts a new pair. If the second entry in a pair is empty, it indicates that the directory in the first entry is to be left untranslated (which has the same effect as if the directory had been repeated). For example, @code{"/foo:/bar::/baz:"} means: specify that outputs for things under directory @file{/foo/} are translated to be under @file{/bar/}; then include the inherited configuration; then specify that outputs for things under directory @file{/baz/} are not translated. @node Semantics of Output Translations, Output Caching Results, Output Shell-friendly syntax for configuration, Controlling where ASDF saves compiled files @section Semantics of Output Translations From the specified configuration, a list of mappings is extracted in a straightforward way: mappings are collected in order, recursing through included or inherited configuration as specified. To this list is prepended some implementation-specific mappings, and is appended a global default. The list is then compiled to a mapping table as follows: for each entry, in order, resolve the first designated directory into an actual directory pathname for source locations. If no mapping was specified yet for that location, resolve the second designated directory to an output location directory add a mapping to the table mapping the source location to the output location, and add another mapping from the output location to itself (unless a mapping already exists for the output location). Based on the table, a mapping function is defined, mapping source pathnames to output pathnames: given a source pathname, locate the longest matching prefix in the source column of the mapping table. Replace that prefix by the corresponding output column in the same row of the table, and return the result. If no match is found, return the source pathname. (A global default mapping the filesystem root to itself may ensure that there will always be a match, with same fall-through semantics). @node Output Caching Results, Output location API, Semantics of Output Translations, Controlling where ASDF saves compiled files @section Caching Results The implementation is allowed to either eagerly compute the information from the configurations and file system, or to lazily re-compute it every time, or to cache any part of it as it goes. To explicitly flush any information cached by the system, use the API below. @node Output location API, Credits for output translations, Output Caching Results, Controlling where ASDF saves compiled files @section Output location API The specified functions are exported from package ASDF. @defun initialize-output-translations @Aoptional{} PARAMETER will read the configuration and initialize all internal variables. You may extend or override configuration from the environment and configuration files with the given @var{PARAMETER}, which can be @code{nil} (no configuration override), or a SEXP (in the SEXP DSL), a string (as in the string DSL), a pathname (of a file or directory with configuration), or a symbol (fbound to function that when called returns one of the above). @end defun @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. @node Credits for output translations, , Output location API, Controlling where ASDF saves compiled files @section Credits for output translations Thanks a lot to Peter van Eynde for @code{Common Lisp Controller} and to Bjorn Lindberg and Gary King for @code{ASDF-Binary-Locations}. 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 @tindex system-definition-error @tindex 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-failure-behaviour* ASDF checks for warnings and errors when a file is compiled. The variables @var{*compile-file-warnings-behaviour*} and @var{*compile-file-failure-behaviour*} 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. @menu * Controlling file compilation:: * Controlling source file character encoding:: * Miscellaneous Functions:: * Some Utility Functions:: @end menu @node Controlling file compilation, Controlling source file character encoding, Miscellaneous additional functionality, Miscellaneous additional functionality @section Controlling file compilation @cindex :around-compile @cindex around-compile keyword @cindex compile-check keyword @cindex :compile-check @findex compile-file* @c FIXME: Needs rewrite. Start with motivation -- why are we doing @c this? (there is some, but it's buried). Also, all of a sudden in @c the middle of the discussion we start talking about a "hook," which @c is confusing. When declaring a component (system, module, file), you can specify a keyword argument @code{:around-compile function}. If left unspecified (and therefore unbound), the value will be inherited from the parent component if any, or with a default of @code{nil} if no value is specified in any transitive parent. The argument must be either @code{nil}, an fbound symbol, a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk ...) ...)}) a function object (e.g. using @code{#.#'} but that's discouraged because it prevents the introspection done by e.g. asdf-dependency-grovel), or a string that when @code{read} yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. A non-nil value designates a function of one argument that will be called with a function that will invoke @code{compile-file*} with various arguments; the around-compile hook may supply additional keyword arguments to pass to that call to @code{compile-file*}. One notable argument that is heeded by @code{compile-file*} is @code{:compile-check}, a function called when the compilation was otherwise a success, with the same arguments as @code{compile-file}; the function shall return true if the compilation and its resulting compiled file respected all system-specific invariants, and false (@code{nil}) if it broke any of those invariants; it may issue warnings or errors before it returns @code{nil}. (NB: The ability to pass such extra flags is only available starting with ASDF 2.22.3.) This feature is notably exercised by asdf-finalizers. By using a string, you may reference a function, symbol and/or package that will only be created later during the build, but isn't yet present at the time the defsystem form is evaluated. However, if your entire system is using such a hook, you may have to explicitly override the hook with @code{nil} for all the modules and files that are compiled before the hook is defined. Using this hook, you may achieve such effects as: locally renaming packages, binding @var{*readtables*} and other syntax-controlling variables, handling warnings and other conditions, proclaiming consistent optimization settings, saving code coverage information, maintaining meta-data about compilation timings, setting gensym counters and PRNG seeds and other sources of non-determinism, overriding the source-location and/or timestamping systems, checking that some compile-time side-effects were properly balanced, etc. Note that there is no around-load hook. This is on purpose. Some implementations such as ECL, GCL or MKCL link object files, which allows for no such hook. Other implementations allow for concatenating FASL files, which doesn't allow for such a hook either. We aim to discourage something that's not portable, and has some dubious impact on performance and semantics even when it is possible. Things you might want to do with an around-load hook are better done around-compile, though it may at times require some creativity (see e.g. the @code{package-renaming} system). @node Controlling source file character encoding, Miscellaneous Functions, Controlling file compilation, Miscellaneous additional functionality @section Controlling source file character encoding Starting with ASDF 2.21, components accept a @code{:encoding} option so authors may specify which character encoding should be used to read and evaluate their source code. When left unspecified, the encoding is inherited from the parent module or system; if no encoding is specified at any point, or if @code{nil} is explicitly specified, an extensible protocol described below is followed, that ultimately defaults to @code{:utf-8} since ASDF 3. The protocol to determine the encoding is to call the function @code{detect-encoding}, which itself, if provided a valid file, calls the function specified by @var{*encoding-detection-hook*}, or else defaults to the @var{*default-encoding*}. The @var{*encoding-detection-hook*} is by default bound to function @code{always-default-encoding}, that always returns the contents of @var{*default-encoding*}. @var{*default-encoding*} is bound to @code{:utf-8} by default (before ASDF 3, the default was @code{:default}). Whichever encoding is returned must be a portable keyword, that will be translated to an implementation-specific external-format designator by function @code{encoding-external-format}, which itself simply calls the function specified @var{*encoding-external-format-hook*}; that function by default is @code{default-encoding-external-format}, that only recognizes @code{:utf-8} and @code{:default}, and translates the former to the implementation-dependent @var{*utf-8-external-format*}, and the latter to itself (that itself is portable but has an implementation-dependent meaning). In other words, there now are plenty of extension hooks, but by default ASDF enforces the previous @emph{de facto} standard behaviour of using @code{:utf-8}, independently from whatever configuration the user may be using. Thus, system authors can now rely on @code{:utf-8} being used while compiling their files, even if the user is currently using @code{:koi8-r} or @code{:euc-jp} as their interactive encoding. (Before ASDF 3, there was no such guarantee, @code{:default} was used, and only plain ASCII was safe to include in source code.) Some legacy implementations only support 8-bit characters, and some implementations provide 8-bit only variants. On these implementations, the @var{*utf-8-external-format*} gracefully falls back to @code{:default}, and Unicode characters will be read as multi-character mojibake. To detect such situations, UIOP will push the @code{:asdf-unicode} feature on implementations that support Unicode, and you can use reader-conditionalization to protect any @code{:encoding @emph{encoding}} statement, as in @code{#+asdf-unicode :encoding #+asdf-unicode :utf-8}. We recommend that you avoid using unprotected @code{:encoding} specifications until after ASDF 2.21 or later becomes widespread. As of May 2016, all maintained implementations provide ASDF 3.1, so you may prudently start using this and other features without such protection. While it offers plenty of hooks for extension, and one such extension is available (see @code{asdf-encodings} below), ASDF itself only recognizes one encoding beside @code{:default}, and that is @code{:utf-8}, which is the @emph{de facto} standard, already used by the vast majority of libraries that use more than ASCII. On implementations that do not support unicode, the feature @code{:asdf-unicode} is absent, and the @code{:default} external-format is used to read even source files declared as @code{:utf-8}. On these implementations, non-ASCII characters intended to be read as one CL character may thus end up being read as multiple CL characters. In most cases, this shouldn't affect the software's semantics: comments will be skipped just the same, strings with be read and printed with slightly different lengths, symbol names will be accordingly longer, but none of it should matter. But a few systems that actually depend on unicode characters may fail to work properly, or may work in a subtly different way. See for instance @code{lambda-reader}. We invite you to embrace UTF-8 as the encoding for non-ASCII characters starting today, even without any explicit specification in your @file{.asd} files. Indeed, on some implementations and configurations, UTF-8 is already the @code{:default}, and loading your code may cause errors if it is encoded in anything but UTF-8. Therefore, even with the legacy behaviour, non-UTF-8 is guaranteed to break for some users, whereas UTF-8 is pretty much guaranteed not to break anywhere (provided you do @emph{not} use a BOM), although it might be read incorrectly on some implementations. @code{:utf-8} has been the default value of @code{*default-encoding*} since ASDF 3. If you need non-standard character encodings for your source code, use the extension system @code{asdf-encodings}, by specifying @code{:defsystem-depends-on ("asdf-encodings")} in your @code{defsystem}. This extension system will register support for more encodings using the @code{*encoding-external-format-hook*} facility, so you can explicitly specify @code{:encoding :latin1} in your @file{.asd} file. Using the @code{*encoding-detection-hook*} it will also eventually implement some autodetection of a file's encoding from an emacs-style @code{-*- mode: lisp ; coding: latin1 -*-} declaration, or otherwise based on an analysis of octet patterns in the file. At this point, @code{asdf-encoding} only supports the encodings that are supported as part of your implementation. Since the list varies depending on implementations, we still recommend you use @code{:utf-8} everywhere, which is the most portable (next to it is @code{:latin1}). Recent versions of Quicklisp include @code{asdf-encodings}; if you're not using it, you may get this extension using git: @kbd{git clone https://gitlab.common-lisp.net/asdf/asdf-encodings.git} or @kbd{git clone git@@gitlab.common-lisp.net:asdf/asdf-encodings.git}. You can also browse the repository on @url{https://gitlab.common-lisp.net/asdf/asdf-encodings}. When you use @code{asdf-encodings}, any @file{.asd} file loaded will use the autodetection algorithm to determine its encoding. If you depend on this detection happening, you should explicitly load @code{asdf-encodings} early in your build. Note that @code{:defsystem-depends-on} cannot be used here: by the time the @code{:defsystem-depends-on} is loaded, the enclosing @code{defsystem} form has already been read. In practice, this means that the @code{*default-encoding*} is usually used for @file{.asd} files. Currently, this defaults to @code{:utf-8}, and you should be safe using Unicode characters in those files. This might matter, for instance, in meta-data about author's names. Otherwise, the main data in these files is component (path)names, and we don't recommend using non-ASCII characters for these, for the result probably isn't very portable. @node Miscellaneous Functions, Some Utility Functions, Controlling source file character encoding, Miscellaneous additional functionality @section Miscellaneous Functions These functions are exported by ASDF for your convenience. @anchor{system-relative-pathname} @defun system-relative-pathname system name @Akey{} type It's often handy to locate a file relative to some system. The @code{system-relative-pathname} function meets this need. It takes two mandatory arguments @var{system} and @var{name} and a keyword argument @var{type}: @var{system} is name of a system, whereas @var{name} and optionally @var{type} specify a relative pathname, interpreted like a component pathname specifier by @code{coerce-pathname}. @xref{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. For these cases, @code{(asdf:clear-system :foo)} will remove the system from the table of currently loaded systems: the next time the system @code{foo} or one that depends on it is re-loaded, @code{foo} will be loaded again.@footnote{Alternatively, you could touch @code{foo.asd} or remove the corresponding fasls from the output file cache.} Note that this does not and cannot undo the previous loading of the system. Common Lisp has no provision for such an operation, and its reliance on irreversible side-effects to global data structures makes such a thing impossible in the general case. If the software being re-loaded is not conceived with hot upgrade in mind, re-loading may cause many errors, warnings or subtle silent problems, as packages, generic function signatures, structures, types, macros, constants, etc. are being redefined incompatibly. It is up to the user to make sure that reloading is possible and has the desired effect. In some cases, extreme measures such as recursively deleting packages, unregistering symbols, defining methods on @code{update-instance-for-redefined-class} and much more are necessary for reloading to happen smoothly. ASDF itself goes to extensive effort to make a hot upgrade possible with respect to its own code. If you want, you can reuse some of its utilities such as @code{uiop:define-package} and @code{uiop:with-upgradability}, and get inspiration (or disinspiration) from what it does in @file{header.lisp} and @file{upgrade.lisp}. @end defun @defun register-preloaded-system name @Arest{} keys @Akey{} version @AallowOtherKeys{} 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}. If @var{version} is @code{t} (default), then the version is copied from the defined system of the same name (if registered) or else is @code{nil} (this automatic copy of version is only available starting since ASDF 3.1.8). A preloaded system is considered as having already been loaded into the current image, and if at some point some other system @code{:depends-on} it yet no source code is found, it is considered as already provided, and ASDF will not raise a @code{missing-component} error. This function is particularly useful if you distribute your code as fasls with either @code{compile-bundle-op} or @code{monolithic-compile-bundle-op}, and want to register systems so that dependencies will work uniformly whether you're using your software from source or from fasl. Note that if the system was already defined or loaded from source code, its build information will remain active until you call @code{clear-system} on it, at which point a system without build information will be registered in its place. @end defun @defun register-immutable-system name @Arest{} keys A system with name @var{name} is registered as preloaded, and additionally is marked as @emph{immutable}: that is, attempts to compile or load it will be succeed without actually reading, creating or loading any file, as if the system was passed as a @code{force-not} argument to all calls to @code{plan} or @code{operate}. There will be no search for an updated @file{.asd} file to override the loaded version, whether from the source-register or any other method. If a @var{version} keyword argument is specified as @code{t} or left unspecified, then the version is copied from the defined system of the same name (if registered) or else is @code{nil}. This automatic copy of version is available starting since immutable systems have been available in ASDF 3.1.5. This function, available since ASDF 3.1.5, is particularly useful if you distribute a large body of code as a precompiled image, and want to allow users to extend the image with further extension systems, but without making thousands of filesystem requests looking for inexistent (or worse, out of date) source code for all the systems that came bundled with the image but aren't distributed as source code to regular users. @cindex immutable systems @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 behaviour is only well-defined on Unix platforms (which include MacOS X and cygwin). On Windows, anything goes. The following documentation is only for the purpose of your migrating away from it in a way that preserves semantics. Instead we recommend the use @code{run-program}, described in the next section, and available as part of ASDF since ASDF 3. @code{run-shell-command} takes as arguments a format @code{control-string} and arguments to be passed to @code{format} after this control-string to produce a string. This string is a command that will be evaluated with a POSIX shell if possible; yet, on Windows, some implementations will use CMD.EXE, while others (like SBCL) will make an attempt at invoking a POSIX shell (and fail if it is not present). @end defun @node Some Utility Functions, , Miscellaneous Functions, Miscellaneous additional functionality @section Some Utility Functions The below functions are not exported by ASDF itself, but by UIOP, available since ASDF 3. Some of them have precursors in ASDF 2, but we recommend that for active developments, you should rely on the package UIOP as included in ASDF 3. UIOP provides many, many more utility functions, and we recommend you read its @file{README.md} and sources for more information. @defun parse-unix-namestring name @Akey{} type defaults dot-dot ensure-directory @AallowOtherKeys Coerce @var{name} into a @var{pathname} using standard Unix syntax. Unix syntax is used whether or not the underlying system is Unix; on non-Unix systems it is only usable for relative pathnames. In order to manipulate relative pathnames portably, it is crucial to possess a portable pathname syntax independent of the underlying OS. This is what @code{parse-unix-namestring} provides, and why we use it in ASDF. When given a @code{pathname} object, just return it untouched. When given @code{nil}, just return @code{nil}. When given a non-null @code{symbol}, first downcase its name and treat it as a string. When given a @code{string}, portably decompose it into a pathname as below. @code{#\/} separates directory components. The last @code{#\/}-separated substring is interpreted as follows: 1- If @var{type} is @code{:directory} or @var{ensure-directory} is true, the string is made the last directory component, and its @code{name} and @code{type} are @code{nil}. if the string is empty, it's the empty pathname with all slots @code{nil}. 2- If @var{type} is @code{nil}, the substring is a file-namestring, and its @code{name} and @code{type} are separated by @code{split-name-type}. 3- If @var{type} is a string, it is the given @code{type}, and the whole string is the @code{name}. Directory components with an empty name the name @code{.} are removed. Any directory named @code{..} is read as @var{dot-dot}, which must be one of @code{:back} or @code{:up} and defaults to @code{:back}. @vindex *nil-pathname* @code{host}, @code{device} and @code{version} components are taken from @var{defaults}, which itself defaults to @code{*nil-pathname*}. @code{*nil-pathname*} is also used if @var{defaults} is @code{nil}. No host or device can be specified in the string itself, which makes it unsuitable for absolute pathnames outside Unix. For relative pathnames, these components (and hence the defaults) won't matter if you use @code{merge-pathnames*} but will matter if you use @code{merge-pathnames}, which is an important reason to always use @code{merge-pathnames*}. Arbitrary keys are accepted, and the parse result is passed to @code{ensure-pathname} with those keys, removing @var{type}, @var{defaults} and @var{dot-dot}. When you're manipulating pathnames that are supposed to make sense portably even though the OS may not be Unixish, we recommend you use @code{:want-relative t} so that @code{parse-unix-namestring} will throw an error if the pathname is absolute. @end defun @defun merge-pathnames* specified @Aoptional{} defaults 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 behaviour. @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 behaviour.) @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{} @code{slurp-input-stream} is a generic function of two arguments, a target object and an input stream, and accepting keyword arguments. Predefined methods based on the target object are as follows: @itemize @item If the object is a function, the function is called with the stream as argument. @item If the object is a cons, its first element is applied to its rest appended by a list of the input stream. @item If the object is an output stream, the contents of the input stream are copied to it. If the @var{linewise} keyword argument is provided, copying happens line by line, and an optional @var{prefix} is printed before each line. Otherwise, copying happen based on a buffer of size @var{buffer-size}, using the specified @var{element-type}. @item If the object is @code{'string} or @code{:string}, the content is captured into a string. Accepted keywords include the @var{element-type} and a flag @var{stripped}, which when true causes any single line ending to be removed as per @code{uiop:stripln}. @item If the object is @code{:lines}, the content is captured as a list of strings, one per line, without line ending. If the @var{count} keyword argument is provided, it is a maximum count of lines to be read. @item If the object is @code{:line}, the content is captured as with @code{:lines} above, and then its sub-object is extracted with the @var{at} argument, which defaults to @code{0}, extracting the first line. A number will extract the corresponding line. See the documentation for @code{uiop:access-at}. @item If the object is @code{:forms}, the content is captured as a list of s-expressions, as read by the Lisp reader. If the @var{count} argument is provided, it is a maximum count of lines to be read. We recommend you control the syntax with such macro as @code{uiop:with-safe-io-syntax}. @item If the object is @code{:form}, the content is captured as with @code{:forms} above, and then its sub-object is extracted with the @var{at} argument, which defaults to @code{0}, extracting the first form. A number will extract the corresponding form. See the documentation for @code{uiop:access-at}. We recommend you control the syntax with such macro as @code{uiop:with-safe-io-syntax}. @end itemize @end defun @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 https://gitlab.common-lisp.net/asdf/asdf.git} You will find the above referenced tags in this repository. You can also browse the repository on @url{https://gitlab.common-lisp.net/asdf/asdf}. Discussion of ASDF development is conducted on the mailing list (@pxref{Mailing list}). @node FAQ, Ongoing Work, Getting the latest version, Top @comment node-name, next, previous, up @chapter FAQ @menu * Where do I report a bug?:: * Mailing list:: * What has changed between ASDF 1 ASDF 2 and ASDF 3?:: * Issues with installing the proper version of ASDF:: * Issues with configuring ASDF:: * Issues with using and extending ASDF to define systems:: * ASDF development FAQs:: @end menu @node Where do I report a bug?, Mailing list, FAQ, FAQ @section ``Where do I report a bug?'' @cindex bug tracker @cindex gitlab @cindex launchpad ASDF bugs are tracked on common-lisp.net's gitlab:: @url{https://gitlab.common-lisp.net/asdf/asdf/issues}. Previously, we had done bug-tracking on @code{launchpad.net}, but we are now consolidating project management on @code{common-lisp.net}. If you're unsure about whether something is a bug, or for general discussion, use the asdf-devel mailing list (@pxref{Mailing list}). @node Mailing list, What has changed between ASDF 1 ASDF 2 and ASDF 3?, Where do I report a bug?, FAQ @section Mailing list @cindex mailing list 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 What has changed between ASDF 1 ASDF 2 and ASDF 3?, Issues with installing the proper version of ASDF, Mailing list, FAQ @section ``What has changed between ASDF 1, ASDF 2, and ASDF 3?'' We released ASDF 2.000 on May 31st 2010, ASDF 3.0.0 on May 15th 2013, ASDF 3.1.2 on May 6th 2014. Releases of ASDF 2 and now ASDF 3 have since then been included in all actively maintained CL implementations that used to bundle ASDF 1, plus many implementations that previously did not. ASDF has been made to work with all actively maintained CL implementations and even a few implementations that are @emph{not} actively maintained. Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 or ASDF 3 on the fly (though we recommend instead upgrading your implementation or replacing its ASDF module). For this reason, we have stopped supporting ASDF 1 and ASDF 2. If you are using ASDF 1 or ASDF 2 and are experiencing any kind of issues or limitations, we recommend you upgrade to ASDF 3 --- and we explain how to do that. @xref{Loading ASDF}. Note that in the context of compatibility requirements, ASDF 2.27, released on Feb 1st 2013, and further releases up to 2.33, count as pre-releases of ASDF 3, and define the @code{:asdf3} feature, though the first stable release of ASDF 3 was release 3.0.1. Significant new or improved functionality were added in ASDF 3.1; the @code{:asdf3.1} feature is present in recent enough versions to detect this functionality; the first stable release since then was ASDF 3.1.2. New @code{*features*} are only added at major milestones, and the next one will probably be @code{:asdf3.2}. @menu * What are ASDF 1 2 3?:: * How do I detect the ASDF version?:: * ASDF can portably name files in subdirectories:: * Output translations:: * Source Registry Configuration:: * Usual operations are made easier to the user:: * Many bugs have been fixed:: * ASDF itself is versioned:: * ASDF can be upgraded:: * Decoupled release cycle:: * Pitfalls of the transition to ASDF 2:: * Pitfalls of the upgrade to ASDF 3:: * What happened to the bundle operations:: @end menu @node What are ASDF 1 2 3?, How do I detect the ASDF version?, What has changed between ASDF 1 ASDF 2 and ASDF 3?, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection What are ASDF 1, ASDF 2, and ASDF 3? ASDF 1 refers to any release earlier than 1.369 or so (from August 2001 to October 2009), and to any development revision earlier than 2.000 (May 2010). If your copy of ASDF doesn't even contain version information, it's an old ASDF 1. Revisions between 1.656 and 1.728 may count as development releases for ASDF 2. ASDF 2 refers to releases from 2.000 (May 31st 2010) to 2.26 (Oct 30th 2012), and any development revision newer than ASDF 1 and older than 2.27 (Feb 1st 2013). ASDF 3 refers to releases from 2.27 (Feb 1st 2013) to 2.33 and 3.0.0 onward (May 15th 2013). 2.27 to 2.33 count as pre-releases to ASDF 3. ASDF 3.1 refers to releases from 3.1.2 (May 6th 2014) onward. These releases are also considered part of ASDF 3. @node How do I detect the ASDF version?, ASDF can portably name files in subdirectories, What are ASDF 1 2 3?, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection How do I detect the ASDF version? @findex asdf-version @cindex *features* All releases of ASDF push @code{:asdf} onto @code{*features*}. Releases starting with ASDF 2 push @code{:asdf2} onto @code{*features*}. Releases starting with ASDF 3 (including 2.27 and later pre-releases) push @code{:asdf3} onto @code{*features*}. Furthermore, releases starting with ASDF 3.1.2 (May 2014), though they count as ASDF 3, include enough progress that they also push @code{:asdf3.1} onto @code{*features*}. You may depend on the presence or absence of these features to write code that takes advantage of recent ASDF functionality but still works on older versions, or at least detects the old version and signals an error. Additionally, all releases starting with ASDF 2 define a function @code{(asdf:asdf-version)} you may use to query the version. All releases starting with 2.013 display the version number prominently on the second line of the @file{asdf.lisp} source file. If you are experiencing problems or limitations of any sort with ASDF 1 or ASDF 2, we recommend that you should upgrade to the latest release, be it ASDF 3 or other. Finally, here is a code snippet to programmatically determine what version of ASDF is loaded, if any, that works on all versions including very old ones: @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 it returns anything older than @code{"3.0.1"}, you really need to upgrade your implementation or at least upgrade its ASDF. @xref{Replacing your implementation's ASDF}. @node ASDF can portably name files in subdirectories, Output translations, How do I detect the ASDF version?, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection ASDF can portably name files in subdirectories Common Lisp namestrings are not portable, except maybe for logical pathname namestrings, that themselves have various limitations and require a lot of setup that is itself ultimately non-portable. In ASDF 1, the only portable ways to refer to pathnames inside systems and components were very awkward, using @code{#.(make-pathname ...)} and @code{#.(merge-pathnames ...)}. Even the above were themselves were inadequate in the general case due to host and device issues, unless horribly complex patterns were used. Plenty of simple cases that looked portable actually weren't, leading to much confusion and greavance. ASDF 2 implements its own portable syntax for strings as pathname specifiers. Naming files within a system definition becomes easy and portable again. @xref{Miscellaneous additional functionality,system-relative-pathname}, @code{merge-pathnames*}, @code{coerce-pathname}. On the other hand, there are places where systems used to accept namestrings where you must now use an explicit pathname object: @code{(defsystem ... :pathname "LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} must now be written with the @code{#p} syntax: @code{(defsystem ... :pathname #p"LOGICAL-HOST:PATH;TO;SYSTEM;" ...)} @xref{Pathname specifiers}. @node Output translations, Source Registry Configuration, ASDF can portably name files in subdirectories, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection Output translations A popular feature added to ASDF was output pathname translation: @code{asdf-binary-locations}, @code{common-lisp-controller}, @code{cl-launch} and other hacks were all implementing it in ways both mutually incompatible and difficult to configure. Output pathname translation is essential to share source directories of portable systems across multiple implementations or variants thereof, or source directories of shared installations of systems across multiple users, or combinations of the above. In ASDF 2, a standard mechanism is provided for that, @code{asdf-output-translations}, with sensible defaults, adequate configuration languages, a coherent set of configuration files and hooks, and support for non-Unix platforms. @xref{Controlling where ASDF saves compiled files}. @node Source Registry Configuration, Usual operations are made easier to the user, Output translations, What has changed between ASDF 1 ASDF 2 and ASDF 3? @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}. @node Usual operations are made easier to the user, Many bugs have been fixed, Source Registry Configuration, What has changed between ASDF 1 ASDF 2 and ASDF 3? @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}. @node Many bugs have been fixed, ASDF itself is versioned, Usual operations are made easier to the user, What has changed between ASDF 1 ASDF 2 and ASDF 3? @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 @code{:version} and the @code{: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 cubic time recursive append, for an overall @emph{O(n)} complexity vs @emph{O(n^4)}. @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, though some tests are commented out on a few implementations. @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 @node ASDF itself is versioned, ASDF can be upgraded, Many bugs have been fixed, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection ASDF itself is versioned Between new features, old bugs fixed, and new bugs introduced, there were various releases of ASDF in the wild, and no simple way to check which release had which feature set. People using or writing systems had to either make worst-case assumptions as to what features were available and worked, or take great pains to have the correct version of ASDF installed. With ASDF 2, we provide a new stable set of working features that everyone can rely on from now on. Use @code{#+asdf2} to detect presence of ASDF 2, @code{(asdf:version-satisfies (asdf:asdf-version) "2.345.67")} to check the availability of a version no earlier than required. @node ASDF can be upgraded, Decoupled release cycle, ASDF itself is versioned, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection ASDF can be upgraded When an old version of ASDF was loaded, it was very hard to upgrade ASDF in your current image without breaking everything. Instead you had to exit the Lisp process and somehow arrange to start a new one from a simpler image. Something that can't be done from within Lisp, making automation of it difficult, which compounded with difficulty in configuration, made the task quite hard. Yet as we saw before, the task would have been required to not have to live with the worst case or non-portable subset of ASDF features. With ASDF 2, it is easy to upgrade from ASDF 2 to later versions from within Lisp, and not too hard to upgrade from ASDF 1 to ASDF 2 from within Lisp. We support hot upgrade of ASDF and any breakage is a bug that we will do our best to fix. There are still limitations on upgrade, though, most notably the fact that after you upgrade ASDF, you must also reload or upgrade all ASDF extensions. @node Decoupled release cycle, Pitfalls of the transition to ASDF 2, ASDF can be upgraded, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection Decoupled release cycle When vendors were releasing their Lisp implementations with ASDF, they had to basically never change version because neither upgrade nor downgrade was possible without breaking something for someone, and no obvious upgrade path was visible and recommendable. With ASDF 2, upgrade is possible, easy and can be recommended. This means that vendors can safely ship a recent version of ASDF, confident that if a user isn't fully satisfied, he can easily upgrade ASDF and deal with a supported recent version of it. This means that release cycles will be causally decoupled, the practical consequence of which will mean faster convergence towards the latest version for everyone. @node Pitfalls of the transition to ASDF 2, Pitfalls of the upgrade to ASDF 3, Decoupled release cycle, What has changed between ASDF 1 ASDF 2 and ASDF 3? @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. @code{source-file-type} is deprecated. To access a component's file-type, use @code{file-type}, instead. @code{source-file-type} will be removed. @findex source-file-type @findex file-type @end itemize @node Pitfalls of the upgrade to ASDF 3, What happened to the bundle operations, Pitfalls of the transition to ASDF 2, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection Pitfalls of the upgrade to ASDF 3 While ASDF 3 is largely compatible with ASDF 2, there are a few pitfalls when upgrading from ASDF 2, due to limitations in ASDF 2. @itemize @item ASDF 2 was designed so it could be upgraded; but upgrading it required a special setup at the beginning of your build files. Failure to upgrade it early could result in catastrophic attempt to self-upgrade in mid-build. @item Starting with ASDF 3 (2.27 or later), ASDF will automatically attempt to upgrade itself as the first step before any system operation, to avoid any possibility of such catastrophic mid-build self-upgrade. But that doesn't help if your old implementation still provides ASDF 2. @item It was unsafe in ASDF 2 for a system definition to declare a dependency on ASDF, since it could trigger such catastrophe for users who were not carefully configured. If you declare a dependency on a recent enough ASDF, yet want to be nice with these potentially misconfigured users, we recommend that you not only specify a recent ASDF in your dependencies with @code{:depends-on ((:version "asdf" "3.1.2"))}, but that you @emph{also} check that ASDF 3 is installed, or else the upgrade catastrophe might happen before that specification is checked, by starting your @file{.asd} file with a version check as follows: @example #-asdf3 (error "@var{MY-SYSTEM} requires ASDF 3.1.2") @end example @item When you upgrade from too old a version of ASDF, previously loaded ASDF extensions become invalid, and will need to be reloaded. Example extensions include CFFI-Grovel, hacks used by ironclad, etc. Since it isn't possible to automatically detect what extensions need to be invalidated and what systems use them, ASDF will invalidate @emph{all} previously loaded systems when it is loaded on top of a forward-incompatible ASDF version. @footnote{ @vindex *oldest-forward-compatible-asdf-version* Forward incompatibility can be determined using the variable @code{asdf/upgrade::*oldest-forward-compatible-asdf-version*}, which is 2.33 at the time of this writing.} @item To write a portable build script, you need to rely on a recent version of UIOP, but until you have ensured a recent ASDF is loaded, you can't rely on UIOP being present, and thus must manually avoid all the pathname pitfalls when loading ASDF itself. @item Bugs in CMUCL and XCL prevent upgrade of ASDF from an old forward-incompatible version. Happily, CMUCL comes with a recent ASDF, and XCL is more of a working demo than something you'd use seriously anyway. @item For the above reasons, your build and startup scripts should load ASDF 3, configure it, and upgrade it, among the very first things they do. They should ensure that only ASDF 3 or later is used indeed, and error out if ASDF 2 or earlier was used. @item Now that (since May 2016) all maintained implementations (i.e. having had at least one release since 2014, or a commit on their public source code repository) provide ASDF 3.1 or later, the simple solution is just to use code as below in your setup, and when it fails, upgrade your implementation or replace its ASDF. (@pxref{Replacing your implementation's ASDF}): @example (require "asdf") #-asdf3.1 (error "ASDF 3.1 or bust") @end example @item For scripts that try to use ASDF simply via @code{require} at first, and make heroic attempts to load it the hard way if at first they don't succeed, see @file{tools/load-asdf.lisp} distributed with the ASDF source repository, or the code of @url{https://cliki.net/cl-launch,@code{cl-launch}}. @item @anchor{reinitializeASDFAfterUpgrade} Note that in addition to the pitfalls and constraints above, these heroic scripts (should you wish to write or modify one), must take care to configure ASDF @emph{twice}. A first time, right after you load the old ASDF 2 (or 1!) and before you upgrade to the new ASDF 3, so it may find where you put ASDF 3. A second time, because most implementations can't handle a smooth upgrade from ASDF 2 to ASDF 3, so ASDF 3 doesn't try (anymore) and loses any configuration from ASDF 2. @lisp (ignore-errors (funcall 'require "asdf")) ;; <--- try real hard ;; <--- insert heroics here, if that failed to provide ASDF 2 or 3 ;; <--- insert configuration here, if that succeeded (asdf:load-system "asdf") ;; <--- re-configure here, too, in case at first you got ASDF 2 @end lisp @end itemize @node What happened to the bundle operations, , Pitfalls of the upgrade to ASDF 3, What has changed between ASDF 1 ASDF 2 and ASDF 3? @subsection What happened to the bundle operations? @tindex fasl-op (obsolete) @tindex load-fasl-op (obsolete) @tindex binary-op (obsolete) @tindex monolithic-fasl-op (obsolete) @tindex monolithic-load-fasl-op (obsolete) @tindex monolithic-binary-op (obsolete) @tindex compile-bundle-op @tindex load-bundle-op @tindex deliver-asd-op @tindex monolithic-compile-bundle-op @tindex monolithic-load-bundle-op @tindex monolithic-deliver-asd-op @code{asdf-ecl} and its short-lived successor @code{asdf-bundle} are no more, having been replaced by code now built into ASDF 3. Moreover, the name of the bundle operations has changed since ASDF 3.1.3. Starting with ASDF 3.2.0, @code{load-system} will once again use @code{load-bundle-op} instead of @code{load-op} on ECL, as originally intended by @code{asdf-ecl} authors, but disabled for a long time due to bugs in both ECL and ASDF. Note that some of the bundle operations were renamed after ASDF 3.1.3, and the old names have been removed. Old bundle operations, and their modern equivalents are: @itemize @item @code{fasl-op} is now @code{compile-bundle-op} @item @code{load-fasl-op} is now @code{load-bundle-op} @item @code{binary-op} is now @code{deliver-asd-op} @item @code{monolithic-fasl-op} is now @code{monolithic-compile-bundle-op} @item @code{monolithic-load-fasl-op} is now @code{monolithic-load-bundle-op} @item @code{monolithic-binary-op} is now @code{monolithic-deliver-asd-op} @end itemize @node Issues with installing the proper version of ASDF, Issues with configuring ASDF, What has changed between ASDF 1 ASDF 2 and ASDF 3?, FAQ @section Issues with installing the proper version of ASDF @menu * My Common Lisp implementation comes with an outdated version of ASDF. What to do?:: * I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?:: * After upgrading ASDF, ASDF (and Quicklisp) can't find my systems: After upgrading ASDF. @end menu @node My Common Lisp implementation comes with an outdated version of ASDF. What to do?, I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, Issues with installing the proper version of ASDF, Issues with installing the proper version of ASDF @subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?'' If you have a recent implementation, it should already come with ASDF 3 or later. If you need a more recent version than is provided, we recommend you simply upgrade ASDF by installing a recent version in a path configured in your source-registry. @xref{Upgrading ASDF}. If you have an old implementation that does not provide ASDF 3, we recommend you replace your implementation's ASDF. @xref{Replacing your implementation's ASDF}. @node I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, After upgrading ASDF, My Common Lisp implementation comes with an outdated version of ASDF. What to do?, Issues with installing the proper version of ASDF @subsection ``I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?'' Since ASDF 2, it should always be a good time to upgrade to a recent version of ASDF. You may consult with the maintainer for which specific version they recommend, but the latest @code{release} should be correct. Though we do try to test ASDF releases against all implementations that we can, we may not be testing against all variants of your implementation, and we may not be running enough tests; we trust you to thoroughly test it with your own implementation before you release it. If there are any issues with the current release, it's a bug that you should report upstream and that we will fix ASAP. 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 since 1.1.13 or MKCL since 1.1.9, have ASDF create bundle FASLs that are provided as modules by your Lisp distribution. You may also, but we don't recommend that anymore, as in SBCL up until 1.1.12, have ASDF be implicitly used to @code{cl:require} these modules that are provided by your Lisp distribution; if you do, you should add these modules in the beginning of both @code{wrapping-source-registry} and @code{wrapping-output-translations}. @item If you have magic systems as above, like SBCL used to do, then we explicitly ask you to @emph{NOT} distribute @file{asdf.asd} as part of those magic systems. You should still include the file @file{asdf.lisp} in your source distribution and precompile it in your binary distribution, but @file{asdf.asd} if included at all, should be secluded from the magic systems, in a separate file hierarchy. Alternatively, you may provide the system after renaming it and its @file{.asd} file to e.g. @code{asdf-ecl} and @file{asdf-ecl.asd}, or @code{sb-asdf} and @file{sb-asdf.asd}. Indeed, if you made @file{asdf.asd} a magic system, then users would no longer be able to upgrade ASDF using ASDF itself to some version of their preference that they maintain independently from your Lisp distribution. @item If you do not have any such magic systems, or have other non-magic systems that you want to bundle with your implementation, then you may add them to the @code{wrapping-source-registry}, and you are welcome to include @file{asdf.asd} amongst them. Non-magic systems should be at the back of the @code{wrapping-source-registry} while magic systems are at the front. If they are precompiled, they should also be in the @code{wrapping-output-translations}. @item Since ASDF 3, the library UIOP comes transcluded in ASDF. But if you want to be nice to users who care for UIOP but not for ASDF, you may package UIOP separately, so that one may @code{(require "uiop")} and not load ASDF, or one may @code{(require "asdf")} which would implicitly require and load the former. @item 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 @node After upgrading ASDF, , I'm a Common Lisp implementation vendor. When and how should I upgrade ASDF?, Issues with installing the proper version of ASDF @subsection After upgrading ASDF, ASDF (and Quicklisp) can't find my systems @vindex *central-registry* @cindex Quicklisp When you upgrade the ASDF running in your Lisp image from an ancient ASDF 2 or older to ASDF 3 or newer, then you may have to re-configure ASDF. If your configuration only consists in using the source-registry and output-translations (as it should), and if you are not explicitly calling @code{asdf:initialize-source-registry} or @code{asdf:initialize-output-translations} with a non-nil argument, then ASDF will reconfigure itself. Otherwise, you will have to configure ASDF 2 (or older) to find ASDF 3, then configure ASDF 3. Notably, @var{*central-registry*} is not maintained across upgrades from ASDF 2. @xref{reinitializeASDFAfterUpgrade,note about ASDF reconfiguration after upgrade}. Problems like this may be experienced if one loads Quicklisp (which as of this writing bundles an obsolete ASDF version 2.26), upgrades ASDF, and then tries to load new systems. The correct solution is to load the most up-to-date ASDF you can, @emph{then} configure it, @emph{then} load Quicklisp and any other extension. Do @emph{not} try to upgrade from ASDF 2 @emph{after} loading Quicklisp, for it will leave both ASDF and Quicklisp badly misconfigured. For details see the discussion at the above cross-reference. Also, if you are experiencing such failures due to Quicklisp shipping an ancient ASDF, please complain to Zach Beane about it. @node Issues with configuring ASDF, Issues with using and extending ASDF to define systems, Issues with installing the proper version of ASDF, FAQ @section Issues with configuring ASDF @menu * How can I customize where fasl files are stored?:: * How can I wholly disable the compiler output cache?:: * How can I debug problems finding ASDF systems:: @end menu @node How can I customize where fasl files are stored?, How can I wholly disable the compiler output cache?, Issues with configuring ASDF, Issues with configuring ASDF @subsection ``How can I customize where fasl files are stored?'' @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. @node How can I wholly disable the compiler output cache?, How can I debug problems finding ASDF systems, How can I customize where fasl files are stored?, Issues with configuring ASDF @subsection ``How can I wholly disable the compiler output cache?'' To permanently disable the compiler output cache for all future runs of ASDF, you can: @example mkdir -p ~/.config/common-lisp/asdf-output-translations.conf.d/ echo ':disable-cache' > \ ~/.config/common-lisp/asdf-output-translations.conf.d/99-disable-cache.conf @end example This assumes that you didn't otherwise configure the ASDF files (if you did, edit them again), and don't somehow override the configuration at runtime with a shell variable (see below) or some other runtime command (e.g. some call to @code{asdf:initialize-output-translations}). To disable the compiler output cache in Lisp processes run by your current shell, try (assuming @code{bash} or @code{zsh}) (on Unix and cygwin only): @example export ASDF_OUTPUT_TRANSLATIONS=/: @end example To disable the compiler output cache just in the current Lisp process, use (after loading ASDF but before using it): @example (asdf:disable-output-translations) @end example Note that this does @emph{NOT} belong in a @file{.asd} file. Please do not tamper with ASDF configuration from a @file{.asd} file, and only do this from your personal configuration or build scripts. @node How can I debug problems finding ASDF systems, , How can I wholly disable the compiler output cache?, Issues with configuring ASDF @comment node-name, next, previous, up @subsection How can I debug problems finding ASDF systems? Sometimes ASDF will be unable to find and load your systems, although you believe that it should be able to. There are a number of things you can do to debug such issues. @vindex *central-registry* If you are using @code{asdf:*central-registry*} (@pxref{Configuring ASDF to find your systems --- old style}), you can simply look at the pathnames and namestrings in this variable, and use conventional tools such as @code{cl:probe-file} and @code{cl:directory} to poke around and see why your systems are not being found. If you are using one of the newer methods for configuring ASDF's system finding (@pxref{Controlling where ASDF searches for systems}), you can try: @vindex *source-registry* @example (alexandria:hash-table-alist asdf/source-registry::*source-registry*) @end example (alphabetizing the results here may be helpful). Or for a higher-level view: @findex flatten-source-registry @example (asdf/source-registry:flatten-source-registry) @end example Finally, if you use the source registry cache (@pxref{Caching Results}), you can: @example find ~/common-lisp -name .cl-source-registry.cache @end example at the shell. It is still, unfortunately, an open question how to monitor ASDF's interpretation of its source configuration as it happens. @node Issues with using and extending ASDF to define systems, ASDF development FAQs, Issues with configuring ASDF, FAQ @section Issues with using and extending ASDF to define systems @menu * How can I cater for unit-testing in my system?:: * How can I cater for documentation generation in my system?:: * How can I maintain non-Lisp (e.g. C) source files?:: * I want to put my module's files at the top level. How do I do this?:: * How do I create a system definition where all the source files have a .cl extension?:: * How do I mark a source file to be loaded only and not compiled?:: * How do I work with readtables?:: * How can I capture ASDF's output?:: * LOAD-PATHNAME has a weird value:: @end menu @node How can I cater for unit-testing in my system?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems, Issues with using and extending ASDF to define systems @subsection ``How can I cater for unit-testing in my system?'' ASDF provides a predefined test operation, @code{test-op}. @xref{Predefined operations of ASDF, test-op}. The test operation, however, is largely left to the system definer to specify. @code{test-op} has been a topic of considerable discussion on the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} (@pxref{Mailing list}), and on the @url{https://launchpad.net/asdf,launchpad bug-tracker} (@pxref{Where do I report a bug?}). We provide some guidelines in the discussion of @code{test-op}. @c cut the following because it's discussed in the discussion of test-op. @c Here are some guidelines: @c @itemize @c @item @c For a given system, @var{foo}, you will want to define a corresponding @c test system, such as @var{foo-test}. The reason that you will want this @c separate system is that ASDF does not out of the box supply components @c that are conditionally loaded. So if you want to have source files @c (with the test definitions) that will not be loaded except when testing, @c they should be put elsewhere. @c @item @c The @var{foo-test} system can be defined in an asd file of its own or @c together with @var{foo}. An aesthetic preference against cluttering up @c the filesystem with extra asd files should be balanced against the @c question of whether one might want to directly load @var{foo-test}. @c Typically one would not want to do this except in early stages of @c debugging. @c @item @c Record that testing is implemented by @var{foo-test}. For example: @c @example @c (defsystem @var{foo} @c :in-order-to ((test-op (test-op @var{foo-test}))) @c ....) @c (defsystem @var{foo-test} @c :depends-on (@var{foo} @var{my-test-library} ...) @c ....) @c @end example @c @end itemize @c This procedure will allow you to support users who do not wish to @c install your test framework. @c One oddity of ASDF is that @code{operate} (@pxref{Operations,operate}) @c does not return a value. So in current versions of ASDF there is no @c reliable programmatic means of determining whether or not a set of tests @c has passed, or which tests have failed. The user must simply read the @c console output. This limitation has been the subject of much @c discussion. @node How can I cater for documentation generation in my system?, How can I maintain non-Lisp (e.g. C) source files?, How can I cater for unit-testing in my system?, Issues with using and extending ASDF to define systems @subsection ``How can I cater for documentation generation in my system?'' Various ASDF extensions provide some kind of @code{doc-op} operation. See also @url{https://bugs.launchpad.net/asdf/+bug/479470}. @node How can I maintain non-Lisp (e.g. C) source files?, I want to put my module's files at the top level. How do I do this?, How can I cater for documentation generation in my system?, Issues with using and extending ASDF to define systems @subsection ``How can I maintain non-Lisp (e.g. C) source files?'' See @code{cffi}'s @code{cffi-grovel}. @anchor{report-bugs} @node I want to put my module's files at the top level. How do I do this?, How do I create a system definition where all the source files have a .cl extension?, How can I maintain non-Lisp (e.g. C) source files?, Issues with using and extending ASDF to define systems @subsection ``I want to put my module's files at the top level. How do I do this?'' By default, the files contained in an asdf module go in a subdirectory with the same name as the module. However, this can be overridden by adding a @code{:pathname ""} argument to the module description. For example, here is how it could be done in the spatial-trees ASDF system definition for ASDF 2 or later: @example (asdf:defsystem "spatial-trees" :components ((:module "base" :pathname "" :components ((:file "package") (:file "basedefs" :depends-on ("package")) (:file "rectangles" :depends-on ("package")))) (:module tree-impls :depends-on ("base") :pathname "" :components ((:file "r-trees") (:file "greene-trees" :depends-on ("r-trees")) (:file "rstar-trees" :depends-on ("r-trees")) (:file "rplus-trees" :depends-on ("r-trees")) (:file "x-trees" :depends-on ("r-trees" "rstar-trees")))) (:module viz :depends-on ("base") :pathname "" :components ((:static-file "spatial-tree-viz.lisp"))) (:module tests :depends-on ("base") :pathname "" :components ((:static-file "spatial-tree-test.lisp"))) (:static-file "LICENCE") (:static-file "TODO"))) @end example All of the files in the @code{tree-impls} module are at the top level, instead of in a @file{tree-impls/} subdirectory. Note that the argument to @code{:pathname} can be either a pathname object or a string. A pathname object can be constructed with the @file{#p"foo/bar/"} syntax, but this is discouraged because the results of parsing a namestring are not portable. A pathname can only be portably constructed with such syntax as @code{#.(make-pathname :directory '(:relative "foo" "bar"))}, and similarly the current directory can only be portably specified as @code{#.(make-pathname :directory '(:relative))}. However, as of ASDF 2, you can portably use a string to denote a pathname. The string will be parsed as a @code{/}-separated path from the current directory, such that the empty string @code{""} denotes the current directory, and @code{"foo/bar"} (no trailing @code{/} required in the case of modules) portably denotes the same subdirectory as above. When files are specified, the last @code{/}-separated component is interpreted either as the name component of a pathname (if the component class specifies a pathname type), or as a name component plus optional dot-separated type component (if the component class doesn't specifies a pathname type). @node How do I create a system definition where all the source files have a .cl extension?, How do I mark a source file to be loaded only and not compiled?, I want to put my module's files at the top level. How do I do this?, Issues with using and extending ASDF to define systems @subsection How do I create a system definition where all the source files have a .cl extension? Starting with ASDF 2.014.14, you may just pass the builtin class @code{cl-source-file.cl} as the @code{:default-component-class} argument to @code{defsystem}: @lisp (defsystem my-cl-system :default-component-class cl-source-file.cl ...) @end lisp Another builtin class @code{cl-source-file.lsp} is offered for files ending in @file{.lsp}. If you want to use a different extension for which ASDF doesn't provide builtin support, or want to support versions of ASDF earlier than 2.014.14 (but later than 2.000), you can define a class as follows: @lisp ;; Prologue: make sure we're using a sane package. (defpackage :my-asdf-extension (:use :asdf :common-lisp) (:export #:cl-source-file.lis)) (in-package :my-asdf-extension) (defclass cl-source-file.lis (cl-source-file) ((type :initform "lis"))) @end lisp Then you can use it as follows: @lisp (defsystem my-cl-system :default-component-class my-asdf-extension:cl-source-file.lis ...) @end lisp Of course, if you're in the same package, e.g. in the same file, you won't need to use the package qualifier before @code{cl-source-file.lis}. Actually, if all you're doing is defining this class and using it in the same file without other fancy definitions, you might skip package complications: @lisp (in-package :asdf) (defclass cl-source-file.lis (cl-source-file) ((type :initform "lis"))) (defsystem my-cl-system :default-component-class cl-source-file.lis ...) @end lisp @node How do I mark a source file to be loaded only and not compiled?, How do I work with readtables?, How do I create a system definition where all the source files have a .cl extension?, Issues with using and extending ASDF to define systems @subsection How do I mark a source file to be loaded only and not compiled? There is no provision in ASDF for ensuring that some components are always loaded as source, while others are always compiled. There is @code{load-source-op} (@pxref{Predefined operations of ASDF,load-source-op}), but that is an operation to be applied to a system as a whole, not to one or another specific source files. While this idea often comes up in discussions, it doesn't play well with either the linking model of ECL or with various bundle operations. In addition, the dependency model of ASDF would have to be modified incompatibly to allow for such a trick. @c If your code doesn't compile cleanly, fix it. @c If compilation makes it slow, use @code{declaim} or @code{eval-when} @c to adjust your compiler settings, @c or eschew compilation by @code{eval}uating a quoted source form at load-time. @node How do I work with readtables?, How can I capture ASDF's output?, How do I mark a source file to be loaded only and not compiled?, Issues with using and extending ASDF to define systems @subsection How do I work with readtables? @cindex readtables It is possible to configure the lisp syntax by modifying the currently-active readtable. However, this same readtable is shared globally by all software being compiled by ASDF, especially since @code{load} and @code{compile-file} both bind @var{*readtable*}, so that its value is the same across the build at the start of every file (unless overridden by some @code{perform :around} method), even if a file locally binds it to a different readtable during the build. Therefore, the following hygiene restrictions apply. If you don't abide by these restrictions, there will be situations where your output files will be corrupted during an incremental build. We are not trying to prescribe new restrictions for the sake of good style: these restrictions have always applied implicitly, and we are simply describing what they have always been. @itemize @item It is forbidden to modifying any standard character or standard macro dispatch defined in the CLHS. @item No two dependencies may assign different meanings to the same non-standard character. @item Using any non-standard character while expecting the implementation to treat some way counts as such an assignment of meaning. @item libraries need to document these assignments of meaning to non-standard characters. @item free software libraries will register these changes on: @url{http://www.cliki.net/Macro%20Characters} @end itemize If you want to use readtable modifications that cannot abide by those restrictions, you @emph{must} create a different readtable object and set @var{*readtable*} to temporarily bind it to your new readtable (which will be undone after processing the file). For that, we recommend you use system @code{named-readtables} to define or combine such readtables using @code{named-readtables:defreadtable} and use them using @code{named-readtables:in-readtable}. Equivalently, you can use system @code{cl-syntax}, that itself uses @code{named-readtables}, but may someday do more with, e.g. @var{*print-pprint-dispatch*}. For even more advanced syntax modification beyond what a readtable can express, you may consider either: @itemize @item a @code{perform} method that compiles a constant file that contains a single form @code{#.*code-read-with-alternate-reader*} in an environment where this special variable was bound to the code read by your alternate reader, or @item using the system @code{reader-interception}. @end itemize Beware that @c unless and until the @code{syntax-control} branch is merged, it is unsafe to use ASDF from the REPL to compile or load systems while the readtable isn't the shared readtable previously used to build software. You @emph{must} manually undo any binding of @var{*readtable*} at the REPL and restore its initial value whenever you call @code{operate} (via e.g. @code{load-system}, @code{test-system} or @code{require}) from a REPL that is using a different readtable. @subsubsection How should my system use a readtable exported by another system? Use from the @code{named-readtables} system the macro @code{named-readtables:in-readtable}. If the other system fails to use @code{named-readtables}, fix it and send a patch upstream. In the day and age of Quicklisp and clbuild, there is little reason to eschew using such an important library anymore. @subsubsection How should my library make a readtable available to other systems? Use from the @code{named-readtables} system the macro @code{named-readtables:defreadtable}. @node How can I capture ASDF's output?, LOAD-PATHNAME has a weird value, How do I work with readtables?, Issues with using and extending ASDF to define systems @subsection How can I capture ASDF's output? @cindex ASDF output @cindex Capturing ASDF output @vindex *standard-output* Output from ASDF and ASDF extensions are sent to the CL stream @code{*standard-output*}, so rebinding that stream around calls to @code{asdf:operate} should redirect all output from ASDF operations. @node LOAD-PATHNAME has a weird value, , How can I capture ASDF's output?, Issues with using and extending ASDF to define systems @subsection *LOAD-PATHNAME* and *LOAD-TRUENAME* have weird values, help! @vindex *LOAD-PATHNAME* @vindex *LOAD-TRUENAME* Conventional Common Lisp code may use @code{*LOAD-TRUENAME*} or @code{*LOAD-PATHNAME*} to find files adjacent to source files. This will generally @emph{not} work in ASDF-loaded systems. Recall that ASDF relocates the FASL files it builds, typically to a special cache directory. Thus the value of @code{*LOAD-PATHNAME*} and @code{*LOAD-TRUENAME*} at load time, when ASDF is loading your system, will typically be a pathname in that cache directory, and useless to you for finding other system components. There are two ways to work around this problem: @enumerate @findex system-relative-pathname @item Use the @code{system-relative-pathname} function. This can readily be used from outside the system, but it is probably not good software engineering to require a source file @emph{of} a system to know what system it is going to be part of. Contained objects should not have to know their containers. @item Store the pathname at compile time, so that you get the pathname of the source file, which is presumably what you want. To do this, you can capture the value of @code{(or *compile-file-pathname* *load-truename*)} (or @code{*LOAD-PATHNAME*}, if you prefer) in a macro expansion or other compile-time evaluated context. @end enumerate @node ASDF development FAQs, , Issues with using and extending ASDF to define systems, FAQ @section ASDF development FAQs @menu * How do I run the tests interactively in a REPL?:: @end menu @node How do I run the tests interactively in a REPL?, , ASDF development FAQs, ASDF development FAQs @subsection How do I run the tests interactively in a REPL? This not-so-frequently asked question is primarily for ASDF developers, but those who encounter an unexpected error in some test may be interested, too. Here's the procedure for experimenting with tests in a REPL: @example ;; BEWARE! Some tests expect you to be in the .../asdf/test directory ;; If your REPL is not there yet, change your current directory: ;; under SLIME, you may: ,change-directory ~/common-lisp/asdf/test/ ;; otherwise you may evaluate something like: (require "asdf") (asdf:upgrade-asdf) ;load UIOP & update asdf.lisp (uiop:chdir (asdf:system-relative-pathname :asdf "test/")) (setf *default-pathname-defaults* (uiop:getcwd)) ;; Load the test script support. (load "script-support.lisp") ;; Initialize the script support for interaction. ;; This will also change your *package* to asdf-test ;; after frobbing the asdf-test package to make it usable. ;; NB: this function is also available from package cl-user, ;; and also available with the shorter name da in both packages. (asdf-test:debug-asdf) ;; Now, you may experiment with test code from a .script file. ;; See the instructions given at the end of your failing test ;; to identify which form is needed, e.g. (run-test-script "test-utilities.script") @end example @comment FIXME: Add a FAQ about how to use a new system class... @comment node-name, next, previous, up @node Ongoing Work, Bibliography, FAQ, Top @unnumbered Ongoing Work For an active list of things to be done, see the @file{TODO} file in the source repository. Also, bugs are currently tracked on launchpad: @url{https://launchpad.net/asdf}. @node Bibliography, Concept Index, Ongoing Work, Top @unnumbered Bibliography @itemize @item Andrey Mokhov, Neil Mitchell and Simon Peyton Jones: ``Build Systems à la Carte'', International Conference on Functional Programming, 2018. @url{https://www.microsoft.com/en-us/research/uploads/prod/2018/03/build-systems-final.pdf} This influential article provides axes along which to describe build systems in general; ASDF, in addition to being in-image (an axis not considered by these authors), has the following characteristics: ASDF's persistent build information is file modification times (the way ASDF is written, it should be easy enough to write an extension that modifies it to use a ``cloud cache'' à la Bazel, but that would involve using some database, network and cryptographic libraries, which cannot reasonably be included in the base ASDF, that must remain a minimal bootstrappable system with no external dependencies). The object model of ASDF was initially designed for ``static'' dependencies with a ``topological'' scheduler, but its @code{defsystem-depends-on} mechanism (and more generally, the ability to call ASDF from within an @code{.asd} file) allows for multiple @emph{phases} of execution resulting in ``dynamic'' dependencies with a ``suspending'' scheduler. The rebuilder essentially uses a ``dirty bit'', except that the in-image model and the multiple phase support mean that's actually more than a bit: instead it's three bits plus the timestamp plus a phase depth level. The build is guaranteed ``minimal'' in number of steps computed. It is local. It assumes but does not enforce determinism. It does not assume early cutoff of the build when rebuild dependencies didn't change. @item Robert Goldman, Elias Pipping, and François-René Rideau: ``Delivering Common Lisp Applications with ASDF 3.3'', European Lisp Symposium, 2017. @url{https://github.com/fare/asdf2017} This short article gives an overview of the changes in ASDF 3.2 and 3.3, including improved application delivery, asynchronous subprocess management, correct support for multi-phase builds, and enhanced source location configuration. @item Francois-Rene Rideau: ``ASDF 3, or Why Lisp is Now an Acceptable Scripting Language'', European Lisp Symposium, 2014. @url{https://github.com/fare/asdf3-2013} This article describes the innovations in ASDF 3 and 3.1, as well as historical information on previous versions. @item Alastair Bridgewater: ``Quick-build'' (private communication), 2012. @code{quick-build} is a simple and robust one file, one package build system, similar to @code{faslpath}, in 182 lines of code (117 of which are neither blank nor comments nor docstrings). Unhappily, it remains unpublished and its IP status is unclear as of April 2014. @code{asdf/package-system} is mostly compatible with it, modulo a different setup for toplevel hierarchies. @item Zach Beane: ``Quicklisp'', 2011. The Quicklisp blog and Xach's personal blogs contain information on Quicklisp. @url{http://blog.quicklisp.org/} @url{http://lispblog.xach.com/} (new) @url{http://xach.livejournal.com/} (old) @item Francois-Rene Rideau and Robert Goldman: ``Evolving ASDF: More Cooperation, Less Coordination'', International Lisp Conference, 2010. This article describes the main issues solved by ASDF 2, and exposes its design principles. @url{https://common-lisp.net/project/asdf/ilc2010draft.pdf} @url{http://rpgoldman.goldman-tribe.org/papers/ilc2010-asdf.pdf} @item Francois-Rene Rideau and Spencer Brody: ``XCVB: an eXtensible Component Verifier and Builder for Common Lisp'', International Lisp Conference, 2009. This article describes XCVB, a proposed competitor for ASDF; many of its ideas have been incorporated into ASDF 2 and 3, though many other ideas still haven't. @url{https://common-lisp.net/project/xcvb/} @item Peter von Etter: ``faslpath'', 2009. @code{faslpath} is similar to the latter @code{quick-build} and our yet latter @code{asdf/package-system} extension, except that it uses dot @code{.} rather than slash @code{/} as a separator. @url{https://code.google.com/p/faslpath/} @item Drew McDermott: ``A Framework for Maintaining the Coherence of a Running Lisp,'' International Lisp Conference, 2005. @url{http://www.cs.yale.edu/homes/dvm/papers/lisp05.pdf} @item Dan Barlow: ``ASDF Manual'', 2004. Older versions of this document from the days of ASDF 1; they include ideas laid down by Dan Barlow, and comparisons with older defsystems (@code{mk-defsystem}) and defsystem (@code{defsystem-4}, kmp's Memo 801). @item Marco Antoniotti and Peter Van Eynde: ``@code{DEFSYSTEM}: A @code{make} for Common Lisp, A Thoughtful Re-Implementation of an Old Idea'', 2002. The @file{defsystem-4} proposal available in the CLOCC repository. @item Mark Kantrovitz: ``Defsystem: A Portable Make Facility for Common Lisp'', 1990. The classic @file{mk-defsystem}, later variants of which are available in the CLOCC repository as @code{defsystem-3.x}. @item Richard Elliot Robbins: ``BUILD: A Tool for Maintaining Consistency in Modular Systems'', MIT AI TR 874, 1985. @url{http://www.dtic.mil/dtic/tr/fulltext/u2/a162744.pdf} @item Kent M. Pitman (kmp): ``The Description of Large Systems'', MIT AI Memo 801, 1984. Available in updated-for-CL form on the web at @url{http://nhplace.com/kent/Papers/Large-Systems.html} @item Dan Weinreb and David Moon: ``Lisp Machine Manual'', 3rd Edition MIT, March 1981. The famous CHINE NUAL describes one of the earliest variants of DEFSYSTEM. (NB: Not present in the second preliminary version of January 1979) @url{http://bitsavers.org/pdf/mit/cadr/chinual_3rdEd_Mar81.pdf} @end itemize @node Concept Index, Function and Macro Index, Bibliography, Top @unnumbered Concept Index @printindex cp @node Function and Macro Index, Variable Index, Concept Index, Top @unnumbered Function and Macro Index @printindex fn @node Variable Index, Class and Type Index, Function and Macro Index, Top @unnumbered Variable Index @printindex vr @node Class and Type Index, , Variable Index, Top @unnumbered Class and Type Index @printindex tp @bye @c LocalWords: clbuild tarballs defsystem Quicklisp initarg uiop fasl @c LocalWords: namestring initargs fasls asdf-3.3.4/doc/best_practices.md000066400000000000000000001310311362155115300165200ustar00rootroot00000000000000ASDF Best Practices =================== This document presents the current best practices and conventions for using ASDF 3, as of 2017. It is not a tutorial, though it starts like one, because it assumes for each category of ASDF user (beginner, simple user, more elaborate user) that he already knows what seems to be common knowledge among such users, and tries to complete this knowledge with less obvious points that are often wrong in systems seen in the wild. Table of Contents ----------------------------------- - [Trivial Examples](#trivial_examples) + [Trivial Uses of ASDF](#trivial_asdf) * [Loading a System](#loading_system) * [Testing a System](#testing_system) * [Designating a System](#designating_system) + [Trivial System Definition](#trivial_system) * [Using the system you defined](#using_system) + [Trivial Testing Definition](#trivial_testing) * [Notes on ASDF 2 compatibility](#notes_asdf2) + [Trivial Packaging](#trivial_packaging) * [Digression about symbols and packages](#digression) - [Simple Examples](#simple_examples) + [Simple Uses of a System](#simple_uses) * [Building a System](#building_system) * [Inspecting a System](#inspecting_system) * [Other Operations](#other_operations) + [System Naming](#system_naming) * [Primary Systems](#primary_systems) * [Secondary Systems](#secondary_systems) + [Simple System Definition](#simple_system) + [Simple Packaging](#simple_packaging) * [Initial Package for a Lisp File](#initial_package) * [Using Symbols from ASDF and UIOP](#using_symbols) + [Simple Testing](#simple_testing) + [Other Secondary Systems](#other_secondary) * [Delivering an Executable](#delivering_executable) * [System Connections](#system_connections) - [More Elaborate Examples](#moreelaborate_examples) + [More Elaborate Uses of ASDF](#moreelaborate_asdf) * [force](#force) * [force-not](#force_not) * [Require](#require) + [More Elaborate System Definitions](#elaborate_definitions) * [package-inferred-system](#package_inferred) * [Using ASDF Extensions](#using_extensions) * [Code in .asd files](#code_asd) * [Conditional Code](#conditional_code) + [More Elaborate Testing](#moreelaborate_testing) + [Defining ASDF Extensions](#defining_extensions) * [Source File Types](#source_types) * [Conditional Outputs and Conditional Perform](#conditional_outputs) - [Other](#other) + [Syntax Control](#syntax_control) + [Using ASDF Internals](#using_asdf_internals) Trivial Examples ------------------------------------------------ Let's start with some trivial examples. We'll see below how these examples evolve as systems grow more complex. ### Trivial Uses of ASDF #### Loading a System The most trivial use of ASDF is by calling `(asdf:load-system :foobar)` to load your library. Then you can use it. For instance, if it exports a function `some-fun` in its package `foobar`, then you will be able to call it with `(foobar:some-fun ...)` or with: (in-package :foobar) (some-fun ...) #### Testing a System To run the tests for a system, you may use: (asdf:test-system :foobar) The convention is that an error SHOULD be signalled if tests are unsuccessful. #### Designating a System Using keywords to name systems is good and well at the REPL. However, when writing a program, a bootstrap script, or a system definition, you SHOULD follow the good style of writing names in the canonical way; and the canonical name of a system is a string, which by convention is in lower-case (indeed any symbol used as system designator is downcased by `asdf:coerce-name`). Thus, the proper way to designate a system in a program is with lower-case strings, as in: (asdf:load-system "foobar") (asdf:test-system "foobar") (Historical note: MK-DEFSYSTEM and before it Genera's SCT used string-upcase to normalize system names, and use that as filenames, which made sense on Genera's filesystem or using logical pathnames as common with MK-DEFSYSTEM. Dan Barlow's ASDF, to "Play Nice With Unix", preferred lower-case file names, and used string-downcase to normalize symbols into strings; at the same time, he allowed you to specify mixed case or upper-case names by using a string. The latter was probably a mistake, and I strongly recommend against using anything but lower-case. If that weren't allowed, there would be a case for making lower-case symbols the default syntax, and let the various case conversions do their job without quotes. But that is not where we are. In any case, system names designate `.asd` files, not Lisp bindings, and this determines their syntax.) ### Trivial System Definition A trivial system would have a single Lisp file called `foobar.lisp`. That file would depend on some existing libraries, say `alexandria` for general purpose utilities, and `trivia` for pattern-matching. To make this system buildable using ASDF, you create a system definition file called `foobar.asd`, with the following contents: (defsystem "foobar" :depends-on ("alexandria" "trivia") :components ((:file "foobar"))) Note how the type `lisp` of `foobar.lisp` is implicit in the name of the file above. As for contents of that file, they would look like this: (defpackage :foobar (:use :common-lisp :alexandria :trivia) (:export #:some-function #:another-function #:call-with-foobar #:with-foobar)) (in-package :foobar) (defun some-function (...) ...) ... #### Using the system you defined Assuming your system is installed under the `~/common-lisp/` hierarchy or some other filesystem hierarchy already configured for ASDF, you can load it with: `(asdf:load-system "foobar")`, or shorter `(asdf:make :foobar)` If your Lisp was already started when you created that file, you may have to `(asdf:clear-configuration)` to re-process the configuration. ### Trivial Testing Definition Even the most trivial of systems needs some tests, if only because it will have to be modified eventually, and you want to make sure those modifications don't break client code. Tests are also a good way to document expected behavior. The simplest way to write tests is to have a file `foobar-tests.lisp` and modify the above `foobar.asd` as follows: (defsystem "foobar" :depends-on ("alexandria" "trivia") :components ((:file "foobar")) :in-order-to ((test-op (test-op "foobar/tests")))) (defsystem "foobar/tests" :depends-on ("foobar" "fiveam") :components ((:file "foobar-tests")) :perform (test-op (o c) (symbol-call :fiveam '#:run! :foobar))) The `:in-order-to` clause in the first system allows you to use `(asdf:test-system :foobar)` which will chain into `foobar/tests`. The `:perform` clause in the second system does the testing itself. In the test system, `fiveam` is the name of a popular test library, and the content of the `perform` method is how to invoke this library to run the test suite `:foobar`. Obviously your mileage may vary if you use a different library. #### Note on ASDF 2 compatibility The `:in-order-to ((test-op (test-op ...)))` idiom will not work with ASDF 2: attempts to `test-system` will result in failure due to circular dependencies; however, `load-system` will still work. As for the `:perform` method, you need to specify `:after` right after `test-op` for ASDF 2 to accept the `defsystem` form at all (but still not make the `:in-order-to` work); so it's probably OK if your test system is in a separate `.asd` file, but if you want backward compatibility and it's a secondary system, you'll use `:after`. Making things work completely on ASDF 2 as well as ASDF 3 would take a lot of pain, and would be colloquial for neither. But *friends don't let friends use ASDF 2*. ASDF 3 has been available since 2013, and all implementations have now been providing it for a long time. Many systems, and growing, assume ASDF 3, possibly some you depend on, and it's pointless to maintain compatibility with a moribund system (especially so if you don't also check that all your dependencies do, too). Upgrade your implementations and/or at least your ASDF, and tell your friends to do as much. The [very founding principle of ASDF 2](http://fare.livejournal.com/149264.html) (and 3) was to provide users with the ability to install a newer ASDF on top of an old one to fix its bugs (an ability that did not exist with ASDF 1); thus, users do not have to maintain compatibility with antique bugs. These days, I even recommended that you should freely rely on features of ASDF 3.1 (2014) not present in ASDF 3.0 (2013), such as: `~/common-lisp/` being included in the source-registry by default; `run-program` being full-fledged with input and error-output support; or the `package-inferred-system` feature. Conversely, if you want indefinite backward compatibility, why stop at ASDF 2? Why not also support ASDF 1, and MK-DEFSYSTEM, and the original Lisp Machine DEFSYSTEM? A good rule of thumb for me is that it is not worth writing workarounds for bugs that were fixed or features that were changed two years ago or more. Two years seems to be the time it takes for a release of ASDF to become ubiquitously available by default on all implementations; and, remember, if a user must use an older implementation, he can always trivially install a newer ASDF on top of it. Thus, by October 2019, people should not be shy about dropping support for ASDF versions older than 3.3. And even before then, if you need a recent ASDF, just document it, and tell your users to upgrade their implementation and/or install a recent ASDF on top of their implementation's. ### Trivial Packaging In the previous testing code, `symbol-call` is a function defined in package `uiop`. It helps deal with the fact that the package `:fiveam` isn't defined yet at the time the `defsystem` form is read. Thus you can't simply write `(fiveam:run! :foobar)`, as this might cause a failure at read-time when file `foobar.asd` is first read and the system `fiveam` isn't loaded yet. This of course also holds for packages defined by system `foobar` itself. To get a symbol in it that is not a function being called, you can also use `(find-symbol* :some-symbol :foobar)`, and you can use `symbol-value` to get the value bound to such a symbol as denoting a variable. For complex expressions, you can use `eval` and `read-from-string`, as in `(eval (read-from-string "(foobar:some-fun foobar:*some-var*)"))`, or equivalently, also from `uiop`: `(eval-input "(foobar:some-fun foobar:*some-var*)")`. System definition files are loaded with the current `*package*` bound to the package `:asdf-user`, that uses the packages `:cl`, `:asdf` and `:uiop`. Therefore, you don't need to and you SHOULD NOT specify `cl:`, `asdf:` or `uiop:` prefixes when referring to symbols in these respective packages. It is considered bad form to do so, unless you changed the package, and even then, your package should probably use these packages, too. In particular you SHOULD NOT to write `(asdf:defsystem "foobar" ...)` instead of `(defsystem "foobar" ...)`. Also, you SHOULD NOT use `(in-package ...)` or `(defpackage ...)` if all you do can legitimately be done in package `ASDF-USER`. System definition files are loaded by a special function `asdf::load-asd`; this function locally binds the current `*package*` to the `:asdf-user` package, but it also does many other things. You MUST NOT ever load a `.asd` file using `cl:load`, as this will not work in general, and may fail in subtle or spectacular ways. You MUST always use `asdf::load-asd` for that purpose (the function is exported in ASDF 3.2 and above, but not in earlier versions). You SHOULD NOT encourage the illusion that a `.asd` file can be loaded with `cl:load` by using `(in-package :asdf-user)` or anything, or by using the package prefix `asdf:` for `defsystem` and other such symbols. You SHOULD be using the `slime-asdf` extension to SLIME if you are going to edit `.asd` file and then load them from SLIME, as it will automatically use `load-asd` to load the file contents. #### Digression about symbols and packages A crucial notion in Common Lisp is that of *symbols*, to which are associated functions, variables, macros, properties, and other meanings. These symbols are organized in a two-level namespace that is global to a given Lisp image. Symbols are the second level, and the first level are *packages*. Symbols and packages are traditionally uppercase internally, but you traditionally write them lower-case in source code; the Common Lisp reader is *case-converting*. These internal representation details matter, because they are exposed when you either write macros at compile-time or introspect the system at runtime. The conventional way to refer to a package is with its name designated by a lower-case keyword, starting with the colon character `:`. For instance, the standard package `COMMON-LISP` is commonly designated as `:common-lisp` (or `(find-package :common-lisp)` if you need an actual package object). Keywords are themselves symbols in the magic package `KEYWORD`, where each interned symbol is also a constant bound to its own name as a value. Using a keyword as designator rather than a string ensures that we can maintain the same convention of using lower-case in source code while the runtime will use uppercase. Simple Examples ---------------------------------------------- As systems grow, the above pattern quickly becomes insufficient, but systems can still remain simple. ### Simple Uses of a System #### Building a System Some systems offer operations that are neither loading in the current image, nor testing. Whichever operation a system is meant to be used with, you may use it with: (asdf:make :foobar) This will invoke `build-op`, which in turn will depend on the `build-operation` for the system, if defined, or `load-op` if not. Therefore, for usual Lisp systems that want you to load them, the above will be equivalent to `(asdf:load-system :foobar)`, but for other Lisp systems, e.g. one that creates a shell command-line executable, `(asdf:make ...)` will do the Right Thing™, whatever that Right Thing™ is. #### Inspecting a System To look at what ASDF knows of your system, try: (describe (asdf:find-system "foobar")) If you're looking for the `.asd` file, try `(asdf:system-source-file "foobar")`. For the directory in which the `.asd` file resides, try `(asdf:system-source-directory "foobar")`. For a specific file under that directory try `(asdf:system-relative-pathname "foobar" "path/to/the/file.extension")`. #### Other Operations ASDF has the concept of an *operation* that can act upon a system (or a smaller component thereof). Typical operations that matter to end-users include: * `load-op` for loading a system in the current Lisp image, as used by `asdf:load-system`, * `test-op` for running tests associated to the system, as used by `asdf:test-system`, * `build-op` for doing whatever build operation is associated to the system, (which by default is `load-op` if the system didn't override it), as used by `asdf:make`. Further operations of interest to users include: * `compile-op` (ensure the system is compiled, without necessarily loading all of it, or any bit of it), * `load-source-op` (load the system from source without compiling), * `compile-bundle-op` (create a single fasl for the entire system, for delivery), * `monolithic-compile-bundle-op` (create a single fasl for the entire system *and all its transitive dependencies*, for delivery), * `image-op` (create a development image with this system already loaded, for fast startup), * `program-op` (create a standalone application, which we will see below), etc. Whichever operation you want, `(asdf:operate `*operation* *system*`)` will ensure this operation is performed on that system (after all the necessary dependencies of such an action). A short-hand `asdf:oos` is available for `asdf:operate` (the name `oos` is an old acronym for `operate-on-system`, and both functions existed as synonyms in the old MK-DEFSYSTEM; the latter function doesn't exist in ASDF, which instead has just `operate`). The operation is typically specified as a symbol that names the operation class. Since ASDF 3, you can also use a keyword to specify an action in the ASDF package. Thus, `(asdf:oos :load-op :foobar)` is equivalent to `(asdf:load-system :foobar)`. ### System Naming #### Primary Systems ASDF has a notion of *primary system*, that it can find in configured parts of the filesystem (the *source-registry*), in a file that has the same name and the type `asd`. Thus, primary system `foobar` is defined in a file `foobar.asd`. While arbitrary strings are accepted in system names, it is strongly discouraged to use anything but lower-case ASCII letters and digits for primary system names, plus the separators `-` (hyphen) and `.` (dot). The `.` itself is only recommended in primary system names that are part of an informal hierarchy; for instance the popular library `iolib` contains many related systems: `iolib.asdf`, `iolib.base`, `iolib.common-lisp`, `iolib.conf`, `iolib.examples`, `iolib.grovel`, `iolib.tests`. The main one is ostensibly `iolib`, but it contains many systems, and for some reasons (notably proper phase separation) they cannot all be secondary systems in the same file. #### Secondary Systems A *secondary system* is a system defined in the same file as a primary system. By convention, its name starts the same as the file's primary system, followed by a slash `/` and by a *suffix* made of some arbitrary characters, preferably ASCII letters and digits plus the separators `-` (hyphen), `.` (dot) and `/` (slash). We already saw an example of it with system `foobar/tests` in the trivial testing definition above. The convention above allows ASDF 3 and later to find a secondary system by name, by first looking for the associated primary system. ASDF 3.2 or later will issue a `warning` when you violate this naming convention. (Historically, ASDF 1 (and 2) allowed arbitrary names for secondary systems, and in practice many people used `foo-test` or such for secondary system names in `foo.asd`; however, ASDF 1 (and 2) couldn't find those systems by name, and horrific bugs could happen if a system was simultaneously defined in multiple files.) ### Simple System Definition A simple system may be made of many files. Typically, in `package.lisp` (or `packages.lisp`) you'll define the package (or packages) used by all the files in your system in one or more forms such as `(defpackage :foobar ...)`. Then, in a package `utils.lisp` you'll define utility macros and functions that you're using throughout your system; maybe some of them deserve to be moved to `alexandria` and other utility systems; and maybe they already exist out there and you just haven't looked hard enough. Then a file `foobar.lisp` defines the meat of your system. Your system definition will look like: (defsystem "foobar" :depends-on ("alexandria" "trivia") :serial t :components ((:file "package") (:file "utils") (:file "foobar"))) The `:serial t` indicates that each of these files depends on (all) the previous. As your system grows some more, soon enough instead of a single file `foobar.lisp`, you will have several files, one for each aspect of your system, such as `foo.lisp`, `bar.lisp` as well as `foobar.lisp`. Moreover, `:serial t` soon becomes inappropriate: it will make your code slower to compile, but also to read. Indeed, those who read the code won't be readily able to tell which parts of the code they need to keep active in their brains to understand the code at hand. Instead, you may prefer to explicitly represent the dependencies between the components of your system using `:depends-on` clauses as follows: (defsystem "foobar" :depends-on ("alexandria" "trivia" "trivia.ppcre") :components ((:file "package") (:file "utils" :depends-on ("package")) (:file "foo" :depends-on ("utils")) (:file "bar" :depends-on ("utils")) (:file "foobar" :depends-on ("foo" "bar")))) Out of good style, you SHOULD still list the components in an order that makes sense, such that the readers can read the files and mentally rebuild the system. However, note that this order, if coherent, will be respected only in ASDF 3.3 or later, due to a bug in earlier versions of ASDF. But that precise order shouldn't matter, or it should be reflected in the `:depends-on` declarations (or in a `:serial t` declaration). ### Simple Packaging #### Initial Package for a Lisp File You MAY assume that the current package uses `CL` at the beginning of a file, but you MUST NOT assume that it is any particular package at this point: right now, it *is* guaranteed to be the `CL-USER` package of the underlying implementation, but it is conceivable that in some indeterminate future, some extension to CL may provide a well-defined portable alternative that ASDF would use. Therefore, the sane way to write a Lisp file is that it SHOULD start with an `in-package` form, optionally preceded by a `defpackage` form (or a `uiop:define-package` form). You SHOULD NOT write `cl:in-package` or precede your `defpackage` with an `(in-package :cl-user)` (which is stupid, because to be pedantic you'd have to `(cl:in-package :cl-user)`, at which point you may as well `(cl:defpackage ...)` and `(cl:in-package ...)`). If it's a regular `cl-source-file`, it can assume the language is CL indeed, and that the readtable something reasonable, etc. #### Using Symbols from ASDF and UIOP You MAY use any of the symbols documented and exported by ASDF or UIOP. Actually, it is warmly recommended to use them everywhere that it matters, instead of less documented or less portable alternatives. You MUST NOT use `asdf:run-shell-command`, `asdf:system-definition-pathname`, or other deprecated functions that were once recommended in the time of ASDF 1. They will be removed in the near future (one to two year horizon). ASDF 3.2 or 3.3 will issue a `style-warning` when you do, and some future version of ASDF will issue a full `warning`, which will then break the SBCL build. See `backward-interface.lisp` for a list of deprecated function — or just heed the damn warnings. ### Simple Testing Test systems can also be divided in multiple files. If possible (which is not always the case), the file names for test files should match file names for regular code files, so that the file that tests `bar.lisp` will be called `bar-test.lisp` or `bar-tests.lisp` (pick singular or plural, but have a story for it and be consistent about it). To keep things tidy as the test system grows, you may even put all test files in a subdirectory `t/`, `test/` or `tests/`. Your test system definition may then look like: (defsystem "foobar/tests" :depends-on ("fiveam" "foobar") :pathname "t/" ;; specify the subdirectory :components ((:file "test-suite") (:file "utils-test" :depends-on ("test-suite")) (:file "foo-test" :depends-on ("test-suite")) (:file "bar-test" :depends-on ("test-suite")) (:file "foobar-test" :depends-on ("test-suite"))) :perform (test-op (o c) (symbol-call :foobar/tests :run-test-suite))) As the system and its test system both grow, the test system may be moved to its own file `foobar-tests.asd` or `foobar.tests.asd` where it is its own primary system: (defsystem "foobar-tests" ...) ### Other secondary systems Other secondary systems may be created beyond test systems: for instance systems that provide independent aspects of the system, or optional add-ons to it. One case is a command that makes the Lisp functionality accessible from a Unix shell. #### Delivering an Executable To build an executable, define a system as follows (in this case, it's a secondary system, but it could also be a primary system). You will be able to create an executable file `foobar-command` by evaluating `(asdf:make :foobar/executable)`: (defsystem "foobar/executable" :build-operation program-op :build-pathname "foobar-command" ;; shell name :entry-point "foobar::start-foobar" ;; thunk :depends-on ("foobar") :components ((:file "main"))) The `build-pathname` gives the name of the executable; a `.exe` type will be automatically added on Windows. As a horrible kluge that may go away in the future, the output will be created in the system's directory (where the `foobar.asd` file resides) when the `build-operation` matches the requested operation. A future version of ASDF will probably instead have some `:output` argument to `operate`, or some such thing, and drop this ugly special case. You have been warned. Contact me if you want that sooner, or not at all. There, file `main.lisp` defines a function `start-foobar` in package `foobar`, that takes no argument, and initializes and starts the executable --- after `uiop` calls its own `*image-restore-hook*` and evaluates any provided `*image-prelude*`. Importantly, libraries may register functions to call in the `*image-restore-hook*` using `register-image-restore-hook` (see also `register-image-dump-hook`); UIOP and ASDF themselves make use of this facility. Typically, `start-foobar` will be defined as something like: (defun start-foobar () (main (uiop:command-line-arguments))) Where function `main` parses the arguments (a list of strings, excluding the magic C `argv[0]`, which can be computed as `(uiop:argv0)`) and does whatever its magic. You may want to use the full-featured `net.didierverna.clon` or my small `command-line-arguments` or one of a slew of other libraries to parse the command-line arguments. You may want to use `cl-scripting` to nicely wrap Lisp code into execution contexts that handle errors in a nice(r) user-visible way for the shell user. You may want to use `inferior-shell` if your program in turn invokes other shell programs. Instead may also use `cl-launch` to build executables, or `buildapp`. `cl-launch` is largely compatible with ASDF (indeed, a lot of code formerly written as part of `cl-launch` was later made part of ASDF 3's UIOP). `buildapp`, that came before ASDF 3 but after `cl-launch`, has a slightly incompatible convention where a main function is called with a list of arguments that includes the `argv[0]`. (`cl-launch` and after it UIOP had many good enough reasons to start the argument list at the "user arguments", if only because when invoking a Lisp implementation via `cl-launch`, the process' `argv[0]` may not be available or meaningful, whereas the user arguments may be only a subset of the actual process' arguments.) Both `cl-launch` and `buildapp` have similar functionality to handle multicall binaries à la [Busybox](http://busybox.net/), with the same incompatibility as above. #### System Connections Sometimes, a system can provide an extension to another system. For instance, if you use both `metacopy` and `contextl`, you may be interested in some system `metacopy/with-contextl` that creates synergies between these two systems. There exists a system `asdf-system-connections` that will allow you to define such system connections that are *automatically* loaded when both the connected systems are loaded. While I debugged that mechanism and made sure it works with ASDF 3, I recommend against using it, because it introduces side-effects within the build. Instead I recommend explicitly loading the system connections as part of the larger system that will use them. More Elaborate Examples -------------------------------------------------------- ### More Elaborate Uses of ASDF #### force Sometimes, you want to force ASDF to re-build some system. At those times, you can pass the `:force` argument to `asdf:operate` (or its wrappers `asdf:load-system`, `asdf:test-system`, `asdf:oos`, etc.). Passing an argument `t` will force rebuild of just the system, and none of its dependencies (and that also means none of the dependencies that happen to be secondary systems with the same primary system name). Passing a list of system designators (preferably lower-case strings) will force the specific systems to be rebuilt (if they appear in the build plan at all, that is). Finally, passing `:all` as argument will force a rebuild of everything, including all dependencies. Thus, if you ran tests that use the `prove` test framework, in which loading the files is itself the test, and you want to force a re-run, even though ASDF might be satisfied with already having loaded the files, then you can use: `(asdf:load-system :clack-test :force t)` Note that it is strongly recommended to not have any non-determinism or side-effects that are not declared to ASDF, that would cause the forcing to be meaningful. Forcing is thus a debugging feature for ASDF systems that fail this good practice. In the case of `prove`, we will have to work with its author so that the correct way to use it doesn't violate ASDF invariants, but instead properly declare that ASDF should not consider tests already run. #### force-not The converse of `:force` is `:force-not`, and you can specify a list of systems to not rebuild. In this context `t` means "everything but this system" rather than " this system". `force-not` takes precedence over `force`, and by default includes a list of "immutable" systems that may be used when delivering extensible applications to customers (See function `asdf::register-immutable-system`). Note that these flags are only for use by the user at the toplevel. You MUST NOT call `asdf:operate` with `:force` or `:force-not` from within a build. Actually, you should probably not explicitly use `asdf:operate` at all, except maybe inside a `.asd` file in cases where `defsystem-depends-on` isn't sufficient. #### Require You SHOULD NOT use `cl:require` as a substitute for `asdf:load-system`. You SHOULD NOT use `asdf:require-system` except at the toplevel. Back in the days of ASDF 1, a convenient hook was added to ASDF so that when you call `cl:require`, it would try to load the named system, and if not fall back on the builtin require mechanism. This was a cool hack, and when you merely wanted a dependency, it was easier to type `(require :foo)` than `(asdf:operate 'asdf:load-op :foo)` as you then had to. Moreover, on SBCL where ASDF was developed, ASDF itself was used to compile and load SBCL modules at runtime, so this hook came naturally. As ASDF maintainer, I now consider this in bad taste: * First, this hook is not 100% portable, so it is bad taste to recommend relying on it. * Second, `cl:require` has a mechanism for loading things only once by checking `cl:*modules*` which may subtly interfere with ASDF's mechanism for keeping things up to date. * Third, it interferes with ASDF's capacity to detect legitimate vs illegitimate recursive uses of `operate` at places that defeat tracking of dependencies. * Fourth, it adds a lot of complexity for dubious gain: at a time you had to type `(asdf:operate 'asdf:load-op :foo)`, `(require :foo)` may have been a nice short-hand, but it isn't such a great gain over `(asdf:make :foo)`. * Fifth, SBCL now uses ASDF 3's `compile-bundle-op` to create a fasl during the build of SBCL itself, and that fasl can latter be loaded at runtime without ASDF. Therefore the hook has no natural use anymore. Similarly, in ASDF 2.21 I added a function `require-system` that used to called `load-system` with `:force-not (already-loaded-systems)`, which was a nice hack at the time, that I latter used as part of the `cl:require` hook. That was all a big mistake, as `:force-not` interferes with the ability to keep a coherent plan across recursive uses of `asdf:operate` as required by builds that involve `:defsystem-depends-on` and other ASDF extensions. These days, this function only checks whether the requested component is already loaded, and if not calls `asdf:load-system` on it. This function MUST only be used at the toplevel, never in a script or build. It may be deprecated in a future version of ASDF. ### More Elaborate System Definitions #### package-inferred-system When you start writing large enough systems, putting everything in one big package leads to a big mess: it's hard to find what function is defined where, or should be defined where; you invent your own symbol prefixing system to avoid name clashes; totally unrelated things end up in the same mother-of-all package; you divide your mother-of-all package into a few subpackages, but as the software keeps growing each of these packages in turn becomes too big. Meanwhile, as you grow large enough libraries, you find that you loading a big library just to use a small part of it becomes a big hassle, leading to code bloat, too much recompilation, too much re-testing, and not enough understanding of what's going on. A solution to both these problems is the "one file, one package, one system" style, once spearheaded by faslpath and quick-build, and now available as part of ASDF (since ASDF 3.1, 2014) using the `package-inferred-system` class. Following this style, your top `.asd` file defines uses this class for its primary system (you can still define secondary systems with different classes). Then, any secondary system, if not explicitly defined, will be searched for in a file as named by the secondary system suffix, under the directory that contains the system definition file. Thus, if `~/common-lisp/foobar-1.0/foobar.asd` defines a primary system of class `package-inferred-system`, but no secondary class `foobar/x/y`, then ASDF will look for a file `~/common-lisp/foobar-1.0/x/y.lisp` to contain this system. That file will be a regular Lisp file, that will begin with a `defpackage` or `uiop:define-package` form. (The latter form is more friendly to live upgrades, but also allows to use a mix of packages with a priority on symbol conflicts, or to reexport imported symbols.) Dependencies for this system will be deduced from the `:use`, `:import-form` and `:shadowing-import-from` clauses of that `defpackage`, where each package name is downcased and interpreted as a system name, unless registered otherwise via `asdf:register-system-packages`. This allows for large modular libraries, wherein you may use one file, and only that file and its transitive dependencies will be loaded, rather than the entire humongous library. This also helps you enforce a discipline wherein it is always clear in which file each symbol is defined, which files have symbols used by any other file, etc. #### Using ASDF Extensions If you need an ASDF extension, the recommended way is to use `:defsystem-depends-on`. The extension will define new classes of operations or components, new functions, etc. If it defines them in the ASDF package, you can refer to them using a keyword of the same name, e.g. `:cffi-wrapper-file` for one of the component classes defined by system `cffi-grovel`, `:static-program-op` for one of the operation classes defined by `cffi-toolchain`, or `:f2cl-system` for the system class defined by system `f2cl`. Otherwise, you can refer to them using a string that when read yields the symbol, e.g. the system `asdf-finalizers` defines a function that you can use as an around-compile hook for your system using the clause `:around-compile "asdf-finalizers:check-finalizers-around-compile"`. You cannot usually specify the qualified symbol directy, because it lives in a package that hasn't been defined yet at the time the `defsystem` form is read. Sometimes, you may want to use several build extensions at once, but a given system, smaller component or operation, can have only one class. You may split that system in two (say, a primary system and a secondary system) so each has its own extension (say, make the primary system a `package-inferred-system`, but have a secondary system be a `program-system`). For more advanced cases, you may have to define a class that inherits from multiple other classes in your own extension. (In a prototype OO system, you could just mix and match extensions without defining a new class, but CLOS is not a prototype OO system.) #### Code in .asd files ASDF currently allows arbitrary Lisp code in a `.asd` file. I would like to deprecate that in the future to make ASDF more declarative. In the meantime, here are some guidelines for how to write such code properly. First, you SHOULD minimize the amount of such code and you SHOULD strongly consider defining an extension in a separate `.asd` file that you `:defsystem-depends-on`. Then, `.asd` files are read with the current package being `asdf-user`. You MAY use any symbols defined in packages `cl`, `asdf` and `uiop`, and you SHOULD stay in package `asdf-user` if it suffices; you SHOULD NOT needlessly create a package for your system definition file if you're not going to define any such function nor variable nor macro. But you MUST NOT pollute that package with bindings that could clash with uses by other systems. It is poor taste to define functions, variables or macros in package `asdf-user`, unless strictly necessary or widely useful, and even then with a long name that distinctively includes the name of your system. However it is perfectly acceptable to define methods on existing functions, preferably using the `:perform` syntax used above, as part of a `defsystem` form. If you must define new functions, variables or macros, you MUST define a new package in which to define them. That system would typically be named `foobar-system` and would export the relevant symbols, as in: (defpackage :foobar-system (:use :cl :asdf :uiop) (:export #:my-foobar-class ...)) (in-package :foobar-system) That said, if you need more than trivial definitions, and if these definitions ever need to be used by others, it is appropriate to move them to their own system. Also, it is poor taste to define symbols used in the system itself (e.g. `*version*`) since the system then depends on ASDF and cannot be directly built using Bazel, or some other future build system. For versions, consider having ASDF extract the version from a file, as in `:version (:read-file-form "variables.lisp" :at (2 2 2)`. See the ASDF manual for details, and `asdf.asd` itself for an example. #### Conditional Code The recommended way to conditionally use code is to rely on the CL features; yet, you SHOULD NOT use read-time conditionals if you can avoid it, and instead use the ASDF 3 `:feature` and `:if-feature` features: * To conditionally depend on another system or module, specify as a `:depends-on` argument something like `(:feature :sbcl (:require :sb-introspect))` or `(:feature (:or :ccl :sbcl) "bordeaux-threads")`. * To conditionally enable a component, specify a `:if-feature` argument to it like `(:file "sbcl-support" :if-feature :sbcl)` Note that the feature expressions MUST use keywords, not symbols in the current package (unless you're pervert enough to make `:keyword` your current package). Also note that ASDF at this time wants all the component classes to be defined, so if your component classes are conditionally defined, you may have to resort back to the otherwise deprecated use of read-time conditionals, as in: (defsystem "foo" :defsystem-depends-on ((:feature :sbcl "some-sb-magic")) :components (#+sbcl (:sb-magic-file "some-magic"))) If the condition you want to express doesn't have a corresponding `*features*` keyword, you MAY use a `(when ... (pushnew :my-keyword *features*))` form to add a feature keyword for it. However, you SHOULD NOT needlessly push new features; in particular, the mere fact of having loaded your system does not warrant a new feature. A feature is only warranted if your system is some deep infrastructure with mostly compatible rivals that it needs to be distinguished from. ### More Elaborate Testing You MUST NOT call `asdf:operate` or any of its derivatives, such as `asdf:load-system` or `asdf:test-system` from within a `perform` method. Instead, you SHOULD declare proper dependencies between actions using methods on `component-depends-on`, or more simply using an `:in-order-to` clause in your `defsystem` form. You MUST NOT call `asdf:clear-system` or in any way interfere with the build while in a `perform` method. You SHOULD NOT define methods on `asdf:operate` --- most of the time it's totally the wrong thing because users would *not* be "operating" on *your* system, but on *their* system that depends on it. Instead you SHOULD define methods on `asdf:perform`, `asdf:component-depends-on`, etc. ### Defining ASDF Extensions #### Source File Types You MUST NOT define methods on `source-file-type`. This bad ASDF 1 interface must die and will be removed in a future version of ASDF. Instead, override the slot `type` for your file class and provide a proper `:initform`, as in: (defclass cl-source-file.l (cl-source-file) ((type :initform "l"))) You can then provide the name of that class as class name for individual components, or as `:default-component-class` to relevant systems or modules. #### Conditional Outputs and Conditional Perform An operation MUST actually create all the outputs declared by the `output-files` method. If some of these outputs are conditional, the `output-files` method MUST check the condition and remove uncreated outputs from the list. If some output is sometimes non meaningful but that is only known after calling the `perform` method, it is sometimes appropriate to create an empty file instead of not creating the file. If you conditionally avoid performing an action altogether using an `:around` method, you MUST still call `mark-operation-done` on the action in the branch of the method where the action is not performed. In that case, both the `output-files` and `input-files` methods should probably return `nil` when that condition is met. Alternatively, if avoiding some actions is uniform for all operations on a given component, you MAY want to override or wrap around the `component-if-feature` method for that component instead of defining all those `perform`, `output-files` and `input-files` methods. Other -------------------------- ### Syntax Control Do not side-effect the current `*readtable*`, which is never guaranteed to be writable, and may not be what is current when you need the modification. If you need modifications to the readtable, use `named-readtables`, `reader-interception`, or some other adequate mechanism. To bind the readtable, use `named-readtables:in-readtable` or `cl-syntax:in-syntax` in each file that needs a non-standard readtable, and/or use an `:around-compile` hook to automatically bind it around every file in a module or system. See the syntax-control document (in the syntax-control branch if it wasn't merged yet). ### Using ASDF Internals At times, you will have to use some ASDF internals to get your software to work. When this happens, follow these rules to minimize the breakage associated to bitrot: * You MUST use the `asdf::` package prefix rather than `asdf/foo:` to name the symbols internal to ASDF. Indeed, from one version of ASDF to the next, which internal package a symbol will reside in may change; for instance `asdf/find-system:primary-system-name` recently became `asdf/system:primary-system-name` (it is still present, not exported, in the former system); but it is always present (though not currently exported) in package `asdf`. * When you use internals, you MUST notify the ASDF maintainers, and request that they either export the symbol and support the API, or offer an alternative API more to their liking for the same functionality. Otherwise, they will be justified in modifying internals that no one is supposed to use, and they will blame you when they later change or remove these internals and your software breaks. Note that the latter point is true of all software, not just ASDF. asdf-3.3.4/doc/cclan.png000066400000000000000000000251311362155115300147750ustar00rootroot00000000000000PNG  IHDRS,[TgAMA a IDATxyյ?zz6aDEP\\qHܣF_~ Q&LD5Dcb\@O42"\ ʰLuTU]kcֹu.{( ](p< i(p< i(p< i(p< i(p< i(p< i(p< i(p<u/yzOJ=PG,J+NY?gϣ*YDpN2qS~ݹ@*οGc󑛔{{$m[Kﴀ_1&I/+NKKm+ܧ& $<66\:Or_ˑ/|lJheR4}} sɔc /uZ~M͘<8S4[k8=}rм$Zϒ_Ckw5>*T|Յ cڭg='RO1$0I'_iݞ)_/rG?NJo6w&;T JeF˟l}괬y-w7w"Vˀtc U'}ؚhoўTul&lȌ'qPAj/:3M? (:P2JCD,dd$b? \n{im4p;\[>Wܣ.q|Rt--}_jSL+f5DrN37i*6vl{W9j~9~s)- $ҕ% I9I@(*| 1 eJ@Cä+bFCǍ~BJQ /iRH?tՐ̑c_Ĩ<򛓫3-8'=w#zF,Aآ;{R D<{ uĝJ힋'"o{ e v{8ip`_xENE%յxe}%K]Ӂpޓ>j{ꄓͳYiTWV:䌓{_ۿ;fzÃ;sYrӆ `z=c S نNۅhY+ otSW+"bLI)ڂ"9qODDzc {<4\/}Gō^04fVX@N Pj[\J0GyczO:μC0stW^`5Jc heq'gx%kYiK~;fv0P7XvG*)_X/HƇlQ!tfH⨛gUQ?%Vˏ[(ض`9i6T[,"H-Nܯ)kf{a4^,:p- Fpjdrh@&k4z7yB@?״n5Pi?}#sį_Tvq(plHFrtKR6fьh&ߧ _E`0+Bx@@{6JOG-YZ9MB Z:68qZ R<}A C:A|27ښ9m$E{3@a ,&[w40i޲]YtqZ3Ss w6pö́J|кNWDqj\f/pxdLCO݄68L7a^O( XS =Ά_%p}#|"ɈחRO#k)tFΆ< =;_[" _Ͳ=QS/#,}$t(is)ms>K~o-Fڜvy'qzVZ5k4&|@EeWCkZ4Ǔrzkj ~K]sb?b3,x,rz5F@^#:S+ +)9RcRG/Ԁ"GIf{&$EUo-@Y+wJUu_Sx3CnMnR_y8iQ'&'.|POqZP hYsd =Q!8ɱ`5Eqͩ5m KŚE;h4y*&rj0k޸ 0jΪϷəzYNZL!Ωq-u+q-ΡfW4WiNP6eo<ԹݭHBECRǎ٩5Sط@ MhZGUu_M]yWX}NϺ#ćH< UY-ہ!Cé-sKمqKË~c)JmDN!eKyb'$0l:Y b uK6WO5@kf oؤV[DwR1B""WeMakWg4;ՙ#mʺJB5ԢRMO>|xݩӛR|%}p:t?:urLm9$kvӂӖܳ%C02_TSS&k'_eؔ5Y:BSn^wݱ}e|{~k=JR!Be7`&~czehw0Cg6KK[]YБ6gZ" V3bJ8EeT4+ࣞ~h.֔޷ K}2[*O\?~y Y8}]IvTk6+`lwY /\_5='#ŀde,L wm0\ )7|:WIs#vKqÚ'3\ɇՏɸ'7P*ofM]_ܿh֚Κ;̮%hKyϽ}>_͔FCB֐c㕐HT)-/_vI?^4E2|ȱي` Rg^_lO<K9'~bPѤR&eО`Wc)?v1-ԎWė}!T)IGP:jy4WCEDFڧ\ǓCj}*_rJPxG*XmtR{ z4δIg~lB%JP:1|x"Qs'VTLRTNk Ǵw*' Q:EDGq"崟3ϷeQNol!~@^Mq8nI"j>4#9Z,Rj0#;Bo%Ӗ+{oRSȭ`x |^b 7Ǖ 7.SHUABW!$vRٌp)QVuBKW?R'Lg_lHh*%6voJ %YzG$1ު I=@Irz춿P:몛GbSRjC".+}q:.~m1lXi+i5E/ ɜ6J\l{I% JiuujHDBSRjmv P7>9UՆߛJjYp5Ĵ'E6OSī-NFo_}"3j*;px)%^ӎّx&3 JlX#gVqNB8}iq&N<3]O;z'jR}SfUO5rԤ[먩2zHx%|,-sMq4MBdLR#enn|@TC{=*S?H w/jC7|q(<$EU*4M hg=5P†*f_z⥵v([i <\5OsFls/Ke];GZ+)~:'׺8,LZ^^Y hᷲG;?^1I΁_NO*=&*opQL%%'uuGGw5ѭ3TUlUd*_Ϛ1T@_N+|͠37hmA}0(aZ?\ u=nQ0J+{?j}&Z'9Lo'>cY&["/MJv)@pi=4Wyw"xPzeX& ][/*..0> }ӲlXtF˵؎.y·k_+5Vgbf둎*͒p -m*X!4lMb=vF|o+"]Q:Nת9pѝhf!TYajէ$u#@MQ,(T5ֆY+vJSK^+P{}|:ɹO#fuJKAk S.Y‡5] ??Z. I )85??;r;VY>/sr{C{g̨R酢}9]5 Zv8ӱ/~fI m!(*Wݔ33h 7S뢛aoڱ3?ݚPP.aCjӎOdh,%Xvd;Ds>ɻ6& *Zk";tA4w}^-zQ<7Uen,҃;`tÝxB$6 !USƔM=>/.]V!?5kqa'-]!̴9}0̜ZzEQ JK pti!gs cp̄ߚZP gX#]QKЬw^)y&{1f>+P98À^@P*RAG+®F}lXի,"x"N{M܂#K0}Jpͭ}VTI5KU?}FIGf=tMmRNU8ȅENJzOY.LT6hTT)uJ^.^m?2]1;Wsټ"6T@hڪͅӾEаE+2.ug}|BҕxEjW%`u%Cf|:/ ͕SQhRhG#F s)Mf|,:Ɂxi90'ޤZuw2>dF'([h@<ɉjٲiu:+ qP 0P(!oĨ;'Nx!X{qI@ٞ\#b` uC[+(T3Ή1}/>z"HG+`Y{c'|P7n "[-&{}\nbLi%Z/_^z=-N۾}F!7NCDn_Y+hmg >f,ˁ ȍSkW z֞6kD7c<]H V?ЪRji:MQ覧.?j@";1~#s2j,two^v\a֊}݌5C>qlMz2IOFDZG( p:aoVx  m.(#<lmyn_dr[7eb_ĖV݌/ŒFfwS{3cm G/[ynM;i&X^]#]iЍ[iVwϗE5)U4NU!_N{ = 'yo?}ԼVlYT!'y`qՀ@ʳPowRCx~6-R.RX݁)9?Cx~m8r[aY+wUO񎉞^'S|ilybQz i>5L<&$zB}h=y㦤ypyI ABbh[3Ƹ\L1g&$snR[\ud@Lm5AizWCv8!Xp~Vp&8myqx^h[bӕ \$kb @ƧmKg[lmFk+3*4iSgP i77U4-[P>?x!®[j;/bzcF"ޝ/(Rsou%me%lLJi`&֢DZKBe3c1WO1/?Z`K?Q4"/.-Pl9PxtZٯ.i$E.wJ-Zի|1|륞Y31Ғŝ*nSݫ[V1Nzgjמ8Zi[TOR2⢌7 :ʏ#ʎBك{t|0sDnʰ]moWW7". Z^Ajr~¿=3e1~k Uʯ?`v+S ?0_˧lrw^^ ~A/i6Ag藪@Y?9vtN^՗uT*?W P: W!}#U<_{yf.݁Вm| Zr%DS&dYX-i9U['`&/rsڿPH69s^_H\,}uGY$ jѿ(O#}-Hvr2^@jJ IB*) k+RiٵE b~ЙqlEEd;12迂1/ꐤNzRkoҹ13EDɁuk!3},CybDZvP%;rl9m>~ N/ &nyx.& ASDF - Another System Definition Facility

ASDF

Another System Definition Facility

ASDF 3

ASDF is the de facto standard build facility for Common Lisp. Your Lisp implementation probably contains a copy of ASDF, which you can load using (require "asdf").

ASDF 3 is the current successor to Daniel Barlow's ASDF (created on August 1st 2001) and François-René Rideau's ASDF 2 (released May 31st 2010). It was rewritten for improved portability, robustness, usability, extensibility, configurability, internal consistency, and the ability to deliver standalone executables, all while maintaining substantial backward compatibility. Its notable versions include pre-release 2.27 on February 1st 2013, first stable release 3.0.1 on May 16th 2013, major releases 3.1.2 on May 6th 2014, 3.2.0 on January 10th 2017 and 3.3.0 on October 6th 2017. The latest release is 3.3.4, published on February 14th, 2019.

What it is

ASDF is what Common Lisp hackers use to build and load software. It is the successor of the Lisp DEFSYSTEM of yore. ASDF stands for Another System Definition Facility.

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 and load these systems. The build happens based on a plan in term of actions that depend on previous actions; the plan is computed from the structure of the systems.

Typical actions consist in compiling a Lisp source file (unless already up to date) and loading the resulting compilation output (unless both already 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.

If you come from the C/C++ world, ASDF covers a bit of what each of make, autoconf, dlopen and libc do for C programs: it orchestrates the compilation and dependency management, handles some of the portability issues, dynamically finds and loads code, and offers some portable system access library (see uiop below for the latter). Except everything is different in Common Lisp, and ultimately much simpler overall, though it does require acquiring some basic concepts that do not exactly match those of the C and Unix world. Importantly, ASDF builds all software in the current Lisp image, as opposed to building software into separate processes.

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

the Utilities for Implementation- and OS- Portability, formerly known as asdf/driver, 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.md for an overview, and the documentation as extracted from its docstrings by Declt or HEΛP (NB: in HEΛP, you can, though it's not obvious, scroll the list of packages with a scrollbar on the right of the top-left pane, and then click on the package you're interested in to browse its symbols).

uiop is distributed as part of 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.

ASDF is also not a tool to build or run Common Lisp software from the Unix command-line. For that, you want cl-launch, buildapp, or roswell.

If you're unsatisfied with ASDF, beside helping with our TODO list, you might be interested in other build systems for Common-Lisp:

  • Google's deterministic and scalable build system Bazel, for which Lisp support is available: bazelisp.
  • Alastair Bridgewater's small and simple one-package-per-file quick-build (also reimplemented as the ASDF extension asdf-package-system, now part of ASDF 3; similar to faslpath below).
  • François-René Rideau's XCVB (building object and image files deterministically and in parallel, but not actively maintained and bitrotten since 2012; a hypothetical ASDF 4 could conceivably be evolved to support these features thanks to the groundwork laid by ASDF 3; or you could use Bazel).
  • Drew McDermott's YTools (the polar opposite of XCVB, 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, much less featureful, robust or portable than ASDF 3),
  • 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 2, aborted),
  • Peter von Etter's faslpath (a much simpler system establishing a mapping between packages and files, abandoned but see asdf-package-system and quick-build above),
  • Alexander Kahl's evol (a reimplementation in Lisp of the GNU autotools stack, abandoned).
There are probably more. However, none of these systems seems to ever have had the traction of ASDF, probably because none was technically superior and/or portable enough (if at all) to compensate for the first mover advantage.

Supported Implementations

ASDF 3 now supports all CL implementations that seem to have any current user base, and then some. But ASDF does not magically turn broken implementations into working ones, and some ASDF or UIOP features may not work on less-maintained implementations that do not support them (see below).

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 these implementations provide ASDF 3.1 or later in their latest version, but your software distribution might have an older version.

As for remaining implementations, they are obsolete and/or mostly unmaintained; ASDF was made to run with each of them at some point, but some hacking is probably required to make the latest ASDF work well with the latest release of these implementations:

  • CLISP is generally well-tested with ASDF, though it has a few minor bugs. The implementation has received only minimal maintenance since 2010, and the last official release doesn't ship with ASDF, or often has antique version of ASDF tucked on it. However, ASDF has been recently updated in its source control system, and there is hope of a new release some day soon. If needs be, you can replace CLISP's provided ASDF with a newer one, or use an upgrade on top of that.
  • CormanLisp was recently open-sourced. Its bundled ASDF has not yet been updated from 1.x; ASDF 3 should work fine with it, but several features were disabled because CormanLisp was insufficiently compliant with the CLHS, and requires some work in this regard. Ask the new CormanLisp maintainers for updates.
  • ECL is generally well-tested with ASDF, but its bytecode compiler doesn't support the bundle operations, and support for Windows seems to be less stable. For instance, as of January 2017, cl:require and ext:system (and thus uiop:run-program) seem not to be working correctly on Windows.
  • GCL is somewhat maintained but its maintainer doesn't seem to care about ASDF, and hasn't replied for years to requests for bug fixes or for providing ASDF via (require "asdf")
  • Genera was never open-source and never bundled ASDF, but should otherwise just work with a recent ASDF 3, if you somehow have a license and a working version. There are rumors of people doing active development with it and having minor patches to improve ASDF on it.
  • MCL similarly was open-sourced, but never bundled ASDF; ASDF 3 should work just fine with it, but Rosetta is not supported in the latest versions of MacOS X, so a lot of work is required to make something out of it — at which point, you might just use CCL.
  • Mocl has its own heavily modified variant of ASDF2, and is the only implementation not currently supported by ASDF3. To make it work with ASDF 3 would require ASDF to be taught about natively supporting cross-compilation.
  • SCL was seemingly abandoned and never open-sourced. It never bundled ASDF, but otherwise should just work with a recent ASDF 3, if you somehow have a license and a working version.
  • XCL is now an abandoned experiment. It provides some old ASDF 2; but you can replace it with ASDF 3, which works well with it, inasmuch as anything works at all with XCL.

Provide ASDF 3.1 or later No ASDF Unmaintained
Free ABCL, CCL, Clasp, CLISP, CMUCL, ECL, Mezzano, MKCL, SBCL CormanLisp, GCL, MCL XCL
Proprietary Allegro, LispWorks Genera, mocl, SCL

To deal with an implementation that does not yet provide ASDF 3.1 or later, we provide a script that will install the ASDF from your git checkout to where your implementation goes looking for it when you (require "asdf").

Note that upgrading from an old version of ASDF 2 or earlier is possible, but quite complex to do right in a robust way, and we do not recommend it. Also note that mocl only supports a heavily modified variant of ASDF 2, and will require robust cross-compilation support to be added to ASDF before it is actually supported.

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:

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.

There is now also a Best Practices document explaining recommended usage patterns when writing .asd files, and detailing common pitfalls or deprecated practices to avoid.

About the latest developments in ASDF 3.2 and ASDF 3.3, see our demo Delivering Common Lisp Applications with ASDF 3.3 (2-page PDF, slides, git). Regarding the internal design of ASDF in general, and the work we did on ASDF 3, see the extended version (26 pages) of our paper ASDF 3, or Why Lisp is Now an Acceptable Scripting Language (PDF, git). The shorter version (8 pages), presented at ELS 2014, focuses on ASDF 3 and misses historical and technical information (PDF, HTML). Regarding ASDF 3, see also the slides of the ASDF 3 tutorial presented at ELS 2013, and for an introduction to the source code, this video: ASDF 3.1 walkthrough. For details about our previous work on ASDF 2, see our paper presented at ILC 2010, Evolving ASDF: More Cooperation, Less Coordination (git).

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

Until we write more documentation on the further innovations of ASDF, 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 https://gitlab.common-lisp.net/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: gitlab
  • download the tarball of a past release: archives

Extensions

Known extensions to ASDF include:

  • asdf-dependency-grovel, to compute the actual dependencies in a big ASDF system.
  • 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-flv, to bind file-local variables around the compilation of some files.
  • asdf-system-connections, lets you specify systems that are automatically loaded when two other systems are loaded, to connect them.
  • cffi, lets you interface between functions and datastructures written in C and functions written in Lisp, including support for automatically detecting constants from C macros, linking to dynamic (and now also static) libraries, and writing your own wrapper code in C.
  • poiu, to compile a system in parallel on a multiprocessor machine.

Former extensions, now superseded, include:

  • asdf-binary-locations used to allow one to redirect where ASDF 1 created its output files, so they don't clash between implementations and don't pollute source directories. It is superseded by asdf/defsystem's 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 (built into ASDF 2 and later).
  • 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 users to deliver a single FASL for a system, a standalone executable program (on supported implementations), or an image containing your system precompiled.
  • 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.
  • asdf-contrib, an empty package that used to collect dependencies on other systems in the list above and below.
  • 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 (this functionality is built into recent versions of ASDF 3.1 and later, but this package exists for backward compatibility with earlier versions of ASDF 3; search the manual for package-inferred-system).
  • 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.

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 common-lisp.net 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.

Note that the most valuable thing you can send this way are test cases, if possible as .script files readily runnable by our test system. If you're courageous, send us merge requests on gitlab.

While bug fixes are useful, they are not usually as valuable as test cases: small easy fixes will be obvious from the test case, and large fixes written by someone who isn't either a maintainer or working tightly with one will probably not be correct and not fit the codebase: any modification at one point is likely to have repercussions at other unobvious places in the codebase, for the code to be correct in a wider variety of scenarios than casual developers usually think about. Now, if you're willing to become a maintainer, you're welcome to join the team!

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-devel mailman site to subscribe
  • 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. asdf-announce mailman site to subscribe

Contributing

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

What is happening

For a detailed description of changes see our Changelog

February 2020
Release of 3.3.4: fourth bugfix release for the 3.3 release series.
March 2019
Release of 3.3.3: third bugfix release for the 3.3 release series.
May 2018
Release of 3.3.2: second bugfix release for the 3.3 release series.
November 2017
Release of 3.3.1: bugfix release for 3.3.0 addressing a backwards-incompatibility issue with timestamp computations, and other minor breakage.
October 2017
Release of 3.3.0, with substantial revision to the build plan to correct handle multiple phases of loading, due to e.g. DEFSYSTEM-DEPENDS-ON dependencies.
April 2017
Release of 3.2.1, with many small bugfixes and cleanups. Presentation at ELS 2017 about ASDF 3.3.
January 2017
Release of 3.2.0, a release containing many notable improvements, such as a new portable uiop:launch-program facility for spawning asynchronous subprocesses (with many thanks to Elias Pipping), a uiop:with-deprecation facility to handle progressive deprecation of functions, a cleanup and tightening of the internal dependency model (you are now required to use make-operation to instantiate an operation class; also you'll be WARNed if your .asd file contains improperly named secondary systems), a systematic pass of adding documentation to all functions, many fixes to small bugs and portability issues across all underlying platforms and operating systems, an improved test suite, and the removal of some long deprecated functionality.
March 2016
Release of 3.1.7, another bug fix release for the 3.1.x series.
October 2015
Although we had hoped that ASDF 3.1.5 would be the final release in the ASDF 3.1 series, a number of bug reports led us to prepare release 3.1.6. Support for Windows continues to improve, and we wished to release a number of bug fixes, and support the recent Allegro Common Lisp 10.0 release.
July 2015
An extensive bout of bug-fixing, notably on Windows, leads to release of ASDF 3.1.5 on 21 July 2015. XDG handling has been improved to be more compliant with the standard. Preliminary support for immutable systems has been added.
May 2015
With the LispWorks 7.0 release, all actively maintained CL implementations are now providing ASDF 3.0 or later, and support for older variants is now officially dropped.
October 2014
More bug fixing leads to release of 3.1.4 on 10 October 2014. There should be no incompatibilities. See the Changelog for more details.
August 2014
The ASDF mailing lists have been reestablished, in particular asdf-announce, which should allow CL implementers better access to only the information they want about ASDF development.
May 2014 to July 2014
ASDF bug fixing from 3.1.2 leads to release of 3.1.3, a major bug fix release. We strongly urge implementors that have shipped with 3.1.2 to upgrade to 3.1.3. There should be no incompatibilities, and some very important bug fixes are provided. See the Changelog for more details.
July 2013 to May 2014
François-René Rideau has resigned as maintainer but remained an active developer. Robert P. Goldman is interim maintainer until someone more gifted, charming, dedicated, and better-looking can be secured to fill the role. ASDF 3.0.2 was released in July 2013, 3.0.3 in October 2013, and 3.1.2 in May 2014. In addition to significant improvements and bug fixes, notably better Windows support, ASDF 3.1.2 notably sports the package-inferred-system extension.
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 slightly 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.
asdf-3.3.4/doc/lisp-logo120x80.png000066400000000000000000000322121362155115300164030ustar00rootroot00000000000000PNG  IHDRxVRgAMAOX2tEXtSoftwareAdobe ImageReadyqe<4IDATx}U[&<0!gT$+`€kZ]UW5aMYs2arNsg<5]]]u==RTUf99' |r;II~f}t G&ɫl;z<G G=p~Cӹqg,|Yzָf״A| yu9$pmjYԆdzG9!PFk+bݛUHj(?vhע~)8鸝F߹a'@LjqAH5#/|mjpHȢӍz ɴ=墁ђS)?3#{һX:Su@h_H<M'п[hB:jEDTDtꐆ)X"%B^Lf\@EѤg ].NRq;*gG3"@y^=iz;`Mv9Tg]<1,\TC*j$^6x/c)*C`*>[xXUҫQjс+ WAc}-l Ӆ0dgyݍߐ`)Oz;v5 5OԤhj l;i6G҅ PZZ93C;gUTvBB99D/PGFwL|<3g@݆[g ] =<:zwpQ꼆$y#uV|Bbab9ʳQ_ ըgM:!:*NW^z*cCU˄8d"\aFq~uZgr(t풁˦ +u?&fc6##p]b#mgo410[dH(z뫨OO|ydTkl6 N ^ٱ]$jYI>mn~4w?ZKioDLxѷOIvcİlY_oÅ3QW?xߑgB+kͧʕ<ONBE ^ dc,"N GvF"h$")`j~XtT){7*uyj@KgoC]ض\**!Xj?INdcpS]}P uǼ͒\Td;pDGFnksi:c or٤ Jv7T{y t6漳{!!>t(?op6ޜtmسwuw3D&Un၇ҵVL^վW6qo,ng %WPzՈ #Z%vΥsZHصA @U Pt7{-Wv4Iջl>,[W~4)~f& :n }g0H^oΤ?`CY-j ~D%j?P.9_l#ZDc#۫g,  Wf%[1$ŋJbm̗K`ls?lڒ/TnDv 5[D|q]zGCQu@ȃמbmt*GF*X ƀA7>m%_C1|j*ͳڔ^g (PڜBSï ew#a@ 0K>ڀ C-nMFM <*AvE҄\YiBDEizLj%BΈ'|)3ox77iX䱋&j|3܍ueLT,pVϢ@V(}uӹGJkɞ%EcĊo HAvq~ߛ v-|~ / ё.t0B. IB=._:HQ 'Jra @C'2ؒAjS$(MT;2"K3ڵM$c `Ok[ j#ZRAOh?K0{{I:Ҁ -Ff}{FRRIRKQZKb`EA!@BjV:GVT6J8zEqUCӋth h=q't_,d+UEXC" >0/T`q?6m⑑ %miҔa0%~~c<fǝ7@T#@&)^kᦫg`1hd}^ YFk{.༏] 5Ix}l bTa h R zML@Vf> b`4^3P"-KfJ7-A3ߺ0 J,>.*~-ӇcʤbQp|-Z˧sN4#>gFȴpUNG&h4HX׹TS B~S2e$JTzիY &&g5n^<E-O=.*̋$J>]kb1'ӾϽ4;kHjY[K*Пd#T2ȈPL$Gi9W6`d5dpUK SJgGi~@ $RGFmK}WXXCK]NI?L{kڝt ,w]9l^D&\]Z^K{?nzP=o~<([m 2[ő_cDJ'UhLi!cD mEa#2ׂ!61o9Bt7TOFiދ#>$AFZ:9]s:aZVG0vo);n֝G`:i[1^~gw4>/UUu'7蓎sL p{VÍǜUQD~FHQccg 36KmaHzœ؃eb蠶ص EC1DT|GEwb>^p'Ci/|%N( '0bѻ[zuI1QRelT8쑍8|` 蕁7?؀Ym xFI>Y>3@)xDyZjUlC& A~9Z0Ub=}#NƠSZֲy)c&^A*(zOo$y/#N>V]z҅)ᑒ1]hOIgU'h9lvĶ-ϫ4IVqls~kO.F&St|VaLsC5K< qpﹿmZ`, %nrwW2^nb"GI[vpVj}Z峏.[AbQko:Q? @iE} XEUՐH9)! |&qK1~Xc -z3a ")L$+3tk1)ex ꪋb( 3&wcŚ|VNk~W^OJUaCH|Oh9!+;lp\Xtp_yʕ&\bK0̆*cMUvri߁J1K|%/ 0C,bMz3 i3!t?2z 6j !SVVVa|Ꙉ%ݎ<%eutRWTܞlU"j%0bp&Po8*rŋI NwER\U ۮݧᩗĢ%[d``# ִ0?.kVbx 2[EkN=qhR|'vWx!;`/g I+yAECQ(9w}p9ᢁop8s+EzKzS EZh8ch&aېdj6-60R<9`$ma7:3D"c~횓ϿgQ5LW-nr;oZ_b}mchϮ +i+`2&+5,WG{|u{Ja+Q@|ڌy@VJz_!ZG@ϗI]ƍʖ=1 266zQ{Vm,¦GHV1WĐj>S0_+6Em.aTU57LTGt۷M@ }1hZ#ϭ͇q׵=FEU#ZZ߅9 i/E=w0I'۱xEþЏ)TLDlKR:nt6Vt!PlUWfmʵEn{_IՊJK3O;#Ϳd+%uJSXX'HlojŌg WvFGJ񁎌HAӌp%iTocˎRBnYݞf3_U哻amyPt "`Ƅ`i]o|U'nwN6eڳK2Ɯ%Zxwf?m/܄ʪ!b0[p>xyo?01yBgv3ѰHx ƙ2PT$;5bHkw@SGJpϣٸiZ/Xp% E&&Dzoȵ90ifb*& '.+SOe {RJׯ$տ_/C1ZB|>T5C"^R\jx+y}bEGjRڼA5R l{M!Li)ok60e,f#CV'?>mif/vaCH E]1aie2غ\"e㪨{H]s|Aq-E23A҈:d!';a&ŪК$X|N (-G.lxG˺uGcڬXrWo,$pyHRaB~]CLCb.?$ rt܌jVR#cWъ;eBtn9nnE{еCr}ںDձϼ_|ӧİAg[ZJ ŨS3N.WaSQ!ؚ[܀牴q%E%:*GXc퉉=رe X*G^#qŝ ȝb0i\?A_K#lSLَƆ zRt"1ݗW+o[N@+Ǹ1Ym&y+UqMSTEE/SO8 5x.a.&T 5N^zr3ؘXHĄO?|}^K,{Sp!xS_GkKJ=v6q9[BU ټ8=P.RL`@ClźBZ_$:bMVnpBm}qpmvbEaY媺MIW3'%dޟW!qo:z`>[Ͽk9O5n/o8n{l Y)cJz!Rd?J4.A!WN'^ͲS˅[wDj>gƈA%@sqsnS(!fWHH!\W̃Dۯ(R<Ԡ|KxX<~id~ޢ@6Y\ +|Mxch뷞xu+pmuwc&ԩQav3yd9f)x]"4${wO]}h  aomV6J_$5X0<b8\?œiGUPհfx<:-A_E̙ 'ev[sːMl6[1;9}.7?cن}MU>ĬOoRy -m-1dJ9=8dl @^_{H R%tyTweھl, SߛS{n~|u.o(/A~QVY>N=yq5q()xxgK.EXX+/yN &dsNhAu(jJv`XX1' DZ4(RTQ\RF!Fё:,Y~{UjU(׹}"?3 wsMBPeuJ3żoO`/˛Ml1`r!My{0QKMXdVI}}$=9L9zh.>+?M2G͑I^D[p NFySq62Fj<#?ذWMSz`JL׏]X %N`L-Xz*?2嫏M'u{37j1[﫪k%vaR[E\B{a!A gҸAdQZվ)f󰃈s}зG*1XX{M}}D8ve}EE;~A%a>EDb4:1h)%j3-L4]z-ɓK MVG?jVfs9^Wځ@Έ!`9--iWڸ5<FwTJVJASMYLy2?ӣWfw~ Mf2d½]4#.a҃d + PNe5K tvIq}msDLSiN88 fj5Ŝ:ԫkGnN- fih.YuV=^mAm] xmDv#mcK1Zѻ"ƻm Ÿž"f2%Y\jC!Bk o>]oׁrlQ"զGpLѭΓfd*s y1YW6ehE]rtWtk?O-ZԆi򻱐5V4RdY Ek`->@ϸ&5޷lYU+ϼ3CX5hU.PۭAsGj3@Okp4&׻Փf1uX.5dӅ\ !/;5`V@U\8 UdIOlu*KBŭE j w*zcQL/Z=JaN8|%$xicUiB ]oRz#FEK$%J7o;̈~gCJp(5-igo7ebjEY% LEY؛/B0ARMhS:yc,A" @XtIBΉhO>7+AU (a9#U\ ]yqlٌodǞcC\h[jrV[%ecb#932^[5cJu 7g.\r@T C}Y:%2  :KIn5'vjh#}gqoQ{"Fz3絽`QiƖ2΍op8ghߏUl#ˎTK7hy(@6q=^wI {+6ZzNǀ^>ç XM~%sb,]g(}iʁ`բ?Amƌ>#-40(V_MsPı@u~%> W䡲0O>gJƭ,ofǽdqRz¬y7MuP2%4ify.o-t؀ ߬k :0vd[L$ДPinW&hGrƫx%x@zLv00-^y+IzH6Xgˬf>pric[va1Ҕ6l-%,Xrqy3;RE}3hpQ uT?(WGZJftoS'vkNxj9f}lr[C$c3&T O7.ZWqO= ot=v4\miC&;?~1ƕ Hhc懛\_ h}~-X_bK3ple~j5ϋZ>M+uQOssu *QQJ Ǵsĵ1^>V,iGyEuF1@E5@x.î}>s:o`T9NIO/+&Fܨ2kR-E2`xݤCl9Wlqėj=QWS D_~"l) LCY)k#}JvX䷉ךg'EjP2KVدG`NTaj9go S쨞!^TJãqْVbؒ&}XE&;!}o)kĊ\*h'>{#JjJjnpN>>zu2 uft>,٫%8kxa?wUNM'MjVń~[Wk;6:[Uus/w>V/R+Wt\9'cB1R]Go(z4^G$G%0\LiqN%.|vL*s,Og0Ooa:񽇜S{bI70&vǸYZ$=~4TT:|eAf$/]aKGUU-N$l#>kq{t{x h+ԃjypۡ[p-Aj:6g.튾ؔ @{  (yA^1CVGE(sY6AIL.|6l(qkV=J-nS\8Aj+JL>Y;{S@ V/FuVd'3ӣ $|Ҩ|p8K̗=U13QIL֌&حi,^3P{웆H{<s:I;Nee3'sjɬqm:sbz:'e lԑع ٍKn'_q]su>ԭTT}|D8_b u'1P&qR%R#L%fHxIQ8LÚ̞Ck6[TI>4ӧƹ&eqq{n)d'MeQ\lW|]ۇzyu>#Vxz) p݋xg>r%o˄=%+sɚ_ }S_Wŷ7'@8 ^|gzfSaVeD9q˃, b@x/hv54SIe?jY ,\Q Lj89xaX0y%XjpnR*Ql 5f(,Psǐ6VXwcLAb삎{o^tB*em666* swaᒽJɁJVob.9<4I6e˹ῦŃWt֢[ DS>kY/=zM_F Du>\#T_%.9R-~RǨg~9;8圮|v'xL`)dpc4Ϭ-͓lm2d~P^m#{[+Vh+Q^,aB1&*w.t$Bxy/&KM4Ū9w6l="A(B+. kP^dQ]xj=у[==tE&.f} cOoK&vhuFtex9vwxS=lu e'_e%OG+riz յ =ĸPS7m̋zbNxCزK h5=IhpJũ1볝FnNbb˫&f%K oE`ﶂd"{sfY]SqĮ!A_#R{*ɺqFO$L\-6pd6xB'vځ%3bz~za ?A['$*K%mv?oܨ,"pOxW%G ' vsMYQVvӿnioC]GƬy;ƄbĠ68ol{%Ga Q#EvDC;cR"u< |y>)|⥵j|޳oG eβȋ]rܛQie&GVOeeeVNQn8jᗿ^@DD4=ɼϨ/wNK6CTGڊ"FrkK ׽ڵO#8KfYvг'LV/Qa~}`tÈ<{UjvU*qA]<`T0Am6K w?~h߯*648W|rc҇]rgVqR ɱqaRؘIѲzk\L,s+džiD\\8˪,t#:,vGrcm+WΌiಡic{)Av=HeNby̼Jj#IE=z֘we.3yR!?Xcۼ܎R,^'INLwaa:W%jE>ڿ6dɘEX6ҚZ(sLGlA=nF"<7ȯko폶d=0\%Iprqbй]H:KŮ4b:U*:^Aq56(2*T9%AB:'F\^2Y*IENDB`asdf-3.3.4/doc/release-emails/000077500000000000000000000000001362155115300160755ustar00rootroot00000000000000asdf-3.3.4/doc/release-emails/asdf-3.1.2.txt000066400000000000000000000010301362155115300202040ustar00rootroot00000000000000Today I have released (with much help from Fare) ASDF 3.1.3. We urge implementations that are currently shipping with 3.1.2 to move forward to 3.1.3. 3.1.3 has no API incompatibilities that we know of, and contains significant bug fixes. Most significantly, 3.1.3 fixes bugs that impede hot-upgrade from 3.1.2 to a later version of ASDF, which is critical to ASDF development. In addition, we have fixed multiple bugs in ASDF system search caching, that impeded correct use of restarts involving adding new systems to a running CL. asdf-3.3.4/doc/release-emails/asdf-3.1.5.txt000066400000000000000000000065701362155115300202250ustar00rootroot00000000000000We would like to announce the release of ASDF 3.1.5, much later than expected, but also much more solid. As usual many thanks are due to Faré for many bug fixes, clean ups, explanations, etc. Thanks are also owed to Dave Cooper, for testing on the Windows platform, enabling the maintainers to test on Windows, and identifying many uncaught bugs. Thanks to Anton Vodonosov for testing the release candidate against Quicklisp on cl-test-grid. Finally, thanks to all who found bugs, provided patches, and used prerelease candidates. Although ASDF 3.1.5 is primarily a bug fix release, it does add *experimental* support for immutable systems. Immutable systems will be loaded once, and then never updated, even if their definition changes. Immutable systems help support application delivery for Common Lisp, allowing programmers to bundle a version of a required library that will not be subject to change based on the environment into which it is installed. Thanks to Dave Cooper for the idea. One thing that we have cleaned up that might affect some users is the treatment of the XDG directories. If you are using Windows and taking advantage of the default search path for the configuration and/or source-registry, then you will find that this path has just changed in incompatible ways. If you have configuration files, you may have to move or copy them from $LOCALAPPDATA/common-lisp/config/ to $LOCALAPPDATA/config/common-lisp/. Meanwhile your cache will be moved from $LOCALAPPDATA/common-lisp/cache/ to $LOCALAPPDATA/cache/common-lisp/. However, you should not have to move your source code, still in subdirectories of $LOCALAPPDATA/common-lisp/source/ We urge implementations that are currently bundling previous versions of ASDF to adopt 3.1.5. 3.1.5 does not introduce any API incompatibilities that we know of, and contains significant bug fixes on multiple platforms and implementations. See the Changelog (attached) for a list of the major bug fixes. Details on minor bugfixes can be found at launchpad.net/asdf We hope that 3.1.5 will be the last 3.1.x release. We will now move to developing ASDF 3.2, which we expect will add new features. Here is the changelog entry for 3.1.5: cl-asdf (2:3.1.5-1) unstable; urgency=low Bug fix and portability release: * Add immutable-system support (thanks to Dave Cooper). This support should be regarded as preliminary and subject to change. * Substantially improved operation on Windows: many bugfixes and improve- ments to UIOP functions that interface with the operating system. * Add CLASP support. * Many miscellaneous fixes for issues on individual implementations, notably UIOP incompatibility introduced by SBCL 1.2.12, support for LispWorks 7 character types, fixes to chdir on ABCL, improvements to run-program on Windows. * Added OS-COND to UIOP to paper over some incompatibilities about when and how operating system can be detected on different implementations. Made OS predicates run test at runtime so you can bind *features* from a target system and determine its OS. * Fixes to XDG configuration directory handling. Try to stick to the XDG spec, rather than guessing what it should be on different platforms. To recognize this, change UIOP functions about XDG files to "XDG-" prefixes. * Documentation improvements. -- François-René Rideau Sat, 18 Jul 2015 16:51:50 -0500 asdf-3.3.4/doc/release-emails/asdf-3.1.6.txt000066400000000000000000000032361362155115300202220ustar00rootroot00000000000000We would like to announce the release of ASDF 3.1.6, the latest bug fix release for ASDF. As usual many thanks are due to Faré for many bug fixes, clean ups, explanations, etc. Thanks are also owed to Dave Cooper, for testing on the Windows platform, enabling the maintainers to test on Windows, and identifying uncaught bugs. Thanks to Anton Vodonosov for testing the release candidate against Quicklisp on cl-test-grid. Finally, thanks to all who found bugs, provided patches, and used prerelease candidates. We urge implementations that are currently bundling previous versions of ASDF to adopt 3.1.6. 3.1.6 does not introduce any API incompatibilities that we know of, and contains significant bug fixes on multiple platforms and implementations. See the Changelog (below) for a list of the major bug fixes. Details on minor bugfixes can be found at launchpad.net/asdf We had hoped that 3.1.5 would be the last 3.1.x bug fix release, paving the way for us to move to developing ASDF 3.2, which we expect will add new features. Maybe this time! Here is the changelog entry for 3.1.6: Bug fix and portability release: * Fix backtrace on SBCL. * Fix RUN-PROGRAM of string (shell command) on Windows SBCL (ticket #1501373). * Fix a number of issues with bundle operations (especially on non-C-compiler-based implementations). * Fix component-finding in package-inferred-system. * Fix race condition between multiple concurrent lisp processes doing ASDF builds (ticket #1483948). * Fix misplaced fasl cache on Windows. * Miscellaneous bug fixes. * Documentation improvements. -- Robert P. Goldman Sat, 17 Oct 2015 15:01:34 -0500 asdf-3.3.4/doc/release-emails/asdf-3.2.0.txt000066400000000000000000000063561362155115300202230ustar00rootroot00000000000000It is with great pleasure that we announce the release of ASDF 3.2.0, a new milestone in the development of ASDF. This change in minor version number advertises how much ASDF has evolved since we released 3.1 in 2014, and at the same time how stable the API has been since we release 3.0 in 2013. Note that we already have significant changes in the pipeline and are intending to release a 3.3.0 in a couple of months. We urge implementations that are currently bundling previous versions of ASDF to adopt 3.2.0 at their earliest convenience. Release 3.2.0 contains significant bug fixes on multiple platforms and implementations, and does not introduce any incompatibilities on public APIs. It does however introducing cleanups and refactorings that break some undocumented (and sometimes explicitly deprecated) internals. Those systems in Quicklisp that abused these internals have been fixed (notably including slime, asdf-system-connections, cffi, iolib, prove, cl-protobufs). Details on bugfixes can be found at https://launchpad.net/asdf and in the discussions in merged branches of https://gitlab.common-lisp.net/asdf/asdf Notable credits go to Robert Goldman for his relentless testing and push for quality, to Elias Pipping for his contribution of the new launch-program infrastructure and upping the standards for code, to François-René Rideau for general coding and fixing a few more bugs than he put in, to Dave Cooper for lending access to a Windows test server, and to Anton Vodonosov for repeatedly testing with cl-test-grid. Here is the changelog entry for 3.2.0, compared to 3.1.7: New milestone: * launch-program: new UIOP API for asynchronous subprocesses, now available on: abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl. Big thanks to Elias Pipping for this significant contribution! * parameter-error, not-implemented-error: new UIOP functions to better signal abuse of parameters in function calls, or lack of function implementation. * with-deprecation macro in UIOP signals style-warnings, then warnings, then errors when deprecated functions are used. This macro is now used for all deprecated functions in ASDF. * require-system, component-loaded-p fixed to not reload .asd files, and to work in presence of preloaded-systems, that are now eagerly loaded. * registered-system added as an abstraction for internals and extensions. * make-operation is now the only supported way to create an operation; calling make-instance directly will raise an error. Update your software! * Removal of several obsolete backward-compatible internals: if-component-dep-fails, operation-forced. Update SLIME! * Robustness and portability fixes all around uiop, notably dealing with directory access, bundles on ECL and MKCL or with cffi-toolchain, dealing with a fatal-condition, surviving use of "logical" pathnames, etc. * Tests improved and extensively run on Linux, macOS and, notably, Windows, with recent versions of all the maintained CL implementations. * Internals of ASDF systematically cleaned up and documented. * Build, test, release infrastructure improved, both classic and asdf-tools. * Documentation updated. -- Francois-Rene Rideau Sun, 08 Jan 2017 20:45:29 -0500 asdf-3.3.4/doc/release-emails/asdf-3.2.1.txt000066400000000000000000000045411362155115300202160ustar00rootroot00000000000000It is with great pleasure that we announce the release of ASDF 3.2.1. This new release brings increased stability to the 3.2 series with many fixes to small issues since ASDF 3.2.0 from last January. Note that we already have significant changes in the pipeline and are still intending to release a 3.3.0 "in a couple of months". We urge implementations that are currently bundling previous versions of ASDF to adopt 3.2.1 at their earliest convenience. Release 3.2.1 contains significant bug fixes on multiple platforms and implementations, and does not introduce any incompatibilities on public APIs. It builds on 3.2.0, that did contain cleanups and refactorings that broke some previously undocumented (and sometimes explicitly deprecated) internals. Those systems in Quicklisp that used or abused these internals have been fixed (notably including slime, asdf-system-connections, cffi, iolib, prove, cl-protobufs). Details on bugfixes can be found at https://launchpad.net/asdf and in the discussions in merged branches of https://gitlab.common-lisp.net/asdf/asdf Notable credits go to Robert P. Goldman for continued testing, François-René Rideau for general coding and fixing a few more bugs than he put in, to Dave Cooper for lending access to a Windows test server, and to Anton Vodonosov for repeatedly testing with cl-test-grid. Here is the changelog entry for 3.2.1, compared to 3.1.0: cl-asdf (2:3.2.1-1) unstable; urgency=low New release: * source-registry: resolve conflicts in a way compatible with Quicklisp. * Upgrade: make the upgrade logic more robust, especially on CCL. * Require-system: better normalize module vs system names on CMUCL MKCL SBCL. * Logical pathnames: fix bad-system-name warning behavior when using LPNs. * XDG: skip empty entries, for compatibility with Ubuntu * Bundles: numerous fixes for bundles especially so for ECL and MKCL. Don't try to combine .a's as it's not portable; only ever combine but .o's. Getting rid of the *load-system-operation*, now it's always load-op. * launch-program: more fixes, notably for ECL, clasp. * Deprecation: fix issues with the deprecation schedule of some functions. * Test and Release: fixes to the release process and to a few tests. * Documentation: a document describing best practices when using ASDF. -- Francois-Rene Rideau Sun, 03 Avril 2017 14:49:29 +0100 asdf-3.3.4/doc/release-emails/asdf-3.3.0.txt000066400000000000000000000072661362155115300202250ustar00rootroot00000000000000Today we release ASDF 3.3. The most substantial change is to the build planning process, which has been reformed by François-René Rideau so that DEFSYSTEM-DEPENDS-ON now behaves correctly. There are a number of other improvements, and we are indebted to Daniel Kochmanski, Rommel Martinez, and Chun Tian for contributions. Thanks again to Anton Vodonosov and Dave Cooper for support in testing, and new thanks to Martti Halminen, Jens K. Loewe, and Jason Miller. I would like to dedicate this ASDF release to the late Elias Pipping. On a technical level, Elias made great improvements in some of the most challenging ASDF internals, notably the RUN-PROGRAM component of UIOP, a place where implementations are not constrained by the language specification, diverge radically from each other, and are poorly documented. On a personal level, Elias was very supportive to me as ASDF maintainer, and while I was going through an illness. He did all these things despite being gravely ill with the cancer that eventually killed him. He will be greatly missed, Z'chrono L'vracha. We urge implementations that are currently bundling previous versions of ASDF to adopt 3.3.0 at their earliest convenience. The improvements offered in this release will substantially improved the reliability and predictability of ASDF use. Details on bugfixes can be found at https://launchpad.net/asdf and in the discussions in merged branches of https://gitlab.common-lisp.net/asdf/asdf Here is the changelog entry for 3.3: cl-asdf (2:3.3.0-1) unstable; urgency=low New milestone: * Build-plan: Extensively revised the build plan process so that :DEFSYSTEM-DEPENDS-ON would work correctly, even when depended on systems change (which didn't work before). See our ELS demonstration about it: "Delivering Common Lisp Applications with ASDF 3.3" < https://github.com/fare/asdf2017 > * Internals: to support the above, many ASDF internals have changed. ASDF now has the notion of multiple build phases to a common build session (which generalizes the previous build cache). ASDF considers loading a .asd file as an operation DEFINE-OP, and tracks as dependencies files mentioned during in :LOAD-FILE-FORM statements, etc. Some code has moved to new files or among old files, and between packages. Actions are now uniformly represented as a CONS of an OPERATION and a COMPONENT, where in some cases previously only the class of the operation was preserved. Forcing is constrained to be uniform across all phases of a top level ASDF operation invocation. Fixed the protocol for resetting systems being (re)defined, allowing subclasses to define default slot values. Remove *LOAD-SYSTEM-OPERATION*, as the current maintainer of ECL, for which it was originally designed, decided that it could never be made to work properly, after all. * ASDF&UIOP: Tweak dependencies between ASDF and UIOP. To avoid DEFINE-OP circularity, asdf.asd with no longer causes uiop.asd to be loaded. A standalone UIOP won't be loaded at all unless it's strictly more recent than ASDF. * Tests: tests for new capabilities and bugs. Test backtraces can be disabled. * Documentation: a number of improvements and clarifications. * Feature: a new feature :asdf3.3 * ECL: restored the deprecated function MAKE-BUILD, removed in 3.2.0, in a way that works on top of supported APIs (we still recommend you migrate to these supported APIs). Also stop using the deprecated COMPUTE-INIT-NAME. * Deprecation: starting to emit STYLE-WARNINGs for deprecated functions. Will gradually escalate to true WARNINGs and then ERRORs. -- Robert P. Goldman Sun, 20 August 2017 21:00:00 -0500 asdf-3.3.4/doc/release-emails/asdf-3.3.1.txt000066400000000000000000000030611362155115300202130ustar00rootroot00000000000000Today we release ASDF 3.3.1, the first bugfix release for the 3.3.0 release series. Of primary interest in this release are 1. a fix for an incompatibility in the UIOP stamp-comparison functions. The handling of infinity as a bound in these functions changed between 3.2 and 3.3, potentially causing problems in backward compatibility. In order to maintain compatibility, the old behavior was restored to the stamp-comparison functions, and new functions -- TIMEstamp comparison functions -- were added to carry the new behaviors. 2. a fix for upgrade from version 3.2.1 3. fixes for bugs that can occur when the default readtable is manipulated inside a dependency loaded by DEFSYSTEM-DEPENDS-ON. We urge implementations that are currently bundling previous versions of ASDF -- and especially those bundling 3.3.0 -- to upgrade to 3.3.1 at their earliest convenience. Here is the changelog entry for 3.3.1: cl-asdf (2:3.3.167-1) unstable; urgency=low New milestone: * UIOP compatibility fix: Introduced new replacement "timestamp" comparison functions, because of inadvertent change in the API. Functions that are compatible with the old semantics are retained as "stamp" comparison functions, but will eventually be deprecated. * Upgrade fix: Upgrade from 3.2.1 needed repair. * Syntax manipulation: Fix for bugs that could be introduced when the default readtable was manipulated during the loading of a defsystem-depends-on system. * Tests: tests for new capabilities and bugs * Documentation: a number of improvements and clarifications. asdf-3.3.4/doc/release-emails/asdf-3.3.2.txt000066400000000000000000000035421362155115300202200ustar00rootroot00000000000000Today we release ASDF 3.3.2, the second bugfix release for the 3.3 release series. Of primary interest in this release are 1. Multiple fixes in handling misnamed (or "legacy-named," if you prefer) secondary systems ("foo-test" instead of "foo/test"). Thanks to Eric Timmons, there is also a similar fix for package-inferred-systems. 2. Fix an annoying warning message for compute-action-stamp. 3. Add support for the Mezzano implementation (thanks to E. Housel, H. Harrington). 4. Miscellaneous minor fixes and documentation tweaks. We urge implementations that are currently bundling previous versions of ASDF -- and especially those bundling 3.3.0 or 3.3.1 -- to upgrade to 3.3.2 at their earliest convenience. Immense thanks, as always, to Fare Rideau. Also thanks to the many bug reporters and patch submitters (see the Changelog), and to Anton Vodonosov and Dave Cooper for help with testing. Here is the changelog entry for 3.3.2: cl-asdf (2:3.3.2-1) unstable; urgency=low Bug fix release: * Dependency tracking: fix bugs in handling misnamed secondary systems. We now distinguish between "syntactic" and "semantic" primariness, properly warn in case a secondary system is misnamed, yet properly recompile or avoid spurious recompilation depending on whether there or not is a conflict or redefinition. Similarly handle package-inferred-system (thanks to Eric Timmons). Better warning in a fishy case of compute-action-stamp. * UIOP: Add package location information to define-package on SBCL. * Upgrade: fix issue with asdf/bundle. * Portability: add support for Mezzano (thanks to E. Housel, H. Harrington) * Documentation: add discussion of best practices. * Package-inferred system: Improve source file handling. * Test and documentation improvements. -- Francois-Rene Rideau Thu, 03 May 2018 22:46:19 -0400 asdf-3.3.4/doc/release-emails/asdf-3.3.3.txt000066400000000000000000000011411362155115300202120ustar00rootroot00000000000000In honor of the 2019 European Lisp Symposium, today we release ASDF 3.3.3, the third bugfix release for the 3.3 release series. We urge implementations that are currently bundling previous versions of ASDF -- and especially those bundling 3.3.0 or 3.3.1 -- to upgrade to 3.3.3 at their earliest convenience. Immense thanks, as always, to Faré Rideau. Also thanks to the many bug reporters and patch submitters including (alphabetically): * Marius Gerbershagen * Hugo Ishimaru * Attila Lendvai * Jan Moringen * P. Neidhardt * François-René Rideau * Eric Timmons * Didier Verna * "privet-kitty" asdf-3.3.4/doc/release-emails/asdf-3.3.4.txt000066400000000000000000000013201362155115300202120ustar00rootroot00000000000000In honor of Valentine's Day, and more honestly, just because it's overdue, today we release ASDF 3.3.4, the fourth bugfix release for the 3.3 release series. We urge implementations that are currently bundling previous versions of ASDF -- and especially those bundling 3.3.0 or 3.3.1 -- to upgrade to 3.3.4 at their earliest convenience. This is especially true for SBCL, for which 3.3.4 fixes a bug preventing ASDF upgrade from working smoothly. Immense thanks, as always, to Faré Rideau. Also thanks to the many bug reporters and patch submitters including (alphabetically): * Rommel Martinez * Jan Moringen * Karsten Poeck * François-René Rideau * Martin Simmons * Eric Timmons * Guillaume Le Vaillant asdf-3.3.4/doc/style.css000066400000000000000000000104551362155115300150640ustar00rootroot00000000000000body { 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; } asdf-3.3.4/doc/undocumented-functions000077500000000000000000000015471362155115300176420ustar00rootroot00000000000000#! /usr/bin/env perl use FindBin; use strict; my $funFile = $FindBin::RealBin . "/exported-functions"; my $infoFile = $FindBin::RealBin . "/asdf.texinfo"; my %exported; our %indexed; open(FUNFILE, $funFile) || die "Couldn't find list of functions in $funFile."; while () { chomp; $exported{$_} = 1; } close FUNFILE; open INFOFILE, "< $infoFile" || die "couldn't find $infoFile"; while () { chomp; if (m|\@findex +([\*a-zA-Z\+][a-zA-Z\-\*\+]+)|) { indexIt($1); } elsif (m|\@defun +([\*a-zA-Z\+][a-zA-Z\-\*\+]+)|) { indexIt($1); } } close INFOFILE; # print "\n\nINDEXED:\n"; # foreach my $fun (sort(keys(%indexed))) { # print "$fun\n"; # } # exit 0; foreach my $fun (sort(keys(%exported))) { print "$fun\n" unless $indexed{$fun}; } sub indexIt ($) { my $key = shift; $key = uc $key; $indexed{$key} = 1; return; } asdf-3.3.4/find-component.lisp000066400000000000000000000156551362155115300162650ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Finding components (uiop/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/system-registry) (:export #:find-component #:resolve-dependency-name #:resolve-dependency-spec #:resolve-dependency-combination ;; Conditions #:missing-component #:missing-requires #:missing-parent #: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 (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition missing-component-of-version (missing-component) ((version :initform nil :reader missing-version :initarg :version))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (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 resolve-dependency-combination (component combinator arguments) (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS) in the context of COMPONENT")) ;; Methods for find-component ;; If the base component is a string, resolve it as a system, then if not nil follow the path. (defmethod find-component ((base string) path &key registered) (if-let ((s (if registered (registered-system base) (find-system base nil)))) (find-component s path :registered registered))) ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that. ;; If nil, use the path as base if not nil, or else return nil. (defmethod find-component ((base symbol) path &key registered) (cond (base (find-component (coerce-name base) path :registered registered)) (path (find-component path nil :registered registered)) (t nil))) ;; If the base component is a cons cell, resolve its car, and add its cdr to the path. (defmethod find-component ((base cons) path &key registered) (find-component (car base) (cons (cdr base) path) :registered registered)) ;; If the base component is a parent-component and the path a string, find the named child. (defmethod find-component ((parent parent-component) (name string) &key registered) (declare (ignorable registered)) (compute-children-by-name parent :only-if-needed-p t) (values (gethash name (component-children-by-name parent)))) ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base. (defmethod find-component (base (name symbol) &key registered) (if name (find-component base (coerce-name name) :registered registered) base)) ;; If the path is a cons, first resolve its car as path, then its cdr. (defmethod find-component ((c component) (name cons) &key registered) (find-component (find-component c (car name) :registered registered) (cdr name) :registered registered)) ;; If the path is a component, return it, disregarding the base. (defmethod find-component ((base t) (actual component) &key registered) (declare (ignorable registered)) actual) ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint. ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec. (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)))) (unless (component-parent component) (let ((name (coerce-name name))) (unset-asdf-cache-entry `(find-system ,name)))))))) ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT. ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON. (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))))) ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications. (defmethod resolve-dependency-combination (component combinator arguments) (parameter-error (compatfmt "~@") 'resolve-dependency-combination (cons combinator arguments) component)) (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) (when (featurep (first arguments)) (resolve-dependency-spec component (second arguments)))) (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788 asdf-3.3.4/find-system.lisp000066400000000000000000000427421362155115300156040ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Finding systems (uiop/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) (:import-from #:asdf/component #:%additional-input-files) (:export #:find-system #:locate-system #:load-asd #:define-op #:load-system-definition-error #:error-name #:error-pathname #:error-condition)) (in-package :asdf/find-system) (with-upgradability () (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))))) ;;; Methods for find-system ;; Reject NIL as a system designator. (defmethod find-system ((name null) &optional (error-p t)) (when error-p (sysdef-error (compatfmt "~@")))) ;; Default method for find-system: resolve the argument using COERCE-NAME. (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) (defun find-system-if-being-defined (name) ;; This function finds systems being defined *in the current ASDF session*, as embodied by ;; its session cache, even before they are fully defined and registered in *registered-systems*. ;; The purpose of this function is to prevent races between two files that might otherwise ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. ;; This function explicitly MUST NOT find definitions merely registered in previous sessions. ;; NB: this function depends on a corresponding side-effect in parse-defsystem; ;; the precise protocol between the two functions may change in the future (or not). (first (gethash `(find-system ,(coerce-name name)) (asdf-cache)))) (defclass define-op (non-propagating-operation) () (:documentation "An operation to record dependencies on loading a .asd file.")) (defmethod record-dependency ((plan null) (operation t) (component t)) (unless (or (typep operation 'define-op) (and (typep operation 'load-op) (typep component 'system) (equal "asdf" (coerce-name component)))) (if-let ((action (first (visiting-action-list *asdf-session*)))) (let ((parent-operation (action-operation action)) (parent-component (action-component action))) (cond ((and (typep parent-operation 'define-op) (typep parent-component 'system)) (let ((action (cons operation component))) (unless (gethash action (definition-dependency-set parent-component)) (push (cons operation component) (definition-dependency-list parent-component)) (setf (gethash action (definition-dependency-set parent-component)) t)))) (t (warn 'recursive-operate :operation operation :component component :action action))))))) (defmethod component-depends-on ((o define-op) (s system)) `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below. ;; 2- We don't call-next-method to avoid other methods ,@(loop* :for (o . c) :in (definition-dependency-list s) :collect (list o c)))) (defmethod component-depends-on ((o operation) (s system)) `(,@(when (and (not (typep o 'define-op)) (or (system-source-file s) (definition-dependency-list s))) `((define-op ,(primary-system-name s)))) ,@(call-next-method))) (defmethod perform ((o operation) (c undefined-system)) (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c))) ;; TODO: could this file be refactored so that locate-system is merely ;; the cache-priming call to input-files here? (defmethod input-files ((o define-op) (s system)) (if-let ((asd (system-source-file s))) (list asd))) (defmethod perform ((o define-op) (s system)) (nest (if-let ((pathname (first (input-files o s))))) (let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control (print-pprint-dispatch *print-pprint-dispatch*))) (with-standard-io-syntax) (let ((*print-readably* nil) ;; 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) ;; restore inside syntax table (*print-pprint-dispatch* print-pprint-dispatch) (*package* (find-package :asdf-user)) (*default-pathname-defaults* ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. (pathname-directory-pathname (physicalize-pathname pathname))))) (handler-bind (((and error (not missing-component)) #'(lambda (condition) (error 'load-system-definition-error :name (coerce-name s) :pathname pathname :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") (coerce-name s) pathname) ;; dependencies will depend on what's loaded via definition-dependency-list (unset-asdf-cache-entry `(component-depends-on ,o ,s)) (unset-asdf-cache-entry `(input-files ,o ,s))) (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))) (defun load-asd (pathname &key name) "Load system definitions from PATHNAME. NAME if supplied is the name of a system expected to be defined in that file. Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (with-asdf-session () ;; TODO: use OPERATE, so we consult the cache and only load once per session. (flet ((do-it (o c) (operate o c))) (let ((primary-name (primary-system-name (or name (pathname-name pathname)))) (operation (make-operation 'define-op))) (if-let (system (registered-system primary-name)) (progn ;; We already determine this to be obsolete --- ;; or should we move some tests from find-system to check for up-to-date-ness here? (setf (component-operation-time operation system) t (definition-dependency-list system) nil (definition-dependency-set system) (list-to-hash-set nil)) (do-it operation system)) (let ((system (make-instance 'undefined-system :name primary-name :source-file pathname))) (register-system system) (unwind-protect (do-it operation system) (when (typep system 'undefined-system) (clear-system system))))))))) (defvar *old-asdf-systems* (make-hash-table :test 'equal)) ;; (Private) function to check that a system that was found isn't an asdf downgrade. ;; Returns T if everything went right, NIL if the system was an ASDF at an older version, ;; or UIOP of the same or older version, that shall not be loaded. ;; Also issue a warning if it was a strictly older version of ASDF. (defun check-not-old-asdf-system (name pathname) (or (not (member name '("asdf" "uiop") :test 'equal)) (null pathname) (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop (version-pathname (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp"))) (version (and (probe-file* version-pathname :truename nil) (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2))))) (old-version (asdf-version))) (cond ;; Same version is OK for ASDF, to allow loading from modified source. ;; However, do *not* load UIOP of the exact same version: ;; it was already loaded it as part of ASDF and would only be double-loading. ;; Be quiet about it, though, since it's a normal situation. ((equal old-version version) asdfp) ((version< old-version version) t) ;; newer version: Good! (t ;; old version: bad (ensure-gethash (list (namestring pathname) version) *old-asdf-systems* #'(lambda () (let ((old-pathname (system-source-file (registered-system "asdf")))) (if asdfp (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) ;; NB: for UIOP, don't warn, just ignore. (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)" old-version old-pathname version pathname) )))) nil))))) ;; only issue the warning the first time, but always return nil (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY 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. PATHNAME when not null is a path from which 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. PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system." (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful, ;; and keeping a negative cache was a bug (see lp#1335323), which required ;; explicit invalidation in clear-system and find-system (when unsucccessful). (let* ((name (coerce-name name)) (previous (registered-system name)) ; load from disk if absent or newer on disk (previous-primary-name (and previous (primary-system-name previous))) (previous-primary-system (and previous-primary-name (registered-system previous-primary-name))) (previous-time (and previous-primary-system (component-operation-time 'define-op previous-primary-system))) (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)) (system-source-file found-system) (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) (check-type previous system) ;; asdf is preloaded, so there should be a previous one. (setf found-system nil pathname nil)) (values foundp found-system pathname previous previous-time previous-primary-system)))) ;; TODO: make a prepare-define-op node for this ;; so we can properly cache the answer rather than recompute it. (defun definition-dependencies-up-to-date-p (system) (check-type system system) (or (not (primary-system-p system)) (handler-case (loop :with plan = (make-instance *plan-class*) :for action :in (definition-dependency-list system) :always (action-up-to-date-p plan (action-operation action) (action-component action)) :finally (let ((o (make-operation 'define-op))) (multiple-value-bind (stamp done-p) (compute-action-stamp plan o system) (return (and (timestamp<= stamp (component-operation-time o system)) done-p))))) (system-out-of-date () nil)))) ;; Main method for find-system: first, make sure the computation is memoized in a session cache. ;; Unless the system is immutable, use locate-system to find the primary system; ;; reconcile the finding (if any) with any previous definition (in a previous session, ;; preloaded, with a previous configuration, or before filesystem changes), and ;; load a found .asd if appropriate. Finally, update registration table and return results. (defmethod find-system ((name string) &optional (error-p t)) (nest (with-asdf-session (:key `(find-system ,name))) (let ((name-primary-p (primary-system-p name))) (unless name-primary-p (find-system (primary-system-name name) nil))) (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))) (multiple-value-bind (foundp found-system pathname previous previous-time previous-primary) (locate-system name) (assert (eq foundp (and (or found-system pathname previous) t)))) (let ((previous-pathname (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)) (if-let ((stamp (get-file-stamp pathname))) (let ((up-to-date-p (and previous previous-primary (or (pathname-equal pathname previous-pathname) (and pathname previous-pathname (pathname-equal (physicalize-pathname pathname) (physicalize-pathname previous-pathname)))) (timestamp<= stamp previous-time) ;; Check that all previous definition-dependencies are up-to-date, ;; traversing them without triggering the adding of nodes to the plan. ;; TODO: actually have a prepare-define-op, extract its timestamp, ;; and check that it is less than the stamp of the previous define-op ? (definition-dependencies-up-to-date-p previous-primary)))) (unless up-to-date-p (restart-case (signal 'system-out-of-date :name name) (continue () :report "continue")) (load-asd pathname :name name))))) ;; Try again after having loaded from disk if needed (or (registered-system name) (when error-p (error 'missing-component :requires name))))) ;; Resolved forward reference for asdf/system-registry. (defun mark-component-preloaded (component) "Mark a component as preloaded." (let ((component (find-component component nil :registered t))) ;; Recurse to children, so asdf/plan will hopefully be happy. (map () 'mark-component-preloaded (component-children component)) ;; Mark the timestamps of the common lisp-action operations as 0. (let ((cot (component-operation-times component))) (dolist (o `(,@(when (primary-system-p component) '(define-op)) prepare-op compile-op load-op)) (setf (gethash (make-operation o) cot) 0)))))) asdf-3.3.4/footer.lisp000066400000000000000000000066401362155115300146350ustar00rootroot00000000000000;;;; ----------------------------------------------------------------------- ;;;; ASDF Footer: last words and cleanup (uiop/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) (:use :uiop/common-lisp :uiop :asdf/system ;; used by ECL :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle) ;; Happily, all those implementations all have the same module-provider hook interface. #+(or abcl clasp cmucl clozure ecl mezzano mkcl sbcl) (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext #+mezzano :sys.int #:*module-provider-functions* #+ecl #:*load-hooks*) #+(or clasp mkcl) (:import-from :si #:*load-hooks*)) (in-package :asdf/footer) ;;;; Register ASDF itself and all its subsystems as preloaded. (with-upgradability () (dolist (s '("asdf" "uiop" "asdf-package-system")) ;; Don't bother with these system names, no one relies on them anymore: ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem" (register-preloaded-system s :version *asdf-version*))) ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. #+(or abcl clasp clisp clozure cmucl ecl mezzano mkcl sbcl) (with-upgradability () ;; Hook into CL:REQUIRE. #-clisp (pushnew 'module-provide-asdf *module-provider-functions*) #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil)) (eval `(pushnew 'module-provide-asdf ,x))) #+(or clasp ecl mkcl) (progn (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car) #+os-windows (unless (assoc "asd" *load-hooks* :test 'equal) (appendf *load-hooks* '(("asd" . si::load-source)))) ;; Wrap module provider functions in an idempotent, upgrade friendly way (defvar *wrapped-module-provider* (make-hash-table)) (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf) (defun wrap-module-provider (provider name) (let ((results (multiple-value-list (funcall provider name)))) (when (first results) (register-preloaded-system (coerce-name name))) (values-list results))) (defun wrap-module-provider-function (provider) (ensure-gethash provider *wrapped-module-provider* (constantly #'(lambda (module-name) (wrap-module-provider provider module-name))))) (setf *module-provider-functions* (mapcar #'wrap-module-provider-function *module-provider-functions*)))) #+cmucl ;; Hook into the CMUCL herald. (with-upgradability () (defun herald-asdf (stream) (format stream " ASDF ~A" (asdf-version))) (setf (getf ext:*herald-items* :asdf) '(herald-asdf))) ;;;; Done! (with-upgradability () #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) ;; Advertise the features we provide. (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*)) ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. (provide "asdf") (provide "ASDF") ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF. (cleanup-upgraded-asdf)) (when *load-verbose* (asdf-message ";; ASDF, version ~a~%" (asdf-version))) asdf-3.3.4/forcing.lisp000066400000000000000000000154231362155115300147650ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Forcing (uiop/package:define-package :asdf/forcing (:recycle :asdf/forcing :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation :asdf/system :asdf/system-registry) (:export #:forcing #:make-forcing #:forced #:forced-not #:performable-p #:normalize-forced-systems #:normalize-forced-not-systems #:action-forced-p #:action-forced-not-p)) (in-package :asdf/forcing) ;;;; Forcing (with-upgradability () (defclass forcing () (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not ;; settings than the session can only be used for read-only queries that do not cause the ;; status of any action to be raised. (performable-p :initform nil :initarg :performable-p :reader performable-p) ;; Parameters (parameters :initform nil :initarg :parameters :reader parameters) ;; Table of systems specified via :force arguments (forced :initarg :forced :reader forced) ;; Table of systems specified via :force-not argument (and/or immutable) (forced-not :initarg :forced-not :reader forced-not))) (defgeneric action-forced-p (forcing operation component) (:documentation "Is this action forced to happen in this plan?")) (defgeneric action-forced-not-p (forcing operation component) (:documentation "Is this action forced to not happen in this plan? Takes precedence over action-forced-p.")) (defun normalize-forced-systems (force system) "Given a SYSTEM on which operate is called and the specified FORCE argument, extract a hash-set of systems that are forced, or a predicate on system names, or NIL if none are forced, or :ALL if all are." (etypecase force ((or (member nil :all) hash-table function) force) (cons (list-to-hash-set (mapcar #'coerce-name force))) ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) (defun normalize-forced-not-systems (force-not system) "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, or predicate on system names, or NIL if none are forced, or :ALL if all are." (let ((requested (etypecase force-not ((or (member nil :all) hash-table function) force-not) (cons (list-to-hash-set (mapcar #'coerce-name force-not))) ((eql t) (if system (let ((name (coerce-name system))) #'(lambda (x) (not (equal x name)))) :all))))) (if (and *immutable-systems* requested) #'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x))) (or *immutable-systems* requested)))) ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? (defun action-override-p (forcing operation component override-accessor) "Given a plan, an action, and a function that given the plan accesses a set of overrides, i.e. force or force-not, see if the override applies to the current action." (declare (ignore operation)) (call-function (funcall override-accessor forcing) (coerce-name (component-system (find-component () component))))) (defmethod action-forced-p (forcing operation component) (and ;; Did the user ask us to re-perform the action? (action-override-p forcing operation component 'forced) ;; You really can't force a builtin system and :all doesn't apply to it. (not (builtin-system-p (component-system component))))) (defmethod action-forced-not-p (forcing operation component) ;; Did the user ask us to not re-perform the action? ;; NB: force-not takes precedence over force, as it should (action-override-p forcing operation component 'forced-not)) ;; Null forcing means no forcing either way (defmethod action-forced-p ((forcing null) (operation operation) (component component)) nil) (defmethod action-forced-not-p ((forcing null) (operation operation) (component component)) nil) (defun or-function (fun1 fun2) (cond ((or (null fun2) (eq fun1 :all)) fun1) ((or (null fun1) (eq fun2 :all)) fun2) (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x)))))) (defun make-forcing (&key performable-p system (force nil force-p) (force-not nil force-not-p) &allow-other-keys) (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*))) (system (and system (coerce-name system))) (forced (normalize-forced-systems force system)) (forced-not (normalize-forced-not-systems force-not system)) (parameters `(,@(when force `(:force ,force)) ,@(when force-not `(:force-not ,force-not)) ,@(when (or (eq force t) (eq force-not t)) `(:system ,system)) ,@(when performable-p `(:performable-p t)))) forcing) (cond ((not session-forcing) (setf forcing (make-instance 'forcing :performable-p performable-p :parameters parameters :forced forced :forced-not forced-not)) (when (and performable-p *asdf-session*) (setf (forcing *asdf-session*) forcing))) (performable-p (when (and (not (equal parameters (parameters session-forcing))) (or force-p force-not-p)) (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~ unless identically to toplevel" (find-symbol* :operate :asdf) :force :force-not)) (setf forcing session-forcing)) (t (setf forcing (make-instance 'forcing ;; Combine force and force-not with values from the toplevel-plan :parameters `(,@parameters :on-top-of ,(parameters session-forcing)) :forced (or-function (forced session-forcing) forced) :forced-not (or-function (forced-not session-forcing) forced-not))))) forcing)) (defmethod print-object ((forcing forcing) stream) (print-unreadable-object (forcing stream :type t) (format stream "~{~S~^ ~}" (parameters forcing)))) ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case. (defmethod forcing ((x null)) (if-let (session (toplevel-asdf-session)) (forcing session) (make-forcing :performable-p t))) ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing. (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session)))) asdf-3.3.4/header.lisp000066400000000000000000000053471362155115300145720ustar00rootroot00000000000000;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- ;;; This is ASDF 3.3.4: 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-2019 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. #+genera (eval-when (:compile-toplevel :load-toplevel :execute) (multiple-value-bind (system-major system-minor) (sct:get-system-version) (multiple-value-bind (is-major is-minor) (sct:get-system-version "Intel-Support") (unless (or (> system-major 452) (and is-major (or (> is-major 3) (and (= is-major 3) (> is-minor 86))))) (error "ASDF requires either System 453 or later or Intel Support 3.87 or later"))))) asdf-3.3.4/interface.lisp000066400000000000000000000151221362155115300152720ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. (uiop/package:define-package :asdf/interface (:nicknames :asdf :asdf-utilities) (:recycle :asdf/interface :asdf) (:unintern #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/system-registry :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system) ;; Note: (1) we are NOT automatically reexporting everything from previous packages. ;; (2) we only reexport UIOP functionality when backward-compatibility requires it. (:export #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name #:primary-system-name #:oos #:operate #:make-plan #:perform-plan #:sequential-plan #:system-definition-pathname #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:load-systems* #:require-system #:test-system #:clear-system #:operation #:make-operation #:find-operation #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation #:build-op #:make #:load-op #:prepare-op #:compile-op #:prepare-source-op #:load-source-op #:test-op #:define-op #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname #:component-depends-on ; backward-compatible name rather than action-depends-on #:input-files #:additional-input-files #:output-files #:output-file #:perform #:perform-with-restarts #:operation-done-p #:explain #:action-description #:component-sideway-dependencies #:needed-in-image-p #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #:program-system #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op #: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 #:register-preloaded-system #:sysdef-preloaded-system-search #:register-immutable-system #:sysdef-immutable-system-search #:package-inferred-system #:register-system-packages #:component-children #:component-children-by-name #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-system #:component-encoding #:component-external-format #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:system-licence #:system-version #: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-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on #:*system-definition-search-functions* ; variables #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* #:*verbose-out* #:asdf-version #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning #: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 #:bad-system-name #:system-out-of-date #:package-inferred-system-missing-package-error #:operation-definition-warning #:operation-definition-error #:try-recompiling ; restarts #:retry #:accept #:coerce-entry-to-directory #:remove-entry-from-registry #:clear-configuration-and-retry #:*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 #:registered-system #: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 ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release. #:*asdf-verbose* #:run-shell-command #:component-load-dependencies #:system-registered-p #:package-system #+ecl #:make-build #:operation-on-warnings #:operation-on-failure #:operation-error #:compile-failed #:compile-warned #:compile-error #:module-components #:component-property #:traverse)) asdf-3.3.4/lisp-action.lisp000066400000000000000000000275451362155115300155700ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Actions to build Common Lisp software (uiop/package:define-package :asdf/lisp-action (:recycle :asdf/lisp-action :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/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 #: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)) (in-package :asdf/lisp-action) ;;;; Component classes (with-upgradability () (defclass cl-source-file (source-file) ((type :initform "lisp")) (:documentation "Component class for a Common Lisp source file (using type \"lisp\")")) (defclass cl-source-file.cl (cl-source-file) ((type :initform "cl")) (:documentation "Component class for a Common Lisp source file using type \"cl\"")) (defclass cl-source-file.lsp (cl-source-file) ((type :initform "lsp")) (:documentation "Component class for a Common Lisp source file using type \"lsp\""))) ;;;; Operation classes (with-upgradability () (defclass basic-load-op (operation) () (:documentation "Base class for operations that apply the load-time effects of a file")) (defclass basic-compile-op (operation) () (:documentation "Base class for operations that apply the compile-time effects of a file"))) ;;; Our default operations: loading into the current lisp image (with-upgradability () (defclass prepare-op (upward-operation sideway-operation) ((sideway-operation :initform 'load-op :allocation :class)) (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT.")) (defclass load-op (basic-load-op downward-operation selfward-operation) ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, ;; so we need to directly depend on prepare-op for its side-effects in the current image. ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)) (:documentation "Operation for loading the compiled FASL for a Lisp file")) (defclass compile-op (basic-compile-op downward-operation selfward-operation) ((selfward-operation :initform 'prepare-op :allocation :class)) (:documentation "Operation for compiling a Lisp file to a FASL")) (defclass prepare-source-op (upward-operation sideway-operation) ((sideway-operation :initform 'load-source-op :allocation :class)) (:documentation "Operation for loading the dependencies of a Lisp file as source.")) (defclass load-source-op (basic-load-op downward-operation selfward-operation) ((selfward-operation :initform 'prepare-source-op :allocation :class)) (:documentation "Operation for loading a Lisp file as source.")) (defclass test-op (selfward-operation) ((selfward-operation :initform 'load-op :allocation :class)) (:documentation "Operation for running the tests for system. If the tests fail, an error will be signaled."))) ;;;; Methods for prepare-op, compile-op and load-op ;;; prepare-op (with-upgradability () (defmethod action-description ((o prepare-op) (c component)) (format nil (compatfmt "~@") c)) (defmethod perform ((o prepare-op) (c component)) nil) (defmethod input-files ((o prepare-op) (s system)) (if-let (it (system-source-file s)) (list it)))) ;;; compile-op (with-upgradability () (defmethod action-description ((o compile-op) (c component)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o compile-op) (c parent-component)) (format nil (compatfmt "~@") c)) (defgeneric call-with-around-compile-hook (component thunk) (:documentation "A method to be called around the PERFORM'ing of actions that apply the compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used to setup readtables and other variables that control reading, macroexpanding, and compiling, etc. Note that it will NOT be called around the performing of LOAD-OP.")) (defmethod call-with-around-compile-hook ((c component) function) (call-around-hook (around-compile-hook c) function)) (defun perform-lisp-compilation (o c) "Perform the compilation of the Lisp file associated to the specified action (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 #+(or clasp ecl mkcl) object-file #+clisp lib-file warnings-file &rest rest) outputs ;; Allow for extra outputs that are not of type warnings-file ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional. (declare (ignore rest)) (when warnings-file (unless (equal (pathname-type warnings-file) (warnings-file-type)) (setf warnings-file nil))) (call-with-around-compile-hook c #'(lambda (&rest flags) (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 clasp ecl mkcl) (list :object-file object-file) flags))))) (check-lisp-compile-results output warnings-p failure-p "~/asdf-action::format-action/" (list (cons o c)))))) (defun report-file-p (f) "Is F a build report file containing, e.g., warnings to check?" (equalp (pathname-type f) "build-report")) (defun perform-lisp-warnings-check (o c) "Check the warnings associated with the dependencies of an action." (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) "Compute the output-files for compiling the Lisp file for the specified action (O . C), an OPERATION and a COMPONENT." (let* ((i (first (input-files o c))) (f (compile-file-pathname i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl #+mkcl :fasl-p #+mkcl t))) `(,f ;; the fasl is the primary output, in first position #+clasp ,@(unless nil ;; was (use-ecl-byte-compiler-p) `(,(compile-file-pathname i :output-type :object))) #+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)) nil) ;; Performing compile-op on a system will check the deferred warnings for the system (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: ;; (collect-dependencies 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)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o load-op) (c parent-component)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o load-op) (c component)) (format nil (compatfmt "~@") c)) (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) "Perform the loading of a FASL associated to specified action (O . C), an OPERATION and a COMPONENT." (if-let (fasl (first (input-files o c))) (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)) nil)) ;;;; prepare-source-op, load-source-op ;;; prepare-source-op (with-upgradability () (defmethod action-description ((o prepare-source-op) (c component)) (format nil (compatfmt "~@") c)) (defmethod input-files ((o prepare-source-op) (s system)) (if-let (it (system-source-file s)) (list it))) (defmethod perform ((o prepare-source-op) (c component)) nil)) ;;; load-source-op (with-upgradability () (defmethod action-description ((o load-source-op) (c component)) (format nil (compatfmt "~@") c)) (defmethod action-description ((o load-source-op) (c parent-component)) (format nil (compatfmt "~@") c)) (defun perform-lisp-load-source (o c) "Perform the loading of a Lisp file as associated to specified action (O . C)" (call-with-around-compile-hook c #'(lambda () (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)) nil)) ;;;; test-op (with-upgradability () (defmethod perform ((o test-op) (c component)) nil) (defmethod operation-done-p ((o test-op) (c system)) "Testing a system is _never_ done." nil)) asdf-3.3.4/make-asdf.bat000066400000000000000000000047021362155115300147630ustar00rootroot00000000000000@echo off :: Usage: ./make-asdf.bat [keyword=argument ...] :: See the Makefile for the list of acceptable keyword arguments set here=%~dp0 set header_lisp=header.lisp set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + forcing.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp %~d0 cd "%~p0" if "%~1"=="" goto all if "%~1"=="all" goto all if "%~1"=="build_asdf" goto build_asdf if "%~1"=="build_asdf_tools" goto build_asdf_tools if "%~1"=="ext" goto ext if "%~1"=="noext" goto noext if "%~1"=="driver_files" goto driver_files if "%~1"=="defsystem_files" goto defsystem_files call "%0" build_asdf_tools "%here%\build\asdf-tools.exe" env %* goto end :all :: Default action: bootstrap asdf.lisp :build_asdf :: That's the only thing that we really need before we may invoke the asdf-tools if not exist build mkdir build set a=build\asdf.lisp copy /y /b %header_lisp% + %driver_lisp% + %defsystem_lisp% %a%.tmp > nul if not exist %a% goto clobber fc /b /0 %a%.tmp %a% > nul if errorlevel 1 goto clobber del /f /q %a%.tmp goto end :build_asdf_tools :: Building a binary for asdf-tools if exist build\asdf-tools.exe goto end call "%0" build_asdf "%here%\tools\asdf-tools.bat" build-asdf-tools goto end :clobber if exist %a% del /f /q %a% rename %a%.tmp asdf.lisp goto end :ext :: Download all the development-time dependencies of ASDF: git submodule update --init goto end :noext :: Remove all the development-time dependencies of ASDF: git submodule deinit . goto end :driver_files :: These targets are used during tests to ensure the Makefile is in synch with the .asd files. echo %driver_lisp% goto end :defsystem_files :: These targets are used during tests to ensure the Makefile is in synch with the .asd files. echo %defsystem_lisp% goto end :end asdf-3.3.4/make-asdf.sh000077500000000000000000000041451362155115300146330ustar00rootroot00000000000000#!/bin/sh # Usage: ./make-asdf.sh [keyword=argument ...] # See the Makefile for the list of acceptable keyword arguments here="$(dirname $0)" header_lisp="header.lisp" driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp" all () { # Default action: bootstrap asdf.lisp build_asdf } build_asdf () { # That's the only thing that we really need before we may invoke asdf-tools. mkdir -p build a=build/asdf.lisp cat ${header_lisp} ${driver_lisp} ${defsystem_lisp} > ${a}.tmp if [ -f ${a} ] && cmp -s ${a} ${a}.tmp ; then rm -rf ${a}.tmp else mv -f ${a}.tmp ${a} fi } build_asdf_tools () { if [ -x build/asdf-tools ] ; then : "Reusing existing asdf-tools." else : "Building asdf-tools." build_asdf ${here}/tools/asdf-tools build-asdf-tools fi } ext () { # Download all the development-time dependencies of ASDF: git submodule update --init } noext () { # Remove all the development-time dependencies of ASDF: git submodule deinit . } driver_files () { # These targets are used during tests to ensure the Makefile is in synch with the .asd files. echo ${driver_lisp} } defsystem_files () { # These targets are used during tests to ensure the Makefile is in synch with the .asd files. echo ${defsystem_lisp} } case "$1" in "") all ;; all|build_asdf|build_asdf_tools|ext|noext|driver_files|defsystem_files) "$@" ;; *) build_asdf_tools ; exec ${here}/build/asdf-tools env "$@" ;; esac ; exit asdf-3.3.4/operate.lisp000066400000000000000000000346041362155115300147770ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations (uiop/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/system-registry :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan) (:export #:operate #:oos #:build-op #:make #:load-system #:load-systems #:load-systems* #:compile-system #:test-system #:require-system #:module-provide-asdf #:component-loaded-p #:already-loaded-systems #:recursive-operate)) (in-package :asdf/operate) (with-upgradability () (defgeneric operate (operation component &key) (:documentation "Operate does mainly four things for the user: 1. Resolves the OPERATION designator into an operation object. OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION. 2. Resolves the COMPONENT designator into a component object. COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM. 3. It then calls MAKE-PLAN with the operation and system as arguments. 4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system. The entire computation 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. If a PLAN-CLASS argument is supplied, that class is used for the plan. If a PLAN-OPTIONS argument is supplied, the options are passed to the plan. 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-NOT has precedence over :FORCE; builtin systems cannot be forced. For backward compatibility, all keyword arguments are passed to MAKE-OPERATION when instantiating a new operation, that will in turn be inherited by new operations. But do NOT depend on it, for this is deprecated behavior.")) (define-convenience-action-methods operate (operation component &key) :if-no-component (error 'missing-component :requires component)) ;; This method ensures that an ASDF upgrade is attempted as the very first thing, ;; with suitable state preservation in case in case it actually happens, ;; and that a few suitable dynamic bindings are established. (defmethod operate :around (operation component &rest keys &key verbose (on-warnings *compile-file-warnings-behaviour*) (on-failure *compile-file-failure-behaviour*)) (nest (with-asdf-session ()) (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) (etypecase operation (operation (let ((name (type-of operation))) #'(lambda () (make-operation name)))) ((or symbol string) (constantly operation)))) (component-path (typecase component ;; to remake the component after ASDF upgrade (component (component-find-path component)) (t component))) (system-name (labels ((first-name (x) (etypecase x ((or string symbol) x) ; NB: includes the NIL case. (cons (or (first-name (car x)) (first-name (cdr x))))))) (coerce-name (first-name component-path))))) (apply 'make-forcing :performable-p t :system system-name keys) ;; 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 (asdf-upgraded-p (toplevel-asdf-session)) (setf (asdf-upgraded-p (toplevel-asdf-session)) t) (when (upgrade-asdf) ;; If we were upgraded, restart OPERATE the hardest of ways, for ;; its function may have been redefined. (return-from operate (with-asdf-session (:override t :override-cache t) (apply 'operate (funcall operation-remaker) component-path keys)))))) ;; Setup proper bindings around any operate call. (let* ((*verbose-out* (and verbose *standard-output*)) (*compile-file-warnings-behaviour* on-warnings) (*compile-file-failure-behaviour* on-failure))) (unwind-protect (progn (incf (operate-level)) (call-next-method)) (decf (operate-level))))) (defmethod operate :before ((operation operation) (component component) &key version) (unless (version-satisfies component version) (error 'missing-component-of-version :requires component :version version)) (record-dependency nil operation component)) (defmethod operate ((operation operation) (component component) &key plan-class plan-options) (let ((plan (apply 'make-plan plan-class operation component :forcing (forcing *asdf-session*) plan-options))) (perform-plan plan) (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))) (define-condition recursive-operate (warning) ((operation :initarg :operation :reader condition-operation) (component :initarg :component :reader condition-component) (action :initarg :action :reader condition-action)) (:report (lambda (c s) (format s (compatfmt "~@") 'operate (type-of (condition-operation c)) (component-find-path (condition-component c)) (action-path (condition-action c))))))) ;;;; Common operations (when-upgrading () (defmethod component-depends-on ((o prepare-op) (s system)) (call-next-method))) (with-upgradability () (defclass build-op (non-propagating-operation) () (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, to operate by default on a system or component, via the function BUILD. Its meaning is configurable via the :BUILD-OPERATION option of a component. which typically specifies the name of a specific operation to which to delegate the build, as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on); if NIL is specified (the default), BUILD-OP falls back to LOAD-OP, that will load the system in the current image.")) (defmethod component-depends-on ((o build-op) (c component)) `((,(or (component-build-operation c) 'load-op) ,c) ,@(call-next-method))) (defun make (system &rest keys) "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). It will build system FOO using the operation BUILD-OP, the meaning of which is configurable by the system, and defaults to LOAD-OP, to load it in current image." (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-op 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 the function REQUIRE-SYSTEM, that, similarly to REQUIRE, ;; only tries to load its specified target if it's not loaded yet. (with-upgradability () (defun component-loaded-p (component) "Has the given COMPONENT been successfully loaded in the current image (yet)? Note that this returns true even if the component is not up to date." (if-let ((component (find-component component () :registered t))) (nth-value 1 (component-operation-time (make-operation 'load-op) component)))) (defun already-loaded-systems () "return a list of the names of the systems that have been successfully loaded so far" (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*))))) ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL ;; Note that despite the two being homonyms, the _function_ require-system ;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes. (with-upgradability () (defvar *modules-being-required* nil) (defclass require-system (system) ((module :initarg :module :initform nil :accessor required-module)) (:documentation "A SYSTEM subclass whose processing is handled by the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (defmethod perform ((o compile-op) (c require-system)) nil) (defmethod perform ((o load-op) (s require-system)) (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) (unless (and (length=n-p arguments 1) (typep (car arguments) '(or string (and symbol (not null))))) (parameter-error (compatfmt "~@") 'resolve-dependency-combination (cons combinator arguments) component combinator)) ;; :require must be prepared for some implementations providing modules using ASDF, ;; as SBCL used to do, and others may might do. Thus, the system provided in the end ;; would be a downcased name as per module-provide-asdf above. For the same reason, ;; we cannot assume that the system in the end will be of type require-system, ;; but must check whether we can use find-system and short-circuit cl:require. ;; Otherwise, calling cl:require could result in nasty reentrant calls between ;; cl:require and asdf:operate that could potentially blow up the stack, ;; all the while defeating the consistency of the dependency graph. (let* ((module (car arguments)) ;; NB: we already checked that it was not null ;; CMUCL, MKCL, SBCL like their module names to be all upcase. (module-name (string module)) (system-name (string-downcase module)) (system (find-system system-name nil))) (or system (let ((system (make-instance 'require-system :name system-name :module module-name))) (register-system system) system)))) (defun module-provide-asdf (name) ;; We must use string-downcase, because modules are traditionally specified as symbols, ;; that implementations traditionally normalize as uppercase, for which we seek a system ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine. ;; We could make complex, non-portable rules to try to preserve case, and just documenting ;; them would be a hell that it would be a disservice to inflict on users. (let ((module-name (string name)) (system-name (string-downcase name))) (unless (member module-name *modules-being-required* :test 'equal) (let ((*modules-being-required* (cons module-name *modules-being-required*)) #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal))) (handler-bind (((or style-warning recursive-operate) #'muffle-warning) (missing-component (constantly nil)) (fatal-condition #'(lambda (e) (format *error-output* (compatfmt "~@~%") name e)))) (let ((*verbose-out* (make-broadcast-stream))) (let ((system (find-system system-name nil))) (when system ;; Do not use require-system after all, use load-system: ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice, ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with ;; the toplevel session forcing settings. (load-system system :verbose nil) t))))))))) ;;;; Some upgrade magic (with-upgradability () (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. (let ((systems-being-defined (when *asdf-session* (prog1 (loop :for k :being :the hash-keys :of (asdf-cache) :when (eq (first k) 'find-system) :collect (second k)) (clrhash (asdf-cache)))))) ;; Regardless, clear defined systems, since they might be invalid ;; after an incompatible ASDF upgrade. (clear-registered-systems) ;; The configuration also may have to be upgraded. (upgrade-configuration) ;; If we were in the middle of an operation, be sure to restore the system being defined. (dolist (s systems-being-defined) (find-system s nil)))) (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf)) asdf-3.3.4/operation.lisp000066400000000000000000000064631362155115300153420ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Operations (uiop/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 :asdf/session) (:export #:operation #:*operations* #:make-operation #:find-operation #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature. (in-package :asdf/operation) ;;; Operation Classes (when-upgrading (:version "2.27" :when (find-class 'operation nil)) ;; override any obsolete shared-initialize method when upgrading from ASDF2. (defmethod shared-initialize :after ((o operation) (slot-names t) &key) (values))) (with-upgradability () (defclass operation () () (:documentation "The base class for all ASDF operations. ASDF does NOT and never did distinguish between multiple operations of the same class. Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions. ")) (defvar *in-make-operation* nil) (defun check-operation-constructor () "Enforce that OPERATION instances must be created with MAKE-OPERATION." (unless *in-make-operation* (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION."))) (defmethod print-object ((o operation) stream) (print-unreadable-object (o stream :type t :identity nil))) ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking. #-genera ;; Genera adds its own system initargs, e.g. clos-internals:storage-area 8 (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys) (unless (null initargs) (parameter-error "~S does not accept initargs" 'operation)))) ;;; make-operation, find-operation (with-upgradability () ;; A table to memoize instances of a given operation. There shall be only one. (defparameter* *operations* (make-hash-table :test 'equal)) ;; A memoizing way of creating instances of operation. (defun make-operation (operation-class) "This function creates and memoizes an instance of OPERATION-CLASS. All operation instances MUST be created through this function. Use of INITARGS is not supported at this time." (let ((class (coerce-class operation-class :package :asdf/interface :super 'operation :error 'sysdef-error)) (*in-make-operation* t)) (ensure-gethash class *operations* `(make-instance ,class)))) ;; This function is mostly for backward and forward compatibility: ;; operations used to preserve the operation-original-initargs of the context, ;; and may in the future preserve some operation-canonical-initargs. ;; Still, the treatment of NIL as a disabling context is useful in some cases. (defgeneric find-operation (context spec) (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) (defmethod find-operation ((context t) (spec operation)) spec) (defmethod find-operation ((context t) (spec symbol)) (when spec ;; NIL designates itself, i.e. absence of operation (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) (defmethod find-operation ((context t) (spec string)) (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) asdf-3.3.4/output-translations.lisp000066400000000000000000000377261362155115300174270ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; asdf-output-translations (uiop/package:define-package :asdf/output-translations (:recycle :asdf/output-translations :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:*output-translations* #:*output-translations-parameter* #:invalid-output-translation #:output-translations #:output-translations-initialized-p #:initialize-output-translations #:clear-output-translations #:disable-output-translations #:ensure-output-translations #:apply-output-translations #:validate-output-translations-directive #:validate-output-translations-form #:validate-output-translations-file #:validate-output-translations-directory #:parse-output-translations-string #:wrapping-output-translations #:user-output-translations-pathname #:system-output-translations-pathname #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname #:environment-output-translations #:process-output-translations #:compute-output-translations #+abcl #:translate-jar-pathname )) (in-package :asdf/output-translations) ;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro ;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us. (when-upgrading (:version "3.1.2") (fmakunbound '(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 () "Return the configured output-translations, if any" (car *output-translations*)) ;; Set the output-translations, by sorting the provided new-value. (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 (normalize-pathname-directory-component (pathname-directory (car x))))) (if (listp directory) (length directory) 0)))))))) new-value) (defun (setf output-translations) (new-value) (set-output-translations new-value)) (defun output-translations-initialized-p () "Have the output-translations been initialized yet?" (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) ;;; Validation of the configuration directives... (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)) ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents (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))))))))) ;; The default sources of configuration for output-translations (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)) ;; Compulsory implementation-dependent wrapping for the translations: ;; handle implementation-provided systems. (defun wrapping-output-translations () `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. #+(or clasp #|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)) ;; Relative pathnames of output-translations configuration to XDG configuration directory (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf")) (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/")) ;; Locating various configuration pathnames, depending on input or output intent. (defun user-output-translations-pathname (&key (direction :input)) (xdg-config-pathname *output-translations-file* direction)) (defun system-output-translations-pathname (&key (direction :input)) (find-preferred-file (system-config-pathnames *output-translations-file*) :direction direction)) (defun user-output-translations-directory-pathname (&key (direction :input)) (xdg-config-pathname *output-translations-directory* direction)) (defun system-output-translations-directory-pathname (&key (direction :input)) (find-preferred-file (system-config-pathnames *output-translations-directory*) :direction direction)) (defun environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) ;;; Processing the configuration. (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))))) ((typep dst 'boolean) (funcall collect (list trusrc t))) (t (let* ((trudst (resolve-location dst :ensure-directory t :wilden t))) (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 pathname) &key inherit collect) (cond ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) :inherit inherit :collect collect)) ((probe-file* pathname :truename *resolve-symlinks*) (process-output-translations (validate-output-translations-file pathname) :inherit inherit :collect collect)) (t (inherit-output-translations inherit :collect collect)))) (defmethod process-output-translations ((string string) &key inherit collect) (process-output-translations (parse-output-translations-string string) :inherit inherit :collect collect)) (defmethod process-output-translations ((x null) &key inherit collect) (inherit-output-translations inherit :collect collect)) (defmethod process-output-translations ((form cons) &key inherit collect) (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect))) ;;; Top-level entry-points to configure output-translations (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)) ;; Saving the user-provided parameter to output-translations, if any, ;; so we can recompute the translations after code upgrade. (defvar *output-translations-parameter* nil) ;; Main entry-point for users. (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))) ;; Top-level entry-point to _use_ 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) ;;; Implementation-dependent hacks #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar. (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)))))) asdf-3.3.4/package-inferred-system.lisp000066400000000000000000000167521362155115300200550ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Package systems in the style of quick-build or faslpath (uiop:define-package :asdf/package-inferred-system (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action :asdf/parse-defsystem) (:export #:package-inferred-system #:sysdef-package-inferred-system-search #:package-system ;; backward compatibility only. To be removed. #:register-system-packages #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error)) (in-package :asdf/package-inferred-system) (with-upgradability () ;; The names of the recognized defpackage forms. (defparameter *defpackage-forms* '(defpackage define-package)) (defun initial-package-inferred-systems-table () ;; Mark all existing packages are preloaded. (let ((h (make-hash-table :test 'equal))) (dolist (p (list-all-packages)) (dolist (n (package-names p)) (setf (gethash n h) t))) h)) ;; Mapping from package names to systems that provide them. (defvar *package-inferred-systems* (initial-package-inferred-systems-table)) (defclass package-inferred-system (system) () (:documentation "Class for primary systems for which secondary systems are automatically in the one-file, one-file, one-system style: system names are mapped to files under the primary system's system-source-directory, dependencies are inferred from the first defpackage form in every such file")) ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release: (defclass package-system (package-inferred-system) ()) ;; Is a given form recognizable as a defpackage form? (defun defpackage-form-p (form) (and (consp form) (member (car form) *defpackage-forms*))) ;; Find the first defpackage form in a stream, if any (defun stream-defpackage-form (stream) (loop :for form = (read stream nil nil) :while form :when (defpackage-form-p form) :return form)) (defun file-defpackage-form (file) "Return the first DEFPACKAGE form in FILE." (with-input-file (f file) (stream-defpackage-form f))) (define-condition package-inferred-system-missing-package-error (system-definition-error) ((system :initarg :system :reader error-system) (pathname :initarg :pathname :reader error-pathname)) (:report (lambda (c s) (format s (compatfmt "~@") (error-system c) (error-pathname c))))) (defun package-dependencies (defpackage-form) "Return a list of packages depended on by the package defined in DEFPACKAGE-FORM. A package is depended upon if the DEFPACKAGE-FORM uses it or imports a symbol from it." (assert (defpackage-form-p defpackage-form)) (remove-duplicates (while-collecting (dep) (loop* :for (option . arguments) :in (cddr defpackage-form) :do (ecase option ((:use :mix :reexport :use-reexport :mix-reexport) (dolist (p arguments) (dep (string p)))) ((:import-from :shadowing-import-from) (dep (string (first arguments)))) #+sbcl ((:local-nicknames) (loop* :for (local-nickname actual-package-name) :in arguments :do (dep (string actual-package-name)))) ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) :from-end t :test 'equal)) (defun package-designator-name (package) "Normalize a package designator to a string" (etypecase package (package (package-name package)) (string package) (symbol (string package)))) (defun register-system-packages (system packages) "Register SYSTEM as providing PACKAGES." (let ((name (or (eq system t) (coerce-name system)))) (dolist (p (ensure-list packages)) (setf (gethash (package-designator-name p) *package-inferred-systems*) name)))) (defun package-name-system (package-name) "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists, otherwise return a default system name computed from PACKAGE-NAME." (check-type package-name string) (or (gethash package-name *package-inferred-systems*) (string-downcase package-name))) ;; Given a file in package-inferred-system style, find its dependencies (defun package-inferred-system-file-dependencies (file &optional system) (if-let (defpackage-form (file-defpackage-form file)) (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) (error 'package-inferred-system-missing-package-error :system system :pathname file))) ;; Given package-inferred-system object, check whether its specification matches ;; the provided parameters (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) (and (eq (type-of system) 'package-inferred-system) (equal (component-name system) name) (pathname-equal directory (component-pathname system)) (equal dependencies (component-sideway-dependencies system)) (equal around-compile (around-compile-hook system)) (let ((children (component-children system))) (and (length=n-p children 1) (let ((child (first children))) (and (eq (type-of child) 'cl-source-file) (equal (component-name child) "lisp") (and (slot-boundp child 'relative-pathname) (equal (slot-value child 'relative-pathname) subpath)))))))) ;; sysdef search function to push into *system-definition-search-functions* (defun sysdef-package-inferred-system-search (system) (let ((primary (primary-system-name system))) (unless (equal primary system) (let ((top (find-system primary nil))) (when (typep top 'package-inferred-system) (if-let (dir (component-pathname top)) (let* ((sub (subseq system (1+ (length primary)))) (f (probe-file* (subpathname dir sub :type "lisp") :truename *resolve-symlinks*))) (when (file-pathname-p f) (let ((dependencies (package-inferred-system-file-dependencies f system)) (previous (registered-system system)) (around-compile (around-compile-hook top))) (if (same-package-inferred-system-p previous system dir sub around-compile dependencies) previous (eval `(defsystem ,system :class package-inferred-system :source-file ,(system-source-file top) :pathname ,dir :depends-on ,dependencies :around-compile ,around-compile :components ((cl-source-file "lisp" :pathname ,sub))))))))))))))) (with-upgradability () (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*) (setf *system-definition-search-functions* (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil) *system-definition-search-functions*))) asdf-3.3.4/parse-defsystem.lisp000066400000000000000000000530171362155115300164520ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Defsystem (uiop/package:define-package :asdf/parse-defsystem (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares (:use :uiop/common-lisp :asdf/driver :asdf/upgrade :asdf/session :asdf/component :asdf/system :asdf/system-registry :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) (:import-from :asdf/system #:depends-on #:weakly-depends-on) ;; these needed for record-additional-system-input-file (:import-from :asdf/operation #:make-operation) (:import-from :asdf/component #:%additional-input-files) (:import-from :asdf/find-system #:define-op) (:export #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form #:non-toplevel-system #:non-system-system #:bad-system-name #:*known-systems-with-bad-secondary-system-names* #:known-system-with-bad-secondary-system-names-p #:sysdef-error-component #:check-component-input #:explain)) (in-package :asdf/parse-defsystem) ;;; Pathname (with-upgradability () (defun determine-system-directory (pathname) ;; The defsystem macro calls this function to determine the pathname of a system as follows: ;; 1. If the pathname argument is an pathname object (NOT a namestring), ;; that is already an absolute pathname, return it. ;; 2. Otherwise, the directory containing the LOAD-PATHNAME ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and ;; if it is indeed available and an absolute pathname, then ;; the PATHNAME argument is normalized to a relative pathname ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) ;; and merged into that DIRECTORY as per SUBPATHNAME. ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source, ;; but 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 () ;; What :file gets interpreted as, unless overridden by a :default-component-class (defvar *default-component-class* 'cl-source-file) (defun class-for-type (parent type) (or (coerce-class type :package :asdf/interface :super 'component :error nil) (and (eq type :file) (coerce-class (or (loop :for p = parent :then (component-parent p) :while p :thereis (module-default-component-class p)) *default-component-class*) :package :asdf/interface :super 'component :error nil)) (sysdef-error "don't recognize component type ~S" type)))) ;;; Check inputs (with-upgradability () (define-condition non-system-system (system-definition-error) ((name :initarg :name :reader non-system-system-name) (class-name :initarg :class-name :reader non-system-system-class-name)) (:report (lambda (c s) (format s (compatfmt "~@") (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))))) (define-condition bad-system-name (warning) ((name :initarg :name :reader component-name) (source-file :initarg :source-file :reader system-source-file)) (:report (lambda (c s) (let* ((file (system-source-file c)) (name (component-name c)) (asd (pathname-name file))) (format s (compatfmt "~@") file name asd (strcat asd "/") (strcat asd "/test")))))) (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 record-additional-system-input-file (pathname component parent) (let* ((record-on (if parent (loop :with retval :for par = parent :then (component-parent par) :while par :do (setf retval par) :finally (return retval)) component)) (comp (if (typep record-on 'component) record-on ;; at this point there will be no parent for RECORD-ON (find-component record-on nil))) (op (make-operation 'define-op)) (cell (or (assoc op (%additional-input-files comp)) (let ((new-cell (list op))) (push new-cell (%additional-input-files comp)) new-cell)))) (pushnew pathname (cdr cell) :test 'pathname-equal) (values))) ;; Given a form used as :version specification, in the context of a system definition ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form ;; to an acceptable ASDF-format version. (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 (if-let (target (find-component parent component)) (builtin-system-p target)) (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) (let ((path (subpathname pathname subpath))) (record-additional-system-input-file path component parent) (safe-read-file-form path :at at :package :asdf-user)))) ((:read-file-line) (destructuring-bind (subpath &key (at 0)) (rest form) (let ((path (subpathname pathname subpath))) (record-additional-system-input-file path component parent) (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)))))) ;;; "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) (defparameter *standard-method-combination-qualifiers* '(:around :before :after)) ;;; Find inline method definitions of the form ;;; ;;; :perform (test-op :before (operation component) ...) ;;; ;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods. (defun %define-component-inline-methods (ret rest) ;; find key-value pairs that look like inline method definitions in REST. For each identified ;; definition, parse it and, if it is well-formed, define the method. (loop* :for (key value) :on rest :by #'cddr :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) :when name :do ;; parse VALUE as an inline method definition of the form ;; ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY) (destructuring-bind (operation-name &rest rest) value (let ((qualifiers '())) ;; ensure that OPERATION-NAME is a symbol. (unless (and (symbolp operation-name) (not (null operation-name))) (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~ designating an operation but ~S." value operation-name)) ;; ensure that REST starts with either a cons (potential lambda list, further checked ;; below) or a qualifier accepted by the standard method combination. Everything else ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely ;; has to start with the lambda list. (cond ((consp (car rest))) ((not (member (car rest) *standard-method-combination-qualifiers*)) (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~ qualifiers ~{~S~^ ~} is allowed, not ~S." value *standard-method-combination-qualifiers* (car rest))) (t (setf qualifiers (list (pop rest))))) ;; REST must start with a two-element lambda list. (unless (and (listp (car rest)) (length=n-p (car rest) 2) (null (cddar rest))) (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~ a lambda-list of the form (OPERATION COMPONENT) and a method body." value operation-name)) ;; define the method. (destructuring-bind ((o c) &rest body) rest (pushnew (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,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))) ;;; Main parsing function (with-upgradability () (defun parse-dependency-def (dd) (if (listp dd) (case (first dd) (:feature (unless (= (length dd) 3) (sysdef-error "Ill-formed feature dependency: ~s" dd)) (let ((embedded (parse-dependency-def (third dd)))) `(:feature ,(second dd) ,embedded))) (feature (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd)) (:require (unless (= (length dd) 2) (sysdef-error "Ill-formed require dependency: ~s" dd)) dd) (:version (unless (= (length dd) 3) (sysdef-error "Ill-formed version dependency: ~s" dd)) `(:version ,(coerce-name (second dd)) ,(third dd))) (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) (coerce-name dd))) (defun parse-dependency-defs (dd-list) "Parse the dependency defs in DD-LIST into canonical form by translating all system names contained using COERCE-NAME. Return the result." (mapcar 'parse-dependency-def dd-list)) (defun* (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key (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 (ignore perform explain output-files operation-done-p builtin-system-p)) (check-component-input type name weakly-depends-on depends-on components) (when (and parent (find-component parent name) (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 (when (typep component 'system) ;; cache information for introspection (setf (slot-value component 'depends-on) (parse-dependency-defs depends-on) (slot-value component 'weakly-depends-on) ;; these must be a list of systems, cannot be features or versioned systems (mapcar 'coerce-name weakly-depends-on))) (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous (when (and (typep component 'system) (not bspp)) (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) (setf 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 (error "The system definition for ~S uses deprecated ~ ASDF option :IF-COMPONENT-DEP-FAILS. ~ Starting with ASDF 3, please use :IF-FEATURE instead" (coerce-name (component-system component)))) component))) ;; the following are all systems that Stas Boukarev maintains and refuses to fix, ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them. (defparameter* *known-systems-with-bad-secondary-system-names* (list-to-hash-set '("cl-ppcre" "cl-interpol"))) (defun known-system-with-bad-secondary-system-names-p (asd-name) ;; Does .asd file with name ASD-NAME contain known exceptions ;; that should be screened out of checking for BAD-SYSTEM-NAME? (gethash asd-name *known-systems-with-bad-secondary-system-names*)) (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 the asdf-cache. (nest (with-asdf-session ()) (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))))) (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x)))) (let* ((asd-name (and source-file (equal "asd" (fix-case (pathname-type source-file))) (fix-case (pathname-name source-file)))) ;; note that PRIMARY-NAME is a *syntactically* primary name (primary-name (primary-system-name name))) (when (and asd-name (not (equal asd-name primary-name)) (not (known-system-with-bad-secondary-system-names-p asd-name))) (warn (make-condition 'bad-system-name :source-file source-file :name name)))) (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object, ;; so that in case it fails, there is no incomplete object polluting the build. (checked-defsystem-depends-on (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) (deps (loop :for spec :in dep-forms :when (resolve-dependency-spec nil spec) :collect :it))) (load-systems* deps) dep-forms)) (system (or (find-system-if-being-defined name) (if-let (registered (registered-system name)) (reset-system-class registered 'undefined-system :name name :source-file source-file) (register-system (make-instance 'undefined-system :name name :source-file source-file))))) (component-options (append (remove-plist-keys '(:defsystem-depends-on :class) options) ;; cache defsystem-depends-on in canonical form (when checked-defsystem-depends-on `(:defsystem-depends-on ,checked-defsystem-depends-on)))) (directory (determine-system-directory pathname))) ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: (set-asdf-cache-entry `(find-system ,name) (list system))) ;; 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) (reset-system-class system class))) (parse-component-form nil (list* :module name :pathname directory component-options)))) (defmacro defsystem (name &body options) `(apply 'register-system-definition ',name ',options))) asdf-3.3.4/plan.lisp000066400000000000000000000764561362155115300143050ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Plan (uiop/package:define-package :asdf/plan ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions ;; that used to live there before 3.2.0. (:recycle :asdf/plan :asdf/action :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation :asdf/action :asdf/lisp-action :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing) (:export #:plan #:plan-traversal #:sequential-plan #:*plan-class* #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p #:action-already-done-p #:+status-good+ #:+status-todo+ #:+status-void+ #:system-out-of-date #:action-up-to-date-p #:circular-dependency #:circular-dependency-actions #:needed-in-image-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies #:compute-action-stamp #:traverse-action #:record-dependency #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done #:required-components #:filtered-sequential-plan #:plan-component-type #:plan-keep-operation #:plan-keep-component)) (in-package :asdf/plan) ;;;; Generic plan traversal class (with-upgradability () (defclass plan () () (:documentation "Base class for a plan based on which ASDF can build a system")) (defclass plan-traversal (plan) (;; The forcing parameters for this plan. Also indicates whether the plan is performable, ;; in which case the forcing is the same as for the entire session. (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing)) (:documentation "Base class for plans that simply traverse dependencies")) ;; Sequential plans (the default) (defclass sequential-plan (plan-traversal) ((actions-r :initform nil :accessor plan-actions-r)) (:documentation "Simplest, default plan class, accumulating a sequence of actions")) (defgeneric plan-actions (plan) (:documentation "Extract from a plan a list of actions to perform in sequence")) (defmethod plan-actions ((plan list)) plan) (defmethod plan-actions ((plan sequential-plan)) (reverse (plan-actions-r plan))) (defgeneric record-dependency (plan operation component) (:documentation "Record an action as a dependency in the current plan")) ;; No need to record a dependency to build a full graph, just accumulate nodes in order. (defmethod record-dependency ((plan sequential-plan) (o operation) (c component)) (values))) (when-upgrading (:version "3.3.0") (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys))) ;;;; Planned action status (with-upgradability () (defclass action-status () ((bits :type fixnum :initarg :bits :reader status-bits :documentation "bitmap describing the status of the action.") (stamp :type (or integer boolean) :initarg :stamp :reader status-stamp :documentation "STAMP associated with the ACTION if it has been completed already in some previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.") (level :type fixnum :initarg :level :initform 0 :reader status-level :documentation "the highest (operate-level) at which the action was needed") (index :type (or integer null) :initarg :index :initform nil :reader status-index :documentation "INDEX associated with the ACTION in the current session, or NIL if no the status is considered outside of a specific plan.")) (:documentation "Status of an action in a plan")) ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded) ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load) ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled) ;; not-nil NIL T T => DONE 3 out-of-date done ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?) ;; NIL NIL NIL T => TODO 1 out-of-date planned ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned ;; ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an ;; action is up-to-date with ACTION-UP-TO-DATE-P. ;; ;; When calling TRAVERSE-ACTION, the +need-bit+ is set, ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP). ;; When PERFORMing an action, the +done-bit+ is set. ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be ;; done before the end of this level of operate. ;; ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value. ;; (defparameter +keep-bit+ 4) (defparameter +done-bit+ 2) (defparameter +need-bit+ 1) (defparameter +good-bits+ 7) (defparameter +todo-bits+ 1) (defparameter +void-bits+ 0) (defparameter +status-good+ (make-instance 'action-status :bits +good-bits+ :stamp t)) (defparameter +status-todo+ (make-instance 'action-status :bits +todo-bits+ :stamp nil)) (defparameter +status-void+ (make-instance 'action-status :bits +void-bits+ :stamp nil))) (with-upgradability () (defun make-action-status (&key bits stamp (level 0) index) (check-type bits (integer 0 7)) (check-type stamp (or integer boolean)) (check-type level (integer 0 #.most-positive-fixnum)) (check-type index (or integer null)) (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) () "Bad action-status :bits ~S :stamp ~S" bits stamp) (block nil (when (and (null index) (zerop level)) (case bits (#.+void-bits+ (return +status-void+)) (#.+todo-bits+ (return +status-todo+)) (#.+good-bits+ (when (eq stamp t) (return +status-good+))))) (make-instance 'action-status :bits bits :stamp stamp :level level :index index))) (defun status-keep-p (status) (plusp (logand (status-bits status) #.+keep-bit+))) (defun status-done-p (status) (plusp (logand (status-bits status) #.+done-bit+))) (defun status-need-p (status) (plusp (logand (status-bits status) #.+need-bit+))) (defun merge-action-status (status1 status2) ;; status-and "Return the earliest status later than both status1 and status2" (make-action-status :bits (logand (status-bits status1) (status-bits status2)) :stamp (latest-timestamp (status-stamp status1) (status-stamp status2)) :level (min (status-level status1) (status-level status2)) :index (or (status-index status1) (status-index status2)))) (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or "Return the same status but with the need bit set, for the given level" (if (and (status-need-p status) (>= (status-level status) level)) status (make-action-status :bits (logior (status-bits status) +need-bit+) :level (max level (status-level status)) :stamp (status-stamp status) :index (status-index status)))) (defmethod print-object ((status action-status) stream) (print-unreadable-object (status stream :type t) (with-slots (bits stamp level index) status (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index))))) (defgeneric action-status (plan operation component) (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN.")) (defgeneric (setf action-status) (new-status plan operation component) (:documentation "Sets the ACTION-STATUS associated to the action of OPERATION on COMPONENT in the PLAN")) (defmethod action-status ((plan null) (o operation) (c component)) (multiple-value-bind (stamp done-p) (component-operation-time o c) (if done-p (make-action-status :bits #.+keep-bit+ :stamp stamp) +status-void+))) (defmethod (setf action-status) (new-status (plan null) (o operation) (c component)) (let ((times (component-operation-times c))) (if (status-done-p new-status) (setf (gethash o times) (status-stamp new-status)) (remhash o times))) new-status) ;; Handle FORCED-NOT: it makes an action return its current timestamp as status (defmethod action-status ((p plan) (o operation) (c component)) ;; TODO: should we instead test something like: ;; (action-forced-not-p plan operation (primary-system component)) (or (gethash (make-action o c) (visited-actions *asdf-session*)) (when (action-forced-not-p (forcing p) o c) (let ((status (action-status nil o c))) (setf (gethash (make-action o c) (visited-actions *asdf-session*)) (make-action-status :bits +good-bits+ :stamp (or (and status (status-stamp status)) t) :index (incf (total-action-count *asdf-session*)))))))) (defmethod (setf action-status) (new-status (p plan) (o operation) (c component)) (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status)) (defmethod (setf action-status) :after (new-status (p sequential-plan) (o operation) (c component)) (unless (status-done-p new-status) (push (make-action o c) (plan-actions-r p))))) ;;;; 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) "Call FUN on all the valid dependencies of the given action in the given plan" (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 (action-valid-p dep-o dep-c) :do (funcall fun dep-o dep-c)))) (defun* (reduce-direct-dependencies) (operation component combinator seed) "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR for each dependency action on the dependency's operation and component and an accumulator initialized with 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) "Compute a list of the direct dependencies of the action within the plan" (reverse (reduce-direct-dependencies operation component #'acons nil))) ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp ;; shall also be parametrized by the plan, or by a second model object, ;; so they need not refer to the state of the filesystem, ;; and the stamps could be cryptographic checksums rather than timestamps. ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP. (define-condition dependency-not-done (warning) ((op :initarg :op) (component :initarg :component) (dep-op :initarg :dep-op) (dep-component :initarg :dep-component) (plan :initarg :plan :initform nil)) (:report (lambda (condition stream) (with-slots (op component dep-op dep-component plan) condition (format stream "Computing just-done stamp ~@[in plan ~S~] for action ~S, but dependency ~S wasn't done yet!" plan (action-path (make-action op component)) (action-path (make-action dep-op dep-component))))))) (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) ;; Given an action, figure out at what time in the past it has been done, ;; or if it has just been done, return the time that it has. ;; Returns two values: ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, ;; or NIL is either hasn't been done or is out of date. ;; (An ASDF extension could use a cryptographic digest instead.) ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done ;; in the current image, or NIL if it hasn't. ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp, ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, ;; i.e. that of the input-files. ;; If just-done is NIL, these values return are the notional fields of ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error). ;; If just-done is T, they are the notional fields of DONE status ;; (or, if something went wrong, TODO). (nest (block ()) (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date) (reduce-direct-dependencies o c #'(lambda (do dc status) ;; out-of-date dependency: don't bother looking further (let ((action-status (action-status plan do dc))) (cond ((and action-status (or (status-keep-p action-status) (and just-done (status-stamp action-status)))) (merge-action-status action-status status)) (just-done ;; It's OK to lose some ASDF action stamps during self-upgrade (unless (equal "asdf" (primary-system-name dc)) (warn 'dependency-not-done :plan plan :op o :component c :dep-op do :dep-component dc)) status) (t (return (values nil nil)))))) +status-good+)) (dep-stamp (status-stamp dep-status)))) (let* (;; collect timestamps from inputs, and exit early if any is missing (in-files (input-files o c)) (in-stamps (mapcar #'get-file-stamp in-files)) (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) (latest-in (timestamps-latest (cons dep-stamp in-stamps)))) (when (and missing-in (not just-done)) (return (values nil nil)))) (let* (;; collect timestamps from outputs, and exit early if any is missing (out-files (remove-if 'null (output-files o c))) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (earliest-out (timestamps-earliest out-stamps))) (when (and missing-out (not just-done)) (return (values nil nil)))) (let (;; Time stamps from the files at hand, and whether any is missing (all-present (not (or missing-in missing-out))) ;; Has any input changed since we last generated the files? ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files. ;; Any race condition is intrinsic to the limited timestamp resolution. (up-to-date-p (timestamp<= latest-in earliest-out)) ;; If everything is up to date, the latest of inputs and outputs is our stamp (done-stamp (timestamps-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)) ;; Shouldn't that be an error instead? (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)))) (let (;; There are three kinds of actions: (out-op (and out-files t)) ; those that create files on the filesystem ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing )) (if (or just-done ;; The done-stamp is valid: if we're just done, or (and all-present ;; if all filesystem effects are up-to-date up-to-date-p (operation-done-p o c) ;; and there's no invalidating reason. (not (action-forced-p (forcing (or plan *asdf-session*)) 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. ;; An image-effecting operation is done when (and (status-done-p dep-status) ;; all the dependencies were done, and (multiple-value-bind (perform-stamp perform-done-p) (component-operation-time o c) (and perform-done-p ;; the op was actually run, (equal perform-stamp done-stamp)))))) ;; with a matching stamp. ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet (values nil nil))))) ;;;; The four different actual traversals: ;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned ;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not ;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date ;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status (with-upgradability () ;; Compute the action status for a newly visited action. (defun compute-action-status (plan operation component need-p) (multiple-value-bind (stamp done-p) (compute-action-stamp plan operation component) (assert (or stamp (not done-p))) (make-action-status :bits (logior (if stamp #.+keep-bit+ 0) (if done-p #.+done-bit+ 0) (if need-p #.+need-bit+ 0)) :stamp stamp :level (operate-level) :index (incf (total-action-count *asdf-session*))))) ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, ;; visits the action defined by its OPERATION and COMPONENT arguments, ;; and all its transitive dependencies (unless already visited), ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P, ;; i.e. needs to be done in the current image vs merely have been done in a previous image. ;; ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its ;; transitive dependencies (that haven't been sufficiently visited so far). ;; It does not return any usable value. ;; ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action, ;; the below method would be insufficient, since it assumes a single image ;; to traverse each node at most twice; non-niip actions would be traversed only once, ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action. (defun traverse-action (plan operation component needed-in-image-p) (block nil (unless (action-valid-p operation component) (return)) ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, ;; instead of just a dependency order as in vanilla ASDF. ;; TODO: It is also needed to detect OPERATE-in-PERFORM. (record-dependency plan operation component) (while-visiting-action (operation component) ; maintain context, handle circularity. ;; needed-in-image distinguishes b/w things that must happen in the ;; current image and those things that simply need to have been done in a previous one. (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image ;; effective niip: meaningful for the action and required by the plan as traversed (eniip (and aniip needed-in-image-p)) ;; status: have we traversed that action previously, and if so what was its status? (status (action-status plan operation component)) (level (operate-level))) (when (and status (or (status-done-p status) ;; all done (and (status-need-p status) (<= level (status-level status))) ;; already visited (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip (return)) ; Already visited with sufficient need-in-image level! (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T (map-direct-dependencies ; recursively traverse dependencies operation component #'(lambda (o c) (traverse-action plan o c niip))) ;; AFTER dependencies have been traversed, compute action stamp (let* ((status (if status (mark-status-needed status level) (compute-action-status plan operation component t))) (out-of-date-p (not (status-keep-p status))) (to-perform-p (or out-of-date-p (and niip (not (status-done-p status)))))) (cond ; it needs be done if it's out of date or needed in image but absent ((and out-of-date-p (not niip)) ; if we need to do it, (visit-action t)) ; then we need to do it *in the (current) image*! (t (setf (action-status plan operation component) status) (when (status-done-p status) (setf (component-operation-time operation component) (status-stamp status))) (when to-perform-p ; if it needs to be added to the plan, count it (incf (planned-action-count *asdf-session*)) (unless aniip ; if it's output-producing, count it (incf (planned-output-action-count *asdf-session*))))))))) (visit-action eniip)))))) ; visit the action ;; NB: This is not an error, not a warning, but a normal expected condition, ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system, ;; *before* it tries to replace it with a new definition. (define-condition system-out-of-date (condition) ((name :initarg :name :reader component-name)) (:documentation "condition signaled when a system is detected as being out of date") (:report (lambda (c s) (format s "system ~A is out of date" (component-name c))))) (defun action-up-to-date-p (plan operation component) "Check whether an action was up-to-date at the beginning of the session. Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN." (block nil (unless (action-valid-p operation component) (return t)) (while-visiting-action (operation component) ; maintain context, handle circularity. ;; Do NOT record the dependency: it might be out of date. (let ((status (or (action-status plan operation component) (setf (action-status plan operation component) (let ((dependencies-up-to-date-p (handler-case (block nil (map-direct-dependencies operation component #'(lambda (o c) (unless (action-up-to-date-p plan o c) (return nil)))) t) (system-out-of-date () nil)))) (if dependencies-up-to-date-p (compute-action-status plan operation component nil) +status-void+)))))) (and (status-keep-p status) (status-stamp status))))))) ;;;; Incidental traversals ;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source ;;; files required by a bundling operation. (with-upgradability () (defclass filtered-sequential-plan (sequential-plan) ((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)) (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions.")) (defmethod initialize-instance :after ((plan filtered-sequential-plan) &key system other-systems) ;; Ignore force and force-not, rely on other-systems: ;; force traversal of what we're interested in, i.e. current system or also others; ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems. (setf (slot-value plan 'forcing) (make-forcing :system system :force :all :force-not (if other-systems nil t)))) (defmethod plan-actions ((plan filtered-sequential-plan)) (with-slots (keep-operation keep-component) plan (loop :for action :in (call-next-method) :as o = (action-operation action) :as c = (action-component action) :when (and (typep o keep-operation) (typep c keep-component)) :collect (make-action o c)))) (defun collect-action-dependencies (plan operation component) (when (action-valid-p operation component) (while-visiting-action (operation component) ; maintain context, handle circularity. (let ((action (make-action operation component))) (unless (nth-value 1 (gethash action (visited-actions *asdf-session*))) (setf (gethash action (visited-actions *asdf-session*)) nil) (when (and (typep component (plan-component-type plan)) (not (action-forced-not-p (forcing plan) operation component))) (map-direct-dependencies operation component #'(lambda (o c) (collect-action-dependencies plan o c))) (push action (plan-actions-r plan)))))))) (defgeneric collect-dependencies (operation component &key &allow-other-keys) (:documentation "Given an action, build a plan for all of its dependencies.")) (define-convenience-action-methods collect-dependencies (operation component &key)) (defmethod collect-dependencies ((operation operation) (component component) &rest keys &key &allow-other-keys) (let ((plan (apply 'make-instance 'filtered-sequential-plan :system (component-system component) keys))) (loop :for action :in (direct-dependencies operation component) :do (collect-action-dependencies plan (action-operation action) (action-component action))) (plan-actions plan))) (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and return a list of the components involved in building the desired action." (with-asdf-session (:override t) (remove-duplicates (mapcar 'action-component (apply 'collect-dependencies goal-operation system (remove-plist-key :goal-operation keys))) :from-end t)))) ;;;; High-level interface: make-plan, perform-plan (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 mark-as-done (plan-class operation component) (:documentation "Mark an action as done in a plan, after performing it.")) (define-convenience-action-methods mark-as-done (plan-class operation component)) (defgeneric perform-plan (plan &key) (:documentation "Actually perform a plan and build the requested actions")) (defparameter* *plan-class* 'sequential-plan "The default plan class to use when building with ASDF") (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) (with-asdf-session () (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys))) (traverse-action plan o c t) plan))) (defmethod perform-plan :around ((plan t) &key) (assert (performable-p (forcing plan)) () "plan not performable") (let ((*package* *package*) (*readtable* *readtable*)) (with-compilation-unit () ;; backward-compatibility. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. (defun action-already-done-p (plan operation component) (if-let (status (action-status plan operation component)) (status-done-p status))) (defmethod perform-plan ((plan t) &key) (loop :for action :in (plan-actions plan) :as o = (action-operation action) :as c = (action-component action) :do (unless (action-already-done-p plan o c) (perform-with-restarts o c) (mark-as-done plan o c)))) (defmethod mark-as-done ((plan plan) (o operation) (c component)) (let ((plan-status (action-status plan o c)) (perform-status (action-status nil o c))) (assert (and (status-stamp perform-status) (status-keep-p perform-status)) () "Just performed ~A but failed to mark it done" (action-description o c)) (setf (action-status plan o c) (make-action-status :bits (logior (status-bits plan-status) +done-bit+) :stamp (status-stamp perform-status) :level (status-level plan-status) :index (status-index plan-status)))))) asdf-3.3.4/session.lisp000066400000000000000000000233511362155115300150200ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Session (uiop/package:define-package :asdf/session (:recycle :asdf/session :asdf/cache :asdf/component :asdf/action :asdf/find-system :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:call-with-asdf-session #:with-asdf-session #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session #:session-cache #:forcing #:asdf-upgraded-p #:visited-actions #:visiting-action-set #:visiting-action-list #:total-action-count #:planned-action-count #:planned-output-action-count #:clear-configuration-and-retry #:retry #:operate-level ;; conditions #:system-definition-error ;; top level, moved here because this is the earliest place for it. #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error)) (in-package :asdf/session) (with-upgradability () ;; The session variable. ;; NIL when outside a session. (defvar *asdf-session* nil) (defparameter* *asdf-session-class* 'session "The default class for sessions") (defclass session () (;; The ASDF session cache is used to memoize some computations. ;; It is instrumental in achieving: ;; * Consistency in the view of the world relied on by ASDF within a given session. ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops ;; (a.k.a. stack overflows) and other erratic behavior. ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and ;; no expensive recomputations of transitive dependencies for input-files or output-files. ;; * Testability of ASDF with the ability to fake timestamps without actually touching files. (ancestor :initform nil :initarg :ancestor :reader session-ancestor :documentation "Top level session that this is part of") (session-cache :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache :documentation "Memoize expensive computations") (operate-level :initform 0 :initarg :operate-level :accessor session-operate-level :documentation "Number of nested calls to operate we're under (for toplevel session only)") ;; shouldn't the below be superseded by the session-wide caching of action-status ;; for (load-op "asdf") ? (asdf-upgraded-p :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.") (forcing :initform nil :initarg :forcing :accessor forcing :documentation "Forcing parameters for the session") ;; Table that to actions already visited while walking the dependencies associates status (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions) ;; Actions that depend on those being currently walked through, to detect circularities (visiting-action-set ;; as a set :initform (make-hash-table :test 'equal) :accessor visiting-action-set) (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list ;; Counts of total actions in plan (total-action-count :initform 0 :accessor total-action-count) ;; Count of actions that need to be performed (planned-action-count :initform 0 :accessor planned-action-count) ;; Count of actions that need to be performed that have a non-empty list of output-files. (planned-output-action-count :initform 0 :accessor planned-output-action-count)) (:documentation "An ASDF session with a cache to memoize some computations")) (defun toplevel-asdf-session () (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*))) (defun operate-level () (session-operate-level (toplevel-asdf-session))) (defun (setf operate-level) (new-level) (setf (session-operate-level (toplevel-asdf-session)) new-level)) (defun asdf-cache () (session-cache *asdf-session*)) ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session. ;; Return those values. (defun set-asdf-cache-entry (key value-list) (values-list (if *asdf-session* (setf (gethash key (asdf-cache)) value-list) value-list))) ;; Unset the session cache entry for KEY, when inside a session. (defun unset-asdf-cache-entry (key) (when *asdf-session* (remhash key (session-cache *asdf-session*)))) ;; Consult the session cache entry for KEY if present and in a session; ;; if not present, compute it by calling the THUNK, ;; and set the session cache entry accordingly, if in a session. ;; Return the values from the cache and/or the thunk computation. (defun consult-asdf-cache (key &optional thunk) (if *asdf-session* (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*)) (if foundp (values-list results) (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) (call-function thunk))) ;; Syntactic sugar for consult-asdf-cache (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () ,@body))) ;; Compute inside a ASDF session with a cache. ;; First, make sure an ASDF session is underway, by binding the session cache variable ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). ;; Second, if a new session was started, establish restarts for retrying the overall computation. ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache ;; entry isn't found, or just call the THUNK if no KEY was specified. (defun call-with-asdf-session (thunk &key override key override-cache override-forcing) (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) (if (and (not override) *asdf-session*) (funcall fun) (loop (restart-case (let ((*asdf-session* (apply 'make-instance *asdf-session-class* (when *asdf-session* `(:ancestor ,(toplevel-asdf-session) ,@(unless override-forcing `(:forcing ,(forcing *asdf-session*))) ,@(unless override-cache `(:session-cache ,(session-cache *asdf-session*)))))))) (return (funcall fun))) (retry () :report (lambda (s) (format s (compatfmt "~@")))) (clear-configuration-and-retry () :report (lambda (s) (format s (compatfmt "~@"))) (clrhash (session-cache *asdf-session*)) (clear-configuration))))))) ;; Syntactic sugar for call-with-asdf-session (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body) `(call-with-asdf-session #'(lambda () ,@body) :override ,override :key ,key :override-cache ,override-cache :override-forcing ,override-forcing)) ;;; Define specific accessor for file (date) stamp. ;; Normalize a namestring for use as a key in the session cache. (defun normalize-namestring (pathname) (let ((resolved (resolve-symlinks* (ensure-absolute-pathname (physicalize-pathname pathname) 'get-pathname-defaults)))) (with-pathname-defaults () (namestring resolved)))) ;; Compute the file stamp for a normalized namestring (defun compute-file-stamp (normalized-namestring) (with-pathname-defaults () (or (safe-file-write-date normalized-namestring) t))) ;; Override the time STAMP associated to a given FILE in the session cache. ;; If no STAMP is specified, recompute a new one from the filesystem. (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)))) ;; Get or compute a memoized stamp for given FILE from the session cache. (defun get-file-stamp (file) (when file (let ((namestring (normalize-namestring file))) (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) ;;; Conditions (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function ;; over print-object; this is always conditions::%print-condition for ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmucl (:report print-object)) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply 'format s (format-control c) (format-arguments c))))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments))) asdf-3.3.4/source-registry.lisp000066400000000000000000000433631362155115300165100ustar00rootroot00000000000000;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 (uiop/package:define-package :asdf/source-registry ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there (:recycle :asdf/source-registry :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry) (: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 #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files #:validate-source-registry-directive #:validate-source-registry-form #:validate-source-registry-file #:validate-source-registry-directory #:parse-source-registry-string #:wrapping-source-registry #:default-user-source-registry #:default-system-source-registry #:user-source-registry #:system-source-registry #:user-source-registry-directory #:system-source-registry-directory #:environment-source-registry #:process-source-registry #:inherit-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 "~@")))) ;; Default list of directories under which the source-registry tree search won't recurse (defvar *default-source-registry-exclusions* '(;;-- Using ack 1.2 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 often builds stuff under the debian directory... BAD. "debian")) ;; Actual list of directories under which the source-registry tree search won't recurse (defvar *source-registry-exclusions* *default-source-registry-exclusions*) ;; The state of the source-registry after search in configured locations (defvar *source-registry* nil "Either NIL (for uninitialized), or an equal hash-table, mapping system names to pathnames of .asd files") ;; Saving the user-provided parameter to the source-registry, if any, ;; so we can recompute the source-registry after code upgrade. (defvar *source-registry-parameter* nil) (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) (let ((asds (directory-asd-files directory))) (map () collect asds) asds)) (defvar *recurse-beyond-asds* t "Should :tree entries of the source-registry recurse in subdirectories after having found a .asd file? True by default.") ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache, ;; read its contents instead of further recursively querying the filesystem. (defun process-source-registry-cache (directory collect) (let ((cache (ignore-errors (safe-read-file-form (subpathname directory ".cl-source-registry.cache"))))) (when (and (listp cache) (eq :source-registry-cache (first cache))) (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s))) t))) (defun collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) (let ((visited (make-hash-table :test 'equalp))) (flet ((collectp (dir) (unless (and (not ignore-cache) (process-source-registry-cache dir collect)) (let ((asds (collect-asds-in-directory dir collect))) (or recurse-beyond-asds (not asds))))) (recursep (x) ; x will be a directory pathname (and (not (member (car (last (pathname-directory x))) exclude :test #'equal)) (flet ((pathname-key (x) (namestring (truename* x)))) (let ((visitedp (gethash (pathname-key x) visited))) (if visitedp nil (setf (gethash (pathname-key x) visited) t))))))) (collect-sub*directories directory #'collectp #'recursep (constantly nil))))) ;;; Validate the configuration forms (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)) ;;; Parse the configuration string (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 default-user-source-registry system-source-registry system-source-registry-directory default-system-source-registry) "List of default source registries" "3.1.0.102") (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf")) (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/")) (defun wrapping-source-registry () `(:source-registry #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) :inherit-configuration #+mkcl (:tree ,(translate-logical-pathname "SYS:")) #+cmucl (:tree #p"modules:") #+scl (:tree #p"file://modules/"))) (defun default-user-source-registry () `(:source-registry (:tree (:home "common-lisp/")) #+sbcl (:directory (:home ".sbcl/systems/")) (:directory ,(xdg-data-home "common-lisp/systems/")) (:tree ,(xdg-data-home "common-lisp/source/")) :inherit-configuration)) (defun default-system-source-registry () `(:source-registry ,@(loop :for dir :in (xdg-data-dirs "common-lisp/") :collect `(:directory (,dir "systems/")) :collect `(:tree (,dir "source/"))) :inherit-configuration)) (defun user-source-registry (&key (direction :input)) (xdg-config-pathname *source-registry-file* direction)) (defun system-source-registry (&key (direction :input)) (find-preferred-file (system-config-pathnames *source-registry-file*) :direction direction)) (defun user-source-registry-directory (&key (direction :input)) (xdg-config-pathname *source-registry-directory* direction)) (defun system-source-registry-directory (&key (direction :input)) (find-preferred-file (system-config-pathnames *source-registry-directory*) :direction direction)) (defun environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) ;;; Process the source-registry configuration (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-user-source-registry default-system-source-registry) :register register)) ((:inherit-configuration) (inherit-source-registry inherit :register register)) ((:ignore-inherited-configuration) nil))) nil) (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) (defmethod process-source-registry ((pathname pathname) &key inherit register) (cond ((directory-pathname-p pathname) (let ((*here-directory* (resolve-symlinks* pathname))) (process-source-registry (validate-source-registry-directory pathname) :inherit inherit :register register))) ((probe-file* pathname :truename *resolve-symlinks*) (let ((*here-directory* (pathname-directory-pathname pathname))) (process-source-registry (validate-source-registry-file pathname) :inherit inherit :register register))) (t (inherit-source-registry inherit :register register)))) (defmethod process-source-registry ((string string) &key inherit register) (process-source-registry (parse-source-registry-string string) :inherit inherit :register register)) (defmethod process-source-registry ((x null) &key inherit register) (inherit-source-registry inherit :register register)) (defmethod process-source-registry ((form cons) &key inherit register) (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) ;; Flatten the user-provided configuration into an ordered list of directories and trees (defun flatten-source-registry (&optional (parameter *source-registry-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)) ;; MAYBE: move this utility function to uiop/pathname and export it? (defun pathname-directory-depth (p) (length (normalize-pathname-directory-component (pathname-directory p)))) (defun preferred-source-path-p (x y) "Return T iff X is to be preferred over Y as a source path" (let ((lx (pathname-directory-depth x)) (ly (pathname-directory-depth y))) (or (< lx ly) (and (= lx ly) (string< (namestring x) (namestring y)))))) ;; Will read the configuration and initialize all internal variables. (defun compute-source-registry (&optional (parameter *source-registry-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))) (unless (gethash name registry) ; already shadowed by something else (if-let (old (gethash name h)) ;; If the name appears multiple times, ;; prefer the one with the shallowest directory, ;; or if they have same depth, compare unix-namestring with string< (multiple-value-bind (better worse) (if (preferred-source-path-p asd old) (progn (setf (gethash name h) asd) (values asd old)) (values old asd)) (when *verbose-out* (warn (compatfmt "~@") directory recurse name better worse))) (setf (gethash name h) asd)))))) (maphash #'(lambda (k v) (setf (gethash k registry) v)) h)))) (values)) (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*)))) asdf-3.3.4/system-registry.lisp000066400000000000000000000360321362155115300165270ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Finding systems (uiop/package:define-package :asdf/system-registry (:recycle :asdf/system-registry :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/system) (:export #:remove-entry-from-registry #:coerce-entry-to-directory #:registered-system #:register-system #:registered-systems* #:registered-systems #:clear-system #:map-systems #:*system-definition-search-functions* #:search-for-system-definition #:*central-registry* #:probe-asd #:sysdef-central-registry-search #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* #:*registered-systems* #:clear-registered-systems ;; defined in source-registry, but specially mentioned here: #:sysdef-source-registry-search)) (in-package :asdf/system-registry) (with-upgradability () ;;; Registry of Defined Systems (defvar *registered-systems* (make-hash-table :test 'equal) "This is a hash table whose keys are strings -- the names of systems -- and whose values are systems. A system is referred to as \"registered\" if it is present in this table.") (defun registered-system (name) "Return a system of given NAME that was registered already, if such a system exists. NAME is a system designator, to be normalized by COERCE-NAME. The value returned is a system object, or NIL if not found." (gethash (coerce-name name) *registered-systems*)) (defun registered-systems* () "Return a list containing every registered system (as a system object)." (loop :for registered :being :the :hash-values :of *registered-systems* :collect registered)) (defun registered-systems () "Return a list of the names of every registered system." (mapcar 'coerce-name (registered-systems*))) (defun register-system (system) "Given a SYSTEM object, register it." (check-type system system) (let ((name (component-name system))) (check-type name string) (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) (setf (gethash name *registered-systems*) system))) (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 *registered-systems* :do (funcall fn registered))) ;;; Preloaded systems: in the image even if you can't find source files backing them. (defvar *preloaded-systems* (make-hash-table :test 'equal) "Registration table for preloaded systems.") (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system (defun make-preloaded-system (name keys) "Make a preloaded system of given NAME with build information from KEYS" (let ((system (apply 'make-instance (getf keys :class 'system) :name name :source-file (getf keys :source-file) (remove-plist-keys '(:class :name :source-file) keys)))) (mark-component-preloaded system) system)) (defun sysdef-preloaded-system-search (requested) "If REQUESTED names a system registered as preloaded, return a new system with its registration information." (let ((name (coerce-name requested))) (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) (when foundp (make-preloaded-system name keys))))) (defun ensure-preloaded-system-registered (name) "If there isn't a registered _defined_ system of given NAME, and a there is a registered _preloaded_ system of given NAME, then define and register said preloaded system." (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) (register-system system))) (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) "Register a system as being preloaded. If the system has not been loaded from the filesystem yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). If VERSION is the default T, and a system was already loaded, then its version will be preserved." (let ((name (coerce-name system-name))) (when (eql version t) (if-let (system (registered-system name)) (setf (getf keys :version) (component-version system)))) (setf (gethash name *preloaded-systems*) keys) (ensure-preloaded-system-registered system-name))) ;;; Immutable systems: in the image and can't be reloaded from source. (defvar *immutable-systems* nil "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, i.e. already loaded in memory and not to be refreshed from the filesystem. They will be treated specially by find-system, and passed as :force-not argument to make-plan. For instance, to can deliver an image with many systems precompiled, that *will not* check the filesystem for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic downgrade, before you dump an image, you may use: (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) Note that direct access to this variable from outside ASDF is not supported. Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and contact maintainers if you need a stable API to do more than that.") (defun sysdef-immutable-system-search (requested) (let ((name (coerce-name requested))) (when (and *immutable-systems* (gethash name *immutable-systems*)) (or (registered-system requested) (error 'formatted-system-definition-error :format-control "Requested system ~A registered as an immutable-system, ~ but not even registered as defined" :format-arguments (list name)))))) (defun register-immutable-system (system-name &rest keys) "Register SYSTEM-NAME as preloaded and immutable. It will automatically be considered as passed to FORCE-NOT in a plan." (let ((system-name (coerce-name system-name))) (apply 'register-preloaded-system system-name keys) (unless *immutable-systems* (setf *immutable-systems* (list-to-hash-set nil))) (setf (gethash system-name *immutable-systems*) t))) ;;; Making systems undefined. (defun clear-system (system) "Clear the entry for a SYSTEM in the database of systems previously defined. However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), then a new system with the same name will be defined and registered in its place from which build details will have been cleared. Note that this does NOT in any way cause any of the code of the system to be unloaded. Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." ;; 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. (let ((name (coerce-name system))) (remhash name *registered-systems*) (unset-asdf-cache-entry `(find-system ,name)) (not (ensure-preloaded-system-registered name)))) (defun clear-registered-systems () "Clear all currently registered defined systems. Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." (map () 'clear-system (registered-systems))) ;;; Searching for system definitions ;; For the sake of keeping things reasonably neat, we adopt a convention that ;; only symbols are to be pushed to this list (rather than e.g. function objects), ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- (defvar *system-definition-search-functions* '() "A list that controls the ways that ASDF looks for system definitions. It contains symbols to be funcalled in order, with a requested system name as argument, until one returns a non-NIL result (if any), which must then be a fully initialized system object with that name.") ;; Initialize and/or upgrade the *system-definition-search-functions* ;; so it doesn't contain obsolete symbols, and does contain the current ones. (defun cleanup-system-definition-search-functions () (setf *system-definition-search-functions* (append ;; Remove known-incompatible sysdef functions from old versions of asdf. ;; Order matters, so we can't just use set-difference. (let ((obsolete '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) (remove-if #'(lambda (x) (member x obsolete)) *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 removes these symmbols ;; 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) ;; This (private) function does the search for a system definition using *s-d-s-f*; ;; it is to be called by locate-system. (defun search-for-system-definition (system) ;; Search for valid definitions of the system available in the current session. ;; Previous definitions as registered in *registered-systems* MUST NOT be considered; ;; they will be reconciled by locate-system then find-system. ;; There are two special treatments: first, specially search for objects being defined ;; in the current session, to avoid definition races between several files; ;; second, specially search for immutable systems, so they cannot be redefined. ;; Finally, use the search functions specified in *system-definition-search-functions*. (let ((name (coerce-name system))) (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) (try 'find-system-if-being-defined) (try 'sysdef-immutable-system-search) (map () #'try *system-definition-search-functions*)))) ;;; The legacy way of finding a system: the *central-registry* ;; This variable contains a list of directories to be lazily searched for the requested asd ;; by sysdef-central-registry-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 variable is for backward compatibility. Going forward, we recommend new users should be using the source-registry.") ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. ;; Return the truename of that file if it is found and TRUENAME is true. ;; Return NIL if the file is not found. ;; On Windows, follow shortcuts to .asd files. (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(!) (os-cond ((os-windows-p) (when (physical-pathname-p defaults) (let ((shortcut (make-pathname :defaults defaults :case :local :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) ;; Function to push onto *s-d-s-f* to use the *central-registry* (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))))))))))) asdf-3.3.4/system.lisp000066400000000000000000000315421362155115300146620ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Systems (uiop/package:define-package :asdf/system (:recycle :asdf :asdf/system :asdf/find-system) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component) (:export #:system #:proto-system #:undefined-system #:reset-system-class #:system-source-file #:system-source-directory #:system-relative-pathname #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license #:system-version #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on #:system-depends-on #:system-weakly-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 #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system (in-package :asdf/system) (with-upgradability () ;; The method is actually defined in asdf/find-system, ;; but we declare the function here to avoid a forward reference. (defgeneric find-system (system &optional error-p) (:documentation "Given a system designator, find the actual corresponding system object. If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL. A system designator is usually a string (conventionally all lowercase) or a symbol, designating the same system as its downcased name; it can also be a system object (designating itself).")) (defgeneric system-source-file (system) (:documentation "Return the source file in which system is defined.")) ;; This is bad design, but was the easiest kluge I found to let the user specify that ;; some special actions create outputs at locations controled by the user that are not affected ;; by the usual output-translations. ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert ;; *there* the ability of specifying special output paths, not in the system definition. (defgeneric component-build-pathname (component) (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the output pathname for the action using the COMPONENT-BUILD-OPERATION. NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead? (defgeneric component-entry-point (component) (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call (with no argument) when running an image dumped from the COMPONENT. NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) (defmethod component-entry-point ((c component)) 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) ;; These two slots contains the *inferred* dependencies of define-op, ;; from loading the .asd file, as list and as set. (definition-dependency-list :initform nil :accessor definition-dependency-list) (definition-dependency-set :initform (list-to-hash-set nil) :accessor definition-dependency-set)) (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when a SYSTEM is redefined and its class is modified.")) (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 :writer (setf system-description)) (long-description :writer (setf system-long-description)) (author :writer (setf system-author) :initarg :author :initform nil) (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil) (licence :writer (setf system-licence) :initarg :licence :writer (setf system-license) :initarg :license :initform nil) (homepage :writer (setf system-homepage) :initarg :homepage :initform nil) (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil) (mailto :writer (setf system-mailto) :initarg :mailto :initform nil) (long-name :writer (setf 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 :writer (setf 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) ;; This slot contains the *declared* defsystem-depends-on dependencies (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on :initform nil) ;; these two are specially set in parse-component-form, so have no :INITARGs. (depends-on :reader system-depends-on :initform nil) (weakly-depends-on :reader system-weakly-depends-on :initform nil)) (:documentation "SYSTEM is the base class for top-level components that users may request ASDF to build.")) (defclass undefined-system (system) () (:documentation "System that was not defined yet.")) (defun reset-system-class (system new-class &rest keys &key &allow-other-keys) "Erase any data from a SYSTEM except its basic identity, then reinitialize it based on supplied KEYS." (change-class (change-class system 'proto-system) new-class) (apply 'reinitialize-instance system keys))) ;;; Canonicalizing system names (with-upgradability () (defun coerce-name (name) "Given a designator for a component NAME, return the name as a string. The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), a SYMBOL (designing its name, downcased), or a STRING (designing itself)." (typecase name (component (component-name name)) (symbol (string-downcase name)) (string name) (t (sysdef-error (compatfmt "~@") name)))) (defun primary-system-name (system-designator) "Given a system designator NAME, return the name of the corresponding primary system, after which the .asd file in which it is defined is named. If given a string or symbol (to downcase), do it syntactically by stripping anything from the first slash on. If given a component, do it semantically by extracting the system-primary-system-name of its system." (etypecase system-designator (string (if-let (p (position #\/ system-designator)) (subseq system-designator 0 p) system-designator)) (symbol (primary-system-name (coerce-name system-designator))) (component (let* ((system (component-system system-designator)) (source-file (physicalize-pathname (system-source-file system)))) (and source-file (equal (pathname-type source-file) "asd") (pathname-name source-file)))))) (defun primary-system-p (system) "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL. If given a string, do it syntactically and return true if the name does not contain a slash. If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T). If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name is the same as its component-name." (etypecase system (string (not (find #\/ system))) (symbol (primary-system-p (coerce-name system))) (component (and (typep system 'system) (equal (component-name system) (primary-system-name system)))))) (defun coerce-filename (name) "Coerce a system designator NAME into a string suitable as a filename component. The (current) transformation is to replace characters /:\\ each by --, the former being forbidden in a filename component. NB: The onus is unhappily on the user to avoid clashes." (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))) ;;; System virtual slot readers, recursing to the primary system if needed. (with-upgradability () (defvar *system-virtual-slots* '(long-name description long-description author maintainer mailto homepage source-control licence version bug-tracker) "The list of system virtual slot names.") (defun system-virtual-slot-value (system slot-name) "Return SYSTEM's virtual SLOT-NAME value. If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in the primary one." (or (slot-value system slot-name) (unless (primary-system-p system) (slot-value (find-system (primary-system-name system)) slot-name)))) (defmacro define-system-virtual-slot-reader (slot-name) `(defun* ,(intern (concatenate 'string (string :system-) (string slot-name))) (system) (system-virtual-slot-value system ',slot-name))) (defmacro define-system-virtual-slot-readers () `(progn ,@(mapcar (lambda (slot-name) `(define-system-virtual-slot-reader ,slot-name)) *system-virtual-slots*))) (define-system-virtual-slot-readers) (defun system-license (system) (system-virtual-slot-value system 'licence))) ;;;; Pathnames (with-upgradability () ;; Resolve a system designator to a system before extracting its system-source-file (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) (when system-name (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) "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, return the absolute pathname of a corresponding file under that system's source code pathname." (subpathname (system-source-directory system) name :type type)) (defmethod component-pathname ((system system)) "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, return the absolute pathname of a corresponding file under that system's source code pathname." (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)) ;; The default method of component-relative-pathname for a system: ;; if a pathname was specified in the .asd file, it must be relative to the .asd file ;; (actually, to its truename* if *resolve-symlinks* it true, the default). ;; The method will return an *absolute* pathname, once again showing that the historical name ;; component-relative-pathname is misleading and should have been component-specified-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))) ;; A system has no parent; if some method wants to make a path "relative to its parent", ;; it will instead be relative to the system itself. (defmethod component-parent-pathname ((system system)) (system-source-directory system)) ;; Most components don't have a specified component-build-pathname, and therefore ;; no magic redirection of their output that disregards the output-translations. (defmethod component-build-pathname ((c component)) nil)) asdf-3.3.4/test/000077500000000000000000000000001362155115300134175ustar00rootroot00000000000000asdf-3.3.4/test/always-error.lisp000066400000000000000000000002261362155115300167370ustar00rootroot00000000000000(in-package :asdf-test) (defparameter *always-error-was-read-p* t) (eval-when (:compile-toplevel :load-toplevel :execute) (error "ALWAYS ERROR")) asdf-3.3.4/test/asdf-pathname-test.script000066400000000000000000000654351362155115300203470ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) (eval-when (:compile-toplevel :load-toplevel :execute) #-(or xcl gcl) (push :asdf-test-logical-pathname *features*) #+xcl (push :buggy-untyped-file *features*)) ;;(setf *unspecific-pathname-type* nil) ;;; 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))) (declare (ignorable root bin-type)) #+asdf-test-logical-pathname (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 :wild))) ("**;*.*" ,(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 nil :version nil)))))) (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) (all-tests :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 (logical-pathname-p system-pathname) (logical-pathname-p module-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 (logical-pathname-p 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 all-tests) test-status (incf directory-count) (let ((success (and (probe-file* (component-pathname module)) t))) (unless success (incf directory-failures)) (push (list success (type-of module) (component-find-path module) (translate-if-needed (component-pathname module)) configuration (list (if-let (parent (component-parent module)) (component-pathname parent)))) all-tests) success))) (defparameter *backtraces* 0) (defparameter *max-backtraces* 10) (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 all-tests) test-status (let ((success (block :foo ;; XCL 0.0.0.291 is confused if using block nil (handler-bind ((error #'(lambda (c) (incf *backtraces*) (dolist (o (list *trace-output* *standard-output*)) (when (<= *backtraces* *max-backtraces*) (print-condition-backtrace c :stream o))) (return-from :foo nil)))) (assert (probe-file* (component-pathname file)) () "Can't find pathname ~S for component ~S" (component-pathname file) file) (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) (assert stream) (println start-time stream))) t))) (incf file-count) (unless success (incf file-failures)) (push (list success (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)))) all-tests)))) (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) 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) (dolist (o (list *trace-output* result-stream)) (format o "~&error during sysdef:~% ~S~%" system-definition) (print-condition-backtrace c :stream o)) (return-from test-pathname-configuration test-status)))) (unless (and (or (logical-pathname-p system-pathname) (logical-pathname-p module-pathname)) (and (stringp file-pathname) (find #\. file-pathname))) (incf system-count) (with-asdf-session (: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))) (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 all-tests) 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)) #+asdf-test-logical-pathname (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) (failures (+ system-failures directory-failures file-failures)) (*print-length* nil)) (format result-stream "~&~%~% pathname failures [~s]:" failures) (dolist (tst (and (plusp failures) all-tests)) (destructuring-bind (success type name intended-pathname configuration parent-pathnames) tst (format result-stream "~&~%~:[FAILURE~;SUCCESS~] ~:[ ~;!~]~a~24T~s~% ~:[missing: ~;found: ~]~24T~s~% configuration:~24T~s~% parent pathnames:~24T~s" success (let ((homogeneousp (let ((f (first configuration))) (assert f) (let ((logicalp (logical-pathname-p f))) (loop for p in (rest configuration) always (or (null p) (eq logicalp (logical-pathname-p p)))))))) (when (and (not success) homogeneousp) (incf homogeneous-failures)) homogeneousp) type name success 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*) (zerop 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/") #+asdf-test-logical-pathname ,@`(,(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/") #+asdf-test-logical-pathname ,@`(,(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 #-buggy-untyped-file ,(parse-unix-namestring "./untyped-file") #-buggy-untyped-file ,(parse-unix-namestring "file") ,(parse-unix-namestring "./file.lisp") ,(parse-unix-namestring "typed-file.type") #-buggy-untyped-file ,(parse-unix-namestring "module2/untyped-file") ,(parse-unix-namestring "module2/file.lisp") ,(parse-unix-namestring "module2/module3/file.lisp") #-buggy-untyped-file ,(subpathname root "asdf-src/system1/module1/untyped-file") ,(subpathname root "asdf-src/system1/module1/file.lisp") #-buggy-untyped-file ,(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") #+asdf-test-logical-pathname ,@`(,(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" #-buggy-untyped-file #-buggy-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 #-buggy-untyped-file #-buggy-untyped-file 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 #-buggy-untyped-file #-buggy-untyped-file 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)) (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) (setup-asdftest-logical-host :root root) #+asdf-test-logical-pathname (assert-pathname-equal (make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name nil :type nil) (parse-namestring "ASDFTEST:system2;module4;")) (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) ;;(format t "Created test file ~S~%" file) (println ":dummy-content" 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))))) #+asdf-test-logical-pathname (when delete-host (setf (logical-pathname-translations "ASDFTEST") nil)) (clear-system "test-system"))) (defun test-pathname-parsing () #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl clasp) (DBG "Can't test pathname parsing: this lisp lacks SETENV support.") #+(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl clasp) (let ((old-config (uiop:getenvp "XDG_CONFIG_DIRS")) (old-home-config (uiop:getenvp "XDG_CONFIG_HOME"))) (unwind-protect (progn (setf (uiop:getenv "XDG_CONFIG_DIRS") "/foo:prismatic") (multiple-value-bind (ret err) (ignore-errors (uiop:xdg-config-pathnames)) (assert (and (not ret) err))) (setf (uiop:getenv "XDG_CONFIG_DIRS") "/foo:") (setf (uiop:getenv "XDG_CONFIG_HOME") "") (multiple-value-bind (ret err) (ignore-errors (uiop:xdg-config-pathnames)) (assert (not err)) (assert (= (length ret) 2)))) (when old-config (setf (uiop:getenv "XDG_CONFIG_DIRS") old-config)) (when old-home-config (setf (uiop:getenv "XDG_CONFIG_HOME") old-home-config))))) (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)) ;; we're testing with unix or some emulation, are we not? (assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname))) #-os-windows (progn (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/")) (assert-pathname-equal (resolve-location '("/foo" "bar" :**/ "baz" :*.*.*) :ensure-directory nil :wilden t) (merge-pathnames* *wild-file* #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)))) #-gcl ;; expected-failure: GCL crashes badly (assert (handler-bind ((bad-system-name #'(lambda (c) (muffle-warning c)))) (test-component-pathnames :delete-host t :support-string-pathnames nil))) #+os-unix (test-pathname-parsing) ;;; test for CMUCL issue with search lists versus pathnames #+os-unix (progn (DBG "Checking CMUCL user-homedir-pathname issue.") (assert-pathname-equal (uiop/common-lisp:user-homedir-pathname) (getenv-pathname "HOME" :want-directory t))) asdf-3.3.4/test/bad-shell-command000077500000000000000000000000231362155115300166070ustar00rootroot00000000000000#! /bin/sh exit 2 asdf-3.3.4/test/cat-to-stderr.sh000077500000000000000000000000301362155115300164370ustar00rootroot00000000000000#!/bin/sh cat "$@" >&2 asdf-3.3.4/test/defmacro-foo.lisp000066400000000000000000000001111362155115300166420ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defmacro foo (x) `(1+ ,x)) asdf-3.3.4/test/defsetf-foo.lisp000066400000000000000000000002441362155115300165110ustar00rootroot00000000000000(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) asdf-3.3.4/test/defsystem-depends-on/000077500000000000000000000000001362155115300174545ustar00rootroot00000000000000asdf-3.3.4/test/defsystem-depends-on/defsystem-dependency.asd000066400000000000000000000002561362155115300242670ustar00rootroot00000000000000(defsystem "defsystem-dependency" :depends-on ("overlapping-dependency") :components ((:file "defsystem-dependency")) :in-order-to ((test-op (test-op "test-system")))) asdf-3.3.4/test/defsystem-depends-on/defsystem-dependency.lisp000066400000000000000000000016131362155115300244650ustar00rootroot00000000000000(in-package :asdf-test) (defvar *dd* 0) (incf *dd*) (format t "Loaded defsystem-dependency.lisp ~d time~(~:*~p~)~%" *dd*) (setf (find-class 'asdf::my-cl-source-file) (find-class 'cl-source-file)) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cdd* 0)) (eval-when (:compile-toplevel :execute) (incf *cdd*)) ;; Modify the current *readtable* -- it's very rude, but it's still supported, ;; and some bugs in previous versions of ASDF (e.g. 3.3.0, fixed in 3.3.0.1) ;; failed to restore syntax tables inside with-standard-io-syntax, causing it to fail. (defun sharp-b (stream chr arg) (declare (ignore chr arg)) (let ((arg (read stream nil nil t))) (if *read-suppress* nil (if (stringp arg) (map '(vector (unsigned-byte 8)) 'char-code arg) (error "#b takes a string argument: ~s" arg))))) (set-dispatch-macro-character #\# #\b #'sharp-b) asdf-3.3.4/test/defsystem-depends-on/intermediate-dependency.asd000066400000000000000000000002261362155115300247330ustar00rootroot00000000000000(defsystem "intermediate-dependency" :defsystem-depends-on ("defsystem-dependency") :components ((:my-cl-source-file "intermediate-dependency"))) asdf-3.3.4/test/defsystem-depends-on/intermediate-dependency.lisp000066400000000000000000000000641362155115300251330ustar00rootroot00000000000000(in-package :asdf-test) (defvar *id* 0) (incf *id*) asdf-3.3.4/test/defsystem-depends-on/main-system.asd000066400000000000000000000002031362155115300224060ustar00rootroot00000000000000(defsystem "main-system" :depends-on ("overlapping-dependency" "intermediate-dependency") :components ((:file "main-system"))) asdf-3.3.4/test/defsystem-depends-on/main-system.lisp000066400000000000000000000000641362155115300226130ustar00rootroot00000000000000(in-package :asdf-test) (defvar *ms* 0) (incf *ms*) asdf-3.3.4/test/defsystem-depends-on/overlapping-dependency.asd000066400000000000000000000003001362155115300246000ustar00rootroot00000000000000(in-package :asdf-test) (defvar *od* 0) (defsystem "overlapping-dependency" ;;:perform (load-op (o c) (incf *od*)) ;; Now done in the file. :components ((:file "overlapping-dependency"))) asdf-3.3.4/test/defsystem-depends-on/overlapping-dependency.lisp000066400000000000000000000002711362155115300250070ustar00rootroot00000000000000(in-package :asdf-test) (defvar *od* 0) (incf *od*) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *cod* 0)) (eval-when (:compile-toplevel :execute) (incf *cod*)) asdf-3.3.4/test/defsystem-depends-on/test-system.asd000066400000000000000000000002741362155115300224510ustar00rootroot00000000000000(defsystem "test-system" :defsystem-depends-on ("defsystem-dependency") :components ((:my-cl-source-file "test-system")) :perform (test-op (o c) (symbol-call :asdf-test :run-test))) asdf-3.3.4/test/defsystem-depends-on/test-system.lisp000066400000000000000000000001411362155115300226420ustar00rootroot00000000000000(in-package :asdf-test) (setf *dd* 10) (defun run-test () (format t "Running tests...") t) asdf-3.3.4/test/defun-foo.lisp000066400000000000000000000001041362155115300161650ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defun foo (x) (1+ x)) asdf-3.3.4/test/defun-setf-foo.lisp000066400000000000000000000002201362155115300171230ustar00rootroot00000000000000(in-package :asdf-test/deferred-warnings) (defvar *foo* (make-hash-table :test 'equal)) (defun (setf foo) (v x) (setf (gethash x *foo*) v)) asdf-3.3.4/test/deliver-bundle.asd000066400000000000000000000006741362155115300170200ustar00rootroot00000000000000;;;--------------------------------------------------------------------------- ;;; This system is to be used to test the generation of ASD files by ;;; DELIVER-ASD-OP. See test-bundle-asd.script. ;;;--------------------------------------------------------------------------- (defsystem :deliver-bundle :defsystem-depends-on ("file3-only") :depends-on ("test1") ; brings in "file1" and "file2" :components ((:file "file4"))) asdf-3.3.4/test/dll-test.lisp000066400000000000000000000005601362155115300160410ustar00rootroot00000000000000(defpackage :test-asdf/dll-test (:use)) ;; dummy, for package-inferred-system dependencies. #+ecl (ffi:clines " extern int sample_function(); int sample_function() { return 42; } ") #+clasp (leave-test "Doesn't work on CLASP yet" 0) #+mkcl (ffi:clines " extern MKCL_DLLEXPORT int sample_function(void); int sample_function(void) { return 42; } ") asdf-3.3.4/test/dll-user.lisp000066400000000000000000000005271362155115300160430ustar00rootroot00000000000000(defpackage :test-asdf/dll-user (:use)) ;; dummy, for package-inferred-system dependencies. (in-package :asdf-test) #+(and mkcl os-windows) (ffi:clines "extern __declspec(dllimport) int sample_function(void);") #-(and mkcl os-windows) (ffi:clines "extern int sample_function(void);") (ffi:def-function "sample_function" () :returning :int) asdf-3.3.4/test/duplicate-components-test.script000066400000000000000000000011451362155115300217600ustar00rootroot00000000000000;;; -*- Lisp -*- (handler-case (asdf:find-system "duplicate-components") (asdf:duplicate-names (x) (declare (ignore x)) t) (asdf:load-system-definition-error (x) (or (and (asdf/find-system::error-condition x) (typep (asdf/find-system::error-condition x) 'asdf:duplicate-names)) (progn (DBG :err (asdf/find-system::error-condition x)) (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))) asdf-3.3.4/test/duplicate-components.asd000066400000000000000000000001221362155115300202400ustar00rootroot00000000000000(defsystem duplicate-components :components ((:file "foo") (:file "foo"))) asdf-3.3.4/test/ecl-make-image.script000066400000000000000000000003411362155115300174010ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG "Test ld-flags in make-image. Should load from ecl-make-image/") #+(and ecl (not ecl-bytecmp) (not os-macosx)) (progn (chdir (subpathname *test-directory* "ecl-make-image/")) (load "readme.lisp")) asdf-3.3.4/test/ecl-make-image/000077500000000000000000000000001362155115300161555ustar00rootroot00000000000000asdf-3.3.4/test/ecl-make-image/hello.lisp000066400000000000000000000003111362155115300201440ustar00rootroot00000000000000(in-package #:cl-user) (ffi::clines "extern const char *hello_string;") (ffi::def-foreign-var ("hello_string" +hello-string+) (* :char) nil) (princ (ffi:convert-from-foreign-string +hello-string+)) asdf-3.3.4/test/ecl-make-image/hello_aux.c000066400000000000000000000000531362155115300202770ustar00rootroot00000000000000const char *hello_string = "Hello world!"; asdf-3.3.4/test/ecl-make-image/hellow.asd000066400000000000000000000006661362155115300201500ustar00rootroot00000000000000(defsystem "hellow" :components ((:file "hello")) :class program-system :build-operation program-op :build-pathname "hellow" :prologue-code "printf(\"Good morning sunshine!\\n\");fflush(stdout);" :epilogue-code (progn (format t "~%Good bye sunshine.~%") (ext:quit 0)) :no-uiop t :extra-build-args (:ld-flags #.(list (namestring (compile-file-pathname "hello_aux.c" :type :object))))) asdf-3.3.4/test/ecl-make-image/readme.lisp000066400000000000000000000053641362155115300203130ustar00rootroot00000000000000;;; ;;; DESCRIPTION: ;;; ;;; This file uses a "Hellow world!" string which is in an another C ;;; file called hello_aux.c. Both hello.lisp and hello_aux.c are ;;; compiled and linked into either ;;; ;;; 1) a FASL file (see build_fasl.lisp) ;;; 2) a shared library (see build_dll.lisp) ;;; 3) or a standalone executable file. (build_exe.lisp) ;;; ;;; USE: ;;; ;;; Launch a copy of ECL and load this file in it ;;; ;;; (load "readme.lisp") ;;; (require 'asdf) (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; BUILDING hello_aux.o FILE ;;; ") ;;; ;;; * We compile hello.lisp and hello_aux.c separately. ;;; ;; (compile-file "hello.lisp" :system-p t) (c::compiler-cc "hello_aux.c" (compile-file-pathname "hello_aux.c" :type :object)) (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; BUILDING A STANDALONE EXECUTABLE ;;; ") ;; ;; * Combine files in a standalone executable. We reuse the files ;; from the previous example ;; (defconstant +standalone-exe+ (compile-file-pathname "hellow" :type :program)) (push (make-pathname :name nil :type nil :version nil :defaults *load-truename*) asdf:*central-registry*) ;; Create hellow using program-op (delete-file-if-exists +standalone-exe+) (asdf:make "hellow") ;; ;; * Test the program ;; (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; TESTING A STANDALONE EXECUTABLE. Also test :no-uiop t ;;; ") (assert-equal (uiop:run-program (format nil "./~A" +standalone-exe+) :output :lines) '("Good morning sunshine!" "Hello world!" "Good bye sunshine.")) (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; AGAIN USING MAKE-BUILD. Also test uiop. ;;; ") ;;; Now create an executable using the legacy make-build interface (delete-file +standalone-exe+) (asdf:make-build :hellow :type :program :move-here "./" :prologue-code "printf(\"In the beginning, there was nothing.\\n\");fflush(stdout);" :epilogue-code '(progn (uiop:format! t "~%The end.~%") (uiop:quit 0)) ;;:no-uiop t :ld-flags (list (namestring (compile-file-pathname "hello_aux.c" :type :object)))) (assert-equal (uiop:run-program (format nil "./~A" +standalone-exe+) :output :lines) '("In the beginning, there was nothing." "Hello world!" "The end.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CLEAN UP ;;; ;; (delete-file (compile-file-pathname "hello.lisp" :type :object)) (delete-file (compile-file-pathname "hello_aux.c" :type :object)) (delete-file +standalone-exe+) asdf-3.3.4/test/ecl-prebuilt-systems.script000066400000000000000000000004021362155115300207350ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG "Regression test: Test if dependencies on prebuilt libraries work. Should load from ecl-prebuilt-systems/") #+(and ecl (not ecl-bytecmp)) (progn (chdir (subpathname *test-directory* "ecl-prebuilt-systems/")) (load "readme.lisp")) asdf-3.3.4/test/ecl-prebuilt-systems/000077500000000000000000000000001362155115300175135ustar00rootroot00000000000000asdf-3.3.4/test/ecl-prebuilt-systems/hello.lisp000066400000000000000000000001061362155115300215040ustar00rootroot00000000000000(in-package #:cl-user) (print `(:asdf-version ,(asdf:asdf-version))) asdf-3.3.4/test/ecl-prebuilt-systems/hellow.asd000066400000000000000000000004551362155115300215020ustar00rootroot00000000000000(defsystem "hellow" :depends-on ("asdf") :components ((:file "hello")) :class program-system :build-operation program-op :build-pathname "hellow" :prologue-code "printf(\"Good morning sunshine!\");fflush(stdout);" :epilogue-code (progn (format t "~%Good bye sunshine.~%") (ext:quit 0))) asdf-3.3.4/test/ecl-prebuilt-systems/readme.lisp000066400000000000000000000020441362155115300216410ustar00rootroot00000000000000;;; ;;; DESCRIPTION: ;;; ;;; This file builds a standalone executable with a dependency on ;;; ASDF. ;;; ;;; ;;; USE: ;;; ;;; Launch a copy of ECL and load this file in it ;;; ;;; (load "readme.lisp") ;;; (require 'asdf) (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; BUILDING A STANDALONE EXECUTABLE ;;; ") ;; ;; * Combine files in a standalone executable. We reuse the files ;; from the previous example ;; (defconstant +standalone-exe+ (compile-file-pathname "hellow" :type :program)) (push (make-pathname :name nil :type nil :version nil :defaults *load-truename*) asdf:*central-registry*) (asdf:make "hellow") ;; ;; * Test the program ;; (format t " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; TESTING A STANDALONE EXECUTABLE ;;; ") (uiop:run-program (format nil "./~A" +standalone-exe+) :output *standard-output*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CLEAN UP ;;; (delete-file +standalone-exe+) asdf-3.3.4/test/exiter.sh000077500000000000000000000002151362155115300152540ustar00rootroot00000000000000#!/bin/sh if [ $# -gt 3 ]; then exit 1 fi if [ $# -ge 2 ]; then echo $2 fi if [ $# -ge 3 ]; then echo $3 >&2 fi exit ${1:-0} asdf-3.3.4/test/file1.lisp000066400000000000000000000001321362155115300153040ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defparameter *file1* t) asdf-3.3.4/test/file2.lisp000066400000000000000000000001431362155115300153070ustar00rootroot00000000000000(in-package :test-package) (assert *file1*) (defparameter *file2* t) (defvar *f2c* 0) (incf *f2c*) asdf-3.3.4/test/file3-only.asd000066400000000000000000000002131362155115300160650ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem file3-only :components ((:file "file3"))) (defvar *file3-only-asd-loaded* 0) (incf *file3-only-asd-loaded*) asdf-3.3.4/test/file3.lisp000066400000000000000000000001321362155115300153060ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defparameter *file3* t) asdf-3.3.4/test/file4.lisp000066400000000000000000000001061362155115300153100ustar00rootroot00000000000000(in-package :test-package) (assert *file3*) (defparameter *file4* t) asdf-3.3.4/test/fun-with-undefined-locals.lisp000066400000000000000000000002201362155115300212550ustar00rootroot00000000000000(defpackage fun-with-undefined-locals-package (:use :common-lisp)) (in-package :fun-with-undefined-locals-package) (defun foo () (+ a b)) asdf-3.3.4/test/good-shell-command000077500000000000000000000000231362155115300170110ustar00rootroot00000000000000#! /bin/sh exit 0 asdf-3.3.4/test/graveyard/000077500000000000000000000000001362155115300154035ustar00rootroot00000000000000asdf-3.3.4/test/graveyard/test-preferences-1.lisp000066400000000000000000000001211362155115300217020ustar00rootroot00000000000000(in-package #:common-lisp-user) (defvar *test-preferences-variable-1* :default) asdf-3.3.4/test/graveyard/test-preferences-1.script000066400000000000000000000006721362155115300222520ustar00rootroot00000000000000;;; -*- 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)) )asdf-3.3.4/test/graveyard/test-preferences-system-1.asd000066400000000000000000000020611362155115300230310ustar00rootroot00000000000000;;; -*- 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*)) asdf-3.3.4/test/graveyard/test-preferences-system-load.lisp000066400000000000000000000001141362155115300240050ustar00rootroot00000000000000(in-package #:common-lisp-user) (setf *test-preferences-variable-1* :load) asdf-3.3.4/test/graveyard/test-preferences-system-test.lisp000066400000000000000000000001141362155115300240450ustar00rootroot00000000000000(in-package #:common-lisp-user) (setf *test-preferences-variable-1* :test) asdf-3.3.4/test/graveyard/test6.script000066400000000000000000000007431362155115300177020ustar00rootroot00000000000000;;; -*- 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*))) asdf-3.3.4/test/graveyard/test7.script000066400000000000000000000010471362155115300177010ustar00rootroot00000000000000;;; -*- 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))) asdf-3.3.4/test/hello-world-example.asd000066400000000000000000000014041362155115300177700ustar00rootroot00000000000000;; Example executable program #.`(defsystem :hello-world-example ;; :build-operation program-op ; this would cause the executable output in same directory :-/ :entry-point "hello:entry-point" :depends-on (:uiop) :components ((:file "hello")) #+mkcl ,@`(;;:prefix-lisp-object-files (,(namestring (truename (translate-logical-pathname #P"SYS:cmp.a")))) :extra-build-args ,(or #-os-windows '(:use-mkcl-shared-libraries nil)) :class program-system :epilogue-code (progn (setq uiop/image:*image-dumped-p* :executable) (setq uiop/image:*lisp-interaction* nil) (uiop/image:restore-image :entry-point (read-from-string "hello:entry-point"))))) asdf-3.3.4/test/hello.lisp000066400000000000000000000005331362155115300154140ustar00rootroot00000000000000(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)) ;; Return success! t) (defun entry-point () (apply 'main *command-line-arguments*)) asdf-3.3.4/test/in-progress.lisp000066400000000000000000000016271362155115300165660ustar00rootroot00000000000000(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/")) ) asdf-3.3.4/test/killer.sh000077500000000000000000000000231362155115300152330ustar00rootroot00000000000000#!/bin/sh kill $$ asdf-3.3.4/test/killercontainer.sh000077500000000000000000000000331362155115300171370ustar00rootroot00000000000000#!/bin/sh sh -c 'kill $$' asdf-3.3.4/test/l-file.lisp000066400000000000000000000004211362155115300154550ustar00rootroot00000000000000(defpackage :l-file (:use :asdf :uiop :cl) ;; asdf/package-inferred-system dependencies (:export #:cl-source-file.l)) (in-package :l-file) (defclass cl-source-file.l (cl-source-file) ((type :initform "l"))) (defclass asdf::cl-source-file.l (cl-source-file.cl) ()) asdf-3.3.4/test/l-operation.lisp000066400000000000000000000004021362155115300165350ustar00rootroot00000000000000(cl:defpackage :l-operation (:use :asdf :uiop :cl) ;; asdf/package-inferred-system dependencies (:export #:op #:*x*)) (cl:in-package :l-operation) (defparameter *x* 0) (defclass op (load-op) ()) (defmethod perform :after ((o op) (c t)) (incf *x*)) asdf-3.3.4/test/lambda.lisp000066400000000000000000000001171362155115300155270ustar00rootroot00000000000000;; -*- coding: latin-2 -*- (in-package :asdf-test) (setf *lambda-string* "λ") asdf-3.3.4/test/logical-file.lisp000066400000000000000000000001331362155115300166340ustar00rootroot00000000000000(defpackage :test-package (:use :cl)) (in-package :test-package) (defvar *logical-file* t) asdf-3.3.4/test/loop.asd000066400000000000000000000000611362155115300150560ustar00rootroot00000000000000(defsystem :loop :components ((:file "loop"))) asdf-3.3.4/test/make-hello-world.lisp000066400000000000000000000030711362155115300174540ustar00rootroot00000000000000;;; -*- Lisp -*- #+lispworks (lispworks:load-all-patches) (load (make-pathname :name "script-support" :defaults *load-pathname*)) (load-asdf) #+(or clasp ecl mkcl) (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) (println "This is make-hello-world, testing its standard-output.") ; *standard-output* (println "This is make-hello-world, testing its error-output." *error-output*) (println "This is make-hello-world, testing its stdout." *stdout*) (println "This is make-hello-world, testing its stderr." *stderr*) #+mkcl (defun add-mkcl-dll (pathname) ;; make sure mkcl-X.X.X.dll is the same directory as the executable (let* ((dll-orig (subpathname (si::self-truename) (strcat #-os-windows "../lib/" "mkcl_" (si:mkcl-version) "." (asdf/bundle:bundle-pathname-type :shared-library)))) (dll-dest (subpathname pathname (strcat #-os-windows "../lib/" (file-namestring dll-orig))))) (ensure-directories-exist dll-dest) (copy-file dll-orig dll-dest))) (defun make-hello-bundle (operation) (operate operation :hello-world-example) #+mkcl (add-mkcl-dll (asdf::output-file operation :hello-world-example)) (quit 0)) (defun make-hello-image () (make-hello-bundle 'image-op)) (defun make-hello-program () (make-hello-bundle 'program-op)) asdf-3.3.4/test/monodll-1.lisp000066400000000000000000000002671362155115300161170ustar00rootroot00000000000000(defpackage :test-asdf/monodll-1 (:use)) ;; dummy, for package-inferred-system dependencies. (ffi:clines "extern " #+mkcl "MKCL_DLLEXPORT " "int always_7() { return 7; } ") asdf-3.3.4/test/monodll-user.lisp000066400000000000000000000002531362155115300167300ustar00rootroot00000000000000(defpackage :test-asdf/monodll-user (:use)) ;; dummy, for package-inferred-system dependencies. (in-package :asdf-test) (ffi:def-function "always_42" () :returning :int) asdf-3.3.4/test/monodll.lisp000066400000000000000000000003601362155115300157530ustar00rootroot00000000000000(defpackage :test-asdf/monodll (:use :test-asdf/monodll-1)) ;; dummy, for package-inferred-system dependencies. (ffi:clines "extern int always_7();" "extern " #+mkcl "MKCL_DLLEXPORT " "int always_42() { return 6*always_7(); } ") asdf-3.3.4/test/package-inferred-system-test.script000066400000000000000000000020601362155115300223310ustar00rootroot00000000000000;;-*- Lisp -*- (register-directory (subpathname *test-directory* "package-inferred-system-test/")) (load-system :package-inferred-system-test/a/x) (load-system :package-inferred-system-test/d) (signals package-inferred-system-missing-package-error (load-system :package-inferred-system-test/e)) ;; No such file. (signals missing-component (handler-bind ((system-out-of-date 'continue)) (load-system :package-inferred-system-test/f))) ;; Test that around-compile is inherited by inferred systems. (assert-equal 3 (symbol-call :package-inferred-system-test/a :add10 1)) ;; add10 must have been compiled in base 2 ;; Test that primary system name returns the correct value when called with a ;; package-inferred-system object. (assert-equal "package-inferred-system-test" (primary-system-name (find-system :package-inferred-system-test/a/x))) ;; Test that SBCL's :local-nicknames are recognized #+sbcl (progn (load-system :package-inferred-system-test/local-nicknames-1) (assert-equal "g" (symbol-call :package-inferred-system-test/local-nicknames-1 :f))) asdf-3.3.4/test/package-inferred-system-test/000077500000000000000000000000001362155115300211055ustar00rootroot00000000000000asdf-3.3.4/test/package-inferred-system-test/a.lisp000066400000000000000000000010051362155115300222120ustar00rootroot00000000000000(defpackage package-inferred-system-test/a (:use cl)) (in-package :package-inferred-system-test/a) (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)) asdf-3.3.4/test/package-inferred-system-test/a/000077500000000000000000000000001362155115300213255ustar00rootroot00000000000000asdf-3.3.4/test/package-inferred-system-test/a/x.lisp000066400000000000000000000001401362155115300224600ustar00rootroot00000000000000(defpackage package-inferred-system-test/a/x (:use common-lisp package-inferred-system-test/c)) asdf-3.3.4/test/package-inferred-system-test/b.lisp000066400000000000000000000001251362155115300222150ustar00rootroot00000000000000(defpackage package-inferred-system-test/b (:use cl package-inferred-system-test/a)) asdf-3.3.4/test/package-inferred-system-test/c.lisp000066400000000000000000000001251362155115300222160ustar00rootroot00000000000000(defpackage package-inferred-system-test/c (:use cl package-inferred-system-test/a)) asdf-3.3.4/test/package-inferred-system-test/d.lisp000066400000000000000000000001641362155115300222220ustar00rootroot00000000000000(defpackage package-inferred-system-test/d (:use cl package-inferred-system-test/b package-inferred-system-test/c)) asdf-3.3.4/test/package-inferred-system-test/e.lisp000066400000000000000000000002111362155115300222140ustar00rootroot00000000000000;; This file is missing a defpackage form, and loading it as a package-inferred-system should trigger an error. (in-package :asdf-test) asdf-3.3.4/test/package-inferred-system-test/local-nicknames-1-dep.lisp000066400000000000000000000002611362155115300257410ustar00rootroot00000000000000(defpackage package-inferred-system-test/local-nicknames-1-dep (:use :cl) (:export #:g)) (in-package :package-inferred-system-test/local-nicknames-1-dep) (defun g () "g") asdf-3.3.4/test/package-inferred-system-test/local-nicknames-1.lisp000066400000000000000000000004001362155115300251660ustar00rootroot00000000000000(defpackage package-inferred-system-test/local-nicknames-1 (:use :cl) (:local-nicknames (:dep :package-inferred-system-test/local-nicknames-1-dep)) (:export #:f)) (in-package :package-inferred-system-test/local-nicknames-1) (defun f () (dep:g)) asdf-3.3.4/test/package-inferred-system-test/package-inferred-system-test.asd000066400000000000000000000005031362155115300272620ustar00rootroot00000000000000(in-package :asdf) (defsystem package-inferred-system-test :class package-inferred-system :defsystem-depends-on #.(unless (find-class 'package-inferred-system nil) '(:asdf-package-inferred-system)) :around-compile (lambda (thunk) (let ((*read-base* 2)) (funcall thunk)))) asdf-3.3.4/test/package-test.lisp000066400000000000000000000000341362155115300166550ustar00rootroot00000000000000(in-package :asdf/package) asdf-3.3.4/test/properly-upgraded.lisp000066400000000000000000000004761362155115300177640ustar00rootroot00000000000000(in-package :asdf-test) (assert (asymval '#:*file1* :test-package)) (assert (asymval '#:*file3* :test-package)) ;; This broke at least when upgrading from 3.1.6-3.1.7 to 3.2.0-3.3.1 (assert-equal (asdf/bundle::gather-type (asdf:make-operation 'asdf:monolithic-lib-op)) :object) (defparameter *properly-upgraded* t) asdf-3.3.4/test/require-system.asd000066400000000000000000000011251362155115300171050ustar00rootroot00000000000000(defsystem "require-system" :version "2.0" :depends-on ("require-system/immutable")) (defsystem "require-system/preloaded" :version "2.0") (defsystem "require-system/immutable" :version "2.0") (defsystem "require-system/not-loaded" :version "2.0") (defsystem "require-system/ordinary" :version "2.0") (defsystem "require-system/require" :version "2.0" :depends-on ((:require "require-system/module1") (:require "require-system/module2"))) (defsystem "require-system/depends" :version "2.0" :depends-on ("test-asdf/module1" "require-system-module2")) asdf-3.3.4/test/run-tests.sh000077500000000000000000000521471362155115300157330ustar00rootroot00000000000000#!/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, ccl (clozure)," echo " allegro, allegro8, allegromodern, allegromodern8," echo " allegro_s, allegro8_s, allegromodern_s, allegromodern8_s (SMP variants)" echo " allegro_64, allegro8_64, allegromodern_64, allegromodern8_64 (64-bit variants)," echo " allegro_64_s, allegro8_64_s, allegromodern_64_s, allegromodern8_64_s, (SMP, 64-bit variants)" echo " clasp, clisp, cmucl, ecl, gcl, sbcl, scl and xcl." echo " To configure the script, you may set environment variables to point to the various lisp runtimes." echo " Allegro CL is a special case: instead of setting environment variables for the specific runtime" echo " locations, you may simply specify the Allegro install directories using these variables:" echo " ALLEGRO64DIR, ALLEGRO64SDIR (64-bit Allegro and SMP Allegro, respectively), ALLEGRODIR, and" echo " ALLEGROSDIR." echo "OPTIONS:" echo " -c -- clean load test." echo " -d -- debug mode." echo " -t -- test interactively." echo " -h -- show this message." echo " -u -- upgrade tests." echo " -l -- load systems tests." echo " -H -- extract all asdf versions to upgrade from." echo " -u -- upgrade tests, we already told you." } 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 if [ -n "$ALLEGRO64DIR" ] ; then ALLEGRO_64=${ALLEGRO64DIR}/alisp ALLEGRO8_64=${ALLEGRO64DIR}/alisp8 ALLEGROMODERN_64=${ALLEGRO64DIR}/mlisp ALLEGROMODERN8_64=${ALLEGRO64DIR}/mlisp8 fi if [ -n "$ALLEGRO64SDIR" ] ; then ALLEGRO_64_S=${ALLEGRO64SDIR}/alisp ALLEGRO8_64_S=${ALLEGRO64SDIR}/alisp8 ALLEGROMODERN_64_S=${ALLEGRO64SDIR}/mlisp ALLEGROMODERN8_64_S=${ALLEGRO64SDIR}/mlisp8 fi if [ -n "$ALLEGRODIR" ] ; then ALLEGRO=${ALLEGRODIR}/alisp ALLEGRO8=${ALLEGRODIR}/alisp8 ALLEGROMODERN=${ALLEGRODIR}/mlisp ALLEGROMODERN8=${ALLEGRODIR}/mlisp8 fi if [ -n "$ALLEGROSDIR" ] ; then ALLEGRO_S=${ALLEGROSDIR}/alisp ALLEGRO8_S=${ALLEGROSDIR}/alisp8 ALLEGROMODERN_S=${ALLEGROSDIR}/mlisp ALLEGROMODERN8_S=${ALLEGROSDIR}/mlisp8 fi while getopts "cdtHulhu" OPTION do case $OPTION in c) clean_load=t ;; d) DEBUG_ASDF_TEST=t ;; t) test_interactively=t ;; h) usage exit 1 ;; u) upgrade=t ;; l) load_systems=t ;; H) extract_all=t ;; 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:run-test-script'|$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) #.(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*|MSYS_NT*) 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*) case "$lisp" in allegro) command="${ALLEGRO:-alisp}" ;; allegro8) command="${ALLEGRO8:-alisp8}" ;; allegromodern) command="${ALLEGROMODERN:-mlisp}" ;; allegromodern8) command="${ALLEGROMODERN8:-mlisp8}" ;; allegro_s) command="${ALLEGRO_S:-alisp_s}" ;; allegro8_s) command="${ALLEGRO8_S:-alisp8_s}" ;; allegromodern_s) command="${ALLEGROMODERN_S:-mlisp_s}" ;; allegromodern8_s) command="${ALLEGROMODERN8_S:-mlisp8_s}" ;; allegro_64) command="${ALLEGRO_64:-alisp_64}" ;; allegro8_64) command="${ALLEGRO8_64:-alisp8_64}" ;; allegromodern_64) command="${ALLEGROMODERN_64:-mlisp_64}" ;; allegromodern8_64) command="${ALLEGROMODERN8_64:-mlisp8_64}" ;; allegro_64_s) command="${ALLEGRO_64_S:-alisp_64_s}" ;; allegro8_64_s) command="${ALLEGRO8_64_S:-alisp8_64_s}" ;; allegromodern_64_s) command="${ALLEGROMODERN_64_S:-mlisp_64_s}" ;; allegromodern8_64_s) command="${ALLEGROMODERN8_64_S:-mlisp8_64_s}" ;; esac # For the sake of the lisp-invocation library, re-export these # ALLEGRO=$command ; export ALLEGRO ; # echo ALLEGRO=$ALLEGRO flags="-q" nodebug="-batch" if [ "$os" = windows ] ; then adir=$(dirname "${command}") ; allegroName=$(basename "${command}" ".exe") ; if [[ ${allegroName: -1} == "8" ]] ; then build=build ; else build=buildi ; fi ; # this takes somewhat unjustifiable advantage of the fact that # the Allegro images have the same name (with .dxl extension) # as the corresponding executables. the "build" executable # runs an ACL image in the current terminal instead of a # separate window, as is normal on Windows. bcmd="${adir}/${build}.exe -I ${adir}/${allegroName}.dxl $flags" ; fi eval="-e" ;; ccl) command="${CCL:-ccl}" flags="--no-init --quiet" nodebug="--batch" eval="--eval" ;; clasp) command="${CLASP:-clasp}" flags="--norc --noinit" 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="" nodebug="-batch" eval="-eval" ;; lispworks) command="${LISPWORKS:-lispworks-console}" # 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="--no-userinit --no-sysinit" # 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)/.. ; command 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 are Faré's "stable" ASDF 2 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 and used by LispWorks since 2012. # 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 in 2013 # # 2.26.x is where the refactoring that begat ASDF 3 took place. # 2.26.61 is the last single-file, single-package ASDF. # 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases # 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 # # The 3.0 series is a stable release of ASDF 3 # with Robert Goldman taking over maintainership at 3.0.2. # 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly # not compatible with ASDF2 anymore, so we immediately released 3.0.1 # 3.0.1 (2013-05-16) is the first stable ASDF 3 release # 3.0.2 (2013-07-02) is the first ASDF 3 in SBCL # 3.0.3 (2013-10-22) is the last in the ASDF 3.0 series # # The 3.1 series provides the 3.1 feature, meaning users can rely on # all the stabilization work done in 3.0 so far, plus extra developments # in UIOP, package-inferred-system, and more robustification. # 3.1.2 (2014-05-06) is the first ASDF 3.1 release # 3.1.3 (2014-07-24) a bug fix release for 3.1.2 # 3.1.4 (2014-10-09) more bug fixes, source-registry cache, in LispWorks 7 # 3.1.5 (2015-07-21) more bug fixes, what SBCL sports (as of 1.3.14, 2017-02-04) # 3.1.6 (2015-10-17) more bug fixes # 3.1.7 (2016-03-23) more bug fixes, last in 3.1 series # # The 3.2 series provides the asdf3.2 feature, meaning users can rely on # all its new features (launch-program, improved bundle support), as well as # the improvements done in 3.1 (e.g. XDG support). # 3.2.0 (2017-01-08) first in 3.2 series # 3.2.1 (2017-04-03) bug fixes, second and last in 3.2 series # # The 3.3 series provides the asdf3.3 feature, meaning users can rely on # all its new features (proper phase separation) as well as earlier features. # 3.3.0 (2017-10-06) first in 3.3 series # 3.3.1 (2017-11-14) bug fixes, second # 3.3.2 (2018-05-03) bug fixes, third and latest in 3.3 series # # We return the above designated versions in order of decreasing relevance, # which pretty much means REQUIRE and most recent first. # We picked the last and first in each relevant series, plus 2.26. if [ "$lisp" = cmucl ]; then echo REQUIRE 3.3.2 3.3.1 3.3.0 else echo REQUIRE 3.3.2 3.3.1 3.3.0 3.2.1 3.2.0 3.1.7 3.1.2 3.0.3 2.26 fi #echo 3.1.7 3.1.6 3.1.5 3.1.4 3.1.3 3.1.2 #echo 3.0.3 3.0.2 3.0.1 #echo 2.32 2.27 #echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000 #echo 1.369 1.97 1.85 } 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][0-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]:*) : ;; # ccl fasl numbering broke loading of old asdf 2.0 ccl:2.0[01]*|ccl:2.2[0-6]*) : ;; # Allegro ships with versions 3*, so give up testing 2 # Also, unpatched Allegro 10 has bug updating from 2.26 and before allegro*:[12].*) : ;; # My old ubuntu 10.04LTS clisp 2.44.1 came wired in # with an antique ASDF 1.374 from CLC that can't be downgraded. # More recent CLISPs work. # 2.00[0-7] use UID, which fails on some old CLISPs. # Note that for the longest time, CLISP has included 2.011 in its distribution. # Now its hg repository includes 3.0.2.29, but clisp hasn't released in many years(!) # We don't punt on upgrade anymore, so we can go at it! #clisp:2.00[0-7]:*|clisp:1.*|clisp:2.0[01]*|clisp:2.2[0-5]:*) : ;; # CMUCL has problems with 2.32 and earlier because of # the redefinition of system's superclass component. cmucl:1.*|cmucl:2.[012]*|cmucl:2.3[012]*) : ;; # Skip many ECL tests, for various ASDF issues ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) : ;; # GCL 2.7.0 from late November 2013 is required, with ASDF 3.1.2 gcl:REQUIRE:*|gcl:1.*|gcl:2.*|gcl:3.0*) : ;; # LispWorks is broken at ASDF 3.0.3, but can upgrade from earlier and later ASDFs. lispworks:3.0.3:*) : ;; # MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip. mkcl:[12]*|mkcl:3.0*) : ;; # 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 tags="`upgrade_tags`" methods="`upgrade_methods`" { for tag in $tags ; do for method in $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 echo "Upgrade test succeeded for ${lisp}" } 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}-test.text" || : do_tests "$@" 2>&1 | \ tee "../build/results/${lisp}-test.text" "../build/results/${lisp}-test-${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}-test.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 if [ $lisp = clasp ] ; then eval_string="(or'#.(load(string'|test/script-support.lisp|):verbose():print())#.(asdf-test:verbose())#.(with-compilation-unit()(load(string'|build/asdf.lisp|):verbose()))#.(uiop/image:quit'0))" else eval_string="(or'#.(load(string'|test/script-support.lisp|):verbose():print())#.(asdf-test:verbose())#.(load(string'|build/asdf.lisp|):verbose())#.(uiop/image:quit'0))" fi $bcmd $eval $eval_string > $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 () { 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. asdf-3.3.4/test/script-support.lisp000066400000000000000000000760431362155115300173400ustar00rootroot00000000000000;;;;; 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 #:does-not-signal #:errors #:with-expected-failure #: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 #:run-test-script #:interactive-test #:test-load-systems #:verbose #:exit-lisp #: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 #:reset-session #:reset-session-visited)) (in-package :asdf-test) #+(and ecl (not ecl-bytecmp)) (require :cmp) (declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) #+(or cmucl scl) (c::brevity 2))) (proclaim '(optimize (speed #-gcl 2 #+gcl 1) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) #+(or cmucl scl) (c::brevity 2) #+(or cmucl scl) (ext:inhibit-warnings 3))) #+clasp (unless (assoc "script" si:*load-hooks* :test #'equal) (push (cons "script" 'si:load-source) si:*load-hooks*)) (defparameter *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 *print-backtrace* t) (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 (si::use-fast-links nil) #+lispworks (setf system:*stack-overflow-behaviour* :warn)) #+genera (unless (fboundp 'ensure-directories-exist) (defun ensure-directories-exist (path) #+genera (fs:create-directories-recursively (pathname 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 asymval (name &optional package) (symbol-value (asym name package))) (defsetf asymval (name &optional package) (new-value) (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*) ,x) (:no-error (&rest ,x) (error "Expression ~S fails to raise condition ~S, instead returning~{ ~S~}" ',sexp ',condition ,x))))) (defmacro does-not-signal (condition sexp &aux (x (gensym))) `(progn (format *error-output* "~&Checking that ~S does NOT signal ~S~%" ',sexp ',condition) (finish-output *error-output*) (handler-case ,sexp (,condition (,x) (error "~&Condition signaled: ~S~%" ,x)) (:no-error (&rest ,x) t)))) (defmacro errors (condition sexp &aux (x (gensym))) `(progn (format *error-output* "~&Checking whether ~S signals error ~S~%" ',sexp ',condition) (finish-output *error-output*) (let ((,x (nth-value 1 (ignore-errors ,sexp)))) (assert-equal ',condition (type-of ,x)) ,x))) (defmacro with-expected-failure ((&optional condition) &body body) `(call-with-expected-failure ,condition (lambda () ,@body))) (defun call-with-expected-failure (condition thunk) (if condition (handler-case (funcall thunk) (:no-error (&rest x) (declare (ignore x)) (error "Unexpected success: ~A" condition)) (t (x) (declare (ignore x)) t)) (funcall thunk))) ;;; 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)) #+mkcl ((acall :pathname-equal x y) (format t "~S and ~S evaluate to functionaly equivalent paths, respectively:~% ~S~%and~% ~S~%" qx qy x y)) ((acall :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))) ;; accept equalp namestrings, to account for case-independent filesystems ((equalp (and x (namestring x)) (and y (namestring y))) (warn "These two expressions yield pathnames that have equalp namestrings yet 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))) (t (error "These two expressions yield paths that are not equal in any way:~%~ 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* ;; the following is annoyingly named "test-getenv" to avoid symbol clash ;; later when we use UIOP. (flet ((test-getenv (x) (declare (ignorable x)) #+(or abcl clasp clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+cmucl (unix:unix-getenv x) #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) #+cormanlisp (let* ((buffer (ct:malloc 1)) (cname (ct:lisp-string-to-c-string x)) (needed-size (win:getenvironmentvariable cname buffer 0)) (buffer1 (ct:malloc (1+ needed-size)))) (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) nil (ct:c-string-to-lisp-string buffer1)) (ct:free buffer) (ct:free buffer1))) #+gcl (system:getenv x) #+genera nil #+lispworks (lispworks:environment-variable x) #+mcl (ccl:with-cstrs ((name x)) (let ((value (_getenv name))) (unless (ccl:%null-ptr-p value) (ccl:%get-cstring value)))) #+mkcl (#.(or (find-symbol "GETENV" :si) (find-symbol "GETENV" :mk-ext)) x) #+sbcl (sb-ext:posix-getenv x) #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv))) (or (test-getenv "ASDF_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)) (defparameter *asdf-directory* (truename (make-sub-pathname :directory '(:relative :back) :defaults *test-directory*))) (defparameter *uiop-directory* (truename (make-sub-pathname :directory '(:relative "uiop") :defaults *asdf-directory*))) (defparameter *build-directory* (make-sub-pathname :directory '(:relative "build") :defaults *asdf-directory*)) (defparameter *implementation* (or #+allegro (ecase excl:*current-case-mode* (:case-sensitive-lower :mlisp) (:case-insensitive-upper :alisp)) #+armedbear :abcl #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl) #+clisp :clisp #+clasp :clasp #+clozure :ccl #+cmucl :cmucl #+corman :cormanlisp #+digitool :mcl #+gcl :gcl #+lispworks :lispworks #+mkcl :mkcl #+sbcl :sbcl #+scl :scl #+xcl :xcl)) (defparameter *early-fasl-directory* (make-sub-pathname :directory `(:relative "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 "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 set-equality (s1 s2 &key (test 'eql)) (and (= (length s1) (length s2)) (every #'(lambda (x) (some #'(lambda (y) (funcall test x y)) s2)) s1))) (defun touch-file (file &key offset timestamp in-filesystem) (let* ((base (or timestamp (get-universal-time))) (stamp (if offset (+ base offset) base))) (if in-filesystem (multiple-value-bind (sec min hr day month year) (decode-universal-time stamp) (acall :run-program `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D" year month day hr min sec) ,(acall :native-namestring file))) (assert-equal (file-write-date file) stamp)) ;; else (progn (unless (asymval :*asdf-session*) (error "Trying to use the ASDF session cache in TOUCH-FILE, but it is not initialized.")) (acall :register-file-stamp file stamp))))) (defun mark-file-deleted (file) (unless (asymval :*asdf-session*) (error "Y U NO use asdf session?")) (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) #+(or clasp ecl) (si:quit code) #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) #+(or cmucl scl) (unix:unix-exit code) #+gcl (system:quit code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? #+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 clasp clisp clozure cmucl 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))) (deftype test-fatal-condition () `(and serious-condition #+ccl (not ccl:process-reset))) (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 ((test-fatal-condition (lambda (c) (ignore-errors (format *error-output* "~&TEST ABORTED: ~A~&" c)) (finish-outputs*) (unless *debug-asdf* (when *print-backtrace* (ignore-errors (format *error-output* "~&Backtrace:~%") (acall :print-condition-backtrace c :count 69 :stream *error-output*))) (leave-test "Script failed" 1))))) (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) #-allegro (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (funcall thunk)) #+allegro (excl:without-redefinition-warnings (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 run-test-script (file) (with-test () (let ((name (string file))) (format t "Running ~A with ~A~%" name (acall :implementation-identifier)) (load name)))) (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*)) :test #'equal)) (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 (#+(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) #+sbcl ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) #'muffle-warning) #-(or cmucl 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 nil) 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 :verbose 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 clasp clisp cmucl 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 () (ecase (with-asdf-conditions (t) (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 hash-table-alist (h) (loop for k being the hash-keys of h using (hash-value v) collect (cons k v))) (defun registry () (let ((sr (asymval :*source-registry*))) (when sr (sort (hash-table-alist sr) 'string< :key 'car)))) (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"))) (setf *print-backtrace* (not (acall :getenvp "NO_ASDF_BACKTRACE")))) (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 ;; Some old versions of ASDF want locate-system to be surrounded by with-asdf-cache ;; so we do it for them for the sake of testing upgrade from these old versions. ;; Yet older versions of ASDF don't even have this session cache, so then we don't. ;; Newer versions of ASDF implicitly use with-asdf-session (successor of the cache) ;; without our having to wrap it. (funcall (or (asym :call-with-asdf-cache) 'funcall) (lambda () (nth-value 2 (acall :locate-system :test-asdf))))))) (assert-pathname-equal-helper ;; not always EQUAL (!) '*test-directory* *test-directory* '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x) (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 () (cond ((find-package :asdf) (format t "Frob packages~%") (use-package :asdf :asdf-test) (when (find-package :uiop) (use-package :uiop :asdf-test)) (when (find-package :asdf/session) (use-package :asdf/session :asdf-test))) (t (format t "NB: No packages to frob, because ASDF not loaded yet."))) (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) ;; do NOT include *asdf-directory*, which would defeat the purpose by causing an upgrade (register-directory *uiop-directory*) (register-directory *test-directory*) (format t "CR ~S~%" (symbol-value (asym :*central-registry*))) (format t "loading uiop~%") (quietly (acall :oos (asym :load-op) :uiop)) (format t "CR ~S~%" (symbol-value (asym :*central-registry*))) (format t "loading test-module-depend~%") (acall :oos (asym :load-op) :test-module-depend) (assert-equal (asymval :*f2c* :test-package) 1) (format t "loading test-module-depend again -- shouldn't rebuild anything~%") (acall :oos (asym :load-op) :test-module-depend) (assert-equal (asymval :*f2c* :test-package) 1) (format t "done loading~%")) (defun load-asdf (&optional tag) (load-asdf-fasl tag) (configure-asdf)) (defun debug-asdf () (setf *debug-asdf* t) (setf *quit-when-done* nil) (frob-packages)) (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) (etypecase name (symbol `(apply (asym :register-system-definition) ',name :pathname ,*test-directory* :source-file nil ',rest)) (string `(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) #+clasp (with-compilation-unit () (load-asdf-lisp)) #-clasp (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) (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) (acall (list old-method :asdf-test) 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) (acall (list new-method :asdf-test)) (format t "Testing it~%") (register-directory *test-directory*) (load-test-system :test-asdf/upgrade) (assert (symbol-value '*properly-upgraded*)))) (defun join-namestrings (namestrings) (format nil (format nil "~~{~~A~~^~A~~}" (acall :inter-directory-separator)) namestrings)) (defun reset-session () (set (asym :*asdf-session*) nil)) (defun reset-session-visited () (clrhash (acall '#:visited-actions (asymval '#:*asdf-session*)))) ;; 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 )) |# asdf-3.3.4/test/show-progress.lisp000066400000000000000000000011171362155115300171320ustar00rootroot00000000000000(defpackage :show-progress (:use :cl)) (in-package :show-progress) (eval-when (:load-toplevel) (defparameter *time* :load-toplevel)) (eval-when (:compile-toplevel) (defparameter *time* :compile-toplevel)) (eval-when (:execute) (defparameter *time* :execute)) (eval-when (:load-toplevel :compile-toplevel :execute) (format t "It's ~A time!~%" *time*) (defvar *times* '()) (push *time* *times*)) (defun foo (x) (format t "~S~%" x)) (defmacro m1 () '(foo 1)) (defmacro m2 () '(foo 2)) (defmacro me () (error "Failing at compile-time")) (defmacro mb () '(me)) (defmacro mc () '(m1)) asdf-3.3.4/test/sleeper.sh000077500000000000000000000001131362155115300154100ustar00rootroot00000000000000#!/bin/sh if [ $# -gt 2 ]; then exit 1 fi sleep ${2:-0} exit ${1:-0} asdf-3.3.4/test/sources/000077500000000000000000000000001362155115300151025ustar00rootroot00000000000000asdf-3.3.4/test/sources/a/000077500000000000000000000000001362155115300153225ustar00rootroot00000000000000asdf-3.3.4/test/sources/a/which-asd2.asd000066400000000000000000000001501362155115300177400ustar00rootroot00000000000000;; Used by test-source-registry. Should shadow other definitions. (defsystem "which-asd2" :version "1") asdf-3.3.4/test/sources/b/000077500000000000000000000000001362155115300153235ustar00rootroot00000000000000asdf-3.3.4/test/sources/b/which-asd2.asd000066400000000000000000000001321362155115300177410ustar00rootroot00000000000000;; Used by test-source-registry. Should be shadowed (defsystem "which-asd2" :version "2") asdf-3.3.4/test/sources/level1/000077500000000000000000000000001362155115300162725ustar00rootroot00000000000000asdf-3.3.4/test/sources/level1/file1.lisp000066400000000000000000000003651362155115300201670ustar00rootroot00000000000000(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~%")) asdf-3.3.4/test/sources/level1/level2/000077500000000000000000000000001362155115300174635ustar00rootroot00000000000000asdf-3.3.4/test/sources/level1/level2/file2.lisp000066400000000000000000000000631362155115300213540ustar00rootroot00000000000000(in-package :test-package) (defvar *file-tmp2* t) asdf-3.3.4/test/sources/level1/level2/static.file000066400000000000000000000000001362155115300216010ustar00rootroot00000000000000asdf-3.3.4/test/sources/level1/test-tmp.cl000066400000000000000000000000001362155115300203550ustar00rootroot00000000000000asdf-3.3.4/test/sources/level1/which-asd.asd000066400000000000000000000001321362155115300206260ustar00rootroot00000000000000;; Used by test-source-registry. Should be shadowed. (defsystem "which-asd" :version "2") asdf-3.3.4/test/sources/which-asd.asd000066400000000000000000000001471362155115300174440ustar00rootroot00000000000000;; Used by test-source-registry. Should shadow other definitions. (defsystem "which-asd" :version "1") asdf-3.3.4/test/stamp-propagation/000077500000000000000000000000001362155115300170645ustar00rootroot00000000000000asdf-3.3.4/test/stamp-propagation/file1.lisp000066400000000000000000000000531362155115300207530ustar00rootroot00000000000000(in-package :asdf-test) (eval-note :file1) asdf-3.3.4/test/stamp-propagation/file2.lisp000066400000000000000000000000531362155115300207540ustar00rootroot00000000000000(in-package :asdf-test) (eval-note :file2) asdf-3.3.4/test/stamp-propagation/test-stamp-propagation.lisp000066400000000000000000000176121362155115300244060ustar00rootroot00000000000000;; 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 (defvar asdf::*asdf-session* 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) (cond ((asdf:version-satisfies (asdf:asdf-version) "3.1.7.30") asdf::*asdf-session*) ((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*)) (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))) (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 (use-cache-p defsystem) (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 'asdf:compile-op '(: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 'asdf:compile-op '(: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)) ;; The test should work on ASDF3 and later: ;; (this is THE bug that motivated the rewrite from ASDF 2 to ASDF 3). (nest #-asdf3 (signals error) ;; TODO: figure out why ABCL and XCL require this with-asdf-session. #+(and asdf3.3 (or abcl xcl)) (with-asdf-session () (load-system "asdf")) (test-defsystem :asdf)) ;; Genera's and Lispworks' defsystem have a bug fix, though ;; users need to manually specify non-default dependencies #+(or genera lispworks) (test-defsystem :native) ;; Allegro's defsystem has the bug #+(or allegro) (signals error (test-defsystem :native)) ;; MK-DEFSYSTEM has the bug #+mk-defsystem (signals error (test-defsystem :mk-defsystem)) asdf-3.3.4/test/stderr000077500000000000000000000002571362155115300146540ustar00rootroot00000000000000#! /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 asdf-3.3.4/test/test-around-compile.script000066400000000000000000000015171362155115300205440ustar00rootroot00000000000000;;; -*- 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-equal 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-equal 10 (funcall 'add10 1)) ;; add10 must have been compiled in base 16 asdf-3.3.4/test/test-asdf.asd000066400000000000000000000064741362155115300160150ustar00rootroot00000000000000(defpackage :test-asdf-system (:use :cl :asdf :uiop)) (in-package :test-asdf-system) (defvar *times-loaded* 0) (incf *times-loaded*) ;;(format! t "Times that test-asdf.asd was loaded: ~D~%" *times-loaded*) (defsystem :test-asdf :class package-inferred-system) (defsystem :test-asdf/all :version "0" :depends-on ((:version :test-asdf/2 "2") :test-asdf/4)) (defsystem :test-asdf/1 :components ((:file "file1" :if-feature :common-lisp) (:file "does-not-exist" :if-feature (:not :common-lisp)))) (defsystem :test-asdf/2 :version "2.2" :depends-on (:test-asdf/1) :components ((:module "foo" :pathname "" :components ((:module "bar" :pathname "" :components ((:file "file2"))))))) (defsystem :test-asdf/4 :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" :if-feature :common-lisp) (:file "does-not-exist" :if-feature (:not :common-lisp)))))))) (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") (:file "invalid-file" :if-feature (:not :common-lisp)))) (defsystem :test-asdf/force :depends-on (:test-asdf/force1) :components ((:file "file4"))) (defsystem :test-asdf/force1 ;; Importantly, this depends on a system that is NOT defined in the same file, ;; so that we can check that forcing causes one file to be reloaded but not the other. :depends-on (:file3-only) :components ((:file "file1"))) ;; These are used by test-defsystem-depends-on-change.asd, test-defsystem-depends-on-change.script (defvar *ta/dcc* 0) (defsystem "test-asdf/dep-can-change" :depends-on ("test-asdf-location-change" "test-asdf/dep-forced") :components ((:file "show-progress")) :perform (load-op (o c) (incf *ta/dcc*))) (defsystem "test-asdf/dep-forced" :components ((:file "file1"))) (defvar *ta/dcd* 0) (defsystem "test-asdf/dep-can-disappear" :depends-on ("test-asdf-location-change") :perform (load-op (o c) (incf *ta/dcd*))) (defvar *ta/dca* 0) (defsystem "test-asdf/dep-can-appear" :depends-on ("test-asdf-location-change") :perform (load-op (o c) (incf *ta/dca*))) (defsystem :test-asdf/upgrade :version "0" :depends-on (:test-asdf/all) :components ((:file "properly-upgraded"))) asdf-3.3.4/test/test-asdf.script000066400000000000000000000007341362155115300165430ustar00rootroot00000000000000(with-asdf-session (:override t) (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")))) asdf-3.3.4/test/test-bad-system-name.asd000066400000000000000000000002771362155115300200610ustar00rootroot00000000000000(defsystem "test-bad-system-name" :description "Test special handling of CL-PPCRE") (defsystem "test-bad-system-name-hyphen-separated-subsystem" :depends-on ("test-bad-system-name")) asdf-3.3.4/test/test-builtin-source-file-type.script000066400000000000000000000034001362155115300224570ustar00rootroot00000000000000;;; -*- Lisp -*- (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"))) (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"))) (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"))) (load-system 'test-builtin-source-file-type-4 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) asdf-3.3.4/test/test-bundle-asd.script000066400000000000000000000060641362155115300176460ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) (use-package :asdf) ;;;--------------------------------------------------------------------------- ;;; Test for GitLab issue 23 ;;;--------------------------------------------------------------------------- #+(or (and ecl ecl-bytecmp) gcl) (leave-test "bundles not on implemented this implementation" 0) (defparameter *test-system-name* "deliver-bundle") (asdf:initialize-source-registry '(:source-registry (:directory :here) :ignore-inherited-configuration)) (asdf:clear-system *test-system-name*) (defparameter *constructed-asdf-file* (output-file (make-operation 'deliver-asd-op) (find-system *test-system-name*))) (ignore-errors (delete-file *constructed-asdf-file*)) (DBG "Writing ASD system definition file:" *constructed-asdf-file*) (operate 'deliver-asd-op *test-system-name*) (defun load-constructed-asd-file (&optional (constructed-file *constructed-asdf-file*)) (with-open-file (str constructed-file) (let* ((sexps (uiop:with-safe-io-syntax (:package :asdf-user) (uiop:read-file-forms str)))) (or (find-if #'(lambda (x) (and (listp x) (eq (car x) 'defsystem))) sexps) (error "Unable to find generated defsystem."))))) (defparameter *defsystem-sexpr* (load-constructed-asd-file)) (DBG "ASDF-created system definition is:") (DBG (format nil "~s" *defsystem-sexpr*)) (assert (equalp (second *defsystem-sexpr*) *test-system-name*)) (assert (eq (getf *defsystem-sexpr* :class) 'asdf/bundle:prebuilt-system)) (assert (equalp (getf *defsystem-sexpr* :components) #-(or clasp ecl mkcl) `((:compiled-file ,(format nil "~a--system" *test-system-name*))) #+(or clasp ecl mkcl) '((:COMPILED-FILE "deliver-bundle")))) #+(and (or clasp ecl mkcl) linux) (assert (equalp (getf *defsystem-sexpr* :lib) "deliver-bundle.a")) (assert (not (getf *defsystem-sexpr* :defsystem-depends-on))) (assert (equalp (getf *defsystem-sexpr* :depends-on) (list "test1")) nil "Dependencies for bundled system are incorrect.") (ignore-errors (delete-file *constructed-asdf-file*)) (operate 'monolithic-deliver-asd-op *test-system-name*) (setf *defsystem-sexpr* (load-constructed-asd-file)) (DBG "ASDF-created MONOLITHIC system definition is:") (DBG (format nil "~s" *defsystem-sexpr*)) (assert (equalp (second *defsystem-sexpr*) *test-system-name*)) (assert (eq (getf *defsystem-sexpr* :class) 'asdf/bundle:prebuilt-system)) (assert (equalp (getf *defsystem-sexpr* :components) #-(or clasp ecl mkcl) `((:compiled-file ,(format nil "~a--all-systems" *test-system-name*))) #+ (or clasp ecl mkcl) '((:COMPILED-FILE "deliver-bundle--all-systems")))) #+(and (or clasp ecl mkcl) linux) (assert (equalp (getf *defsystem-sexpr* :lib) "deliver-bundle--all-systems.a")) (assert (not (getf *defsystem-sexpr* :defsystem-depends-on))) (assert (not (getf *defsystem-sexpr* :depends-on))) asdf-3.3.4/test/test-bundle.script000066400000000000000000000111571362155115300171000ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) ;;;--------------------------------------------------------------------------- ;;; Check to see if the bundle functionality is doing something. ;;;--------------------------------------------------------------------------- (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (clear-system :test-asdf/bundle-1) (clear-system :test-asdf/bundle-2) (when (find-package :test-package) (delete-package :test-package)) #+(and os-macosx ecl) (leave-test "Bundle test doesn't work on Mac on this lisp." 0) #+abcl (when (and (member :abcl *features*) (os-macosx-p) ;; bundles don't work on pre-1.3.0 (second (third (sys::arglist 'directory)))) (leave-test "Bundle test doesn't work on Mac on this version of ABCL." 0)) #+(or (and ecl ecl-bytecmp) gcl) (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 'compile-bundle-op :test-asdf/bundle-1)) (defparameter *bundle-2* (output-file 'compile-bundle-op :test-asdf/bundle-2)) (defparameter *mono-bundle-2* (output-file 'monolithic-compile-bundle-op :test-asdf/bundle-2)) (DBG :test-bundle *bundle-1* *bundle-2*) (assert-equal (list *bundle-2*) (input-files 'load-bundle-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-bundle-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 "Unintern symbols, load the bundle, and check that the symbols are there again.") (set (find-symbol* :*file1* :test-package) nil) (set (find-symbol* :*file3* :test-package) nil) (assert-equal nil (symbol-value (find-symbol* :*file1* :test-package))) (assert-equal nil (symbol-value (find-symbol* :*file3* :test-package))) (load (output-file 'compile-bundle-op :test-asdf/bundle-1)) (assert-equal t (symbol-value (find-symbol* :*file1* :test-package))) (assert-equal t (symbol-value (find-symbol* :*file3* :test-package))) (DBG "Now for the mono-fasl") (operate 'monolithic-compile-bundle-op :test-asdf/bundle-2) (assert (probe-file *mono-bundle-2*)) (DBG "Unintern symbols, load the monolithic bundle, and check that the symbols are there again.") (set (find-symbol* :*file1* :test-package) nil) (set (find-symbol* :*file3* :test-package) nil) (assert-equal nil (symbol-value (find-symbol* :*file1* :test-package))) (assert-equal nil (symbol-value (find-symbol* :*file3* :test-package))) (load (output-file 'monolithic-compile-bundle-op :test-asdf/bundle-2)) (assert-equal t (symbol-value (find-symbol* :*file1* :test-package))) (assert-equal t (symbol-value (find-symbol* :*file3* :test-package))) #+(or ecl mkcl) (progn (DBG "On ECL and MKCL, test dll-op and monolithic-dll-op") (DBG "Test the pre-compiled system feature") (require 'sockets) (progn (DBG "Test that we didn't break require for non-asdf modules") (pop #+ecl ext:*module-provider-functions* #+mkcl mk-ext:*module-provider-functions*) (require 'serve-event)) (DBG "Create a DLL via dll-op") (operate 'dll-op :test-asdf/dll-test) (DBG "Load the DLL") (let ((dll (first (output-files 'dll-op :test-asdf/dll-test)))) (si:load-foreign-module dll) (DBG "Load a library that knows how to use the DLL") (let* (#+(and mkcl os-windows) (compiler::*builder-default-libraries* (list (namestring dll)))) (operate 'load-op :test-asdf/dll-user))) (DBG "Test that the DLL works") (assert-equal (sample-function) 42) (DBG "Create a DLL via monolithic-dll-op") (nest #+(and mkcl os-windows) (let* ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1))) (compiler::*builder-default-libraries* (list (namestring lib))))) (operate 'monolithic-dll-op :test-asdf/monodll)) (DBG "Use and test that DLL") (let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll)))) (si:load-foreign-module dll) (let* (#+(and mkcl os-windows) (compiler::*builder-default-libraries* (list (namestring dll)))) (operate 'load-op :test-asdf/monodll-user))) (assert-equal (always-42) 42)) ;;; TODO: test prebuilt-system. asdf-3.3.4/test/test-cache-for-introspection.script000066400000000000000000000060301362155115300223460ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Test to see that we are correctly caching information about system ;;; definitions ;;;--------------------------------------------------------------------------- (def-test-system test-weakly-depends-on :weakly-depends-on (file3-only) :components ((:file "file1"))) (def-test-system test-no-weakly-depends-on :components ((:file "file1"))) (def-test-system :versioned-system-3 :defsystem-depends-on ((:version :test-asdf/2 "2.1")) :pathname #.*test-directory* :version "1.2") (def-test-system :versioned-system-4 :defsystem-depends-on ((:version test-asdf/2 "2.1")) :pathname #.*test-directory* :version "1.2") (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)))))) (def-test-system :test-structured-depends :depends-on ((:version test-asdf/2 "2.1") :file3-only (:feature :foo (:require "blort"))) :components ((:file "file2" :depends-on ("foo")) (:module "foo" :pathname "" :components ((:file "file1") (:file "file4" :if-feature (:not :common-lisp)))))) (DBG "The weakly-depends-on information is properly cached") (assert (equal '("file3-only") (system-weakly-depends-on (find-system "test-weakly-depends-on")))) (assert (null (system-weakly-depends-on (find-system "test-no-weakly-depends-on")))) (DBG "The depends-on information is properly cached") (assert (null (system-depends-on (find-system "test-no-weakly-depends-on")))) (assert (equalp '("file3-only") (system-depends-on (find-system "test-concatenate-source")))) (DBG "The defsystem-depends-on information is properly cached") (assert (null (system-defsystem-depends-on (find-system "test-no-weakly-depends-on")))) (assert (equalp '((:version "test-asdf/2" "2.1")) (system-defsystem-depends-on (find-system :versioned-system-3)))) (assert (equalp '((:version "test-asdf/2" "2.1")) (system-defsystem-depends-on (find-system :versioned-system-4)))) (DBG "Test structured dependencies") (assert (equalp '((:version "test-asdf/2" "2.1") "file3-only" (:feature :foo (:require "blort"))) (system-depends-on (find-system :test-structured-depends)))) (DBG "Test removal of non-orthogonal feature syntax.") (assert (typep (catch 'error (handler-bind ((system-definition-error #'(lambda (e) (throw 'error e)))) (def-test-system :test-structured-depends-with-obsolete-feature-syntax :depends-on ((:version test-asdf/2 "2.1") :file3-only (feature :foo (:require "blort"))) :components ((:file "file2" :depends-on ("foo")) (:module "foo" :pathname "" :components ((:file "file1") (:file "file4" :if-feature (:not :common-lisp)))))))) 'system-definition-error)) asdf-3.3.4/test/test-cache.script000066400000000000000000000005221362155115300166640ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; Test to check that the cache doesn't upset error signaling from FIND-SYSTEM (in-package :asdf-test) (setf asdf::*asdf-session* nil) (setf *central-registry* nil) (asdf::clear-registered-systems) (assert-equal nil (find-system "test-asdf/force1" nil)) (errors missing-component (find-system "test-asdf/force1" t)) asdf-3.3.4/test/test-compile-file-failure.lisp000066400000000000000000000007201362155115300212560ustar00rootroot00000000000000(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) #+(or clasp ecl) (equal (compile-file-type) "fasc")) (error 'compile-file-error :description "faking it")) (warn "Warning.")) asdf-3.3.4/test/test-compile-file-failure.script000066400000000000000000000011331362155115300216120ustar00rootroot00000000000000;;; -*- Lisp -*- (def-test-system test-compile-file-failure :components ((:file "test-compile-file-failure"))) (assert (handler-case (let ((*compile-file-failure-behaviour* :warn)) (load-system 'test-compile-file-failure :force t) t) (compile-file-error () nil))) (reset-session) (with-expected-failure (#+gcl "GCL failure to report compile-file error") (assert (handler-case (let ((*compile-file-failure-behaviour* :error)) (load-system 'test-compile-file-failure :force t) nil) (compile-file-error () t)))) asdf-3.3.4/test/test-concatenate-source.lisp000066400000000000000000000003241362155115300210460ustar00rootroot00000000000000(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*) asdf-3.3.4/test/test-concatenate-source.script000066400000000000000000000025641362155115300214130ustar00rootroot00000000000000;;; -*- 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)))) (with-expected-failure (#+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))) asdf-3.3.4/test/test-configuration.script000066400000000000000000000141531362155115300204750ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf) (use-package :asdf-test) (import '(asdf-test::DBG)) (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 :supersede :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)) (defun dump-source-registry () (format t "~&Source Registry:~%") (loop :for k :being :each hash-key :of *source-registry* :using (hash-value v) :do (format t "~a --> ~a~%" k v))) (dump-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")) (DBG "Testing link farm found through source registry.") (defparameter *link-farm-directory* (under-tmp-directory "link-farm/")) (defun link-asd-files () (loop :for d :in *tmp-asd-directories* :for i :from 0 :as asd-file = (merge-pathnames* (format nil "foo~D.asd" i) d) :do (assert (probe-file asd-file)) (run-program (format nil "ln -s ~a ~a" (namestring asd-file) (namestring *link-farm-directory*))))) ;;; prepare for link farm test ;; clean up first (describe *link-farm-directory*) (when (uiop:directory-exists-p *link-farm-directory*) (uiop:delete-directory-tree *link-farm-directory* :validate (lambda (x) (subpathp x *tmp-directory*)))) ;; create the link farm (ensure-directories-exist *link-farm-directory*) (link-asd-files) ;;; test following symlinks (initialize-source-registry `(:source-registry (:include ,(namestring *link-farm-directory*)) :ignore-inherited-configuration)) (dump-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))) asdf-3.3.4/test/test-deferred-warnings.script000066400000000000000000000100021362155115300212210ustar00rootroot00000000000000;;; -*- 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-foo-with-wrapper :depends-on (:unintern-foo) :components ((:file "use-foo" :perform (compile-op :around (op c) (declare (ignorable op c)) (let ((asdf:*compile-file-warnings-behaviour* :error)) (call-next-method)))))) (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"))) (def-test-system :undefined-variables :components ((:file "fun-with-undefined-locals"))) (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))) (reset-session) (handler-bind ((error (lambda (c) (DBG :cfwbi-ufww c)))) (load-system :use-foo-with-wrapper :force t)) (reset-session) (handler-bind ((error (lambda (c) (DBG :cfwbi-usfo c)))) (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :use-setf-foo-only :force t))) (reset-session) (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)) (reset-session) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) (perform 'compile-op :use-foo-only) nil) (compile-warned-error () t))) (reset-session) (assert (handler-case (let ((*compile-file-warnings-behaviour* :error)) (perform 'compile-op :use-setf-foo-only) nil) (compile-warned-error () t))) (reset-session) (let ((*compile-file-warnings-behaviour* :error)) (load-system :use-then-defun-foo)) (setf *compile-file-warnings-behaviour* :error) (reset-session) (load-system :use-setf-then-defun-foo) ;; 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. (reset-session) (with-expected-failure (#+clozure "CCL warns while loading, not compiling") (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)))) (reset-session) (with-expected-failure (#+clozure "CCL warns while loading, not compiling") (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)))) (reset-session) (errors #+(or allegro clozure) compile-file-error #+(or cmucl scl) compile-warned-error #+sbcl compile-failed-error (let ((*compile-file-warnings-behaviour* :error)) (load-system :undefined-variables :force t))) (reset-session) (errors #+(or allegro clozure) compile-file-error #+(or cmucl scl) null #+sbcl compile-failed-error (let ((*compile-file-warnings-behaviour* :warning)) (load-system :undefined-variables :force t))) asdf-3.3.4/test/test-defsystem-depends-on-change.asd000066400000000000000000000005671362155115300223550ustar00rootroot00000000000000(defvar *tddoc* 0) (incf *tddoc*) (format t "tddoc loaded ~D time~:P.~%" *tddoc*) (if (= *tddoc* 1) (defsystem "test-defsystem-depends-on-change" :defsystem-depends-on ("test-asdf/dep-can-change" "test-asdf/dep-can-disappear")) (defsystem "test-defsystem-depends-on-change" :defsystem-depends-on ("test-asdf/dep-can-change" "test-asdf/dep-can-appear"))) asdf-3.3.4/test/test-defsystem-depends-on-change.script000066400000000000000000000053121362155115300231030ustar00rootroot00000000000000;;; -*- Lisp -*- ;; Testing proper stratification of defsystem-depends-on changes. (DBG "Test that when a defsystem-depends-on (indirect) dependency changes, the system is recompiled, yet that dependencies of the old definition that are not dependencies of the new definition are not recompiled.") ;; disable cache between those compilations. (setf asdf/session:*asdf-session* nil) (defparameter tddoc "test-defsystem-depends-on-change") (defparameter talc "test-asdf-location-change") (defparameter asdf-user::*tddoc* 0) (terpri)(terpri) (DBG "Load the system, using xach-foo-1") (push (subpathname *test-directory* "xach-foo-1/") *central-registry*) (clear-system tddoc) (load-system tddoc) (assert-equal asdf-user::*tddoc* 1) (assert-equal test-asdf-system::*times-loaded* 1) (assert-equal test-asdf-system::*ta/dcc* 1) (assert-equal test-asdf-system::*ta/dcd* 1) (assert-equal test-asdf-system::*ta/dca* 0) (assert-pathname-equal (subpathname *test-directory* "test-defsystem-depends-on-change.asd") (system-source-file tddoc)) (assert-pathname-equal (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (system-source-file talc)) (terpri)(terpri) (DBG "Load it again: there should be no changes") (load-system "test-defsystem-depends-on-change") (assert-equal asdf-user::*tddoc* 1) (assert-equal test-asdf-system::*times-loaded* 1) (assert-equal test-asdf-system::*ta/dcc* 1) (assert-equal test-asdf-system::*ta/dcd* 1) (assert-equal test-asdf-system::*ta/dca* 0) (assert-pathname-equal (subpathname *test-directory* "test-defsystem-depends-on-change.asd") (system-source-file tddoc)) (assert-pathname-equal (subpathname *test-directory* "xach-foo-1/test-asdf-location-change.asd") (system-source-file talc)) (DBG "Now, change a defsystem-depends-on dependency and try again") (setf (first *central-registry*) (subpathname *test-directory* "xach-foo-2/")) (DBG :before asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*) (load-system "test-defsystem-depends-on-change" :force '("test-asdf/dep-forced")) (DBG :after asdf-user::*tddoc* test-asdf-system::*times-loaded* test-asdf-system::*ta/dcc* test-asdf-system::*ta/dcd* test-asdf-system::*ta/dca*) (assert-equal asdf-user::*tddoc* 2) (assert-equal test-asdf-system::*times-loaded* 1) ;; from test-asdf.asd (assert-equal test-asdf-system::*ta/dcc* 2) (assert-equal test-asdf-system::*ta/dcd* 1) (assert-equal test-asdf-system::*ta/dca* 1) (assert-pathname-equal (subpathname *test-directory* "test-defsystem-depends-on-change.asd") (system-source-file tddoc)) (assert-pathname-equal (subpathname *test-directory* "xach-foo-2/test-asdf-location-change.asd") (system-source-file talc)) asdf-3.3.4/test/test-defsystem-depends-on-circular.asd000066400000000000000000000002011362155115300227150ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem "test-defsystem-depends-on-circular" :defsystem-depends-on ("test-defsystem-depends-on-circular")) asdf-3.3.4/test/test-defsystem-depends-on-missing-system.asd000066400000000000000000000001631362155115300241130ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem test-defsystem-depends-on-missing-system :defsystem-depends-on (nonexistent-system)) asdf-3.3.4/test/test-defsystem-depends-on-phase-overlap.script000066400000000000000000000045621362155115300244320ustar00rootroot00000000000000;;-*- Lisp -*- (in-package :asdf-test) (setf *central-registry* (list (subpathname *test-directory* "defsystem-depends-on/"))) (defvar *od* 0) (defvar *dd* 0) (defvar *id* 0) (defvar *ms* 0) (defvar *cod* 0) (defvar *cdd* 0) (defun reset-vars (&optional (x 0)) (setf *od* x *dd* x *id* x *ms* x *cod* x *cdd* x)) (assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 0 0 0 0)) (DBG "Finding main-system doesn't load defsystem-dependency") (reset-vars) (find-system "main-system") (assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 0 0 0 0)) (DBG "Finding intermediate-dependency does load defsystem-dependency") (reset-vars) (find-system "intermediate-dependency") (assert-equal (list *od* *dd* *id* *ms*) '(1 1 0 0)) (DBG "Loading main-system doesn't reload defsystem-dependency or overlapping-dependency") (reset-vars) (load-system "main-system") (assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 1 1 0 0)) (DBG "Loading main-system a second time doesn't reload anything") (reset-vars) (load-system "main-system") (assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(0 0 0 0 0 0)) (DBG "Loading main-system in a different session loads but doesn't recompile") (reset-vars) (asdf::clear-registered-systems) (load-system "main-system") (assert-equal (list *od* *dd* *id* *ms* *cod* *cdd*) '(1 1 1 1 0 0)) (DBG :foo (component-sideway-dependencies (find-system "intermediate-dependency")) (asdf::direct-dependencies 'prepare-op "intermediate-dependency") (asdf::direct-dependencies 'load-op "intermediate-dependency") (asdf::direct-dependencies 'compile-op "intermediate-dependency")) (DBG "Forcing overlapping-dependency causes a complete reload, but overlapping-dependency is only loaded once") (reset-vars) (with-asdf-session (:override t) (load-system "main-system" :force '("overlapping-dependency"))) (assert-equal (list *od* *dd* *id* *ms*) '(1 1 1 1)) (DBG "actions marked as needed at one level should still be planned if needed at a higher level") (reset-vars) (setf (find-class 'asdf::my-cl-source-file) nil) (asdf::clear-registered-systems) (assert-equal *dd* 0) (with-asdf-session (:override t) ;; get this (and asdf) out of the way, for simpler traces when tracing what matters. (load-system "overlapping-dependency") ;; This is what causes an issue without phase escalation: (test-system "defsystem-dependency")) (assert-equal *dd* 10) asdf-3.3.4/test/test-defsystem-depends-on.script000066400000000000000000000040611362155115300216600ustar00rootroot00000000000000;;-*- Lisp -*- (in-package :asdf-test) (def-test-system test-defsystem-depends-on-1 :defsystem-depends-on (test-asdf/l-file) :default-component-class "l-file:cl-source-file.l" :components ((:cl-source-file.l "file1" :type "lisp") (:cl-source-file "file2" :depends-on ("file1")) (:file "test-extension"))) (load-system :test-defsystem-depends-on-1) (def-test-system test-defsystem-depends-on-2 :defsystem-depends-on (test-asdf/l-operation) :build-operation "l-operation:op" :components ((:file "file3"))) (assert-equal 0 l-operation:*x*) (reset-session) (make :test-defsystem-depends-on-2) (assert-equal 2 l-operation:*x*) ;; perform called twice, on file and on system. (def-test-system test-defsystem-depends-on-3 :defsystem-depends-on (test-asdf/l-operation) :build-operation "does-not-exist" :components ((:file "file3"))) (reset-session) (signals asdf::formatted-system-definition-error (handler-bind ((system-out-of-date 'continue)) (make :test-defsystem-depends-on-3))) (defparameter *newsym* (gentemp (symbol-name 'feature) :keyword)) (reset-session) ;;; FIXME: the following form triggers bug https://bugs.launchpad.net/asdf/+bug/1445638 (eval `(def-test-system test-defsystem-depends-on-4 :defsystem-depends-on ((:feature ,*newsym* "test-defsystem-depends-on-3")))) (assert (find-system "test-defsystem-depends-on-4")) (progn (reset-session) (signals missing-dependency (def-test-system unloadable-system :defsystem-depends-on (nonexistent-system))) (assert (not (registered-system "unloadable-system")))) (progn (signals missing-dependency (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-missing-system"))) (assert (not (asdf::registered-system "test-defsystem-depends-on-missing-system")))) (progn (signals asdf::system-definition-error (handler-bind ((system-out-of-date 'continue)) (find-system "test-defsystem-depends-on-circular"))) (assert (not (asdf::registered-system "test-defsystem-depends-on-circular")))) asdf-3.3.4/test/test-defsystem-errors.script000066400000000000000000000020041362155115300211330ustar00rootroot00000000000000;;; -*- Lisp -*- (defun defsystem-error-handler (form &optional (error 'error)) (declare (ignore 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))) ;;; test for my kluge for cl-ppcre (assert (catch 'bad-name-warn (handler-bind ((bad-system-name #'(lambda (c) (declare (ignorable c)) (format t "~&Catching bad name warning: ~A~%" c) (throw 'bad-name-warn nil)))) (let ((asdf::*known-systems-with-bad-secondary-system-names* (list-to-hash-set '("test-bad-system-name")))) (find-system "test-bad-system-name"))))) asdf-3.3.4/test/test-defsystem-loop.script000066400000000000000000000002641362155115300205760ustar00rootroot00000000000000;;; -*- Lisp -*- (signals formatted-system-definition-error (def-test-system "foo" :perform ((test-op (o c))))) (leave-test "correctly detected ill-formed system definition." 0)asdf-3.3.4/test/test-deprecation.script000066400000000000000000000067061362155115300201300ustar00rootroot00000000000000;;-*- Lisp -*- (setf asdf::*asdf-version* "6.7.8") (DBG "Check still-valid code") (asdf::with-asdf-deprecation (:style-warning "7.0") (defun still-valid () t)) (does-not-signal deprecated-function-condition (eval '(still-valid))) (does-not-signal deprecated-function-condition (compile () '(lambda () (still-valid)))) (defmacro check-deprecation (condition name body) `(let ((c (signals ,condition (eval ',body)))) (assert-equal (deprecated-function-name c) ',name))) (defmacro check-deprecation-style-warning (condition name body) `(progn (check-deprecation ,condition ,name ,body) (nest #+(or abcl (and ecl ecl-bytecmp) mkcl) (does-not-signal condition) #+ccl (signals ccl::compiler-warning) #+clasp (signals CLEAVIR-CST-TO-AST:COMPILER-MACRO-EXPANSION-STYLE-WARNING) #-(or abcl clasp ccl (and ecl ecl-bytecmp) mkcl) (check-deprecation ,condition ,name) (compile () '(lambda () ,body))))) (defmacro check-deprecation-warning (condition name body) `(progn (check-deprecation ,condition ,name ,body) (nest #+(or abcl (and ecl ecl-bytecmp) mkcl) (does-not-signal condition) #+ccl (signals ccl::compiler-warning) #+clasp (signals CLEAVIR-CST-TO-AST:COMPILER-MACRO-EXPANSION-WARNING) #-(or abcl clasp ccl (and ecl ecl-bytecmp) mkcl) (check-deprecation ,condition ,name) (compile () '(lambda () ,body))))) (defmacro check-deprecation-error (condition name body) `(progn (check-deprecation ,condition ,name ,body) (nest #+allegro (signals style-warning) #+(or cmucl (and ecl (not ecl-bytecmp))) (signals c::compiler-error) #+clasp (signals COMPILER:COMPILER-MACRO-EXPANSION-ERROR-WARNING) #+(or (and ecl ecl-bytecmp) mkcl) (does-not-signal condition) #+sbcl (signals simple-warning) #-(or allegro clasp cmucl ecl mkcl sbcl) (check-deprecation ,condition ,name) (compile () '(lambda () ,body))))) (defmacro check-deprecation-delete (condition name body) `(progn (check-deprecation ,condition ,name ,body) (nest #+(or cmucl (and ecl (not ecl-bytecmp))) (signals c::compiler-error) #+clasp (signals CLEAVIR-CST-TO-AST:MACROEXPANSION-ERROR) #+mkcl (errors compiler:compiler-error) #+sbcl (signals sb-c:compiler-error) #-(or clasp cmucl (and ecl (not ecl-bytecmp)) mkcl sbcl) (check-deprecation ,condition ,name) (compile () '(lambda () ,body))))) (DBG "Check style-warning") (asdf::with-asdf-deprecation (:style-warning "6") (defun should-style-warn () t)) (check-deprecation-style-warning deprecated-function-style-warning should-style-warn (should-style-warn)) (DBG "Check warning") (asdf::with-asdf-deprecation (:style-warning "5") ;; next-version 6 is warning... (defun should-warn () t)) (check-deprecation-warning deprecated-function-warning should-warn (should-warn)) (DBG "Check error") (asdf::with-asdf-deprecation (:style-warning "6.5") ;; next- next-version 6.7 is error! (defun should-error () t)) (check-deprecation-error deprecated-function-error should-error (should-error)) (DBG "Check delete") (check-deprecation-delete deprecated-function-should-be-deleted (past-due-f past-due-m) (asdf::with-asdf-deprecation (:style-warning "6.7.1") ;; next- next- next-version 6.7.4 is delete! (defun past-due-f () t) (progn (foo)) (defgeneric past-due-gf ()) (defmethod past-due-m ()))) asdf-3.3.4/test/test-encodings.script000066400000000000000000000120761362155115300176010ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) (when (member :clisp *features*) (quit 0)) (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-session (: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"))))) #+ecl (unless (>= ext:+ecl-version-number+ 160000) (leave-test "This version of ECL is known to have broken encoding support" 0)) ;; 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* "ext/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) (with-expected-failure (#+lispworks "LispWorks doesn't have LATIN-2") ;; Check that it indeed still is broken before we punt. (with-encoding-test (:latin-2) (def-test-system :test-encoding-implicit-autodetect :components ((:file "lambda"))))) #+(or sbcl clasp) (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-expected-failure (#+clasp "Clasp fails here") (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")))))) asdf-3.3.4/test/test-extension.l000066400000000000000000000000001362155115300165530ustar00rootroot00000000000000asdf-3.3.4/test/test-file000066400000000000000000000003211362155115300152320ustar00rootroot00000000000000Single double entry triple word entry escape + escape - escape _ escape . escape , escape % escape @ escape : escape / escape \ escape ! escape & escape * escape [ escape ] escape ( escape ) escape { escape } asdf-3.3.4/test/test-force.script000066400000000000000000000157611362155115300167320ustar00rootroot00000000000000;;; -*- Lisp -*- (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (chdir *test-directory*) ;;(setf *defaut-pathname-defaults* *test-directory*) (clear-system 'test-asdf/force) (assert (not (component-loaded-p 'test-asdf/force))) (defun force-plan (&rest forcing-options) (asdf::make-plan nil 'load-op 'test-asdf/force :forcing (apply 'asdf::make-forcing :system 'test-asdf/force forcing-options))) (defvar *plan* nil) (defun component-out-of-date-p (component) (not (asdf::action-up-to-date-p *plan* (make-operation 'load-op) (find-component component nil :registered t)))) (defun plan-loads-p (component) (member (asdf::make-action (make-operation 'load-op) (find-component () component :registered t)) (asdf::plan-actions *plan*) :test 'equal)) (with-asdf-session (:override t :override-forcing t) (load-system 'test-asdf/force)) (assert (component-loaded-p 'test-asdf/force)) (assert-equal (asymval :*file3* :test-package) t) (assert-equal (asymval :*file4* :test-package) t) (assert-equal (asymval :*times-loaded* :test-asdf-system) 1) (assert-equal (asymval :*file3-only-asd-loaded* :asdf-user) 1) (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) (reset-session-visited) (defparameter *plan* (force-plan :force t)) (DBG "Check that :force t forces the current system but not its dependencies" *plan*) (assert (component-out-of-date-p '("test-asdf/force" "file4"))) (assert (not (component-out-of-date-p '("file3-only" "file3")))) (assert (not (component-out-of-date-p '("test-asdf/force1" "file1")))) (reset-session-visited) (defparameter *plan* (force-plan :force :all)) (DBG "Check that :force :all forces the current system and its dependencies" *plan*) (assert (asdf::plan-actions *plan*)) (assert (component-out-of-date-p '("test-asdf/force" "file4"))) (assert (component-out-of-date-p '("file3-only" "file3"))) (assert (component-out-of-date-p '("test-asdf/force1" "file1"))) (reset-session-visited) (defparameter *plan* (force-plan :force :all :force-not t)) (DBG "Check that :force-not takes precedence over :force, with t means \"all but current system\"" *plan*) (assert (asdf::plan-actions *plan*)) (assert (component-out-of-date-p '("test-asdf/force" "file4"))) (assert (not (component-out-of-date-p '("file3-only" "file3")))) (assert (not (component-out-of-date-p '("test-asdf/force1" "file1")))) (reset-session-visited) (defparameter *plan* (force-plan :force-not :all)) (DBG "Check that :force-not :all means \"all systems\"" *plan*) (assert (null (asdf::plan-actions *plan*))) (reset-session-visited) (defparameter *plan* (force-plan :force :all :force-not :all)) (DBG "Check that :force-not :all takes precedence over :force" *plan*) (assert (null (asdf::plan-actions *plan*))) (reset-session-visited) (defparameter *plan* (force-plan :force :all :force-not '(:test-asdf/force))) (DBG "Check that :force-not with a list takes precedence over :force" *plan*) (assert (null (asdf::plan-actions *plan*))) (reset-session-visited) (defparameter *plan* (force-plan :force :all :force-not '(:test-asdf/force1))) (DBG "Check that :force-not with a list takes precedence over :force, 2" *plan*) (assert (asdf::plan-actions *plan*)) (assert (component-out-of-date-p '("test-asdf/force" "file4"))) ;; transitively included via test-asdf/force1 test-asdf/only, which blocks the traversal (assert (not (plan-loads-p '("file3-only" "file3")))) (assert (component-out-of-date-p '("file3-only" "file3"))) (assert (not (component-out-of-date-p '("test-asdf/force1" "file1")))) (reset-session-visited) (let* ((asdf::*immutable-systems* (list-to-hash-set '("test-asdf/force1"))) (*plan* (force-plan :force :all))) (DBG "Check that immutable-systems will block forcing" *plan*) (assert (asdf::plan-actions *plan*)) (assert (component-out-of-date-p '("test-asdf/force" "file4"))) ;; transitively included via force1 test-asdf/only, which blocks the traversal (assert (not (plan-loads-p '("file3-only" "file3")))) (assert (component-out-of-date-p '("file3-only" "file3"))) (assert (not (component-out-of-date-p '("test-asdf/force1" "file1"))))) ;; unforced, date should stay same (touch-file "test-asdf.asd" :timestamp date1) (touch-file "file1.lisp" :timestamp date1) (touch-file file1 :timestamp date2) (setf test-package::*file1* :modified) (DBG "Check the fake dates from touch-file") (assert-equal (get-file-stamp "test-asdf.asd") date1) (assert-equal (get-file-stamp "file1.lisp") date1) (assert-equal (get-file-stamp file1) date2) (DBG "Check that require-system won't reload") (reset-session-visited) (with-asdf-session (:override t :override-forcing t) (require-system 'test-asdf/force1)) (assert-equal (get-file-stamp file1) date2) (assert-equal test-package::*file1* :modified) ;;; So far, only loaded things once (assert-equal test-asdf-system::*times-loaded* 1) (DBG "Check that load-system will reload") (reset-session-visited) (setf test-package::*file1* nil) (setf test-asdf-system::*times-loaded* 10) (assert (not test-package::*file1*)) (with-asdf-session (:override t :override-forcing t) (load-system 'test-asdf/force1)) (assert test-package::*file1*) ;;; This caused a second loading ;; NB: Somehow this is only 1 when using asdf-tools??? WTF? ;; running from asdf with test/ in paths vs running from test/ with no path prefix. ;;(assert-equal (asymval :*times-loaded* :test-asdf-system) 11) ;;TODO: understand what's going on above! ;; forced, it should be later (DBG "Check that force reloading loads again") (setf test-asdf-system::*times-loaded* 20) (reset-session-visited) (setf test-package::*file3* :reset) (with-asdf-session (:override t :override-forcing t) (load-system 'test-asdf/force :force :all)) (assert-compare (>= (- (get-file-stamp file1) file1-date) 0)) (assert-equal test-package::*file3* t) (DBG "Check that test-asdf.asd was loaded each time it was forced") (assert-equal test-asdf-system::*times-loaded* 21) (DBG "Check that file3-only.asd was loaded only twice, with the :force :all") (assert-equal asdf-user::*file3-only-asd-loaded* 2) (DBG "Check that require-system called with touched .asd won't reload the asdf.") (setf test-asdf-system::*times-loaded* 30) (setf test-package::*file3* :reset) (reset-session-visited) (with-asdf-session (:override t :override-forcing t) (unset-asdf-cache-entry '(find-system "test-asdf")) (unset-asdf-cache-entry '(find-system "test-asdf/force")) (touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1))) (require-system 'test-asdf/force)) (assert-equal test-asdf-system::*times-loaded* 30) (assert-equal test-package::*file3* :reset) (DBG "Check that require-system called with untouched .asd won't reload the asdf.") (reset-session-visited) (with-asdf-session (:override t :override-forcing t) (require-system 'test-asdf/force)) ;; Somehow, it loads the system... (assert-equal test-asdf-system::*times-loaded* 30) (assert-equal test-package::*file3* :reset) asdf-3.3.4/test/test-include1.asd000066400000000000000000000010431362155115300165670ustar00rootroot00000000000000;;;--------------------------------------------------------------------------- ;;; Sample system to test inclusion of lines from other files and ;;; correct reasoning about system modifications. ;;;--------------------------------------------------------------------------- (defsystem test-include :version (:read-file-form "../build/random-version.lisp-expr") :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")))asdf-3.3.4/test/test-include2.asd000066400000000000000000000010441362155115300165710ustar00rootroot00000000000000;;;--------------------------------------------------------------------------- ;;; Sample system to test inclusion of lines from other files and ;;; correct reasoning about system modifications. ;;;--------------------------------------------------------------------------- (defsystem test-include :version (:read-file-form "../build/random-version2.lisp-expr") :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")))asdf-3.3.4/test/test-inline-methods.script000066400000000000000000000014741362155115300205470ustar00rootroot00000000000000;;; -*- 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 - *a* = ~S~%~%" (action-description o c) *a*))) (:file "file2" :depends-on ("file1") :perform (load-op (o c) (incf *a*) (format t "Method run for ~A - *a* = ~S~%" (action-description o c) *a*) (call-next-method))))) ;;; Note: not calling load-system, because on ECL that could end up being a load-fasl-op, ;;; and at most the file1 load-op happen, whereas the file2 .o is linked and never loaded ;;; (the linked fasl, on the other hand, will be loaded, but won't trigger the inline method). (operate 'load-op :foo) (assert-equal *a* 2) asdf-3.3.4/test/test-logical-pathname.asd000066400000000000000000000001341362155115300202700ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem test-logical-pathname :components ((:file "logical-file"))) asdf-3.3.4/test/test-logical-pathname.script000066400000000000000000000050011362155115300210230ustar00rootroot00000000000000;;; -*- Lisp -*- (defun wild (&rest keys) (apply 'make-pathname :defaults (wilden *asdf-directory*) keys)) (setf (logical-pathname-translations "ASDF") `(("**;*.asd.*" ,(wild :type "asd")) ("**;*.lisp.*" ,(wild :type "lisp")) ("**;*.*.*" ,(resolve-location `(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf") :wilden t)))) (setf asdf/session:*asdf-session* nil) (DBG :logical (logical-pathname-translations "ASDF") (translate-logical-pathname "ASDF:test;test-logical-pathname.asd") (truename "ASDF:test;test-logical-pathname.asd") (translate-logical-pathname "ASDF:test;test-logical-pathname.lisp") (translate-logical-pathname "ASDF:test;test-logical-pathname.fasl")) #+(or gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0) (DBG "Test logical pathnames in central registry") (clear-system :test-logical-pathname) (setf *central-registry* '(#p"ASDF:test;")) (assert (logical-pathname-p (first *central-registry*))) (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (DBG "loading" (load-system :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) #+abcl (leave-test "ABCL translates logical pathnames in *LOAD-PATHNAME*" 0) #+clisp (unless (version<= "2.50" (first (split-string (lisp-implementation-version) :separator "-+ "))) (leave-test "CLISP 2.49 translates logical pathnames in *LOAD-PATHNAME*" 0)) (defparameter sys (find-system :test-logical-pathname)) (with-expected-failure (#+clasp "Clasp fails here") (assert (logical-pathname-p (component-pathname sys)))) (assert (logical-pathname-p (system-source-file sys))) (DBG "Done") asdf-3.3.4/test/test-macosx.script-ignore000066400000000000000000000005051362155115300203750ustar00rootroot00000000000000;;; -*- 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)) asdf-3.3.4/test/test-missing-lisp-file.script000066400000000000000000000027541362155115300211650ustar00rootroot00000000000000;;; -*- 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)))) asdf-3.3.4/test/test-module-depend.asd000066400000000000000000000003761362155115300176150ustar00rootroot00000000000000(defsystem :test-module-depend :components ((:file "file1") (:module "quux" :pathname "" :depends-on ("file1") :components ((:file "file2") (:module "file3mod" :pathname "" :components ((:file "file3"))))))) asdf-3.3.4/test/test-module-depend.script000066400000000000000000000030231362155115300203420ustar00rootroot00000000000000;;; -*- Lisp -*- (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (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 file1-date) (assert 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)) (reset-session-visited) (load-system 'test-module-depend) (assert-compare (>= (- (get-file-stamp file2.fasl) file3-date) 0)) ;; does this properly go to the second level? (assert-compare (>= (- (get-file-stamp file3.fasl) file3-date) 0)) asdf-3.3.4/test/test-module-excessive-depend.script000066400000000000000000000071171362155115300223460ustar00rootroot00000000000000;;; -*- 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. ;;;--------------------------------------------------------------------------- (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (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-compare (>= (file-write-date file1) before)) (assert-compare (>= (file-write-date file2) before)) (unless (= (file-write-date file3) file3-date) (error "Excessive compilation of file3.lisp: traverse bug.")) asdf-3.3.4/test/test-module-pathnames.script000066400000000000000000000034761362155115300210770ustar00rootroot00000000000000;;; -*- 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") asdf-3.3.4/test/test-modules-serial.asd000066400000000000000000000005071362155115300200140ustar00rootroot00000000000000;;; -*- 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"))))) asdf-3.3.4/test/test-modules.asd000066400000000000000000000004371362155115300165410ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-modules :components ((:module "a" :pathname "." :components ((:file "file1"))) (:module "b" :pathname "b" :depends-on ("a") :components ((:file "file2"))))) asdf-3.3.4/test/test-multiple.asd000066400000000000000000000006071362155115300167230ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem test-multiple :components ((:file "file3"))) (defsystem test-multiple-too :components ((:file "file1") (:file "file2" :depends-on ("file1")))) (defsystem test-multiple-free :depends-on (:test-multiple :test-multiple-dep) :components ((:file "file4"))) (defsystem test-multiple-dep :depends-on (:test-multiple) :components ((:file "file3"))) asdf-3.3.4/test/test-multiple.script000066400000000000000000000063321362155115300174610ustar00rootroot00000000000000;;; -*- Lisp -*- (defparameter asd (subpathname *test-directory* "test-multiple.asd")) (defparameter asd2 (subpathname *test-directory* "test-multiple-too.asd")) (defparameter file4 (test-fasl "file4")) (setf *central-registry* `(,*test-directory*)) ;; Don't rely on ln -s because of Windows. ;; Also allows pathname tests to distinguish between asd and asd2 (delete-file-if-exists asd2) (concatenate-files (list asd) asd2) ;; don't use copy-file, to ensure the timestamp of asd2 is newer. (defmacro with-bad-system-names (&body body) `(handler-bind ((bad-system-name #'(lambda (c) (muffle-warning c)))) ,@body)) (with-asdf-session () (DBG "Loading test-multiple-too, a copy of test-multiple") (with-bad-system-names (oos 'load-source-op 'test-multiple-too)) (assert (asymval :*file2* :test-package)) (assert (not (asymval :*file4* :test-package))) ;; file4 from test-multiple-free is not loaded ;; All systems loaded from test-multiple-too.asd (assert-pathname-equal (system-source-file (registered-system 'test-multiple)) asd2) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-too)) asd2) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-dep)) asd2) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-free)) asd2)) (with-asdf-session () (DBG "Loading test-multiple-free, a badly named secondary system that depends on test-multiple (that was loaded as badly named from test-multiple-too). It shouldn't be found by path, so the existing definition will be used, which will pull test-multiple, which will in turn override test-multiple-too, but test-multiple-free will be locked to the value at the beginning of the session, which uses test-multiple-too.asd (ouch).") (with-bad-system-names (load-system 'test-multiple-free)) (assert (probe-file* file4)) (assert (asymval :*file4* :test-package)) ;; file4 from test-multiple-free is loaded ;; All systems loaded from test-multiple.asd except test-multiple-free stuck with test-multiple-too.asd (assert-pathname-equal (system-source-file (registered-system 'test-multiple)) asd) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-too)) asd) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-dep)) asd) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-free)) asd2)) (with-asdf-session () (DBG "Loading test-multiple-free again. [I admit I don't fully understand the behavior -fare]") (setf test-package::*file4* nil) (with-bad-system-names (DBG :l (asdf/plan:plan-actions (nth-value 1 (oos 'load-op 'test-multiple-free))))) ;; All systems loaded from test-multiple-too.asd [I'm not sure why; it may have to do with timestamp (!) -fare] (assert-pathname-equal (system-source-file (registered-system 'test-multiple)) asd2) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-too)) asd2) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-dep)) asd2) (assert-pathname-equal (system-source-file (registered-system 'test-multiple-free)) asd2) ;; The above unexpected reloading of asd causes file4 to be reloaded (assert-equal test-package::*file4* t)) asdf-3.3.4/test/test-mutual-redefinition-1.asd000066400000000000000000000004531362155115300212110ustar00rootroot00000000000000;; This file defines test-mutual-redefinition-1 but ALSO defines test-mutual-redefinition-2 ;; There would be an infinite loop if find-system didn't specifically avoid ;; loading a definition twice in the same "session". (defsystem test-mutual-redefinition-1) (defsystem test-mutual-redefinition-2) asdf-3.3.4/test/test-mutual-redefinition-2.asd000066400000000000000000000002521362155115300212070ustar00rootroot00000000000000;; This file defines test-mutual-redefinition-2 but ALSO defines test-mutual-redefinition-1 (defsystem test-mutual-redefinition-1) (defsystem test-mutual-redefinition-2) asdf-3.3.4/test/test-mutual-redefinition.script000066400000000000000000000060161362155115300216110ustar00rootroot00000000000000;;-*- Lisp -*- (setf *asdf-session* nil) (defun current-system-source-file (x) (system-source-file (asdf::registered-system x))) #+abcl (setf jvm::*resignal-compiler-warnings* t) (with-asdf-session (:override t) (terpri) (DBG "Loading test-mutual-redefinition-1") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) (setf warned-p t) (format t "Caught bad-system-name condition: ~A~%" c) (assert-equal (component-name c) "test-mutual-redefinition-2") (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-1")))) (load-system 'test-mutual-redefinition-1)) (assert warned-p)) (assert-pathname-equal (test-source "test-mutual-redefinition-1.asd") (current-system-source-file "test-mutual-redefinition-1")) (assert-pathname-equal (test-source "test-mutual-redefinition-1.asd") (current-system-source-file "test-mutual-redefinition-2")) (terpri) (DBG "Loading test-mutual-redefinition-2 in the same cache session. Looking for its definition should trigger a DEFINE-OP and cause the asd paths to be affected.") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) (setf warned-p t) (format t "Caught bad-system-name condition: ~A~%" c) (assert-equal (component-name c) "test-mutual-redefinition-1") (assert-equal (pathname-name (system-source-file c)) "test-mutual-redefinition-2")))) (load-system 'test-mutual-redefinition-2)) (assert warned-p)) (assert-pathname-equal (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-2")) (assert-pathname-equal (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-1")) (terpri) (DBG "Loading test-mutual-redefinition-1 again in the same cache session. It should be considered already loaded.") (let ((warned-p nil)) (handler-bind ((bad-system-name (lambda (c) (setf warned-p t)))) (load-system 'test-mutual-redefinition-2)) (assert (not warned-p))) (assert-pathname-equal (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-2")) (assert-pathname-equal (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-1"))) (with-asdf-session (:override t) (terpri) (DBG "loading test-mutual-redefinition-2 in a different cache session") (load-system 'test-mutual-redefinition-2) (assert-pathname-equal (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-2")) (assert-pathname-equal (test-source "test-mutual-redefinition-2.asd") (current-system-source-file "test-mutual-redefinition-1"))) asdf-3.3.4/test/test-nested-1.lisp000066400000000000000000000000301362155115300166760ustar00rootroot00000000000000(in-package :asdf-test) asdf-3.3.4/test/test-nested-components.script000066400000000000000000000017751362155115300213010ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; check that added nesting via modules doesn't confuse ASDF (def-test-system test-nested-components-a :components ((:module "nested-components" :pathname "" :components ((:file "test-nested-1"))))) (def-test-system test-nested-components-b :components ((:file "test-nested-1"))) (def-test-system db-agraph-preflight :components ((:module "preflight-checks" :components ((:file "preflight"))))) (defsystem db-agraph-preflight-2 :pathname "preflight-checks" :source-file nil :components ((:file "preflight"))) (writeln (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) (writeln (list (traverse 'load-op 'test-nested-components-a) (traverse 'load-op 'test-nested-components-b))) |# asdf-3.3.4/test/test-never-done.script000066400000000000000000000021641362155115300176670ustar00rootroot00000000000000;;; -*- mode: common-lisp; -*- (DBG "Verify that system loads correctly at first.") (load-system "test-operation-done-p") (assert (find-package :test-package)) (assert (and (symbol-value (find-symbol* '*file1* :test-package)) (symbol-value (find-symbol* '*file2* :test-package)))) (assert-equal (symbol-value (find-symbol* '*f2c* :test-package)) 1) (DBG "System successfully loaded: modifying defined variables") (setf (symbol-value (find-symbol* '*file1* :test-package)) nil) (setf (symbol-value (find-symbol* '*file2* :test-package)) nil) (setf (symbol-value (find-symbol* '*f2c* :test-package)) 0) (assert (not (or (symbol-value (find-symbol* '*file1* :test-package)) (symbol-value (find-symbol* '*file2* :test-package))))) (assert-equal (symbol-value (find-symbol* '*f2c* :test-package)) 0) (DBG "Reloading system") (load-system "test-operation-done-p") (assert (and (symbol-value (find-symbol* '*file1* :test-package)) (symbol-value (find-symbol* '*file2* :test-package)))) (assert-equal (symbol-value (find-symbol* '*f2c* :test-package)) 1) (DBG "Reloading system re-established values") asdf-3.3.4/test/test-operation-classes.script000066400000000000000000000052651362155115300212650ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Test that we can successfully create new subclasses of OPERATION and that we ;;; can detect bad subclasses of OPERATION. ;;;--------------------------------------------------------------------------- (in-package :asdf) (use-package :asdf-test) (defparameter *good-classes* '(build-op compile-bundle-op compile-concatenated-source-op compile-op concatenate-source-op deliver-asd-op dll-op image-op lib-op load-bundle-op load-compiled-concatenated-source-op load-concatenated-source-op load-op load-source-op monolithic-compile-concatenated-source-op monolithic-concatenate-source-op monolithic-deliver-asd-op monolithic-dll-op monolithic-lib-op monolithic-load-compiled-concatenated-source-op monolithic-load-concatenated-source-op prepare-bundle-op prepare-op prepare-source-op program-op test-op) "All of these classes should be instantiable without error.") (defclass my-unupdated-operation (operation) ()) (defclass my-good-operation (downward-operation) ()) (defclass my-incoherent-operation (downward-operation non-propagating-operation) ()) (dolist (class *good-classes*) (assert (make-operation class))) (signals operation-definition-warning (make-operation 'my-unupdated-operation)) (with-expected-failure (#+gcl "GCL has trouble with CLOS?") (signals operation-definition-error (make-operation 'my-incoherent-operation))) (assert (make-operation 'my-good-operation)) ;; This test exercises the backward-compatibility mechanism of operation, ;; whereby traditional unqualified operations are implicitly downward and sideward (defclass trivial-operation (operation) ()) (assert-equal (loop :for (o . c) :in (traverse 'trivial-operation '(:test-asdf/test-module-depend "quux")) :collect (cons (type-of o) (component-find-path c))) '((trivial-operation "test-asdf/test-module-depend" "file1") (trivial-operation "test-asdf/test-module-depend" "quux" "file2") (trivial-operation "test-asdf/test-module-depend" "quux" "file3mod" "file3") (trivial-operation "test-asdf/test-module-depend" "quux" "file3mod") (trivial-operation "test-asdf/test-module-depend" "quux"))) (operate 'trivial-operation 'test-asdf/test-module-depend) ;;; this test intended to catch a bug in operate :around method in operate.lisp, ;;; thanks to Jan Moringen [2014/08/10:rpg] (operate (make-operation 'trivial-operation) 'test-asdf/test-module-depend) ;;; operations should only be made by MAKE-OPERATION, and now we enforce this. (signals system-definition-error (make-instance 'load-op)) asdf-3.3.4/test/test-operation-done-p.asd000066400000000000000000000005001362155115300202400ustar00rootroot00000000000000(defclass never-done (cl-source-file) ()) (defmethod operation-done-p ((op load-op) (c never-done)) nil) (defmethod operation-done-p ((op compile-op) (c never-done)) nil) (defsystem "test-operation-done-p" :serial t :default-component-class never-done :components ((:file "file1") (:file "file2"))) asdf-3.3.4/test/test-package.asd000066400000000000000000000007131362155115300164610ustar00rootroot00000000000000;;; 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"))))) asdf-3.3.4/test/test-package.script000066400000000000000000000004421362155115300172150ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; Testing that defclass module doesn't interfere with use of :module in defsystem. (in-package :cl-user) (defun module () 1) (asdf::load-asd (asdf-test:test-source "test-package.asd")) (defclass module () ()) (asdf::load-asd (asdf-test:test-source "test-package.asd")) asdf-3.3.4/test/test-preloaded.script000066400000000000000000000031101362155115300175540ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) (reset-session) (DBG "Consider a system that does not exist. Loading it fails.") (assert (null (find-system :this-system-does-not-exist nil))) (errors missing-component (load-system :this-system-does-not-exist)) (DBG "Now let's register it as preloaded. Loading it will work!") (register-preloaded-system :this-system-does-not-exist :version "3.14") ;; Eagerly registered since 3.1.7.20. See gitlab merge request 13 for the full story. (assert (registered-system :this-system-does-not-exist)) (load-system :this-system-does-not-exist) ;; We can load it indeed, though it's a NOP. (DBG "Now let's load a simple system. It should create a package.") (load-system :test-asdf/1) (assert (find-package :test-package)) (DBG "Destroy the package, clear the system and load it again. The package should be back.") (delete-package :test-package) (clear-system :test-asdf/1) (load-system :test-asdf/1) (assert (find-package :test-package)) (DBG "Destroy the package, clear the system, and register it as immutable. Try loading it again.") (DBG "The package should NOT be back, because it's immutable thus it's NOT going to be loaded.") (delete-package :test-package) (clear-system :test-asdf/1) (assert (null (registered-system :test-asdf/1))) ;; not registered as loaded (register-immutable-system :test-asdf/1) (assert (registered-system :test-asdf/1)) ;; now it's registered as loaded (load-system :test-asdf/1) (assert (registered-system :test-asdf/1)) ;; and it is "loaded" indeed! (assert (null (find-package :test-package))) ;; but the source code wasn't loaded asdf-3.3.4/test/test-program.script000066400000000000000000000207501362155115300172750ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG :foo (current-lisp-file-pathname)) (unless (or #+(or allegro (and clisp os-unix) clozure cmucl (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t) (DBG "Creating images is not supported on your CL implementation") (leave-test "Skipping test" 0)) (when (or #+clisp t) (DBG "clisp does not reliably run test-program.") (leave-test "Skipping test" 0)) #+(and sbcl openbsd) (let ((version (run-program "uname -r" :output '(:string :stripped t)))) (when (version-satisfies version "6.0") (DBG "Running on OpenBSD >=6.0. Checking this partition for wxallowed.") (let* ((df-line (second (uiop:run-program (list "df" "-P" (native-namestring *build-directory*)) :output :lines))) (device (first (split-string df-line)))) (dolist (mount-line (uiop:run-program "mount" :output :lines)) (let ((mount-device (first (split-string mount-line)))) (when (and (string= device mount-device) (not (search "wxallowed" mount-line))) (leave-test "Skipping test: wxallowed not set" 0))))))) (assert (find-system :hello-world-example)) ;; Try to load lisp-invocation from ext/ or from the user environment. (initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) (:directory (,*asdf-directory* "uiop/")) (:tree (,*asdf-directory* "ext/")) :inherit-configuration)) (unless (find-system :lisp-invocation nil) (leave-test "Couldn't find lisp-invocation. Probably your ASDF ext/ directory needs submodule update." 1)) (unless (version-satisfies (find-system "lisp-invocation") "1.0.12") (leave-test "Lisp-invocation library isn't new enough to test successfully. Probably your ASDF ext/ directory needs submodule update." 1)) (load-system "lisp-invocation/all") ;; Disable any user source registry. (initialize-source-registry `(:source-registry :ignore-inherited-configuration)) (defun make-hello-world (kind) (assert-equal 0 (nth-value 2 (lisp-invocation:invoke-lisp :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant) :cross-compile nil :console t :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")) :eval (format nil "(asdf-test::make-hello-~(~a~))" kind) :run-program-args `(:input nil :ignore-error-status t :output (,*standard-output* :linewise t :prefix "stdout: ") :error-output (,*error-output* :linewise t :prefix "stderr: ")))))) (progn (DBG "test image-op") (defparameter img (output-file (make-operation 'image-op) (find-system :hello-world-example))) (assert (absolute-pathname-p img)) (delete-file-if-exists img) (DBG "- first create an executable image") (make-hello-world 'image) #+cmucl (unless (probe-file* img) (leave-test "CMUCL seemingly can't find the 32-bit compiler and libraries required to dump images. Aborting test." 0)) (assert (probe-file* img) () "Can't find image file ~S" img) (DBG "- then use this executable image") (assert-equal (nest #+lispworks (last) (lisp-invocation:invoke-lisp :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant) :cross-compile nil :image-path (native-namestring img) :console t :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" :run-program-args '(:output :lines :error-output t))) '("hello, world")) (DBG "- now, use this executable image with arguments") #-(or lispworks scl) ;; These can't be passed arguments the normal way (assert-equal (lisp-invocation:invoke-lisp :implementation-type (lisp-invocation/allegro-variants:current-lisp-variant) :image-path (native-namestring img) :cross-compile nil :console t :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" :arguments '("a" "b c" "d") :run-program-args '(:output :lines :error-output t)) '("hello, world" "You passed 3 arguments:" " \"a\"" " \"b c\"" " \"d\""))) (progn (DBG "test program-op") (unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t #+cmucl 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)) (delete-file-if-exists exe) (DBG "- first, create the standalone program") (make-hello-world 'program) (assert (probe-file* exe) () "Can't find executable file ~S" exe) (DBG "- use that standalone program") (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t) '("hello, world")) (DBG "- use that standalone program with arguments") (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t) '("hello, world" "You passed 3 arguments:" " \"a\"" " \"b c\"" " \"d\""))) #+(or ecl mkcl) (progn (DBG "Now create an program without UIOP") #+mkcl (assert (probe-file* (asdf/bundle::system-module-pathname "uiop"))) (assert (probe-file* (asdf/bundle::system-module-pathname "asdf"))) #+ecl (assert (probe-file* (asdf/bundle::system-module-pathname "cmp"))) (def-test-system hello-no-uiop :class program-system :no-uiop t :components ((:file "file1")) :epilogue-code (progn (format t "~:[Look ma, no UIOP~;Oops, UIOP~]!~%" (find-package :uiop)) (format t "~:[But no TEST-PACKAGE :-(~;And TEST-PACKAGE~]!~%" (find-package :test-package)) (format t "~:[And no ASDF~;But ASDF :-( ~]!~%" (find-package :asdf)) #+ecl (si:quit 0) #+mkcl (mk-ext:quit :exit-code 0))) (DBG :run (output-file 'program-op 'hello-no-uiop) (component-depends-on 'program-op 'hello-no-uiop) (input-files 'program-op 'hello-no-uiop) (component-depends-on 'lib-op 'hello-no-uiop) (input-files 'lib-op 'hello-no-uiop) (asdf/bundle::linkable-system "hello-no-uiop")) (operate 'program-op 'hello-no-uiop :force t) (assert-equal (run-program `(,(native-namestring (output-file 'program-op 'hello-no-uiop))) :output :lines :error-output t) '("Look ma, no UIOP!" "And TEST-PACKAGE!" "And no ASDF!")) (DBG "Now create an program with explicit ASDF dependency, without registered ASDF (use implementation-provided prebuilt)") (clear-system :asdf) (setf *central-registry* nil) (initialize-source-registry `(:source-registry :ignore-inherited-configuration)) (DBG :foo (system-source-file :asdf)) (assert-pathname-equal (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf")))) (truename (subpathname (lisp-implementation-directory) #+mkcl "contrib/" #-mkcl nil))) (def-test-system hello-asdf :class program-system :depends-on ("asdf") :components ((:file "file1")) :epilogue-code (progn (format t "~:[~Oops, no ASDF~;Look ma, ASDF~]!~%" (find-package :asdf)) (format t "~:[But no TEST-PACKAGE :-( ~;And TEST-PACKAGE~]!~%" (find-package :test-package)) (uiop:quit 0))) (operate 'program-op 'hello-asdf :force t) (DBG :run (output-file 'program-op 'hello-asdf)) (assert-equal (run-program `(,(native-namestring (output-file 'program-op 'hello-asdf))) :output :lines :error-output t) '("Look ma, ASDF!" "And TEST-PACKAGE!")) (DBG "Now create an program with explicit ASDF dependency") (register-directory *asdf-directory*) (load-asd (subpathname *asdf-directory* "asdf.asd")) ;; force re-loading ASDF, from source (with-asdf-session (:override t) (assert-pathname-equal (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf")))) (truename (resolve-output "asdf/"))) (operate 'program-op 'hello-asdf :force t) (DBG :run (output-file 'program-op 'hello-asdf)) (assert-equal (run-program `(,(native-namestring (output-file 'program-op 'hello-asdf))) :output :lines :error-output t) '("Look ma, ASDF!" "And TEST-PACKAGE!")))) ;;; TODO: include a regular system dependency and a prebuilt-system in the executable. asdf-3.3.4/test/test-read-depends.script000066400000000000000000000142461362155115300201640ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; --------------------------------------------------------------------------- ;;; Test to make sure that an update to included files causes a reload ;;; of the system definition. ;;; --------------------------------------------------------------------------- (in-package :asdf-test) ;; I don't know what this does or when it's necessary ;; (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (defparameter *tmp-directory* (subpathname *asdf-directory* "build/")) ;;(defparameter *test-directory* (subpathname *asdf-directory* "test/")) (push *test-directory* *central-registry*) (defun under-tmp-directory (designator &optional (defaults *tmp-directory*)) (namestring (subpathname defaults designator))) (defun under-test-directory (designator &optional (defaults *test-directory*)) (namestring (subpathname defaults designator))) (defun copy-file-the-hard-way (source dest) (with-open-file (sourcestr source) (with-open-file (deststr dest :direction :output :if-exists :supersede) (loop :for line = (read-line sourcestr nil nil) :while line :do (format deststr "~a~%" line)))) (values)) (defparameter *version-file* (under-tmp-directory "random-version.lisp-expr")) ;; (trace asdf/component:additional-input-files asdf/parse-defsystem::record-additional-system-input-file) ;;; write an initial version file (unwind-protect (progn (with-open-file (str *version-file* :direction :output :if-exists :supersede) (format str "\"1.0\"~%")) (copy-file-the-hard-way (under-test-directory "test-include1.asd") (under-test-directory "test-include.asd")) (DBG "Set up test-include system definition:" (probe-file (under-test-directory "test-include.asd"))) (asdf:load-system "test-include") (let ((system (asdf:find-system "test-include"))) (DBG "On initial load, the system version is" (component-version system)) (DBG "After initial load the input files for the define op are:" (input-files (make-operation 'define-op) system)) ;; read the initial version information correctly... (assert-equal (asdf:component-version system) "1.0")) (DBG "*******Initial load successful*******") (sleep 2) (DBG "*******Reloading*******") ;;(trace asdf/plan::action-up-to-date-p) ;; (trace asdf/action::component-operation-time) ;; #+allegro #+allegro ;; (trace (asdf:input-files :inside asdf/plan::compute-action-stamp) ;; (asdf/plan::timestamp<= :inside asdf/plan::compute-action-stamp) ;; (asdf/plan::get-file-stamp :inside asdf/plan::compute-action-stamp)) ;;; bump the version (with-open-file (str *version-file* :direction :output :if-exists :supersede) (format str "\"2.0\"~%")) (asdf:load-system "test-include") (let ((system (asdf:find-system "test-include"))) (DBG "After reload, system version is" (asdf:component-version system)) ;; read the initial version information correctly... (assert-equal (asdf:component-version system) "2.0"))) (sleep 2) (DBG "*******Using new input file*******") (let ((version-file (under-tmp-directory "random-version2.lisp-expr"))) (unwind-protect ;; swap system definitions with different read file versions (progn (copy-file-the-hard-way (under-test-directory "test-include2.asd") (under-test-directory "test-include.asd")) (with-open-file (str version-file :direction :output :if-exists :supersede) (format str "\"3.0\"~%")) (DBG "Test-include ASDF file write date" (uiop:safe-file-write-date (under-test-directory "test-include.asd"))) (DBG "version file write date" (uiop:safe-file-write-date (under-tmp-directory "random-version2.lisp-expr"))) ;;; the following establishes that it is NOT the fault of ;;; DEFINITION-DEPENDENCIES-UP-TO-DATE-P [2017/07/12:rpg] #+allegro (trace (asdf/find-system::definition-dependencies-up-to-date-p :inside asdf:find-system) (asdf/find-system::get-file-stamp :inside find-system) (asdf/find-system::timestamp<= :inside find-system)) ;; AFAICT, the :WHEREIN in SBCL TRACE does not work ;; properly. In my copious free time, I should see if I ;; can find a minimal test case. [2017/07/12:rpg] #+sbcl (trace asdf/find-system::definition-dependencies-up-to-date-p ;; :wherein asdf:find-system ) (DBG "operation time stamp for define-op before reload" (asdf/action:component-operation-time (asdf:make-operation 'define-op) (asdf:find-system "test-include"))) ;; this is NOT why this is broken on ACL... #+ignore (DBG "ASDF thinks the operation is done?" (asdf:operation-done-p (make-operation 'define-op) (find-system "test-include"))) ;; (trace asdf/action:compute-action-stamp asdf:make-plan) ;; (trace asdf/plan::perform-plan asdf/plan::action-already-done-p) (asdf:load-system "test-include") (let ((system (find-system "test-include"))) (assert-equal (asdf:component-version system) "3.0") (assert-pathnames-equal (asdf:input-files (asdf:make-operation 'asdf:define-op) system) (mapcar 'parse-namestring (list (under-test-directory "test-include.asd") (under-tmp-directory "random-version2.lisp-expr")))))) (uiop:delete-file-if-exists version-file))) (uiop:delete-file-if-exists (under-test-directory "test-include.asd")) (uiop:delete-file-if-exists *version-file*)) asdf-3.3.4/test/test-redundant-recompile.script000066400000000000000000000024511362155115300215650ustar00rootroot00000000000000;;; -*- 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-equal file1-date (file-write-date file1)) (assert-equal file2-date (file-write-date file2)) asdf-3.3.4/test/test-require.script000066400000000000000000000233421362155115300173020ustar00rootroot00000000000000;; -*- Lisp -*- ;;; This script verifies the invariants of both ;;; *function* REQUIRE-SYSTEM and *class* REQUIRE-SYSTEM. ;;; Based on work by Daniel Kochmański (import 'asdf::registered-system) (DBG "---- Tests related to the behavior of preloaded systems") (DBG "- Even dummy `preloaded-system' is listed in `already-loaded-systems'") (register-preloaded-system "test-preloaded-dummy" :version "1.0") (assert (registered-system "test-preloaded-dummy")) (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "- Loaded `preloaded-system' is listed in `already-loaded-systems'") (assert (component-loaded-p (registered-system "test-preloaded-dummy"))) (assert (member "test-preloaded-dummy" (already-loaded-systems) :test #'equal)) (DBG "- Dummy `preloaded-system' doesn't get overwritten by `require-system'") (require-system "test-preloaded-dummy") (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "- Dummy `preloaded-system' doesn't get overwritten by `load-system' because there is no alternative in the filesystem") (load-test-system "test-preloaded-dummy") (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "- Function `clear-system' doesn't remove `preloaded-system'") (assert (not (clear-system "test-preloaded-dummy"))) (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "-`preloaded-system' overridden by defsystem") (def-test-system "test-preloaded-dummy" :version "2.0") (assert-equal (component-version (registered-system "test-preloaded-dummy")) "2.0") (DBG "- Function `clear-system' restores `preloaded-system'") (assert (not (clear-system "test-preloaded-dummy"))) (assert-equal (component-version (registered-system "test-preloaded-dummy")) "1.0") (DBG "-`preloaded-system' overridden by find-system") (assert (not (registered-system "require-system/preloaded"))) (register-preloaded-system "require-system/preloaded" :version "1.0") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (assert (component-loaded-p (registered-system "require-system/preloaded"))) (find-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (DBG "-`find-system' doesn't make the new system loaded") (assert (not (component-loaded-p (registered-system "require-system/preloaded")))) (DBG "-`load-system' does") (load-system "require-system/preloaded") (assert (component-loaded-p (registered-system "require-system/preloaded"))) (DBG "- Function `clear-system' restores registered, preloaded `preloaded-system'") (assert (not (clear-system "require-system/preloaded"))) (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (assert (component-loaded-p (registered-system "require-system/preloaded"))) (assert (member "require-system/preloaded" (already-loaded-systems) :test #'equal)) (DBG "- Function `require-system' doesn't overwrite `preloaded-system'") (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- Function `require-system' doesn't trigger a side-effect reloading system") ;;; `require-system' called `load-system' regardless if the system was ;;; loaded or not. While the `:force' and `:force-not' flags were ;;; handled correctly, `load-system' had a nasty side-effect which ;;; were overwriting our system loaded in-memory, so the second ;;; `require-system' loaded the new `asd'-defined system. (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- System `preloaded-system' won't be reloaded on `require-system' when cache is empty") (reset-session) (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (require-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "1.0") (DBG "- Function `load-system' overwrites `preloaded-system'") (load-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (DBG "- Update the preloaded system version after loading from asd") (register-preloaded-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (assert (not (clear-system "require-system/preloaded"))) (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") ;; Not implemented: #| (deregister-preloaded-system "require-system/preloaded") (assert-equal (component-version (registered-system "require-system/preloaded")) "2.0") (assert (clear-system "require-system/preloaded")) (assert (not (registered-system "require-system/preloaded"))) |# (DBG "---- Tests related to the behavior of immutable systems") (DBG "- Test function `register-immutable-system'") ;; Note: it's not immutable *yet*, but loaded from file. (assert-equal (component-version (registered-system "require-system/immutable")) "2.0") (clear-system "require-system/immutable") (def-test-system "require-system/immutable" :version "1.0" :depends-on ("require-system/not-loaded") :components ((:file "file1"))) (assert (not (component-loaded-p "require-system/immutable"))) (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (let ((system (registered-system "require-system/immutable"))) (register-immutable-system "require-system/immutable") (assert (eq system (registered-system "require-system/immutable")))) (assert (eq 'system (type-of (registered-system "require-system/immutable")))) (assert-equal 1 (length (component-children (registered-system "require-system/immutable")))) (assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (DBG "- Function `require-system' doesn't overwrite `immutable-system'") (require-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded (DBG "- Function `load-system' doesn't overwrite `immutable-system'") (load-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (assert (not (component-loaded-p "require-system/immutable"))) ;; *not* marked loaded (DBG "- Function `load-system' doesn't load an immutable system's dependencies") (assert (not (component-loaded-p "require-system/not-loaded"))) ;; *not* marked loaded (DBG "- Function `clear-system' leaves `immutable-system' loaded, but clears build information") (assert-equal 1 (length (component-children (registered-system "require-system/immutable")))) (assert (not (component-loaded-p "require-system/immutable"))) ;; still not marked loaded (clear-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (assert-equal 0 (length (component-children (registered-system "require-system/immutable")))) (assert (component-loaded-p "require-system/immutable")) ;; *YES* marked loaded! (DBG "- System `immutable-system' won't be reloaded when cache is empty") (reset-session) (load-system "require-system/immutable") (assert-equal (component-version (registered-system "require-system/immutable")) "1.0") (DBG "---- Tests related to the behavior of ordinary systems") (DBG "- Require-system doesn't replace already loaded system") (def-test-system "require-system/ordinary" :version "1.0") (asdf::mark-component-preloaded "require-system/ordinary") (assert (component-loaded-p "require-system/ordinary")) (require-system "require-system/ordinary") (assert-equal (component-version (registered-system "require-system/ordinary")) "1.0") (DBG "- Load-system loads system from the disk") (reset-session) (load-system "require-system/ordinary") (assert-equal (component-version (registered-system "require-system/ordinary")) "2.0") ;;; ASDF assumes that if a same-named system can be found by find-system, then ;;; it overrides any same-named implementation-dependent module (after downcasing) ;;; specified via (:require ...), so as to avoid recursive calls to asdf:operate from ;;; within plan execution, and any double-loading or infinite loop that could result. ;;; ;;; That means that we can't "just" test the (:require ...) feature portably by ;;; relying on the ASDF hook into CL:REQUIRE that many implementations provide. #+clisp (defparameter *dynmod-list* (mapcar 'pathname-name (directory-files (subpathname (lisp-implementation-directory) "dynmod/") "*.lisp"))) (defparameter *mod* (or #+abcl :abcl-contrib #+allegro :sax #+clisp (first (remove "asdf" *dynmod-list* :test 'equal)) #+(or clozure cmucl) :defsystem #+ecl :sockets #+lispworks "comm" #+mkcl :walker #+sbcl :sb-md5 #+scl :http-library)) (unless *mod* (leave-test "This implementation doesn't provide a known module" 0)) ;; Prevent ASDF from finding the modules as ASDF systems on ECL, MKCL, SBCL (and maybe more). (setf asdf::*system-definition-search-functions* (remove 'asdf::sysdef-source-registry-search asdf::*system-definition-search-functions*)) (asdf::clear-registered-systems) (reset-session) (defun has-module-p (x) ;; note that the spec is case-sensitive, but we'll cast a wider net. (and (member x *modules* :test 'string-equal) t)) (DBG :before *modules*) (assert (not (find-system *mod* nil))) (assert (not (has-module-p *mod*))) (eval `(def-test-system :require-test :depends-on ((:require ,*mod*)))) (load-system :require-test) (DBG :after *modules*) (assert (has-module-p *mod*)) asdf-3.3.4/test/test-retry-loading-component-1.script000066400000000000000000000022761362155115300225470ustar00rootroot00000000000000;;; -*- Lisp -*- ;; NB: this test does some evil side-effects in the test source directory itself. UGH! ;;; test asdf:try-recompiling restart (defvar *caught-error* nil) (delete-file-if-exists (test-source "try-reloading-dependency.asd")) (with-asdf-session (:override t) (handler-bind ((error #'(lambda (c) (format t "~&Caught error ~s" c) (assert (not *caught-error*) () "The missing system component error is not fixed by the handler, as expected.") (setf *caught-error* t) ;; Evil side-effect: create a .asd file from .hidden file. (concatenate-files (list (test-source "try-reloading-dependency.hidden")) (test-source "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*)) asdf-3.3.4/test/test-run-program-unix.script000066400000000000000000000625311362155115300210630ustar00rootroot00000000000000(unless (os-unix-p) (leave-test "This test can only be run on UNIX" 0)) (chdir *test-directory*) #+abcl (unless (version-satisfies (second (split-string (implementation-identifier) :separator '(#\-))) "1.4") (leave-test "This test is not meant to be run on versions of ABCL that predate 1.4" 0)) #+clasp (leave-test "Clasp does not have a run-program function" 0) #+cmucl (let* ((v (first (uiop:split-string (lisp-implementation-version)))) (v-main (subseq v 0 2)) (v-sub (subseq v 2 3))) (when (and (= 3 (length v)) ; cannot use length=n-p (every #'digit-char-p v-main) (every #'alpha-char-p v-sub)) (unless (or (version-satisfies v-main "22") (and (version-satisfies v-main "21") (not (string-equal v-sub "a")))) (leave-test "This test is not meant to be run on versions of CMU CL that predate 21B" 0)))) #+mkcl (unless (version-satisfies (lisp-implementation-version) "1.1.10") (leave-test "This test is not meant to be run on versions of MKCL that predate 1.1.10" 0)) #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) (leave-test "This test has never been run on your lisp and would probably fail" 0) ;;; Helpers (defvar *input-file* (subpathname *build-directory* (strcat (implementation-identifier) "-" "input"))) (defvar *output-file* (subpathname *build-directory* (strcat (implementation-identifier) "-" "output"))) (defvar *error-output-file* (subpathname *build-directory* (strcat (implementation-identifier) "-" "error-output"))) ;;; Test setup and execution (defvar *suite-number* -1) (defvar *test-number*) (defvar *suites* nil) (defvar *suites-reversed* t) (defvar *letters* "abcdefghijklmnopqrstuvwxyz") (defvar *number-of-failed-tests* 0) (defvar *number-of-skipped-tests* 0) (defvar *number-of-unsupported-tests* 0) (defvar *number-of-unimplemented-tests* 0) (defun new-test-suite (label) (incf *suite-number*) (setf *test-number* -1) (push (list (format nil "~a ~a" *suite-number* label)) *suites*)) (defun push-test (test) (push test (first *suites*))) (defun run-tests () (when *suites-reversed* (setf *suites* (reverse (mapcar #'reverse *suites*))) (setf *suites-reversed* nil) (dolist (suite *suites*) (format t "~a~%" (first suite)) (dolist (test (cdr suite)) (funcall test) (dolist (file (list *input-file* *output-file* *error-output-file*)) (delete-file-if-exists file)))))) ;; Defines a test that is automatically numbered. Within its body, the ;; following variables are available: ;; - output-string, error-string ;; - suite-number, test-number, test-letter ;; The description string str should not contain more than 57 characters (defmacro define-test (str &body body) `(progn (incf *test-number*) (push-test (let ((suite-number *suite-number*) (test-number *test-number*) error-status error-description) #'(lambda () (let* ((test-letter (aref *letters* test-number)) (output-string (format nil "output~a~a" suite-number test-number)) (error-string (format nil "error~a~a" suite-number test-number))) (declare (ignorable output-string error-string)) (format t " ~a ~a~%" test-letter ,str) (block test-case (handler-bind ((parameter-error #'(lambda (c) (declare (ignore c)) (incf *number-of-unsupported-tests*) (setf error-status 'unsupported) (return-from test-case))) (not-implemented-error #'(lambda (c) (declare (ignore c)) (incf *number-of-unimplemented-tests*) (setf error-status 'not-implemented) (return-from test-case))) (test-skipped #'(lambda (c) (incf *number-of-skipped-tests*) (setf error-status 'skipped) (setf error-description (format nil "~a" c)) (return-from test-case))) (test-failure #'(lambda (c) (declare (ignore c)) (incf *number-of-failed-tests*) (setf error-status 'failed) (return-from test-case))) (error #'(lambda (c) (incf *number-of-failed-tests*) (setf error-status 'general) (setf error-description (format nil "~a" c)) (return-from test-case)))) ,@body)) (case error-status (failed (incf *number-of-failed-tests*)) (unsupported (report-result "" "NOT SUPPORTED")) (not-implemented (report-result "" "NOT IMPLEMENTED")) (skipped (report-result "" "SKIPPED") (format t " Skipped for the following reason: ~a~%" error-description)) (general (report-result "" "ERROR") (format t " The following error was encountered: ~a~%" (string-trim (list #\Space #\ #\Newline) error-description)))))))))) (define-condition test-skipped (error) ((reason :initarg :reason)) (:report (lambda (condition stream) (format stream "~a" (slot-value condition 'reason))))) (defun skip-test (reason) (error 'test-skipped :reason reason)) (define-condition test-failure (error) ()) ;;; Testing utilities (defun file-contains-exactly (filename expected-content) (let ((actual-content (read-file-string filename))) (string= actual-content expected-content))) (defun report-result (description outcome) (format t " ~57,1,0,'.a ~a~%" description outcome)) (defun handle-result (description passed-or-not) (unless passed-or-not (report-result description "FAIL") (error 'test-failure))) (defun check-output (str) (handle-result "output as expected?" (file-contains-exactly *output-file* str))) (defun check-error-output (str) (handle-result "error-output as expected?" (file-contains-exactly *error-output-file* str))) (defun check-strings (str1 str2) (handle-result "received what we sent?" (string= str1 str2))) (defun create-file-from-string (name string) (with-open-file (output name :direction :output :if-exists :supersede) (format output string))) ;; Skips the test if terminate-process cannot be called (defun my-terminate-process (&rest rest) #+ecl (unless (find-symbol* '#:terminate-process :ext nil) (error 'test-skipped :reason "ext:terminate-process missing")) (apply #'terminate-process rest)) ;;; The actual tests (new-test-suite "run-program/launch-program") (define-test ":input/:output/:error-output nil (default)" (run-program (format nil "./exiter.sh 0 ~a" output-string) :input nil :output nil)) (define-test ":error-output :interactive" (run-program (format nil "./exiter.sh 0 ~a" output-string) :error-output :interactive)) (define-test ":error-output :output" (run-program (format nil "./exiter.sh 0 ~a" output-string) :error-output :output)) (define-test ":output (file e.)" (progn (create-file-from-string *output-file* "") (run-program (format nil "./exiter.sh 0 ~a" output-string) :output *output-file*) (check-output (format nil "~a~%" output-string)))) (define-test ":output :error-output (files e.)" (progn (create-file-from-string *output-file* "") (create-file-from-string *error-output-file* "") (run-program (format nil "./exiter.sh 0 ~a ~a" output-string error-string) :output *output-file* :error-output *error-output-file*) (check-output (format nil "~a~%" output-string)) (check-error-output (format nil "~a~%" error-string)))) (define-test ":input (file m.) :i-i-d-n-e :error" (progn (delete-file-if-exists *input-file*) (with-expected-failure (t) (run-program "cat" :input *input-file* :if-input-does-not-exist :error)))) (define-test ":input (file m.) :i-i-d-n-e :create" (progn (delete-file-if-exists *input-file*) (run-program "cat" :input *input-file* :if-input-does-not-exist :create))) (define-test ":input (file e.)" (progn (let ((in-string (format nil "A line.~%And another.~%"))) (create-file-from-string *input-file* in-string)) (run-program "cat" :input *input-file* :if-input-does-not-exist :create))) (define-test ":input (as pathname; file e.)" (progn (let ((in-string (format nil "A line.~%And another.~%"))) (create-file-from-string *input-file* in-string)) (run-program "cat" :input (truename *input-file*) :if-input-does-not-exist :create))) (define-test ":input :output (files e.) :i-o-e :supersede" (let ((in-string (format nil "A line.~%And another.~%"))) (create-file-from-string *input-file* in-string) (create-file-from-string *output-file* "") (run-program "cat" :input *input-file* :output *output-file*) (check-output in-string))) (define-test ":input :output (files e.) :i-o-e :error" (progn (let ((in-string1 (format nil "A line.~%")) (in-string2 (format nil "And another.~%"))) (delete-file-if-exists *output-file*) (create-file-from-string *input-file* in-string1) (run-program "cat" :input *input-file* :output *output-file*) (create-file-from-string *input-file* in-string2) (with-expected-failure (t) (run-program "cat" :input *input-file* :output *output-file* :if-output-exists :error)) (check-output in-string1)))) (define-test ":input :output (files e.) :i-o-e :append" (progn (let ((in-string1 (format nil "A line.~%")) (in-string2 (format nil "And another.~%"))) (delete-file-if-exists *output-file*) (create-file-from-string *input-file* in-string1) (run-program "cat" :input *input-file* :output *output-file*) (create-file-from-string *input-file* in-string2) (run-program "cat" :input *input-file* :output *output-file* :if-output-exists :append) (check-output (concatenate 'string in-string1 in-string2))))) (define-test ":input :output (files e./m.) :i-o-e :supersede" (let ((in-string (format nil "A line.~%And another.~%"))) (create-file-from-string *input-file* in-string) (delete-file-if-exists *output-file*) (run-program "cat" :input *input-file* :output *output-file*) (check-output in-string))) (define-test ":input :error-output (files e.), :i-e-o-e :error" (progn (let ((in-string1 (format nil "A line.~%")) (in-string2 (format nil "And another.~%"))) (delete-file-if-exists *output-file*) (create-file-from-string *input-file* in-string1) (run-program "./cat-to-stderr.sh" :input *input-file* :error-output *error-output-file*) (create-file-from-string *input-file* in-string2) (with-expected-failure (t) (run-program "./cat-to-stderr.sh" :input *input-file* :error-output *error-output-file* :if-error-output-exists :error)) (check-error-output in-string1)))) (define-test ":input :error-output (files e.), :i-e-o-e :append" (progn (let ((in-string1 (format nil "A line.~%")) (in-string2 (format nil "And another.~%"))) (delete-file-if-exists *output-file*) (create-file-from-string *input-file* in-string1) (run-program "./cat-to-stderr.sh" :input *input-file* :error-output *error-output-file*) (create-file-from-string *input-file* in-string2) (run-program "./cat-to-stderr.sh" :input *input-file* :error-output *error-output-file* :if-error-output-exists :append) (check-error-output (concatenate 'string in-string1 in-string2))))) (define-test ":output :error-output " (progn (with-open-file (output *output-file* :direction :output :if-exists :supersede #+clozure :sharing #+clozure :lock) (with-open-file (error-output *error-output-file* :direction :output :if-exists :supersede #+clozure :sharing #+clozure :lock) (run-program (format nil "./exiter.sh 0 ~a ~a" output-string error-string) :output output :error-output error-output))) (check-output (format nil "~a~%" output-string)) (check-error-output (format nil "~a~%" error-string)))) (define-test ":input :output " (let ((in-string (format nil "A line.~%And another.~%"))) (create-file-from-string *input-file* in-string) (with-output-to-string (out-stream) (run-program "cat" :input *input-file* :output out-stream) (check-strings in-string (get-output-stream-string out-stream))))) (define-test ":input :output " (let ((in-string (format nil "A line.~%And another.~%"))) (with-output-to-string (out-stream nil) (with-input-from-string (in-stream in-string) (run-program "cat" :input in-stream :output out-stream)) (check-strings in-string (get-output-stream-string out-stream))))) (define-test ":input :output :stream :wait nil" (let ((in-string (format nil "A line.~%And another.~%"))) (with-open-file (input *input-file* :direction :output :if-exists :supersede) (format input in-string)) (let* ((process (launch-program "cat" :input *input-file* :output :stream)) (output (process-info-output process)) (out-string (make-string (length in-string)))) (wait-process process) (read-sequence out-string output) (check-strings in-string out-string) (close-streams process)))) (defvar *dynamic-input*) (define-test ":input :output " (let ((in-string (format nil "A line.~%And another.~%"))) (with-open-file (input *input-file* :direction :output :if-exists :supersede) (format input in-string)) (create-file-from-string *output-file* "") (with-open-file (input *input-file* :direction :input :if-does-not-exist :error) (let* ((*dynamic-input* input) (input-synonym (make-synonym-stream '*dynamic-input*))) (run-program "cat" :input input-synonym :output *output-file*)) (check-output in-string)))) (define-test ":input :output " (progn (create-file-from-string *output-file* "") (let ((in-string (format nil "A line.~%And another.~%"))) (with-input-from-string (input in-string) (let* ((*dynamic-input* input) (input-synonym (make-synonym-stream '*dynamic-input*))) (run-program "cat" :input input-synonym :output *output-file*))) (check-output in-string)))) (define-test ":directory" (let* ((in-string (format nil "A line.~%And another.~%")) (temporary-directory (subpathname *build-directory* (format nil "test-run-program-unix/~a" (implementation-identifier)) :type :directory)) (relative-filename "input") (temporary-file (subpathname temporary-directory relative-filename))) (ensure-directories-exist temporary-directory) (create-file-from-string temporary-file in-string) (delete-file-if-exists *output-file*) (run-program (format nil "cat ~a" relative-filename) :output *output-file* :directory temporary-directory) (check-output in-string))) (new-test-suite "process-info-pid") (define-test "basic functionality" (let* ((process-info (launch-program "./sleeper.sh 12 1")) (pid (process-info-pid process-info))) (handle-result "obtainable and plausible?" (and (numberp pid) (plusp pid))) (wait-process process-info))) (new-test-suite "wait-process") (define-test "exit code after exit: synchronous" (let ((exit-code (nth-value 2 (run-program "./exiter.sh 12" :ignore-error-status t)))) (handle-result "exit code matches?" (equal 12 exit-code)))) (define-test "exit code after exit: asynchronous (repeated)" (let ((process-info (launch-program "./sleeper.sh 12 1"))) (handle-result "exit code matches?" (equal 12 (wait-process process-info))) (handle-result "exit code matches? (no. 2)" (equal 12 (wait-process process-info))))) (define-test "exit code after signal: synchronous" #+(and lispworks (not lispworks7+)) (skip-test "Known to fail") (let ((exit-code (nth-value 2 (run-program "./killer.sh" :ignore-error-status t)))) (handle-result "exit code matches?" (equal (+ 128 15) exit-code)))) (define-test "exit code after signal: asynchronous (repeated)" #+(and lispworks (not lispworks7+)) (skip-test "Known to fail") (let ((process-info (launch-program "./killer.sh"))) (handle-result "exit code matches?" (equal (+ 128 15) (wait-process process-info))) (handle-result "exit code matches? (no. 2)" (equal (+ 128 15) (wait-process process-info))))) (new-test-suite "process-alive-p / terminate-process") (define-test "not alive (we slept)" (let ((process-info (launch-program "./sleeper.sh 12 1"))) (handle-result "alive?" (process-alive-p process-info)) (sleep 2) (handle-result "dead?" (not (process-alive-p process-info))) (wait-process process-info))) (define-test "not alive (we waited)" (let ((process-info (launch-program "./sleeper.sh 12 1"))) (handle-result "alive?" (process-alive-p process-info)) (wait-process process-info) (handle-result "dead?" (not (process-alive-p process-info))))) (define-test "not alive (we terminated it)" (let ((process-info (launch-program "./sleeper.sh 12 2"))) (handle-result "alive?" (process-alive-p process-info)) (my-terminate-process process-info :urgent t) (sleep 1) (handle-result "dead?" (not (process-alive-p process-info))) (wait-process process-info))) (define-test "not alive (we terminated it repeatedly)" (let ((process-info (launch-program "./sleeper.sh 12 3"))) (handle-result "alive?" (process-alive-p process-info)) (my-terminate-process process-info :urgent t) (sleep 1) (my-terminate-process process-info :urgent t) (sleep 1) (handle-result "dead?" (not (process-alive-p process-info))) (wait-process process-info))) (define-test "multiple processes: proper exit sequence" (let ((process-info1 (launch-program "./sleeper.sh 12 1")) (process-info2 (launch-program "./sleeper.sh 12 2"))) (handle-result "#1 alive?" (process-alive-p process-info1)) (handle-result "#2 alive?" (process-alive-p process-info2)) (wait-process process-info1) (handle-result "#1 dead?" (not (process-alive-p process-info1))) (handle-result "#2 still alive?" (process-alive-p process-info2)) (wait-process process-info2) (handle-result "#1 still dead?" (not (process-alive-p process-info1))) (handle-result "#2 dead?" (not (process-alive-p process-info2))))) (new-test-suite "%process-status / terminate-process") (defun process-status (process-info) (uiop/launch-program::%process-status process-info)) (define-test ":exited (we slept; repeated query)" (let* ((process-info (launch-program "./sleeper.sh 12 1")) (status (process-status process-info))) (handle-result "running?" (equal :running status)) (sleep 2) (multiple-value-bind (status exit-code) (process-status process-info) (handle-result "exited?" (equal :exited status)) (handle-result "proper exit status?" (equal 12 exit-code))) (multiple-value-bind (status exit-code) (process-status process-info) (handle-result "exited? (no. 2)" (equal :exited status)) (handle-result "proper exit status? (no. 2)" (equal 12 exit-code))) (wait-process process-info))) (define-test ":exited/:signaled (it killed itself; repeated query)" #+(and lispworks (not lispworks7+)) (skip-test "Known to fail") (let* ((process-info (launch-program "./killer.sh"))) (sleep 1) (multiple-value-bind (status code) (process-status process-info) (handle-result "exited or signaled?" (member status '(:exited :signaled))) (handle-result "signal/exit code as expected?" (or (and (eq status :exited) (eql code 143)) (and (eq status :signaled) (eql code 15))))) (multiple-value-bind (status code) (process-status process-info) (handle-result "exited or signaled? (no. 2)" (member status '(:exited :signaled))) (handle-result "signal/exit code as expected? (no. 2)" (or (and (eq status :exited) (eql code 143)) (and (eq status :signaled) (eql code 15))))) (wait-process process-info))) (define-test ":exited (it exited >128; repeated query)" (let* ((process-info (launch-program "./killercontainer.sh"))) (sleep 1) (multiple-value-bind (status code) (process-status process-info) (handle-result "exited?" (eq status :exited)) (handle-result "proper exit status?" (eql code (+ 128 15)))) (multiple-value-bind (status code) (process-status process-info) (handle-result "exited (no. 2)?" (eq status :exited)) (handle-result "proper exit status? (no. 2)?" (eql code (+ 128 15)))) (wait-process process-info))) (define-test ":signaled (we terminated it; repeated query)" #+(and lispworks (not lispworks7+)) (skip-test "Known to fail") (let* ((process-info (launch-program "./sleeper.sh 12 2")) (status (process-status process-info))) (handle-result "running?" (equal :running status)) (my-terminate-process process-info :urgent t) (sleep 1) (multiple-value-bind (status code) (process-status process-info) (handle-result "signaled?" (eq status :signaled)) (handle-result "signal as expected?" (member code '(9 15)))) (multiple-value-bind (status code) (process-status process-info) (handle-result "signaled (no. 2)?" (eq status :signaled)) (handle-result "signal as expected (no. 2)?" (member code '(9 15)))) (wait-process process-info))) (fresh-line) (run-tests) (write-line "") (when (plusp *number-of-failed-tests*) (format t "~2@a sub-tests failed.~%" *number-of-failed-tests*)) (when (plusp *number-of-skipped-tests*) (format t "~2@a sub-tests skipped because of known errors.~%" *number-of-skipped-tests*)) (when (plusp *number-of-unsupported-tests*) (format t "~2@a sub-tests could not be run on this platform (not supported).~%" *number-of-unsupported-tests*)) (when (plusp *number-of-unimplemented-tests*) (format t "~2@a sub-tests could not be run on this platform (not implemented).~%" *number-of-unimplemented-tests*)) (when (plusp *number-of-failed-tests*) (format *error-output* "Exiting with non-zero code because of unexpected test failures.~%") (exit-lisp 1)) (exit-lisp 0) ;; Local Variables: ;; mode:common-lisp ;; End: asdf-3.3.4/test/test-run-program.script000066400000000000000000000275651362155115300201120ustar00rootroot00000000000000;; -*- Lisp -*- (declaim (optimize (debug 3) (safety #-gcl 3 #+gcl 0))) ;; On Windows, normalize away CRLF into jut the unixy LF. (defun dewindowize (x) ;; Some buggy implementations output extra space on Windows; ;; Implementations that rely on shell redirection on Windows also do, as a limitation. (string-trim " " (remove (code-char 13) x))) ;;#+(and clisp os-windows) (ext:without-package-lock () (trace ext:run-shell-command)) (os-cond ((os-unix-p) (DBG "Testing echo ok 1 via run-program as a list") (assert-equal "ok 1" (run-program '("echo" "ok" "1") :output '(:string :stripped t)))) ((os-windows-p) (DBG "Testing ipconfig /all via run-progam as a string") ;; Interestingly, "ipconfig /all" fails on the msys2 bash, but not on the cygwin bash. (nest #+ecl (errors parameter-error) ;; FIXME: known breakage (run-program "ipconfig /all")) (DBG "Testing ipconfig /all via run-progam as a list") (run-program '("ipconfig" "/all")))) (DBG "Testing echo ok 1 via run-program as a string") #-(and ecl os-windows) (assert-equal "ok 1" (dewindowize (run-program "echo ok 1" :output '(:string :stripped t)))) #+(and ecl os-windows) (errors parameter-error (dewindowize (run-program "echo ok 1" :output '(:string :stripped t)))) ;;; test asdf run-shell-command function #-(and ecl os-windows) (progn (setf *verbose-out* nil) (DBG "Testing true via run-shell-command") (assert-equal 0 (run-shell-command "exit 0")) (DBG "Testing false via run-shell-command") (with-expected-failure (#+clasp "clasp fails on (EXT:SYSTEM \"exec < /dev/null >> /dev/null 2>> /dev/null ; exit 0\")") (assert-equal 1 (run-shell-command "exit 1"))) (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."))) #+(and ecl os-windows) (errors not-implemented-error (eql 0 (run-shell-command "exit 0"))) (chdir *test-directory*) #+os-unix (progn (DBG "Testing good shell command in current directory via run-shell-command") (assert-equal 0 (run-shell-command "./good-shell-command"))) (DBG "Testing exit status with :output :interactive") ;; This test checks for a problem there was in allegro -- :output :interactive ;; would try to open T as a stream for INPUT. #-(and ecl os-windows) (loop :for (program . exit-code) :in #+os-unix '(("true" . 0) ("false" . 1)) #+os-windows '(("cmd /c exit 0" . 0) ("cmd /c exit 1" . 1)) :do (loop :for force-shell :in '(t nil) :do (if (string= program "true") (assert-equal `(nil nil ,exit-code) (multiple-value-list (run-program program :ignore-error-status t :force-shell force-shell :output :interactive))) (with-expected-failure (#+clasp "Fails for false") (assert-equal `(nil nil ,exit-code) (multiple-value-list (run-program program :ignore-error-status t :force-shell force-shell :output :interactive))))))) #+(and ecl os-windows) (DBG "Test skipped on ECL + Windows") #-(and ecl os-windows) (with-expected-failure (#+clasp "Fails") (assert-equal '("foo" "bar baz" 42) (multiple-value-bind (o e c) (run-program #+os-unix "cat ; echo bar baz >&2 ; exit 42" #+os-windows "findstr \"^\" & echo bar baz >&2 & exit 42" ;; On some versions of windows, findstr hangs indefinitely ;; when passed input without a trailing newline :input '("foo" :terpri t) :output '(:string :stripped t) :error-output '(:string :stripped t) :ignore-error-status t) (DBG "aaa" o e c) (list (dewindowize o) (dewindowize e) c)))) #-(and ecl os-windows) (assert-equal '(("foo" "bar" "baz" "quux") nil 0) (multiple-value-bind (o e c) (run-program #+os-unix "echo foo ; echo bar >&2 ; echo baz ; echo quux >& 2" #+os-windows "echo foo & echo bar >&2 & echo baz & echo quux >& 2" :output :lines :error-output :output) (list (mapcar 'dewindowize o) e c))) #-(and ecl 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) (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)) #-(and ecl os-windows) (assert-equal '(:ok 1) (run-program "echo :ok 1" :output :forms)) #-(and ecl os-windows) (assert-equal "ok" (dewindowize (stripln (with-output-to-string (*standard-output*) (run-program "echo ok" :output t :error-output :output))))) ;; 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 () (DBG "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)) (DBG "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)) (DBG "Test that run-program fails properly with an empty program string") #+(or clozure (and allegro os-unix) cmucl (and lispworks os-unix) sbcl scl) (signals error (run-program '("") :output :lines)) (DBG "An empty string itself is ok since it is passed to the shell.") (assert-equal "" (run-program "" :output :string)) (DBG "Test that run-program fails properly with a nil program list") #+(or clozure (and allegro os-unix) cmucl sbcl scl) (signals error (run-program nil :output :lines)) (DBG "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 () (DBG "Checking that spaces between arguments are collapsed by shell when and only when unquoted") (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))) (DBG "Checking behavior on program success or failure") (assert-equal '(nil nil 0) (multiple-value-list (run-program "true"))) (signals subprocess-error (run-program "false")) (with-expected-failure (#+clasp "Fails") (assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :ignore-error-status t)))) (DBG "Tests with test-file") (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 () (DBG "WINDOWS-ONLY-TEST/RUN-PROGRAM") ;; a basic smoke test (assert-equal "ok" (dewindowize (run-program '("cmd" "/c" "echo" "ok") :output :line))) #-(and ecl os-windows) (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) asdf-3.3.4/test/test-samedir-modules.asd000066400000000000000000000007471362155115300201670ustar00rootroot00000000000000;;; -*- 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 |# asdf-3.3.4/test/test-samedir-modules.script000066400000000000000000000006641362155115300207220ustar00rootroot00000000000000;;; -*- 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))) asdf-3.3.4/test/test-source-file-type-1.asd000066400000000000000000000006411362155115300204200ustar00rootroot00000000000000;; 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"))) asdf-3.3.4/test/test-source-file-type-2.asd000066400000000000000000000004311362155115300204160ustar00rootroot00000000000000;; 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"))) asdf-3.3.4/test/test-source-file-type.script000066400000000000000000000007411362155115300210200ustar00rootroot00000000000000;;; -*- Lisp -*- (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) (load-system 'test-source-file-type-2 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) asdf-3.3.4/test/test-source-registry.script000066400000000000000000000007241362155115300207730ustar00rootroot00000000000000;;; -*- Lisp -*- (DBG "Testing that the source-registry prefers the path that is shorter and/or asciibetically earlier") (setf *verbose-out* t) (initialize-source-registry `(:source-registry (:tree ,*test-directory*) :ignore-inherited-configuration)) (assert-pathname-equal (system-source-directory "which-asd") (subpathname *test-directory* "sources/")) (assert-pathname-equal (system-source-directory "which-asd2") (subpathname *test-directory* "sources/a/")) asdf-3.3.4/test/test-stamp-propagation.script000066400000000000000000000001261362155115300212660ustar00rootroot00000000000000(load (subpathname *test-directory* "stamp-propagation/test-stamp-propagation.lisp")) asdf-3.3.4/test/test-static-and-serial.script000066400000000000000000000034421362155115300211310ustar00rootroot00000000000000;;; -*- Lisp -*- #| make sure that serial t and static-files don't cause full rebuilds all the time... |# (in-package :asdf-test) (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (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) asdf-3.3.4/test/test-symlink-loop.script000066400000000000000000000065421362155115300202660ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; This checks a fix to bug 1533766 where a search of the ;;; registry can be caused to loop forever if symlinks introduce a circularity ;;; into the file tree. ;;; --------------------------------------------------------------------------- (in-package :asdf-test) ;; since symlinks only somewhat exist on Windows, we don't test there. (when (uiop:os-windows-p) (exit-lisp 0)) (let ((scratch-dir (namestring (make-sub-pathname :directory '(:relative "looping-scratch") :defaults *test-directory*)))) (unwind-protect (progn ;; set up pathological directory structure (uiop:run-program (format nil "mkdir ~a" scratch-dir)) (uiop:run-program (format nil "mkdir ~a/subdirs" scratch-dir)) (uiop:run-program (format nil "mkdir ~a/subdirs/subdir" scratch-dir)) (uiop:run-program (format nil "mkdir ~a/subdirs/subdir2" scratch-dir)) (uiop:run-program (format nil "cd ~a/subdirs/subdir ; ln -s .. ln-subdir" scratch-dir)) (uiop:run-program (format nil "cd ~a/subdirs/subdir2 ; ln -s .. ln-subdir" scratch-dir)) (uiop:copy-file (format nil "~a" (namestring (make-sub-pathname :name "loop" :type "asd" :defaults *test-directory*))) (format nil "~a" (namestring (make-sub-pathname :name "loop" :type "asd" :defaults scratch-dir)))) (DBG "Testing search for asdf system definitions.") (assert-equal (list "loop") (let ((asds nil)) (declare (special asds)) (asdf/source-registry:collect-sub*directories-asd-files scratch-dir :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))) (push name asds)))) asds)) (DBG "Resetting source registry.") (initialize-source-registry `(:source-registry (:tree ,scratch-dir) :ignore-inherited-configuration)) (DBG "Looking for the LOOP system") (assert (asdf:find-system :loop))) ;; clean up (DBG "Cleaning up") (uiop:delete-directory-tree scratch-dir :validate (lambda (x) (subpathp x *test-directory*))))) (DBG "Exiting") (exit-lisp 0) asdf-3.3.4/test/test-sysdef-asdf.script000066400000000000000000000144331362155115300200370ustar00rootroot00000000000000;;; -*- Lisp -*- (format! t "~%Using ASDF ~A~%" (asdf-version)) (assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF (setf *asdf-session* nil) (defparameter *ticks* 0) (defun tick () (incf *ticks*)) (DBG "Let's define some methods on input-files, to later check what an upgrade does to them.") (with-asdf-session (:override t) (def-test-system "fooey") (def-test-system "foo") (defmethod input-files :after ((o load-op) (c system)) (DBG :input-files-after-1 o c (tick))) (assert-equal *ticks* 0) (input-files 'load-op "foo") (assert-equal *ticks* 1) (input-files 'load-op "foo") (assert-equal *ticks* 1) ;; It was cached. (assert (find-system "fooey" nil))) (DBG "Try load ASDF with an empty configuration") (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (load-system :asdf) ;; We haven't found it, and got the fallback (assert-equal nil (system-source-file (find-system :asdf))) (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") (clear-system "asdf") ;; Bogus sysdef finding function, for the sake of testing no-load-old-version. (defun sysdef-bogus-test-search (system) (declare (ignore system)) (subpathname *test-directory* "always-error.lisp")) (let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (state "Didn't catch warning")) (handler-bind ((simple-warning #'(lambda (c) (when (search "ASDF will ignore this configured system rather than downgrade itself." (simple-condition-format-control c)) (setf state "Caught warning"))))) (clear-system "asdf") (upgrade-asdf)) (with-expected-failure (#+clasp "Fails") (assert-equal state "Caught warning"))) (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") (let ((*system-definition-search-functions* '(sysdef-bogus-test-search))) (handler-bind ((simple-warning #'(lambda (c) (error "Should not have issued warning, but did issue:~% ~A" c)))) (clear-system "asdf") (upgrade-asdf))) (assert-equal nil (system-source-file (find-system :asdf))) (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) (:directory ,*uiop-directory*) :ignore-inherited-configuration)) (clear-system "asdf") (with-asdf-session (:override t) (with-expected-failure (#+xcl t #+clasp t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf) (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (system-source-file (find-system :asdf)))) (DBG "Loading from the same version shouldn't have reset methods") (setf *ticks* 2) (input-files 'load-op "foo") (assert-equal *ticks* 3)) (DBG "Loading from an ancient version WILL reset methods") (assert (find-system "fooey" nil)) (defparameter *current-version* (asdf-version)) (setf asdf::*asdf-version* "2.0" asdf/upgrade::*previous-asdf-versions* '("2.0")) (assert (asdf/upgrade::upgrading-p)) (clear-system "asdf") (reset-session) (with-expected-failure (#+xcl t #+clasp t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf) (assert-equal (asdf-version) *current-version*) (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (system-source-file (find-system :asdf)))) (DBG "Upgrading from an old-enough version should have redefined away the input-files method!") (setf *ticks* 4) (input-files 'load-op "asdf") (with-expected-failure (#+clasp t) (assert-equal *ticks* 4) ;; It also cleared away previously defined systems (assert (not (find-system "fooey" nil)))) (DBG "Actually upgrade, from a different but forward-compatible version") ;; The data-punting upgrade will mess up component identity, so clear the cache (reset-session) (setf asdf::*asdf-version* asdf/upgrade::*oldest-forward-compatible-asdf-version*) (clear-system "asdf") (def-test-system "fooey") (setf *ticks* 10) (defmethod input-files :after ((o load-op) (c system)) (DBG :input-files-after-2 o c (tick))) (input-files 'load-op "uiop") (with-expected-failure (#+clasp t) (assert-equal *ticks* 12)) (with-expected-failure (#+xcl t) ;; expected-failure: XCL has trouble with the ASDF upgrade (load-system :asdf)) ;; Upgrading from a recent-enough version, the input-files method was preserved! ;; But we need to clear the cache for it not to be short-circuited. (reset-session) (assert (find-system "fooey" nil)) (setf *ticks* 20) (eval '(input-files 'load-op "uiop")) (assert-equal *ticks* 21) (DBG "Checking that the bootstrap script and asdf.asd are in synch") (defun bootstrap-lisp-files (file line-prefix) (with-input-file (input (subpathname *asdf-directory* file)) (loop :for line = (read-line input) :when (string-prefix-p line-prefix line) :return (subseq line (length line-prefix)) :finally (error "Didn't find ~a in ~a" line-prefix file)))) (defun system-lisp-files (system) (loop :for f :in (input-files 'concatenate-source-op system) :collect (unix-namestring (enough-pathname f *asdf-directory*)))) (DBG "Testing that the Makefile and ASDF agree on the order of UIOP files") (loop :with errors = () :for (file prefix-fmt value-fmt backslash) :in '(("Makefile" "~A := " "~{~A~^ ~}") ("make-asdf.sh" "~A=" "\"~{~A~^ ~}\"") ("make-asdf.bat" "set ~A=" "~{~A~^ + ~}" t)) :do (format t "~%Expecting to find in ~A the following lines:~%" file) (loop :for (system variable-name) :in '((:uiop "driver_lisp") (:asdf/defsystem "defsystem_lisp")) :for files = (system-lisp-files system) :for prefix = (format nil prefix-fmt variable-name) :for expected0 = (format nil value-fmt files) :for expected = (if backslash (substitute #\\ #\/ expected0) expected0) :for found = (bootstrap-lisp-files file prefix) :do (format t "~A~A~%" prefix expected) :unless (equal expected found) :do (push (format nil "In ~A expected:~%~A~A~%~%but found:~%~A~A~%~%~%" file prefix expected prefix found) errors)) :finally (when errors (with-expected-failure (#+clasp t) (error (reduce/strcat (reverse errors)))))) asdf-3.3.4/test/test-system-pathnames.script000066400000000000000000000021351362155115300211250ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem :test-system-pathnames :pathname "sources/level1" :source-file nil :components ((:file "file1") (:file "file2" :pathname "level2/file2" :depends-on ("file1")) (:static-file "level2/static.file") (:static-file "test-tmp.cl"))) (DBG "loading test-system-pathnames") (load-system 'test-system-pathnames) (DBG "checking that test-system-pathnames loaded properly") (assert (find-package :test-package) () "package test-package not found") (assert (find-symbol* '*file-tmp* :test-package nil) () "symbol `*file-tmp*` not found") (assert (symbol-value (find-symbol* '*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* '*file-tmp2* :test-package nil) () "symbol `*file-tmp2*` not found") (assert (symbol-value (find-symbol* '*file-tmp2* :test-package)) () "symbol `*file-tmp2*` has wrong value") (assert (probe-file* (test-fasl "sources/level1/level2/file2")) () "compiled file not found") asdf-3.3.4/test/test-tmp.cl000066400000000000000000000004021362155115300155100ustar00rootroot00000000000000;; 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~%")) asdf-3.3.4/test/test-tmp.lsp000066400000000000000000000004041362155115300157120ustar00rootroot00000000000000;; 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~%")) asdf-3.3.4/test/test-touch-system-1.script000066400000000000000000000027071362155115300204320ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test system def reloading if touched ;;; system that can be found using *system-definition-search-functions* (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (defun system-registered-time (name) (asdf::component-operation-time 'asdf::define-op (registered-system (primary-system-name name)))) (setf (asdf-upgraded-p *asdf-session*) t) (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)) (clear-system :test1) (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)) (load-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-compare (>= date4 date3)) (sleep 1) (clear-system :test1) (touch-file test1.asd :timestamp date4 :offset 600) (find-system :test1) (defparameter date6 (system-registered-time :test1)) (assert-compare (> date6 date4)) asdf-3.3.4/test/test-touch-system-2.script000066400000000000000000000021041362155115300204220ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test system definition NOT reloaded if touched ;;; system that canNOT be found using *system-definition-search-functions* (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) (defun system-registered-time (name) (asdf::component-operation-time 'asdf::define-op (registered-system (primary-system-name name)))) (asdf::clear-registered-systems) (defparameter test-asdf.asd (nth-value 2 (locate-system :test-asdf))) (assert-pathname-equal test-asdf.asd (test-source "test-asdf.asd")) (assert (not (registered-system :test-asdf))) ;; not loaded (asdf::clear-registered-systems) (setf asdf:*central-registry* nil) (load-asd test-asdf.asd) (assert (registered-system :test-asdf)) (defparameter date1 (system-registered-time :test-asdf)) (assert date1) (assert-equal 1 test-asdf-system::*times-loaded*) (asdf::clear-registered-systems) (touch-file test-asdf.asd :timestamp date1 :offset +2) (load-asd test-asdf.asd) (find-system :test-asdf) (defparameter date2 (system-registered-time :test-asdf)) (assert date2) (assert-compare (> date2 date1)) asdf-3.3.4/test/test-try-recompiling-1.script000066400000000000000000000012561362155115300211100ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test asdf:try-recompiling restart (defparameter *caught-error* nil) (delete-file-if-exists (test-fasl "try-recompiling-1")) (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))) ;;(DBG :foo c restart (compute-restarts c)) (when restart (invoke-restart restart))))))) (oos 'load-op 'try-recompiling-1)) (assert *caught-error*) asdf-3.3.4/test/test-try-refinding.script000066400000000000000000000062161362155115300204100ustar00rootroot00000000000000;;; -*- Lisp -*- ;;; test retrying finding location of an ASDF system. (setf *asdf-session* nil) (in-package asdf-test) (defparameter *old-registry* asdf:*central-registry*) ;;(defparameter *search-table* (hash-table->alist asdf::*source-registry*)) ;;(pprint *search-table*) ;;(terpri) (assert (asdf:find-system "test-asdf/force1")) (defun clear-caches-and-search () (setf asdf:*central-registry* nil) (clear-system "test-asdf") (clear-system "test-asdf/force1")) (DBG "Clearing the caches and finding.") (clear-caches-and-search) (assert (not (asdf:find-system "test-asdf/force1" nil))) (DBG "Correctly failed to find system.") (defvar *attempts* 0) (assert (with-asdf-session (:override t) (handler-bind ((asdf:missing-component #'(lambda (c) (DBG "Caught MISSING-COMPONENT condition (A)." *attempts*) (if (zerop *attempts*) (let ((missing (asdf::missing-requires c))) (incf *attempts*) (assert (equal missing "test-asdf/force1")) (setf asdf:*central-registry* *old-registry*) (invoke-restart 'asdf:retry)) ;; avoid infinite looping (leave-test 10 "Infinite loop while catching MISSING-COMPONENT"))))) (asdf:find-system "test-asdf/force1" t)))) (assert-equal *attempts* 1) (DBG "Refinding test successful.") (DBG "Now trying LOAD-SYSTEM with refinding.") (clear-caches-and-search) (def-test-system test-missing-dependency :depends-on ("test-asdf/force1") :components ((:file "file2"))) (setf *attempts* 0) (with-asdf-session (:override t) (flet ((handle-missing (c) (if (zerop *attempts*) (let ((missing (asdf::missing-requires c))) (incf *attempts*) (assert (equal missing "test-asdf/force1")) (DBG "Trying to reset the central registry and retry.") (setf asdf:*central-registry* *old-registry*) (unless (find-restart 'asdf:clear-configuration-and-retry) (error "Expected CLEAR-CONFIGURATION-AND-RETRY restart not found.")) (DBG "Before invoking restart, CENTRAL-REGISTRY is:" asdf:*central-registry*) (invoke-restart 'asdf:clear-configuration-and-retry) (DBG "After invoking restart, CENTRAL-REGISTRY is:" asdf:*central-registry*)) ;; avoid infinite looping (leave-test "Infinite loop while catching MISSING-COMPONENT" 11)))) (handler-bind ((asdf:missing-dependency-of-version #'(lambda (c) ;; Nothing Quicklisp can do to recover from this, so ;; just resignal (error c))) (asdf:missing-dependency #'(lambda (c) (DBG "Catching MISSING-DEPENDENCY condition (B):" *attempts*) (handle-missing c))) (asdf:missing-component #'(lambda (c) (DBG "Catching MISSING-COMPONENT condition (C):" *attempts*) (handle-missing c)))) (asdf:load-system "test-missing-dependency")))) (assert-equal *attempts* 1) asdf-3.3.4/test/test-undeferred-warnings.script000066400000000000000000000051131362155115300215730ustar00rootroot00000000000000;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Intended to test behaviors that we see when the deferred warnings check is ;;; NOT deferred. ;;; --------------------------------------------------------------------------- (in-package :asdf-test) (setf asdf/session:*asdf-session* nil) (disable-deferred-warnings-check) (def-test-system :undefined-variables :components ((:file "fun-with-undefined-locals"))) ;;; DEF-TEST-SYSTEM cannot parse :PERFORM arguments #+nil(def-test-system :undefined-variables-throttled :components ((:file "fun-with-undefined-locals" :perform (compile-op :around (op c) (declare (ignorable op c)) (let ((asdf:*compile-file-warnings-behaviour* :ignore)) (call-next-method)))))) (assert (asdf:find-system :undefined-variables-throttled)) ;; GCL fails to warn; CMUCL, SBCL and presumably SCL defer warning to end of compilation unit; ;; SCL and XCL not actually tested (format t "Check for proper errors on warning.~%") (errors #+(or abcl allegro clisp clozure (and ecl (not ecl-bytecmp)) clasp lispworks mkcl xcl) compile-file-error #+(or cmucl (and ecl ecl-bytecmp) gcl sbcl scl) null ;;; need to cover the other cases, or will produce a compile error #-(or abcl allegro clisp clozure (and ecl (not ecl-bytecmp)) clasp lispworks mkcl xcl cmucl (and ecl ecl-bytecmp) gcl sbcl scl) null (let ((*compile-file-warnings-behaviour* :error)) (load-system :undefined-variables :force t))) (format t "Check for proper warnings on warning.~%") (errors #+(or abcl allegro clisp clozure (and ecl (not ecl-bytecmp)) clasp lispworks mkcl xcl) compile-file-error #+(or cmucl (and ecl ecl-bytecmp) gcl sbcl scl) null ;;; need to cover the other cases, or will produce a compile error #-(or abcl allegro clisp clozure (and ecl (not ecl-bytecmp)) clasp lispworks mkcl xcl cmucl (and ecl ecl-bytecmp) gcl sbcl scl) null (let ((*compile-file-warnings-behaviour* :warning)) (load-system :undefined-variables :force t))) (format t "check for undefined variable warnings to not fail a build.~%") (assert (let ((*compile-file-warnings-behaviour* :ignore)) (load-system :undefined-variables :force t))) (format t "check for undefined variable-warnings throttled by PERFORM around method not failing a build.~%") (assert (let ((*compile-file-warnings-behaviour* :error)) (asdf:load-system :undefined-variables-throttled :force t))) asdf-3.3.4/test/test-urls-1.asd000066400000000000000000000001741362155115300162120ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-urls-1 :pathname #p"http://www.scieneer.com/files/" :components ((:file "test"))) asdf-3.3.4/test/test-urls-1.script000066400000000000000000000023051362155115300167450ustar00rootroot00000000000000;;; -*- 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))) asdf-3.3.4/test/test-urls-2.asd000066400000000000000000000001151362155115300162060ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test-urls-2 :components ((:file "test"))) asdf-3.3.4/test/test-urls-2.script000066400000000000000000000023111362155115300167430ustar00rootroot00000000000000;;; -*- 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)))) asdf-3.3.4/test/test-utilities.script000066400000000000000000000613001362155115300176350ustar00rootroot00000000000000;;; -*- Lisp -*- (in-package :asdf-test) ;; the following should not be necessary, because of `frob-packages` ;; call, but somehow is. [2019/06/25:rpg] (use-package :uiop :asdf-test) (proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0))) (defun getcwd-from-run-program () (uiop:parse-native-namestring (nest ;; TODO: fix run-program to use POWERSHELL.EXE rather than CMD, and remove this kluge. #+os-windows (string-trim " ") (run-program (os-cond ((os-unix-p) '("pwd" "-P")) ((os-windows-p) "cd")) :output '(:string :stripped t))) :ensure-directory t)) (defun simplify-pathname-directory (pathname) (setf pathname (ensure-pathname pathname)) (when pathname (make-pathname :defaults pathname :directory (simplify-pathname-directory-component (pathname-directory pathname))))) (defun simplify-pathname-directory-component (dir) (setf dir (normalize-pathname-directory-component dir)) (loop :with head = (progn (unless (and (consp dir) (cdr dir)) (return dir)) (subseq dir 0 1)) :with tail = (rest dir) :for next :in tail :do (unless (equal next ".") (when (member next '(".." :up) :test 'equal) (setf next :back)) (setf head (merge-pathname-directory-components (list :relative next) head))) :finally (return head))) (let ((asdf-directory (truename *asdf-directory*)) (test-directory (truename *test-directory*))) (labels ((check-cwd (dir) (assert-pathname-equal dir (getcwd)) #-(and sbcl os-windows) (assert-pathname-equal dir (getcwd-from-run-program))) (check-true-dpd (dir) (assert-pathname-equal dir (get-pathname-defaults)) (assert-pathname-equal dir (simplify-pathname-directory (truename #p"./"))) (assert-pathname-equal dir (simplify-pathname-directory (truename* #p"./")))) (check-file-exists (file &optional true) (setf file (parse-unix-namestring file)) (if true (assert-pathname-equal true (probe-file file)) (setf true (probe-file file))) (assert-pathname-equal true (truename file)) (assert-pathname-equal true (truename* file)) (assert-pathname-equal true (probe-file* file :truename t)) (assert-pathname-equal true (ensure-absolute-pathname (probe-file* file) 'get-pathname-defaults))) (check-file-doesnt-exist (file) (setf file (parse-unix-namestring file)) (assert-equal nil (probe-file* file)) (assert-equal nil (probe-file file))) (check-directory-exists (file &optional true) (setf file (parse-unix-namestring file)) (let ((dir (truename (ensure-directory-pathname file)))) (if true (assert-pathname-equal true dir) (setf true dir))) (assert-pathname-equal true (truename (ensure-directory-pathname file))) (assert-pathname-equal true (nest #+(and clisp os-windows) (ensure-directory-pathname) (truename* file))) (assert-pathname-equal true (let ((path (probe-file* file :truename t))) #+(or allegro (and clisp os-windows)) (ensure-directory-pathname path) #-(or allegro (and clisp os-windows)) path)) (assert-pathname-equal true (if-let (x (probe-file* file)) (ensure-absolute-pathname (ensure-directory-pathname x) 'get-pathname-defaults)))) (check-directory-doesnt-exist (file) (setf file (parse-unix-namestring file)) (assert-equal nil (probe-file* file))) (check-true-dpd-asdf () (check-true-dpd asdf-directory) (check-file-exists "asdf.asd") (check-file-exists "test/test-utilities.script") (check-directory-exists "tools/") (check-directory-exists "tools") (check-file-doesnt-exist "test-utilities.script") (check-directory-doesnt-exist "stamp-propagation/")) (check-true-dpd-test () (check-true-dpd test-directory) (check-file-exists "test-utilities.script") (check-directory-exists "stamp-propagation/") (check-directory-exists "stamp-propagation") (check-file-doesnt-exist "test/test-utilities.script") (check-directory-doesnt-exist "tools/"))) (DBG "1" (chdir asdf-directory) (setf *default-pathname-defaults* asdf-directory)) (check-true-dpd-asdf) (DBG "2" (chdir test-directory) (setf *default-pathname-defaults* test-directory)) (check-true-dpd-test) (with-expected-failure (#+gcl t) (DBG "3" (chdir asdf-directory) (setf *default-pathname-defaults* test-directory)) (check-true-dpd-test)) #-(or abcl genera xcl ;; on these platforms, chdir changes D-P-D so these tests are not meaningful (and sbcl os-windows)) ;; SBCL on Windows really hates a relative D-P-D. (progn ;; SBCL hates to get (truename #p"") when D-P-D is itself #p"". See https://bugs.launchpad.net/sbcl/+bug/1472414 (DBG "4" (setf *default-pathname-defaults* (nil-pathname)) ;; make things relative to GETCWD (chdir asdf-directory)) ;; note: may or may not change *default-pathname-defaults* to an absolute pathname. (check-true-dpd-asdf) (DBG "5" *default-pathname-defaults* (chdir test-directory)) ;; note: may or may not change *default-pathname-defaults* to an absolute pathname. (check-true-dpd-test) ;; On implementations where chdir doesn't side-effect D-P-D, we can have D-P-D be relative to GETCWD... ;; except on allegro, that hates this trick. (with-expected-failure (#+(or allegro gcl (and clisp os-windows)) t) (unless (absolute-pathname-p *default-pathname-defaults*) (DBG "6" (chdir asdf-directory) (setf *default-pathname-defaults* (parse-unix-namestring "test/"))) (check-true-dpd-test)))) ;; For the rest of this test, use these: (setf *default-pathname-defaults* (nil-pathname)) (chdir test-directory))) (assert (every #'directory-pathname-p (list (make-pathname* :name nil :type nil :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"))))) (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 nil :type "" :directory '(:absolute "tmp")) ;; (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 (not (version-satisfies (find-system :test-asdf) "666"))) (handler-case (version-satisfies (find-system :test-asdf) "666") (simple-warning (c) (assert (search "Requested version ~S but ~S has no version" (simple-condition-format-control c)))) (:no-error (x) (declare (ignore x)) (error "version-satisfies must warn when given component without version"))) (assert (version<= "2.0" (asdf-version))) (assert (not (version-satisfies (asdf-version) "666"))) (DBG "First pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar"))) '(#p"foo" #p"bar")) (DBG "Second pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t) '(#p"foo/" #p"bar/")) (DBG "Third pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t) '(#p"/foo" #p"/bar")) (DBG "Fourth pathname test.") (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t :ensure-directory t) '(#p"/foo/" #p"/bar/")) (DBG "Fifth pathname test.") (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/bundle:prologue-code asdf/bundle:epilogue-code 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 ;; the following is here only for backward compatibility; should be in ;; asdf/system. [2014/02/20:rpg] 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/operation:feature asdf/system:bug-tracker asdf/system:build-pathname asdf/system:system-defsystem-depends-on asdf/system:system-weakly-depends-on 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/system-registry:coerce-entry-to-directory asdf/system-registry:remove-entry-from-registry asdf/lisp-action:try-recompiling ;; types asdf/bundle:user-system #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition uiop/image:fatal-condition ;; on some implementations only asdf/bundle:bundle-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-interface:on-failure asdf/backward-interface:on-warnings asdf/system-registry:contrib-sysdef-search asdf/system-registry:sysdef-find-asdf ;; restart asdf/session:clear-configuration-and-retry )) (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 () (loop :for package :in (list-all-packages) :when (and (or (string-prefix-p "ASDF/" (package-name package)) (string-prefix-p "UIOP/" (package-name package))) (not (equal (package-name package) "UIOP/COMMON-LISP"))) :append (let ((fishy (fishy-exported-symbols package))) (when fishy (list (cons (package-name package) (mapcar 'symbol-name fishy))))))) (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*) (let ((new-file (subpathname *build-directory* "deleteme/a/1.x"))) (when (probe-file new-file) (delete-file new-file)) (with-expected-failure (#+clasp "(system-source-file :asdf) is nil") (copy-file (system-source-file :asdf) new-file))) (let ((new-file (subpathname *build-directory* "deleteme/a/b/2"))) (when (probe-file new-file) (delete-file new-file)) (with-expected-failure (#+clasp "(system-source-file :asdf) is nil") (copy-file (system-source-file :asdf) new-file))) (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"))) (DBG "check to make sure DIRECTORY-FILES doesn't list subdirectories") (let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/"))) (directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/")))) (assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/1.x"))) (assert-pathnames-equal directory-b (list (subpathname *build-directory* "deleteme/a/b/2")))) (DBG "check to make sure DIRECTORY-FILES checks its parameter for directory pathname") (let ((directory-a-no-slash (directory-files (subpathname *build-directory* "deleteme/a"))) (directory-b-no-slash (directory-files (subpathname *build-directory* "deleteme/a/b")))) (assert-pathnames-equal directory-a-no-slash (list (subpathname *build-directory* "deleteme/a/1.x"))) (assert-pathnames-equal directory-b-no-slash (list (subpathname *build-directory* "deleteme/a/b/2")))) (DBG "check to make sure WITH-CURRENT-DIRECTORY checks its parameter for directory pathname") (let ((directory-a-no-slash (subpathname *build-directory* "deleteme/a")) (directory-b-no-slash (subpathname *build-directory* "deleteme/a/b"))) (assert (eq 'with-current-directory 'uiop:with-current-directory)) (with-current-directory (directory-a-no-slash) (with-expected-failure (#+clasp T) (assert-pathnames-equal (directory-files (getcwd)) (list (subpathname *build-directory* "deleteme/a/1.x"))))) (with-current-directory (directory-b-no-slash) (with-expected-failure (#+clasp T) (assert-pathnames-equal (directory-files (getcwd)) (list (subpathname *build-directory* "deleteme/a/b/2")))) (with-expected-failure (#+clasp T) (assert-pathnames-equal (sort (subdirectories (getcwd)) #'string< :key #'(lambda (x) (car (last (pathname-directory x))))) (list (subpathname *build-directory* "deleteme/a/b/c/") (subpathname *build-directory* "deleteme/a/b/d/") (subpathname *build-directory* "deleteme/a/b/e/")))))) (DBG "check to make sure SUBDIRECTORIES does list subdirectories") (let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/"))) (directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/")))) (assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/b/"))) ;; trailing slash should not be necessary... (assert-pathnames-equal (subdirectories (subpathname *build-directory* "deleteme/a")) (list (subpathname *build-directory* "deleteme/a/b/"))) (assert-pathnames-equal (sort directory-b #'string< :key #'(lambda (x) (car (last (pathname-directory x))))) (list (subpathname *build-directory* "deleteme/a/b/c/") (subpathname *build-directory* "deleteme/a/b/d/") (subpathname *build-directory* "deleteme/a/b/e/")))) (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 (<= 4 (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 :initial-element *last-char*))) (assert (typep *last-char* 'base-char))) (defun basify (s) (coerce s 'base-string)) (defun unbasify (s) #-clasp (coerce s '(array character (*))) #+clasp (make-array (length s) :element-type 'character :initial-contents s) ) ; on ECL, literals are base strings (!) on clasp, literals are reduced to base-strings in all chars are base-chars #+non-base-chars-exist-p (progn (assert (= 0 (character-type-index #\a))) (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))) (when (< 256 char-code-limit) (let* ((lambda-char (code-char 955)) (lambda-string (string lambda-char))) (assert (= 1 (character-type-index lambda-char))) (assert-equal (strings-common-element-type (list #\a nil (strcat "hello, " lambda-string "world"))) #-lispworks 'character #+lispworks7+ 'lw:bmp-char #+(and lispworks (not lispworks7+)) 'lw:simple-char) (when (< 65536 char-code-limit) (let* ((amagi (format nil "~a~a" (code-char #x120BC) (code-char #x12104)))) (assert (= #+lispworks7+ 2 #-lispworks7+ 1 (character-type-index (first-char amagi)))) (assert-equal (strings-common-element-type (list #\a nil amagi lambda-string)) #+(or (not lispworks) lispworks7+) 'character #+(and lispworks (not lispworks7+)) 'lw:simple-char)))))) (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 "testing with-temporary-file") (with-temporary-file (:stream s :direction :io :prefix "WTF0") (println "Hello, World" s) (file-position s 0) (assert-equal (read-line s) "Hello, World")) (let ((pn1 (with-temporary-file (:pathname pn :direction :output :prefix "WTF1") (assert-equal (read-file-lines pn) ()) pn))) (assert (not (probe-file pn1)))) (let ((pn2 (with-temporary-file (:stream s :pathname p :keep t :direction :io :prefix "WTF2") (println "Hello, World" s) p))) (assert-equal (read-file-lines pn2) '("Hello, World")) (delete-file pn2)) (with-expected-failure (#+gcl "BUG in GCL compiling the WTF internal loop. Works if loaded without compiling.") (assert (not (probe-file (let ((s 'outer-s)) (with-temporary-file (:stream s :pathname p :direction :io :prefix "WTF3") (assert (open-stream-p s)) (println "Same thing with :close-stream" s) :close-stream (assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope. (assert-equal (read-file-lines p) '("Same thing with :close-stream")) p)))))) (DBG :ensure-gethash) (let ((h (make-hash-table :test 'equal))) (assert-equal (multiple-value-list (gethash 1 h 2)) '(2 nil)) (assert-equal (multiple-value-list (ensure-gethash 1 h 2)) '(2 nil)) (assert-equal (multiple-value-list (gethash 1 h 2)) '(2 t)) (assert-equal (multiple-value-list (ensure-gethash 1 h 3)) '(2 t)) (assert-equal (multiple-value-list (ensure-gethash 1 h '(error "foo"))) '(2 t)) (signals parse-error (ensure-gethash 2 h '(error parse-error))) (assert-equal (multiple-value-list (ensure-gethash 2 h (lambda () 5))) '(5 nil)) (assert-equal (multiple-value-list (gethash 3 h nil)) '(nil nil)) (assert-equal (multiple-value-list (ensure-gethash 3 h nil)) '(nil nil)) (assert-equal (multiple-value-list (gethash 3 h 4)) '(nil t)) (assert-equal (multiple-value-list (ensure-gethash 3 h 5)) '(nil t))) (DBG :optimization-settings) #-(or ecl-bytecmp gcl mkcl) (loop :with settings = (get-optimization-settings) :for i :from 0 :to 3 :do (with-optimization-settings (`((speed ,i) (space ,i) (safety ,i) (debug ,i))) (let ((s (get-optimization-settings))) (loop :for q :in '(speed space safety debug) :do #+mkcl (DBG :os i q s (assoc q s)) (assert-equal i (second (assoc q s)))))) ;;; The order does not seem to be significant, should better test that all values are the same (assert-equal (get-optimization-settings) settings)) (DBG :standard-case-symbol-name) (if (or #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)) (push :modern-syntax *features*) (setf *features* (remove :modern-syntax *features*))) (assert-equal (standard-case-symbol-name "foo") #-modern-syntax "FOO" #+modern-syntax "foo") (assert-equal (standard-case-symbol-name "BaR") #-modern-syntax "BAR" #+modern-syntax "BaR") (assert-equal (standard-case-symbol-name "BAZ") #-modern-syntax "BAZ" #+modern-syntax "BAZ") (assert-equal (standard-case-symbol-name :foo) #-modern-syntax "FOO" #+modern-syntax "foo") (assert-equal (standard-case-symbol-name 'BaR) #-modern-syntax "BAR" #+modern-syntax "BaR") (assert-equal (standard-case-symbol-name '#:BAZ) #-modern-syntax "BAZ" #+modern-syntax "BAZ") (assert-equal (standard-case-symbol-name :|foo|) "foo") (assert-equal (standard-case-symbol-name '|BaR|) "BaR") (assert-equal (standard-case-symbol-name '#:|BAZ|) "BAZ") (DBG :find-standard-case-symbol) (assert-equal 'symbol (find-standard-case-symbol "symbol" "asdf-test")) (assert-equal 'Symbol (find-standard-case-symbol "Symbol" "asdf-test")) (assert-equal 'SYMBOL (find-standard-case-symbol "SYMBOL" "asdf-test")) (assert-equal '|lowercase| (find-standard-case-symbol :|lowercase| :asdf-test)) (assert-equal '|CamelCase| (find-standard-case-symbol :|CamelCase| :asdf-test)) (assert-equal '|UPPER-CASE| (find-standard-case-symbol :|UPPER-CASE| :asdf-test)) (assert-equal #-modern-syntax '|THIS_SYMBOL| #+modern-syntax '|This_Symbol| (find-standard-case-symbol "This_Symbol" "asdf-test")) asdf-3.3.4/test/test-version.script000066400000000000000000000041321362155115300173070ustar00rootroot00000000000000;;; -*- 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 :unversioned-system :pathname #.*test-directory*) (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/2 "2.1")) :pathname #.*test-directory* :version "1.2") (def-test-system :versioned-system-file-form :defsystem-depends-on ((:version :test-asdf/2 "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/2 "2.1")) :pathname #.*test-directory* :version (:read-file-line #.(test-source "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") ;; version UNmatching (vtest :unversioned-system "1" nil) (vtest :versioned-system-1 "1.1" nil) (vtest :versioned-system-2 "1.1" t) (vtest :versioned-system-2 "1.1.1" nil) (vtest :versioned-system-2 "1.2" nil) (vtest :versioned-system-3 "1.2") (vtest :versioned-system-3 "1.1") (vtest :versioned-system-3 "1.1.1") asdf-3.3.4/test/test-weakly-depends-on-present.script000066400000000000000000000021241362155115300226250ustar00rootroot00000000000000;;; -*- 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))) asdf-3.3.4/test/test-weakly-depends-on-unpresent.asd000066400000000000000000000001631362155115300224340ustar00rootroot00000000000000(defsystem test-weakly-depends-on-unpresent :weakly-depends-on (does-not-exist) :components ((:file "file1"))) asdf-3.3.4/test/test-weakly-depends-on-unpresent.script000066400000000000000000000013161362155115300231720ustar00rootroot00000000000000;;; -*- 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))) asdf-3.3.4/test/test-xach-update-bug.script000066400000000000000000000050441362155115300206030ustar00rootroot00000000000000;;; -*- Lisp -*- (setf asdf/session:*asdf-session* nil) ;; disable cache between those two very different compilations. (defparameter foo :test-asdf-location-change) #+ecl (unless (version-satisfies (lisp-implementation-version) "16") (leave-test "ECL only supports this test starting with 16.0.0" 0)) (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") ;;; ECL bug: this fails if we use load-bundle-op instead of load-op as *load-system-operation* ;;; in bundle.lisp. The test-asdf-location-change.fasb is linked and loaded, but that fails to ;;; create the :second-version package; loading the same .fasb in another ecl works fine, and ;;; defines (second-version:wtf). WTF? You can test this bug by uncommenting the ;;; (setf asdf::*load-system-operation* 'load-bundle-op) line at the beginning of this file. ;;; NB: works on MKCL. (load-system foo) (assert (symbol-value (find-symbol* :loaded :second-version))) (assert-equal 42 (symbol-call :second-version :wtf)) asdf-3.3.4/test/test.lisp000066400000000000000000000007211362155115300152670ustar00rootroot00000000000000;;;; 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)) asdf-3.3.4/test/test1.asd000066400000000000000000000006711362155115300151540ustar00rootroot00000000000000;;; -*- Lisp -*- (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 |# asdf-3.3.4/test/test1.script000066400000000000000000000055031362155115300157100ustar00rootroot00000000000000;;; -*- Lisp -*- (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*)) ;; 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") (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*)) asdf-3.3.4/test/test2.asd000066400000000000000000000004371362155115300151550ustar00rootroot00000000000000;;; -*- 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")) asdf-3.3.4/test/test2.script000066400000000000000000000015551362155115300157140ustar00rootroot00000000000000;;; -*- Lisp -*- ;; We don't use load-system, because it can be load-fasl-op on ECL, ;; and these systems define manual dependencies on compile-op. (DBG "test2: loading test2b1") (operate 'load-op '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") (handler-case (operate 'load-op '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") (handler-case (operate 'load-op 'test2b3) (asdf:missing-dependency (c) (format t "load failed as expected: - ~%~A~%" c)) (:no-error (c) (declare (ignore c)) (error "should have failed, oops"))) asdf-3.3.4/test/test2a.asd000066400000000000000000000004451362155115300153150ustar00rootroot00000000000000;;; -*- 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] |# asdf-3.3.4/test/test2b1.asd000066400000000000000000000004671362155115300154030ustar00rootroot00000000000000;;; -*- 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"))))) asdf-3.3.4/test/test2b2.asd000066400000000000000000000004711362155115300153770ustar00rootroot00000000000000;;; -*- 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"))))) asdf-3.3.4/test/test2b3.asd000066400000000000000000000004411362155115300153750ustar00rootroot00000000000000;;; -*- 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)) asdf-3.3.4/test/test3.asd000066400000000000000000000002031362155115300151450ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem test3 :components ((:file "file1" :if-feature :asdf) (:file "file2" :if-feature (:not :asdf)))) asdf-3.3.4/test/test3.script000066400000000000000000000010271362155115300157070ustar00rootroot00000000000000;;; -*- 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 cmucl 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*))) asdf-3.3.4/test/test8.script000066400000000000000000000007321362155115300157160ustar00rootroot00000000000000;;; -*- 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"))) asdf-3.3.4/test/test9-1.asd000066400000000000000000000002151362155115300153140ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test9-1 :version "1.1" :components ((:file "file1")) :depends-on ((:version :test9-2 "2.0"))) asdf-3.3.4/test/test9-2.asd000066400000000000000000000001411362155115300153130ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem test9-2 :version "1.0" :components ((:file "file2"))) asdf-3.3.4/test/test9.script000066400000000000000000000006541362155115300157220ustar00rootroot00000000000000;;; -*- 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. asdf-3.3.4/test/try-recompiling-1.asd000066400000000000000000000001331362155115300173670ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem try-recompiling-1 :components ((:file "try-recompiling-1"))) asdf-3.3.4/test/try-recompiling-1.lisp000066400000000000000000000002601362155115300175700ustar00rootroot00000000000000(in-package :asdf-test) #+clisp (eval-when (:compile-toplevel) (fmakunbound 'try-recompiling-1)) (defun try-recompiling-1 () (assert *caught-error*)) (try-recompiling-1) asdf-3.3.4/test/try-reloading-1.asd000066400000000000000000000002031362155115300170210ustar00rootroot00000000000000;;; -*- Lisp -*- (asdf:defsystem try-reloading-1 :components ((:file "file1")) :depends-on ("try-reloading-dependency")) asdf-3.3.4/test/try-reloading-dependency.hidden000066400000000000000000000001261362155115300214670ustar00rootroot00000000000000;;; -*- Lisp -*- (defsystem try-reloading-dependency :components ((:file "file3"))) asdf-3.3.4/test/undefined-variables-throttled.asd000066400000000000000000000005421362155115300220270ustar00rootroot00000000000000(defsystem :undefined-variables-throttled :components ((:file "fun-with-undefined-locals" :perform (compile-op :around (op c) (declare (ignorable op c)) (let ((asdf:*compile-file-warnings-behaviour* :ignore)) (call-next-method)))))) asdf-3.3.4/test/unintern-foo.lisp000066400000000000000000000003511362155115300167320ustar00rootroot00000000000000(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)) asdf-3.3.4/test/use-foo.lisp000066400000000000000000000003361362155115300156670ustar00rootroot00000000000000(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*))) asdf-3.3.4/test/use-setf-foo.lisp000066400000000000000000000007001362155115300166210ustar00rootroot00000000000000(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*))) asdf-3.3.4/test/version.lisp-expr000066400000000000000000000000121362155115300167420ustar00rootroot00000000000000"1.0" 1.0 asdf-3.3.4/test/wild-module.script000066400000000000000000000003361362155115300170710ustar00rootroot00000000000000;;; -*- Lisp -*- (load (subpathname *asdf-directory* "contrib/wild-modules.lisp")) (def-test-system :wild-module :version "0.0" :components ((:wild-module "systems" :pathname #p"*.asd"))) (load-system :wild-module) asdf-3.3.4/test/xach-foo-1/000077500000000000000000000000001362155115300152615ustar00rootroot00000000000000asdf-3.3.4/test/xach-foo-1/a.lisp000066400000000000000000000002021362155115300163640ustar00rootroot00000000000000;;;; a.lisp (defpackage :first-version (:use #:cl) (:export #:loaded)) (in-package :first-version) (defparameter loaded t) asdf-3.3.4/test/xach-foo-1/test-asdf-location-change.asd000066400000000000000000000001431362155115300226730ustar00rootroot00000000000000;;;; foo.asd (asdf:defsystem #:test-asdf-location-change :serial t :components ((:file "a"))) asdf-3.3.4/test/xach-foo-2/000077500000000000000000000000001362155115300152625ustar00rootroot00000000000000asdf-3.3.4/test/xach-foo-2/a.lisp000066400000000000000000000002121362155115300163660ustar00rootroot00000000000000;;;; a.lisp (defpackage :second-version (:use #:cl) (:export #:loaded #:wtf)) (in-package :second-version) (defparameter loaded t) asdf-3.3.4/test/xach-foo-2/b.lisp000066400000000000000000000000771362155115300164000ustar00rootroot00000000000000;;;; b.lisp (in-package :second-version) (defun wtf () 42) asdf-3.3.4/test/xach-foo-2/test-asdf-location-change.asd000066400000000000000000000002201362155115300226700ustar00rootroot00000000000000;;;; foo.asd (asdf:defsystem #:test-asdf-location-change :serial t :components ((:file "a") (:file "b" :depends-on ("a")))) asdf-3.3.4/tools/000077500000000000000000000000001362155115300136005ustar00rootroot00000000000000asdf-3.3.4/tools/asdf-tools000077500000000000000000000051531362155115300156050ustar00rootroot00000000000000#| -*- Lisp -*- case "$LISP" in # SBCL is our default on Unix, because while CCL has better support on Windows and MacOS, # SBCL still runs decently on MacOS and CCL has a background thread that eats input # (and still puts the tty in raw mode if using single-threaded-ccl) which defeats # the purpose of `make load`. See: https://bugs.launchpad.net/asdf/+bug/1624909 allegro) ${ALLEGRO:-alisp} -qq -e "(setf *load-verbose* nil)" -L "$0" -- "$@" ;; ccl) exec ${CCL:-ccl} --no-init --load "$0" -- "$@" ;; ""|sbcl) exec ${SBCL:-sbcl} --noinform --no-userinit --no-sysinit --script "$0" "$@" ;; # Let cl-launch choose its preferred Lisp cl-launch) cl-launch -Q -sp asdf-tools -r entry-point -- "$@" ;; # asdf-tools could actually run on any implementation, if you configured it above. *) echo >&2 "Unknown Lisp $LISP" ; exit 2 esac ; exit |# (in-package :cl-user) ;; That may be default, but let's make double sure and tell SLIME. ;;; Ensure we load and configure this particular ASDF (eval-when (:compile-toplevel :load-toplevel :execute) (unless (member :cl-launch *features*) ;; (not necessary if we're invoked via cl-launch) (handler-bind ((warning #'muffle-warning)) ;; hush Allegro (load (make-pathname :name "load-asdf" :type "lisp" :defaults (or *compile-file-truename* *load-truename* (truename *default-pathname-defaults*))))))) ;;; ASDF3 is loaded, now use it! (in-package :asdf) (eval-when (:compile-toplevel :load-toplevel :execute) ;; For bootstrap purposes, avoid having to extract cl-launch.asd into ext/cl-launch/ (let* ((asdf-dir (pathname-parent-directory-pathname (ensure-absolute-pathname (current-lisp-file-pathname) 'getcwd))) (cl-launch-dir (subpathname asdf-dir "ext/cl-launch/"))) (when (and (not (find-system "cl-launch/dispatch" nil)) (probe-file* (subpathname cl-launch-dir "dispatch.lisp"))) (eval `(defsystem "cl-launch/dispatch" :class :package-inferred-system :source-file nil :pathname ,cl-launch-dir :components ((cl-source-file "lisp" :pathname "dispatch")))))) ;; Depending on whether Quicklisp was loaded or not, either use it or use regular load-system (defun load-sys (system) (if (featurep :quicklisp) (let ((*standard-output* (make-broadcast-stream))) ;; be quiet (symbol-call :ql :quickload system)) (load-system system :verbose nil))) ;; Finally, load asdf-tools (load-sys "asdf-tools")) ;;; asdf-tools is loaded, now actually run it! (restore-image :entry-point 'asdf-tools::entry-point :lisp-interaction nil) asdf-3.3.4/tools/asdf-tools.asd000066400000000000000000000023451362155115300163500ustar00rootroot00000000000000(defsystem "asdf-tools" :description "tools to build, test, maintain and release ASDF itself" :depends-on ((:version "asdf" "3.2.0") (:version "inferior-shell" "2.0.3.4") (:version "lisp-invocation/all" "1.0.14") (:version "cl-ppcre" "2.0.11") (:version "optima.ppcre" "1.0") (:version "cl-scripting" "0.2") (:feature :sbcl (:require "sb-introspect"))) :build-operation program-op :build-pathname "../build/asdf-tools" :entry-point "asdf-tools::entry-point" :components ((:file "package") (:file "main" :depends-on ("package")) (:file "pathnames" :depends-on ("package")) (:file "version" :depends-on ("package")) (:file "test-environment" :depends-on ("pathnames" "main")) (:file "build" :depends-on ("test-environment")) (:file "git" :depends-on ("test-environment")) (:file "test-basic" :depends-on ("test-environment")) (:file "test-scripts" :depends-on ("test-environment")) (:file "test-upgrade" :depends-on ("test-environment" "git")) (:file "test-all" :depends-on ("test-basic")) (:file "installation" :depends-on ("test-environment")) (:file "release" :depends-on ("version" "test-environment" "git")))) asdf-3.3.4/tools/asdf-tools.bat000066400000000000000000000021141362155115300163410ustar00rootroot00000000000000::@echo off ::: By default. We use CCL, because SBCL doesn't have a good enough run-program on Windows. if "%LISP%" == "" goto ccl if "%LISP%" == "allegro" goto allegro if "%LISP%" == "ccl" goto ccl if "%LISP%" == "sbcl" goto sbcl :ccl if "%CCL%" == "" set CCL=ccl "%CCL%" --no-init --load "%~dp0asdf-tools" -- %* goto end :sbcl ::: As of SBCL 1.2.13, SBCL's run-program fails to call CMD.EXE directly, so can't fully run asdf-tools if "%SBCL%" == "" set SBCL=sbcl "%SBCL%" --noinform --no-userinit --no-sysinit --script "%~dp0asdf-tools" %* goto end :allegro if "%ALLEGRO%" == "" set ALLEGRO=alisp.exe if "%~1" == "get_allegro_dir" goto get_allegro_dir call %0 get_allegro_dir "%ALLEGRO%" "%ALLEGRO%.exe" "%ALLEGRODIR%buildi.exe" -I "%ALLEGRODIR%alisp.dxl" -qq -e "(setf *load-verbose* nil)" -L "%~dp0asdf-tools." -- %* goto end :get_allegro_dir if not "%~dp$PATH:2" == "" ( set ALLEGRODIR=%~dp$PATH:2& goto end ) if not "%~dp$PATH:3" == "" ( set ALLEGRODIR=%~dp$PATH:3& goto end ) if not "%~dp2" == "" ( set ALLEGRODIR=%~dp2& goto end ) goto end ::: Make sure this remains at the end :end asdf-3.3.4/tools/build.lisp000066400000000000000000000027321362155115300155740ustar00rootroot00000000000000(in-package :asdf-tools) (deftestcmd build-asdf () "make sure asdf.lisp is built" (load-system :asdf) (success)) (deftestcmd build-asdf-tools () "build a binary for asdf-tools" (asdf:operate :program-op :asdf-tools) (success)) ;;; Documentation (deftestcmd doc () "build documentation in doc/ directory" (with-failure-context (:name "in doc/ directory") (run* '(make) :directory (pn "doc/")))) (deftestcmd website () "publish documentation onto the public website" (with-failure-context (:name "in doc/ directory") (run* '(make website) :directory (pn "doc/")))) ;;; Line counting (deftestcmd wc () "count lines of lisp code in asdf and uiop" (with-asdf-dir () (flet ((lisp-only (x) (remove "lisp" x :test-not 'equal :key 'pathname-type))) (let ((uiop-files (mapcar #'(lambda (x) (subpathname "uiop/" x)) (lisp-only (uiop-files)))) (defsystem-files (remove "build/asdf.lisp" (lisp-only (asdf-defsystem-files)) :test 'equal))) (run* `(pipe (wc ,@uiop-files) (sort -n))) (terpri) (run* `(pipe (wc ,@defsystem-files) (sort -n))) (terpri) (run* `(pipe (wc ,@uiop-files ,@defsystem-files) (tail -n 1))))))) ;;; debug the source registry that is being used to execute these tools. (deftestcmd list-source-registry () "Display the source-registry cache" (writeln (sort (alexandria:hash-table-alist asdf::*source-registry*) 'string< :key 'car))) asdf-3.3.4/tools/cl-source-registry-cache.lisp000077500000000000000000000044371362155115300213070ustar00rootroot00000000000000#!/usr/bin/cl -sp asdf -E main #| Usage: ~/common-lisp/asdf/tools/cl-source-registry-cache.lisp ~/common-lisp will compute a cache of the .asd files under ~/common-lisp// vastly speeding the future initialization of the source-registry. To update the cache, run the same command again. To invalidate the cache, remove the cache file in the same directory: rm -f ~/common-lisp/.cl-source-registry.cache |# (in-package :asdf) (defun collect-asd (table asd) (multiple-value-bind (previous foundp) (gethash (pathname-name asd) table) (when (or (not foundp) (> (length (pathname-directory previous)) (length (pathname-directory asd)))) (setf (gethash (pathname-name asd) table) asd)))) (defun update-cache (directory &key (exclude *default-source-registry-exclusions*) (recurse-beyond-asds *recurse-beyond-asds*)) (let* ((dir (ensure-pathname directory :namestring :native :ensure-absolute t :want-non-wild t :ensure-directory t :want-existing t)) (table (make-hash-table :test 'equal)) (collector #'(lambda (asd) (collect-asd table asd)))) (collect-sub*directories dir #'(lambda (d) (if-let (cache (unless (equal d dir) (probe-file* (subpathname d ".cl-source-registry.cache")))) (destructuring-bind (tag &rest entries) (read-file-form cache) (assert (eq tag :source-registry-cache)) (dolist (asd entries) (funcall collector (subpathname d asd))) nil) (let ((asds (collect-asds-in-directory d collector))) (or recurse-beyond-asds (not asds))))) #'(lambda (sub) (not (member (car (last (pathname-directory sub))) exclude :test #'equal))) (constantly nil)) (with-output-file (s (subpathname dir ".cl-source-registry.cache") :if-exists :rename-and-delete :if-does-not-exist :create) (format s "(:source-registry-cache~{~% ~S~})~%" (sort (loop :for p :being :the :hash-values :of table :collect (unix-namestring (enough-pathname p dir))) 'string<))))) (defun main (argv) (map () 'update-cache argv)) asdf-3.3.4/tools/git.lisp000066400000000000000000000052341362155115300152600ustar00rootroot00000000000000(in-package :asdf-tools) ;;; Using git ;; 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 (defun git (cmd &rest keys) (with-asdf-dir () (apply 'run* `(git ,@cmd) keys))) (deftestcmd clean () "clean the checkout with git clean -xfd" (git '(clean -xfd))) (deftestcmd %push () "push git branches master and release upstream" (dolist (x '((status) (push --tags cl.net release master) (push --tags github release master) (fetch) (status))) (git x))) (deftestcmd merge-master-into-release () "merge git branch master into release" (dolist (x '((checkout master) (merge release) (checkout release) (merge master) (checkout master))) (git x))) (defparameter *wrongful-tags* '("1.37" ;; It's not asdf.lisp 1.37, it's asdf.lisp 1.85! 1.37 was the CVS version of the README. "1.1720" ;; That was a typo for 1.720 "RELEASE" "STABLE" ;; These were misguided attempts for what should have been branches "README" "emp")) ;; Mistakes (deftestcmd fix-local-git-tags () "delete wrongful tags from local git repository" (call-without-stopping (mapcar (lambda (tag) (lambda () (git `(tag -d ,tag) :on-error nil))) *wrongful-tags*))) (deftestcmd fix-remote-git-tags ((remote "origin")) "delete wrongful tags from remote git repository" (call-without-stopping (mapcar (lambda (tag) (lambda () (git `(push ,remote (:refs/tags/,tag)) :on-error nil))) *wrongful-tags*))) (deftestcmd git-all-committed-p () "is your checkout clean, with all files committed?" (let ((uncommitted (nth-value 2 (git '(status -s) :output :lines)))) (success-if (null uncommitted) "git reports uncommitted files:~{~% ~A~}~%" uncommitted))) (defun get-git-branch () "What is the current checked out branch?" (match (first (nth-value 2 (git '(status) :output :lines))) ((ppcre "^# On branch (.*)$" x) x))) (deftestcmd ext-init () "Populate the ext/ directory if not already populated. Same as `make ext` in the bootstrap make script." (git '(submodule update --init))) (deftestcmd ext-clear () "Depopulate the ext/ directory. Same as `make noext` in the bootstrap make script." (git '(submodule deinit "."))) (deftestcmd ext-reset () "Reset the ext/ directory to the contents specified by the current git checkout." (git '(submodule update --init))) (deftestcmd ext-update () "Update the ext/ directory to the latest version from remote repositories." (git '(submodule update --remote))) asdf-3.3.4/tools/install-asdf.lisp000077500000000000000000000170361362155115300170640ustar00rootroot00000000000000":" ; exec cl-launch "$0" "$@" # -*- Lisp -*- #| Usage: make && ./tools/asdf-tools install-asdf lispworks or make l=lispworks install-asdf or make && cl-launch -l lispworks tools/install-asdf.lisp or make sbcl # or otherwise start your Lisp (load "tools/install-asdf.lisp") This script will install the current version of ASDF as a module pre-compiled for your implementation, as specified by option -l (--lisp) of cl-launch, so you can (require "asdf") within your implementation and have it load a recent ASDF instead of an outdated one. This file requires cl-launch 4 and works on most implementations. It notably doesn't work on: * ABCL, that keeps ASDF in its jar, but that's OK because ABCL has a recent enough ASDF3 that is capable of upgrading itself. * On MKCL and ECL, more work is needed to take into account the linkable variant of ASDF, that may be a .o or a .lib. Also, MKCL now delivers UIOP separately from ASDF, which is great, but requires support. Happily, both ECL and MKCL tend to sport a recent ASDF 3, too. * SBCL since 1.2.3 now like MKCL delivers UIOP separately from ASDF. * mocl, that doesn't support ASDF 3 yet. * Corman Lisp, RMCL, Genera, that are obsolete anyway. Note that if you're using it with LispWorks, you first have to create a command-line executable for LispWorks this way: echo '(hcl:save-image "lispworks-console" :environment nil)' > si.lisp lispworks-7-0-0-x86-linux -siteinit - -init - -build si.lisp |# #+gcl (eval-when (:compile-toplevel :load-toplevel :execute) (declaim (optimize (speed 1) (safety 0) (space 0))) (proclaim '(optimize (speed 1) (safety 0) (space 0))) (si::use-fast-links nil) (compile-file (merge-pathnames #p"../build/asdf.lisp" *load-truename*) :output-file (merge-pathnames #p"../modules/asdf.o" system:*system-directory*)) (system:quit 0)) ;;; Ensure we load and configure this particular ASDF #-cl-launch (eval-when (:compile-toplevel :load-toplevel :execute) (unless (member :cl-launch *features*) ;; (not necessary if we're invoked via cl-launch) (load (make-pathname :name "load-asdf" :type "lisp" :defaults (or *compile-file-truename* *load-truename* (truename *default-pathname-defaults*)))))) (in-package :asdf) (defvar *asdf-dir* (ensure-pathname (system-relative-pathname :asdf ()) :want-physical t :want-absolute t :want-existing t :truename t)) (defun module-directory () #+allegro #p"sys:code;" #+(or clasp ecl mkcl) #p"sys:" #+clisp (subpathname custom:*lib-directory* "asdf/") #+clozure #p"ccl:tools;" #+cmucl #p"modules:asdf/" #+gcl (subpathname system:*system-directory* "../modules/") #+lispworks (system:lispworks-dir "load-on-demand/utilities/") #+sbcl (subpathname (sb-int:sbcl-homedir-pathname) "contrib/") #+scl #p"file://modules/" #+xcl ext:*xcl-home* #-(or allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl xcl) (error "module-directory not implemented on ~A" (implementation-type))) (defun module-fasl (name) #+allegro (flet ((pathname-key (x) (let ((type (pathname-type x))) (cond ((and (stringp type) (every #'digit-char-p type)) (parse-integer type)) ((equal type "fasl") 0) (t -1))))) (first (sort (directory (merge-pathnames* (strcat name ".*") (module-directory))) #'> :key #'pathname-key))) #+(or clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl xcl) (compile-file-pathname (subpathname (truename (module-directory)) name :type "lisp")) #-(or allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl xcl) (error "Not implemented on ~A" (implementation-type))) (defun uiop-module-fasl () (module-fasl "uiop")) (defun asdf-module-fasl () (module-fasl "asdf")) (defun object-file (name &optional (type :object)) #-(or clasp ecl mkcl) (progn name type (assert nil)) #+(or clasp ecl) (compile-file-pathname name :type type) #+mkcl (make-pathname :defaults name :type (bundle-pathname-type type))) (defun call-with-file-replacement (file thunk) (let ((orig (add-pathname-suffix file "-orig"))) (ensure-directories-exist (translate-logical-pathname file)) (when (and (probe-file* file) (not (probe-file* orig))) (rename-file-overwriting-target file orig)) (funcall thunk))) (defmacro with-file-replacement ((file) &body body) `(call-with-file-replacement ,file (lambda () ,@body))) (uiop:uiop-debug) (defun install-asdf-as-module () (nest (let* ((asdf.lisp (subpathname *asdf-dir* "build/asdf.lisp")) (asdf.fasl (asdf-module-fasl)) #+(or clasp ecl mkcl) (asdf.o (object-file asdf.fasl :object)) #+(or clasp ecl mkcl) (asdf.a (object-file asdf.fasl :lib)))) (with-file-replacement (asdf.fasl)) #+(or clasp ecl mkcl) (with-file-replacement (asdf.o)) #+(or clasp ecl mkcl) (with-file-replacement (asdf.a)) (progn (compile-file* asdf.lisp :output-file asdf.fasl #+(or clasp ecl mkcl) :object-file #+(or clasp ecl mkcl) asdf.o) #+(or ecl mkcl) (create-image asdf.a (list asdf.o) :kind :lib)))) (defun install-uiop-and-asdf-as-modules () (let ((uiop.fasl (uiop-module-fasl)) (uiop.asd (subpathname *asdf-dir* "uiop/uiop.asd"))) ;; We need to *explicitly* LOAD UIOP's system definition because FIND-SYSTEM ;; will hide any uiop.asd files with a version that is not strictly greater ;; than the one that is loaded. Because the first step of the install ;; procedure is to load the version of ASDF/UIOP that we're trying to ;; install, that obviously causes issues. We are unable to LOAD-ASD the asd ;; file because UIOP is a PRELOADED system so LOAD-ASD will use the existing ;; system definition (which is essentially empty) to try and find the source ;; files and CLEAR-SYSTEM doesn't help either. (load uiop.asd) (with-file-replacement (uiop.fasl) (operate 'compile-bundle-op "uiop") (rename-file-overwriting-target (first (output-files 'compile-bundle-op "uiop")) uiop.fasl) (load uiop.fasl)) #+(or clasp ecl mkcl) (let ((uiop.a (object-file asdf.fasl :lib))) (with-file-replacement (uiop.a) (operate 'lib-op "uiop") (rename-file-overwriting-target (output-file 'lib-op "uiop") uiop.a))) (nest (let* ((asdf.fasl (asdf-module-fasl)) (asdf.lisp (make-pathname :type "lisp" :defaults asdf.fasl)) #+(or clasp ecl mkcl) (asdf.o (object-file asdf.fasl :object)) #+(or clasp ecl mkcl) (asdf.a (object-file asdf.fasl :lib)))) (with-file-replacement (asdf.lisp)) (with-file-replacement (asdf.fasl)) #+(or clasp ecl mkcl) (with-file-replacement (asdf.o)) #+(or clasp ecl mkcl) (with-file-replacement (asdf.a)) (progn (with-output-file (o asdf.lisp :if-exists :rename-and-delete :if-does-not-exist :create) (println "(cl:require \"uiop\")" o) (dolist (c (component-children (find-system "asdf/defsystem"))) (with-input-file (i (component-pathname c)) (copy-stream-to-stream i o)))) (compile-file* asdf.lisp :output-file asdf.fasl #+(or clasp ecl mkcl) :object-file #+(or clasp ecl mkcl) asdf.o) #+(or clasp ecl mkcl) (create-image asdf.a (list asdf.o) :kind :lib))))) #+(or sbcl mkcl) (progn (install-uiop-and-asdf-as-modules) (quit)) #+(or allegro clasp clisp clozure cmucl ecl gcl lispworks scl xcl) (progn (install-asdf-as-module) (quit)) #+(or abcl cormanlisp genera mcl mocl) (die 2 "Not supported on ~A" (implementation-type)) (error "What kind of implementation is THIS?") asdf-3.3.4/tools/installation.lisp000066400000000000000000000021011362155115300171640ustar00rootroot00000000000000(in-package :asdf-tools) ;;; BONUS: install asdf as module for your favorite Lisp implementation. (deftestcmd install-asdf (lisp) "install asdf as a module on specified Lisp" (flet ((doit () (with-asdf-dir () (run-test-lisp (format nil "installing ASDF to be provided as a module on ~(~A~)" lisp) '((load "tools/install-asdf.lisp")(uiop:quit)) :lisp lisp)))) (case lisp ((:allegro :allegromodern :ccl :clisp :cmucl :ecl :ecl_bytecodes :lispworks :mkcl :sbcl :scl :xcl) (doit)) ((:abcl) (format t "Upgrading the implementation-provided ASDF on ~(~A~) isn't supported (yet). Happily, that implementation is known to keep ASDF reasonably up to date.~%" lisp)) ((:cormancl :gcl :genera :mcl :mocl) (format t "Installing ASDF so it is provided by ~(~A~) isn't supported. If you care, go hack the implementation.~%" lisp)) (otherwise (if (string-prefix-p "allegro" (string-downcase lisp)) (doit) (error "Unknown implementation ~(~A~)" lisp)))))) asdf-3.3.4/tools/load-asdf.lisp000066400000000000000000000320531362155115300163260ustar00rootroot00000000000000;;; The code below exemplifies how to load and configure ASDF ;;; as part of your own deterministic build. ;;; See "User-configurable parts" for where you'd customize it to suit your build. ;;; ;;; We have to play games with packages because on some implementations, ;;; an ASDF upgrade from ASDF 2 can throw away the previous package. ;;; ;;; Everything is MUCH simpler if you can assume your implementation has a recent-enough ASDF 3: ;;; see the commented out alternative below. ;;; ;;; To use the user-configured ASDF rather than a deterministic self-contained project build, ;;; see instead how cl-launch 4.0.4 loads ASDF. ;;; Actually, if you can assume that your implementation or distribution provides ASDF 3, ;;; you may simply use cl-launch, and achieve a deterministic self-contained project build ;;; by having your shell configuration or some shell wrapper script export a proper values ;;; for the CL_SOURCE_REGISTRY and ASDF_OUTPUT_TRANSLATIONS environment variables. (in-package :cl-user) ;; That may be default, but let's make double sure and tell SLIME. ;; Do everything in eval-when, so this works ;; whether this file is being loaded directly or compiled first. (eval-when (:compile-toplevel :load-toplevel :execute) (labels ((asdf-symbol (name) (and (find-package :asdf) (find-symbol (string name) :asdf))) (asdf-call (name &rest args) (apply (asdf-symbol name) args)) (asdf-version () (when (find-package :asdf) (or (symbol-value (or (asdf-symbol '*asdf-version*) (asdf-symbol '*asdf-revision*))) "1.0"))) (subpath (parent &key directory name type version) ;; We need subpath here, because we can't yet assume ASDF 3 and its subpathname (merge-pathnames (make-pathname :defaults parent :directory (cons :relative directory) :name name :type type :version version) (make-pathname :name nil :type nil :version nil :defaults parent))) (here-directory () (subpath (or *compile-file-truename* *load-truename* (truename *default-pathname-defaults*)))) (try-load (x) (ignore-errors (and (probe-file x) (load x)))) (load-and-configure-asdf () ;; First, try to require ASDF from the implementation, if not already loaded. ;; All actively maintained implementations now provide ASDF 3.0; ;; some old versions of maintained implementations, and some unmaintained ;; or obsolete implementations only provide ASDF 2, ASDF 1, or don't provide ASDF. ;; Note that CLISP is case-sensitive, so we need to specify a lowercase string, ;; and not the keyword :asdf or symbol 'asdf; also old CLISP versions that don't ;; provide ASDF may error at compile-time if we call (require "asdf") directly. (ignore-errors (funcall 'require "asdf")) ;; If ASDF 2 isn't provided, load our ASDF from source. ;; ASDF 1 is not enough, because it won't heed our project's output-translations. ;; (Beside, no one serious provides ASDF 1 anymore.) (unless (member :asdf2 *features*) (or (and (try-load (asdf-lisp)) (member :asdf2 *features*)) (error "This Lisp implementation fails to provide ASDF 2 or later. ~ Please install it in ~A" (asdf-lisp)))) ;; Configure ASDF (configure-asdf) (let ((provided-version (asdf-version))) ;; Upgrade ASDF to what we configured it to be. (asdf-call 'load-system :asdf) ;; If the implementation-provided version was too old, ;; we need to re-configure, because old configuration may have been moved away. (unless (asdf-call 'version-satisfies provided-version "2.27") (configure-asdf))) (unless (asdf-call 'version-satisfies (asdf-version) (required-asdf-version)) (error "This program needs ASDF ~A but could only find ASDF ~A" (required-asdf-version) (asdf-version))) ;; Here, we specifically want the ASDF in the current git checkout over ;; whatever quicklisp is providing, so we load quicklisp last. ;; If the checkout weren't providing ASDF and we wanted to rely on Quicklisp ;; to provide a copy of ASDF that the implementation might be lacking, ;; we'd move this form right below the (funcall 'require "asdf") above. ;; See also notes in try-load-quicklisp. ;; (try-load-quicklisp) ) ;; ****** User-configurable parts ****** (required-asdf-version () "3.1.2") ;; In the end, we want at least ASDF 3.1.2 (asdf-lisp () ;; Here, define where your Lisp source code hierarchy stores its copy of ASDF. ;; In your project, that might be :directory '("libraries" "asdf" "build") ;; Or NIL, if you don't do use any fancy ASDF feature, and ;; trust your implementation to provide a recent enough copy. (subpath (here-directory) :directory '(:back "build") :name "asdf" :type "lisp")) (try-load-quicklisp () ;; In a controlled environment, either you'd use your own quicklisp ;; instead of the one in the user's homedir, or you wouldn't use quicklisp at all. ;; Edit this function as desired to reflect that and/or remove the call above. ;; Also, if you rely on quicklisp to load a recent ASDF rather than provide it ;; yourself in your code checkout (see above), you should be using the less portable ;; (merge-pathnames "..." (user-homedir-pathname)) rather than subpathname. (or (try-load (asdf-call 'subpathname (user-homedir-pathname) "quicklisp/setup.lisp")) (try-load (asdf-call 'subpathname (user-homedir-pathname) ".quicklisp/setup.lisp")))) (configure-asdf () (let* ((source-directory ;; Here, define the top of your Lisp source code hierarchy. ;; If you can assume an implementation that has ASDF 2 or later ;; (you should: all serious ones do), you might compute it based on ;; (asdf-call 'getenv "MY_PROJECT_ROOT") instead of (here-directory). ;; If you can assume an implementation that has ASDF 3 or later ;; (you probably can: most serious ones do), you might use instead ;; (asdf-call 'getenv-pathname "MY_PROJECT_ROOT" ;; :want-absolute t :ensure-directory t) (subpath (here-directory) :directory '(:back))) (source-registry (or (asdf-call 'getenv "ASDF_DEVEL_SOURCE_REGISTRY") `(:source-registry (:directory ,source-directory) (:directory (,source-directory "uiop")) (:directory (,source-directory "tools")) (:tree (,source-directory "ext")) ;; In a fully controlled build, you'd :ignore-inherited-configuration instead: :inherit-configuration))) (output-directory ;; There again, you might want to use some getenv variant. ;; Also, "fasls" might be redundant for your project. (subpath source-directory :directory '("build" "fasls"))) (output-translations `(:output-translations ;; Segregate output by ABI. ;; You could replace "asdf" below by the name of your project, ;; or not need it at all if everything is under your source-directory. ((,source-directory :**/ :*.*.*) (,output-directory :implementation "asdf" :**/ :*.*.*)) ;; In a fully controlled build, we shouldn't be using code outside ;; our source-directory, but in case we do, we still want to control the output, ;; and easily detect the fact by looking at this directory (t (,output-directory :implementation "root")) ;; The above should already cover all paths that we use; ;; we don't want user configuration to interfere with the build. :ignore-inherited-configuration))) ;; ****** No more user-configurable parts below. ****** (asdf-call 'initialize-source-registry source-registry) (asdf-call 'initialize-output-translations output-translations)))) ;; Configure the printer (setf *print-readably* nil ; allegro 5.0 may bork without this *print-level* nil) ;; Hush the compiler and loader (setf *load-verbose* nil *load-print* nil *compile-verbose* nil *compile-print* nil) ;; Load and configure ASDF (load-and-configure-asdf))) #| ;;; Here is the much simpler code when you can assume ;;; your implementation provides ASDF 3 (i.e. at least pre-release ASDF 2.27). ;;; No package madness. (eval-when (:compile-toplevel :load-toplevel :execute) (require "asdf")) #-asdf3 (error "Your implementation fails to provide ASDF 3") (in-package :asdf) (eval-when (:compile-toplevel :load-toplevel :execute) (let* ((here-directory (pathname-directory-pathname (or *compile-file-truename* *load-truename* (truename *default-pathname-defaults*)))) ;; User-configurable parts start here (required-asdf-version "3.1.2") ;; In the end, we want at least ASDF 3.1.2 (source-directory ;; Here, define the top of your source code hierarchy. ;; For your project, it could be something like ;; (or (getenv-pathname "MY_PROJECT_ROOT" ;; :want-absolute t :ensure-directory t) ;; (subpathname here-directory "../../")) (subpathname here-directory "../")) (source-registry ;; Here, define your source registry. ;; For your project, it would be based solely on source-directory above, ;; and in a fully controlled build, you'd :ignore-inherited-configuration (or (getenvp "ASDF_DEVEL_SOURCE_REGISTRY") `(:source-registry (:directory ,source-directory) (:directory (,source-directory "uiop")) (:directory (,source-directory "tools")) (:tree (,source-directory "ext")) ;; In a fully controlled build, you'd :ignore-inherited-configuration instead: :inherit-configuration))) (output-directory ;; There again, you might want to use some getenvp variant. ;; Also, "fasls" might be redundant for your project. (subpathname source-directory "build/fasls/")) (output-translations `(:output-translations ;; Segregate output by ABI. ;; You could replace "asdf" below by the name of your project, ;; or not need it at all if everything is under your source-directory. (,source-directory (,output-directory :implementation "asdf")) ;; In a fully controlled build, we shouldn't be using code outside ;; our source-directory, but in case we do, we still want to control the output, ;; and easily detect the fact by looking at this directory (t (,output-directory :implementation "root")) ;; The above should already cover all paths that we use; ;; we don't want user configuration to interfere with the build. :ignore-inherited-configuration))) ;; No more user-configurable parts below. ;; Configure the printer (setf *print-readably* nil ; allegro 5.0 may bork without this *print-level* nil) ;; Hush the compiler and loader (setf *load-verbose* nil *load-print* nil *compile-verbose* nil *compile-print* nil) ;; Configure ASDF (initialize-source-registry source-registry) (initialize-output-translations output-translations) ;; Upgrade to the latest configured version (upgrade-asdf) ;; Load Quicklisp --- see remarks in uncommented version above (if-let (x (or (probe-file (subpathname (user-homedir-pathname) "quicklisp/setup.lisp")) (probe-file (subpathname (user-homedir-pathname) ".quicklisp/setup.lisp")))) (load x)) ;; Check that we have a satisfactorily version (unless (version-satisfies (asdf-version) required-asdf-version) (error "Please install an ASDF ~A or later" required-asdf-version)))) |# asdf-3.3.4/tools/main.lisp000066400000000000000000000112721362155115300154200ustar00rootroot00000000000000;;;; Generic code to interface a Lisp script to the shell command-line. ;;;; How does it work: ;;;; We get our command line from make. ;;;; the MAIN function first initializes the environment for the system, ;;;; then processes the arguments ;;;; A key part of the argument processing is to decode the command name from ;;;; make strings to CL function names. (in-package :asdf-tools) (defun re (arg) "Read-Eval function (the RE of REPL) (the Print and Loop parts are not here)" (eval (read-from-string arg))) (defun find-command (name &optional earlyp) "Given a string NAME, find the symbol for the function that implements the command, or else NIL. Unless EARLYP is true, return NIL if the symbol is not fbound." (block nil (flet ((try (x) (multiple-value-bind (sym foundp) (find-standard-case-symbol x :asdf-tools nil) (when (and sym (or earlyp (and foundp (fboundp sym)))) (return sym))))) (try (strcat "%" (string name))) ;; so that you may use load, t, etc., as targets (try name)))) (defun command-name (x &optional earlyp) "Given a command designator as per FIND-COMMAND, return the unix-y name for it, as a string. The UNIX-y name will be downcased, and any % prefix will be dropped." (let ((c (find-command x earlyp))) (when c (let ((s (string-downcase c))) (if (eql (first-char s) #\%) (subseq s 1) s))))) (defun short-function-description (x) "Short function description for x" (when (stringp x) (setf x (find-command x))) (if-let ((doc (and x (documentation x 'function)))) (let* ((first-line (with-input (s doc) (read-line s))) (len (length first-line))) (if (>= len 50) (strcat (subseq first-line 0 49) "…") first-line)))) (defun public-commands () ;;(loop :for x :being :the :external-symbols :of :asdf-tools ;; :when (and (eq x (find-command x)) (documentation x 'function)) :collect x) '(build-asdf build-asdf-tools doc website wc ;; build clean %push merge-master-into-release fix-local-git-tags fix-remote-git-tags ;; git ext-init ext-clear ext-reset ext-update ;; extension git-all-committed-p bump-version bump ;; version test-load-systems test-clean-load test-basic test-ascii %load install-asdf show-version ;; test-basic test %t test-scripts ;; test-scripts test-upgrade u extract-tagged-asdf extract-all-tagged-asdf extract ;; test-upgrade test-all-basic test-all-clean-load test-all-scripts test-all-no-upgrade test-all-upgrade ;; test-all test-all test-all-scripts-no-stop test-all-upgrade-no-stop test-all-no-upgrade-no-stop test-all-no-stop check-all-scripts-results check-all-upgrade-results check-all-results make-archive make-and-publish-archive publish-archive link-archive archive install ;; release debian-package publish-debian-package re help show-commands makefile-targets)) ;; main (defun public-command-strings () (sort (mapcar 'command-name (public-commands)) 'string<)) (defun show-commands () "print the (sorted list of) names of all the public commands of asdf-tools." (format t "~{~A~^ ~}~%" (public-command-strings)) (success)) (defun makefile-targets () "print declaration for the public commands of asdf-tools as as many Makefile targets so that, when included in the Makefile, they will enable shell completion based on a list of targets" (let ((c (public-command-strings))) (format t ".PHONY: ~{~A~^ ~}~%~%~{~A~^ ~}: force ~C${MAKE_SCRIPT} l='$l' L='$L' u='$u' U='$u' v='$v' s='$s' t='$t' $@~%" c c #\tab)) (success)) (defun help (&optional x) "help about a command, or list of commands" (cond ((null x) (loop :for x :in (public-command-strings) :do (format t "~(~27A~)~@[ ~A~]~%" x (short-function-description x))) (success)) (t (let ((x (find-command x))) (when x (format t "~A~@[ ~A~]~%~@[~A~]~&" (command-name x) (or ()) ;; TODO: remember the arguments to deftestcmd, translate to v=, etc (documentation x 'function)) (success)))))) ;;; Main entry point. ;;; NB: For access control, you could check that only exported symbols are used as entry points. (defun process-arguments (args) (if-let ((fun (and args (find-command (first args))))) (apply 'run-command fun (rest args)) (progn (if args (format t "Command ~A not found~%" (first args)) (format t "No command provided~%")) nil))) ;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main (defun main (argv) (initialize-environment) (process-arguments argv)) (defun entry-point () (main *command-line-arguments*)) asdf-3.3.4/tools/package.lisp000066400000000000000000000005031362155115300160620ustar00rootroot00000000000000(defpackage :asdf-tools (:use :common-lisp :uiop :asdf :fare-utils :inferior-shell :cl-scripting :lisp-invocation :lisp-invocation/non-special :cl-ppcre :optima :optima.ppcre) (:export)) ;; TODO: export stuff ;; Just so we can use the name in our test scripts... (defpackage :asdf-test (:use :common-lisp)) asdf-3.3.4/tools/pathnames.lisp000066400000000000000000000012321362155115300164470ustar00rootroot00000000000000(in-package :asdf-tools) ;;; ASDF directory (defun asdf-dir () (ensure-pathname (system-relative-pathname :asdf/defsystem ()) :want-physical t :want-absolute t :want-existing t :truename t)) (defun pn (&rest x) (subpathname (asdf-dir) (and x (uiop:resolve-relative-location x)))) (defun nn (&rest x) (native-namestring (apply 'pn x))) (defun uiop-dir () (pn "uiop/")) (defun build-dir () (pn "build/")) (defun call-with-asdf-dir (thunk &rest subs) (with-current-directory ((apply 'pn subs)) (funcall thunk))) (defmacro with-asdf-dir ((&rest subs) &body body) `(call-with-asdf-dir (lambda () ,@body) ,@subs)) asdf-3.3.4/tools/release.lisp000066400000000000000000000212471362155115300161170ustar00rootroot00000000000000(in-package :asdf-tools) ;;; Getting a list of source files in a system (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 &key monolithic) (let ((system (find-system system))) (enough-namestrings (system-source-directory system) (input-files (if monolithic 'monolithic-concatenate-source-op 'concatenate-source-op) system)))) ;;; Making release tarballs for asdf, asdf/defsystem, uiop. (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 (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)) (tarball (ensure-pathname (tarname name) :defaults (build-dir) :want-relative t :ensure-absolute t :ensure-subpath t :want-file t :ensure-directories-exist t))) (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* `(cp "-pHux" --parents ,@files ,destination) :directory base :show t) (run* `(tar "zcf" ,tarball "-C" ,(build-dir) ;; TODO: Have better autodetection for which tar is being used, ;; and fall back to no option if not recognized. ;; #+linux (* :owner root :group root) ;; assume GNU tar on Linux. ;; #+darwin (* :uid 0 :gid 0) ;; assume BSD tar on Darwin. (,name /)) :show t) (delete-directory-tree destination :validate #'(lambda (x) (equal x destination))) (success))) (defun uiop-files () "list files in uiop" (let ((*asdf-version* "3")) ;; prevent check-not-old-asdf-system from hiding uiop.asd. (list* "README.md" "uiop.asd" "asdf-driver.asd" "contrib/debug.lisp" (system-source-files "uiop")))) (defun uiop-name () (format nil "uiop-~A" (version-from-file))) (deftestcmd make-uiop-tarball () (make-tarball-under-build (uiop-name) (uiop-dir) (uiop-files))) (defun asdf-defsystem-files () "list files in asdf/defsystem" (list* "build/asdf.lisp" ;; for bootstrap purposes "asdf.asd" "version.lisp-expr" "header.lisp" (system-source-files "asdf/defsystem"))) (defun asdf-defsystem-name () (format nil "asdf-defsystem-~A" (version-from-file))) (deftestcmd make-asdf-defsystem-tarball () (build-asdf) (make-tarball-under-build (asdf-defsystem-name) (asdf-dir) (asdf-defsystem-files))) (defun asdf-all-name () (strcat "asdf-" (version-from-file))) (defun asdf-all-files () (remove-if #'(lambda (x) (string-prefix-p "ext/" x)) (with-asdf-dir () (run/lines '(git ls-files))))) (deftestcmd make-asdf-all-tarball () (build-asdf) (make-tarball-under-build (asdf-all-name) (asdf-dir) (asdf-all-files))) (defun asdf-lisp-name () (format nil "asdf-~A.lisp" (version-from-file))) (deftestcmd make-asdf-lisp () (build-asdf) (concatenate-files (list (pn "build/asdf.lisp")) (pn "build/" (asdf-lisp-name)))) (deftestcmd make-archive () "build tarballs for release" (make-uiop-tarball) (make-asdf-defsystem-tarball) (make-asdf-all-tarball) (make-asdf-lisp)) ;;; Publishing tarballs onto the public repository (defvar *clnet* "common-lisp.net") (defvar *clnet-asdf-public* "/project/asdf/public_html/") (defun public-path (x) (strcat *clnet-asdf-public* x)) (deftestcmd publish-archive () "publish tarballs to the website" (let ((tarballs (mapcar 'tarname (list (uiop-name) (asdf-defsystem-name) (asdf-all-name))))) (run* `(rsync "--times" "--chmod=a+rX,ug+w" ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/"))) :show t :directory (pn "build/"))) (format t "~&To download the tarballs, point your browser at:~% http://common-lisp.net/project/asdf/archives/ ~%")) (deftestcmd link-archive () "symlink new tarballs on the website" (run* (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S" (tarname (uiop-name)) (public-path "archives/uiop.tar.gz") (tarname (asdf-defsystem-name)) (public-path "archives/asdf-defsystem.tar.gz") (tarname (asdf-all-name)) (public-path "archives/asdf.tar.gz") (asdf-lisp-name) (public-path "archives/asdf.lisp")) :show t :host *clnet*)) (deftestcmd make-and-publish-archive () "make and publish tarballs" (make-archive) (publish-archive) (link-archive)) (defalias archive make-and-publish-archive) (defalias install make-and-publish-archive) (defun get-debian-packager-keyid () (or (getenv "DEBSIGN_KEYID") (error "Please export variable DEBSIGN_KEYID to be the 8-hex hash of your GnuPG secret key"))) ;;; Making a debian package (deftestcmd debian-package ((release "release")) "build a debian package" (let* ((debian-version (debian-version-from-file release)) (version (version-from-file release)) (has-ext-p (probe-file* (pn "ext/inferior-shell/inferior-shell.asd"))) (branch (get-git-branch)) (keyid (get-debian-packager-keyid))) (unless (equal version (parse-debian-version debian-version)) (error "Debian version ~A doesn't match asdf version ~A" debian-version version)) (git-all-committed-p) (clean) (ext-clear) (git '(checkout release)) (format t "building package version ~A~%" (debian-version-from-file)) (run* `(git-buildpackage ;; --git-ignore-new ;; for testing purpose ;; Override of the signing key, don't extract the name from the Changelog: (--git-builder="debuild -k0x",keyid" -i -I") (--git-debian-branch= ,release) (--git-upstream-tag="%(version)s") ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag --git-tag --git-retag ;; --git-no-pristine-tar --git-force-create --git-ignore-branch) :directory (pn) :show t) (git `(checkout ,branch)) (when has-ext-p (ext-reset)) (success))) (defun debian-architecture () (run/ss `(dpkg --print-architecture))) (deftestcmd publish-debian-package (release) "publish a debian package" (let ((changes (strcat "cl-asdf_" (debian-version-without-epoch (debian-version-from-file release)) "_" (debian-architecture) ".changes"))) (run* `(dput mentors ,(pn "../" changes))))) (deftestcmd release (new-version lisps scripts systems) "all steps to release the code (NOT YET IMPLEMENTED)" (break) ;; for each function, offer to do it or not (?) (with-asdf-dir () (let ((log (newlogfile "release" "all")) (releasep (= (length (parse-version new-version)) 3))) (when releasep (let ((debian-version (debian-version-from-file))) (unless (equal new-version (parse-debian-version debian-version)) (error "You're trying to release version ~A but the debian/changelog wasn't properly updated" new-version))) (when (nth-value 1 (run '(dpkg-parsechangelog) :output nil :error-output :lines)) (error "Malformed debian/changelog entry"))) scripts ;; TODO: needs to be passed as argument! (git-all-committed-p) (test-all-no-stop) ;; TODO: NEED ARGUMENTS! (test-load-systems lisps systems) (bump new-version) (when releasep (and (debian-package) (publish-debian-package) (merge-master-into-release))) ;; SUCCESS! now publish more widely (%push) (archive) (website) (when releasep (log! log t "Don't forget to send a debian mentors request!")) (log! log "Don't forget to send announcement to asdf-announce, asdf-devel, etc.") (log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad")))) asdf-3.3.4/tools/test-all.lisp000066400000000000000000000066471362155115300162330ustar00rootroot00000000000000(in-package :asdf-tools) (defun call-with-all-lisps (thunk &key (lisps *test-lisps*) muffle-failures) (let ((thunks (loop :for lisp :in (get-lisps lisps) :collect (let ((l lisp)) (lambda () (with-failure-context (:name (format nil "using ~(~A~)" l)) (funcall thunk l))))))) (if muffle-failures (call-without-stopping thunks) (progn (map () 'funcall thunks) (success))))) (defmacro with-all-lisps ((lisp-var lisps &key muffle-failures) &body body) `(call-with-all-lisps (lambda (,lisp-var) ,@body) :lisps ,lisps :muffle-failures ,muffle-failures)) (deftestcmd test-all-basic (lisps systems) "basic test: doc, clean-load, load-systems" (without-stopping () (show-version) (doc) (test-ascii) (test-all-clean-load lisps) (test-all-load-systems lisps systems))) (deftestcmd test-all-load-systems (lisps systems) (with-systems-test (systems) (with-all-lisps (l lisps) (test-load-systems l systems)))) (deftestcmd test-all-clean-load (lisps) "test-clean-load on all lisps" (with-all-lisps (l lisps) (test-clean-load l))) (deftestcmd test-all-scripts (lisps) "test-scripts on all lisps" (with-all-lisps (l lisps) (test-scripts l))) (deftestcmd test-all-no-upgrade () "test-all-basic, and test-all-script" (test-all-basic) (test-all-scripts)) (deftestcmd test-all-upgrade (upgrade-lisps) "test-upgrade on all lisps" (with-all-lisps (l upgrade-lisps) (test-upgrade l))) (deftestcmd test-all () "all tests" (test-all-no-upgrade) (test-all-upgrade)) (deftestcmd test-all-scripts-no-stop (lisps) "test-scripts on all lisps, no stop" (with-all-lisps (l lisps :muffle-failures t) (test-scripts l))) (deftestcmd test-all-upgrade-no-stop (upgrade-lisps) "test-upgrade on all lisps, no stop" (with-all-lisps (l upgrade-lisps :muffle-failures t) (test-upgrade l))) (deftestcmd test-all-no-upgrade-no-stop () "all tests but upgrade on all lisps, no stop" (without-stopping () (test-all-basic) (test-all-scripts-no-stop) (check-all-scripts-results))) (deftestcmd test-all-no-stop () ;; TODO: pass arguments! "all tests on all lisps, no stop" (without-stopping () (test-all-basic) (test-all-scripts-no-stop) (test-all-upgrade-no-stop) (check-all-results))) (deftestcmd check-all-scripts-results () "were there errors in test scripts?" (with-asdf-dir () (let ((bad-lisps (run/lines `(grep "-L" "All tests apparently successful." ,@(mapcar (lambda (l) (format nil "build/results/~(~A~)-test.text" l)) (get-lisps))) :on-error nil))) (failure-if bad-lisps "Unexpected test failures on these implementations:~%~{~A~%~}" bad-lisps)))) (deftestcmd check-all-upgrade-results () "were there upgrade test failures?" (with-asdf-dir () (let ((bad-lisps (run/lines `(grep "-L" "Upgrade test succeeded for " ,@(mapcar (lambda (l) (format nil "build/results/~(~A~)-upgrade.text" l)) (get-upgrade-lisps))) :on-error nil))) (failure-if bad-lisps "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" bad-lisps)))) (deftestcmd check-all-results () "were there failures in any scripts or upgrade?" (without-stopping () (check-all-scripts-results) (check-all-upgrade-results))) asdf-3.3.4/tools/test-basic.lisp000066400000000000000000000064561362155115300165420ustar00rootroot00000000000000(in-package :asdf-tools) (deftestcmd %load (lisp) ;; load would be a clash, so use %load instead "load asdf into an interactive Lisp for debugging load from individual source files, to make it easier to quickly locate compilation errors and to interactively debug ASDF." (with-asdf-dir () (run-test-lisp (format nil "loading ASDF into an interactive ~(~A~)" lisp) `((load "test/script-support.lisp") (asdf-test::interactive-test ',(system-source-files :asdf/defsystem :monolithic t))) :lisp lisp :debugger t :output :interactive))) (defmacro with-systems-test ((systems) &body body) `(call-with-systems-test ,systems (lambda () ,@body))) (defun call-with-systems-test (systems thunk) (if systems (funcall thunk) (format t "Skipping system loading test. To enable the system loading test, export ASDF_TEST_SYSTEMS=\"some systems\" or pass s=\"some systems\" to your make command and this test with make sure those systems can be loaded.~%"))) (deftestcmd test-load-systems (lisp systems) "test loading of your favorite systems Use your preferred Lisp implementation" (with-systems-test (systems) (with-asdf-dir () (let* ((log (newlogfile "systems" lisp))) (log! log "Loading all these systems on ~(~A~):~{~% ~A~}~%~%" lisp systems) (run-test-lisp "loading the systems" `((load "test/script-support.lisp") (asdf-test::with-test () (asdf-test::test-load-systems ,@systems))) :lisp lisp :log log))))) (deftestcmd test-clean-load (lisp log) "test that asdf load cleanly Use your preferred lisp implementation and check that asdf is loaded without any output message" (nest (block () (case lisp ((:gcl :cmucl) (return t)))) ;; These are hopeless (with-asdf-dir ()) (let ((nop (newlogfile "nop" lisp)) (load (newlogfile "load" lisp))) (run-test-lisp (format nil "starting ~(~A~), loading the script support, and exiting without doing anything" lisp) `((load "test/script-support.lisp" :verbose nil :print nil) (asdf-test::exit-lisp 0)) :lisp lisp :output nop :log log) (run-test-lisp (format nil "starting ~(~A~), loading the script support, loading ASDF from source, then exiting" lisp) `((load "test/script-support.lisp" :verbose nil :print nil) (asdf-test::verbose nil) (load "build/asdf.lisp" :verbose nil :print nil) (uiop/image:quit 0)) :lisp lisp :output load :log log) (if (nth-value 2 (run `(diff ,nop ,load) :output :interactive :error-output :output :input nil)) (progn (log! log "GOOD: Loading ASDF on ~(~A~) produces no message" lisp) (return (success))) (progn (log! log "BAD: Loading ASDF on ~(~A~) produces messages" lisp) (return nil)))))) (deftestcmd test-basic (lisp systems) "basic test: doc, clean-load, load-systems" (without-stopping () (show-version) (doc) (test-ascii) (test-clean-load lisp) (test-load-systems lisp systems))) (deftestcmd test-ascii () "test that asdf is all ASCII" (success-if (loop for c across (read-file-string (pn "build/asdf.lisp")) always (<= 0 (char-code c) 127)))) (deftestcmd show-version () (format t "Building and testing asdf ~A~%" (version-from-tag))) asdf-3.3.4/tools/test-environment.lisp000066400000000000000000000247531362155115300200250ustar00rootroot00000000000000(in-package :asdf-tools) ;;; Testing #| To configure the lisp implementations with which to run the tests, you may export environment variables to override the defaults: ASDF_TEST_LISPS and ASDF_UPGRADE_TEST_LISPS can each be a string of space-separated names amongst the above implementation names. You may also explicitly specify the same variables with the respective l= and u= arguments. Individual test commands only use the first (preferred) provided implementation; other test commands (named test-all-FOO) iterate over all implementations. Similarly, you can configure which scripts to tests with ASDF_TEST_SCRIPTS or t= and which systems to test loading with ASDF_TEST_SYSTEMS or s= |# (defparameter *test-lisps* :default "The list of lisp implementations to use for tests") (defparameter *upgrade-test-lisps* :default "The list of lisp implementations to use for upgrade tests") (defparameter *upgrade-test-tags* :default) (defparameter *test-systems* nil) (defparameter *test-scripts* :default) (defparameter *environment-variable-table* nil) (defparameter *environment-variable-specs* '((*test-lisps* ensure-list-of-keywords :default "ASDF_TEST_LISPS" "l") (*upgrade-test-lisps* ensure-list-of-keywords :default "ASDF_UPGRADE_TEST_LISPS" "L") (*test-systems* ensure-list-of-keywords () "ASDF_TEST_SYSTEMS" "s") (*test-scripts* ensure-list-of-strings :default "ASDF_TESTS" "t") (*upgrade-test-tags* ensure-list-of-strings :default "ASDF_UPGRADE_TEST_TAGS" "u") (*upgrade-test-methods* ensure-list-of-test-methods :default "ASDF_UPGRADE_TEST_METHODS" "U") (*new-version* string :default "=NEW_ASDF_VERSION" "v"))) (defun ensure-list-of-strings (x) (remove nil (etypecase x (string (uiop:split-string x :separator " ")) (list x)))) (defun ensure-keyword (x) (etypecase x ((or null keyword) x) ((or string symbol) (intern (standard-case-symbol-name x) :keyword)))) (defun ensure-list-of-keywords (x) (mapcar 'ensure-keyword (ensure-list-of-strings x))) (defun ensure-test-method (x) (safe-read-from-string (strcat "(" (substitute #\space #\: x) ")") :package :keyword)) ; UGLY! (defun ensure-list-of-test-methods (x) (mapcar 'ensure-test-method (ensure-list-of-strings x))) (defun initialize-environment () (let ((h (make-hash-table :test 'equal))) (setf *environment-variable-table* h) (loop :for (variable transformer defaults envvar short) :in *environment-variable-specs* :for x = (list variable transformer) :do (setf (symbol-value variable) (if-let (x (getenvp envvar)) (funcall transformer x) (eval defaults))) (setf (gethash envvar h) x) (setf (gethash short h) x)))) (defun display-environment () (format t "Environment for ASDF tools:~%") (let ((*package* (find-package :asdf-tools))) (loop :for variable-name :in (mapcar 'first *environment-variable-specs*) :do (format t "~T~S = ~S~%" variable-name (symbol-value variable-name)))) (success)) (defun test-definition (def) (block () (match def ((ppcre "^([^=]+)=(.*)$" var val) (if-let (x (gethash var *environment-variable-table*)) (match x ((list* sym transformer _) (unless (emptyp val) (setf (symbol-value sym) (funcall transformer val))) (return t))) (error "Unknown variable ~A" var)))) nil)) (defun show-environment () (loop :for (v) :in *environment-variable-specs* :do (format t "~A = ~S~%" v (symbol-value v))) (success)) (defun env (&rest env) (loop :for (first . rest) :on env :unless (test-definition first) :return (if-let (c (find-command first)) (apply c rest) (progn (format t "Command ~A not found~%" first) nil)) :finally (progn (format t "No command provided~%") (return)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun decl-or-docstring-p (form) (or (stringp form) (and (consp form) (eq 'declare (car form))))) (defun decl-and-body (decl-and-body) (let ((p (position-if-not 'decl-or-docstring-p decl-and-body))) (values (subseq decl-and-body 0 p) (nthcdr p decl-and-body))))) (defmacro deftestcmd (name args &rest decl-and-body) (loop :with argmap = '((lisp ((lisp *test-lisps*)) (setf lisp (get-lisp lisp))) (lisps ((lisps *test-lisps*)) (setf lisps (get-lisps lisps))) (upgrade-lisps ((upgrade-lisps *upgrade-test-lisps*)) (setf upgrade-lisps (get-upgrade-lisps upgrade-lisps))) (systems ((systems *test-systems*))) (test-scripts ((test-scripts *test-scripts*)) (setf test-scripts (get-test-scripts test-scripts))) (upgrade-tags ((upgrade-tags *upgrade-test-tags*)) (setf upgrade-tags (get-upgrade-tags upgrade-tags))) (upgrade-methods ((upgrade-methods *upgrade-test-methods*)) (setf upgrade-methods (get-upgrade-methods upgrade-methods))) (new-version (new-version) (setf new-version (or new-version (compute-next-version (version-from-file)))))) :for arg :in args :for (found larg init) = (assoc arg argmap) :append (if found larg (list arg)) :into largs :append (when found (list init)) :into inits :finally (multiple-value-bind (decl body) (decl-and-body decl-and-body) (return `(defun ,name ,(and largs `(&optional ,@largs)) ,@decl (with-failure-context (:name ,(command-name name)) ,@inits ,@body (success))))))) ;; use return-from ,name to return a value. (defmacro defalias (name real) `(defun ,name (&rest args) ,(format nil "alias for command ~A" (command-name real t)) (apply ',real args))) (deftestcmd interactive-command (lisp) (let* ((command (lisp-invocation-arglist :implementation-type lisp :debugger t :console t))) (return-from interactive-command (cons "rlwrap" command)))) (defparameter *default-test-lisps* '(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro :lispworks :allegromodern :clasp :gcl :xcl :mkcl) ;; NOT SUPPORTED BY OUR AUTOMATED TESTS: ;; :cormancl :genera :lispworks-personal-edition :mcl ;; Also, grep for #+/#- features in the test/ directory ;; to see plenty of disabled tests on some platforms "Default Lisp implementations for tests") (defun get-lisps (&optional (lisps *test-lisps*)) (if (eq lisps :default) *default-test-lisps* (ensure-list-of-keywords lisps))) (defun get-lisp (&optional (lisp *test-lisps*)) (if (and (keywordp lisp) (not (eq lisp :default))) lisp (first (get-lisps lisp)))) (defun get-upgrade-lisps (&optional (x *upgrade-test-lisps*)) (if (eq x :default) (get-lisps) x)) (defun date-string (&optional (date (get-universal-time))) (multiple-value-bind (second minute hour date month year weekday daylight-savings-p timezone) (decode-universal-time date) (declare (ignore second minute hour weekday daylight-savings-p timezone)) (format nil "~4,'0D-~2,'0D-~2,'0D" year month date))) (deftestcmd newlogfile ((kind "log") lisp) (let ((log (pn (format nil "build/results/~(~A-~A~).text" lisp kind)))) (ensure-directories-exist log) (if-let (date (safe-file-write-date log)) (rename-file-overwriting-target log (add-pathname-suffix log (strcat "-" (date-string date))))) (with-output-file (s log) s) ;; create the file ;;(format t "Logging results to ~A" log) (return-from newlogfile log))) (defun log! (log fmt &rest args) (let ((msg (apply 'format nil fmt args))) (format t "~&~A~&" msg) (when log (with-output-file (s log :if-exists :append :if-does-not-exist :create) ;; re-open every time because we're interleaved with inferior process writing to the log, ;; and on e.g. Windows there might be a locking conflict if we keep it open. (format s "~&~A~&" msg)))) (success)) ;; TODO: When composing a form to evaluate in the test lisp implementation, ;; our shell script went through great lengths to avoid a double-quote #\" in the command line, ;; the quoting of which many Windows implementations get wrong. ;; While we're at it, we also avoid spaces and backslashes. ;; We haven't tested our new Lisp implementation of the test infrastructure on Windows, though. (defun run* (cmd &rest keys) (let* ((string (strcat "`" (print-process-spec cmd) "`"))) (with-failure-context (:name string) (apply 'run cmd :on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c))) keys)))) (defun run-test-lisp (activity forms &key (output t) log lisp debugger) ;; Activity is of the form "compiling ASDF", "running this test", etc. (format t "~&Now ~A...~@[ (log in ~A)~]~%" activity log) (let* ((eval (compose-non-special-string forms)) ;; at least avoiding ~% is necessary on Windows. (command (lisp-invocation-arglist :implementation-type (get-lisp lisp) :eval eval :debugger debugger :console t)) (interactive (if (eq output :interactive) :interactive nil)) (output (if (eq output t) *standard-output* output)) (output (if (eq output *stdout*) :interactive output))) (log! log "~A" (print-process-spec command nil)) (multiple-value-bind (out err code) (run `(,@(when interactive '(rlwrap)) ,@command ,@(when log `((>> ,log) (>& 2 1)))) ;; unhappily, | tee -a log eats error codes :-( :input interactive :output output :error-output (or interactive :output) :on-error nil) (declare (ignore out err)) (let ((okp (eql code 0))) (unless interactive (log! log (if okp "SUCCEEDED at ~A." "FAILED at ~A. You can retry ~A with: ~A or more interactively, start with: ~A~%(rlwrap is optional; don't use it when in emacs; skip if not installed.) then copy/paste: ~@< ~@;~A~@:>~&~ Note that to debug rather than merely reproduce, you may want to call~%~ (asdf-test::debug-asdf) before last form to avoid quit-on-failure behavior~%") activity activity (print-process-spec command nil) (print-process-spec (interactive-command lisp) nil) (compose-copy-paste-string forms))) (success-if okp "failed at ~A" activity))))) asdf-3.3.4/tools/test-scripts.lisp000066400000000000000000000071341362155115300171420ustar00rootroot00000000000000(in-package :asdf-tools) (defparameter *default-test-scripts* '("*.script")) (defun get-test-scripts (&optional (test-scripts *test-scripts*)) (typecase test-scripts ((eql :default) (setf test-scripts *default-test-scripts*)) (string (setf test-scripts (ensure-list-of-strings test-scripts)))) (with-asdf-dir ("test/") (sort (loop :for pattern :in test-scripts :append (loop :for file :in (directory* pattern) :collect (enough-pathname file (pn "test/")))) 'string< :key 'namestring))) #| ;; Somehow we never wrote the tests that check our configuration file infrastructure... (defun create-config () (dolist (x '("build/results/" "build/test-source-registry-conf.d/" "build/test-asdf-output-translations-conf.d/")) (ensure-directories-exist (pn x)))) (defun clean-config () (flet ((rm-rf (x) (delete-directory-tree (pn x) :validate (lambda (x) (subpathp x (pn "build/")))))) (rm-rf "build/test-source-registry-conf.d/") (rm-rf "build/test-asdf-output-translations-conf.d/"))) |# (deftestcmd test-scripts (lisp test-scripts) "run test scripts Use the preferred lisp implementation" (nest (with-asdf-dir ()) (let* ((log (newlogfile "test" lisp))) (log! log "Running the following ~D ASDF test script~:*~P on ~(~A~):~%~{ ~A~%~}" (length test-scripts) lisp test-scripts)) (let ((n-tests (length test-scripts)) (test-pass 0) (test-fail 0) (failed-list ()))) (call-without-stopping `(,(lambda () (run-test-lisp "compiling ASDF" '((load "test/script-support.lisp") (asdf-test::compile-asdf-script)) :lisp lisp :log log)) ,@(mapcar (lambda (test-script) (lambda () ;; TODO: do we want to delete the output file cache? ;; If so, we need to do it in the inferior lisp, ;; because only it knows for sure its output configuration. ;; Or we could do it in a more heavy handed way. ;; A better solution would be to do any output operations in a temporary workspace, ;; which would allow test parallelization. (if (with-failure-context (:muffle-failures t) (run-test-lisp (format nil "testing ~A on ~(~A~)" test-script lisp) `((load "test/script-support.lisp") (asdf-test::load-asdf) (asdf-test::frob-packages) (asdf-test::run-test-script ,(native-namestring (subpathname "test/" test-script)))) :lisp lisp :log log)) (incf test-pass) (progn (incf test-fail) (push test-script failed-list))))) test-scripts) ,(lambda () (let ((failp (plusp test-fail))) (log! log "~ -#--------------------------------------- Using ~(~A~) Ran ~D tests, ~D passed, ~D failed~ ~:[~%All tests apparently successful.~;:~:*~{~% ~A~}~] -#---------------------------------------~%" lisp n-tests test-pass test-fail (reverse failed-list)) (when failp (log! log "To view full results and failures, try the following command: less -p ABORTED ~A" (enough-namestring log (pn)))) (failure-if failp "~D test~:*~P failed" test-fail))))))) (deftestcmd test (lisp test-scripts) "run all normal tests but upgrade tests Use the preferred lisp implementation" (without-stopping () (test-basic lisp) (test-scripts lisp test-scripts))) (defalias %t test) asdf-3.3.4/tools/test-upgrade.lisp000066400000000000000000000222071362155115300171000ustar00rootroot00000000000000(in-package :asdf-tools) ;;; Upgrade tests (defparameter *default-upgrade-test-tags* ;; We return a list of entries in reverse chronological order, ;; which should also be more or less the order of decreasing relevance. ;; By default, we only test the last of each relevant series. '("REQUIRE" "3.3.1" "3.3.0" "3.2.1" "3.2.0" "3.1.7" "3.1.2" "3.0.3" "2.26")) (defparameter *all-upgrade-test-tags* '("REQUIRE" ;; a magic tag meaning whatever your implementation provides, if anything ;; Below are versions that once were notable enough to be worth testing an upgrade from. ;; This list is not meant at being exhaustive of releases, particularly not old ones. ;; The 3.3 series provides the asdf3.3 feature, meaning users can rely on ;; all its new features (proper phase separation) as well as earlier features. "3.3.1" ;; (2017-11-14) bug fixes, second and latest in 3.3 series "3.3.0" ;; (2017-10-06) first in 3.3 series ;; The 3.2 series provides the asdf3.2 feature, meaning users can rely on ;; all its new features (launch-program, improved bundle support), as well as ;; the improvements done in 3.1 (e.g. XDG support). "3.2.1" ;; (2017-04-03) bug fixes, second and last in 3.2 series "3.2.0" ;; (2017-01-08) first in 3.2 series ;; The 3.1 series provides the asdf3.1 feature, meaning users can rely on ;; all the stabilization work done in 3.0 so far, plus extra developments ;; in UIOP, package-inferred-system, and more robustification. "3.1.7" ;; (2016-03-23) more bug fixes, last in 3.1 series "3.1.6" ;; (2015-10-17) more bug fixes "3.1.5" ;; (2015-07-21) more bug fixes, what SBCL sports (as of 1.3.14, 2017-02-04) "3.1.4" ;; (2014-10-09) more bug fixes, source-registry cache, in LispWorks 7 "3.1.3" ;; (2014-07-24) a bug fix release for 3.1.2 "3.1.2" ;; (2014-05-06) the first ASDF 3.1 release ;; The 3.0 series is a stable release of ASDF 3 ;; with Robert Goldman taking over maintainership at 3.0.2. ;; 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly ;; not compatible with ASDF2 anymore, so we immediately released 3.0.1 "3.0.3" ;; (2013-10-22) last in the ASDF 3.0 series "3.0.2" ;; (2013-07-02) the first ASDF 3 in SBCL "3.0.1" ;; (2013-05-16) the first stable ASDF 3 release ;; 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases "2.32" ;; (2013-03-05) the first really stable ASDF 3 pre-release "2.27" ;; (2013-02-01) the first ASDF 3 pre-release ;; The ASDF 2 series ;; Note that 2.26.x is where the refactoring that begat ASDF 3 took place. ;; 2.26.61 is the last single-file, single-package ASDF. "2.26" ;; (2012-10-30), last in ASDF 2 series, still sported by Quicklisp 2016-02-22 (!), long used by SBCL, etc. "2.22" ;; (2012-06-12) used by debian wheezy, etc. "2.20" ;; (2012-01-18) in CCL 1.8, Ubuntu 12.04 LTS "2.019" ;; (2011-11-29) still included in LispWorks in 2014. "2.014.6" ;; (2011-04-06) first included in Quicklisp, and for some time. "2.011" ;; (2010-12-09) long used by CLISP 2.49, Debian squeeze, Ubuntu 10.04 LTS. "2.008" ;; (2010-09-10) somewhat stable checkpoint in the ASDF 2 series. "2.000" ;; (2010-05-31) first stable ASDF 2 release. ;; The original ASDF 1 series "1.369" ;; (2009-10-27) the last release by Gary King "1.97" ;; (2006-05-14) the last release before Gary King takes over "1.85")) ;; (2004-05-16) the last release by Daniel Barlow (not 1.37, which is the README revision!) (defun get-upgrade-tags (&optional (x *upgrade-test-tags*)) (etypecase x (list x) ((or string symbol) (cond ((string-equal x :default) *default-upgrade-test-tags*) ((string-equal x :old) (remove-if (lambda (x) (member x *default-upgrade-test-tags* :test 'equal)) *all-upgrade-test-tags*)) ((string-equal x :all) *all-upgrade-test-tags*) (t (ensure-list-of-strings (string x))))))) (defun extract-tagged-asdf (tag) "extract an asdf version from git Use at a given tag, put it under build/asdf-${tag}.lisp" (with-asdf-dir () (ensure-directories-exist (pn "build/")) (unless (string-equal tag "REQUIRE") (let ((file (pn (strcat "build/asdf-" tag ".lisp")))) (unless (probe-file file) (cond ((version<= tag "2.26.61") (git `(show (,tag ":asdf.lisp") (> ,file)))) (t (ensure-directories-exist (pn "build/old/build/")) (run `(pipe (git archive ,tag) (tar "xfC" - ,(pn "build/old/")))) (run `(make) :directory (pn "build/old/")) (rename-file-overwriting-target (pn "build/old/build/asdf.lisp") file))))))) (success)) (deftestcmd extract-all-tagged-asdf (upgrade-tags) "extract all asdf tags used for upgrade" (map () 'extract-tagged-asdf upgrade-tags) (success)) (defalias extract extract-all-tagged-asdf) (defparameter *upgrade-test-methods* :default) (defparameter *all-upgrade-test-methods* '((:load-asdf-lisp :load-asdf-lisp-clean) (:load-asdf-lisp :load-asdf-system) (:load-asdf-lisp :compile-load-asdf-upgrade) (:load-asdf-lisp :load-asdf-fasl) (() :load-asdf-fasl) (:load-asdf-lisp-and-test-uiop :load-asdf-fasl))) (defun get-upgrade-methods (&optional (x *upgrade-test-methods*)) (if (eq x :default) *all-upgrade-test-methods* x)) (defun valid-upgrade-test-p (lisp tag method) (declare (ignore method)) (or (string-equal tag "REQUIRE") ;; we are hopefully always able to upgrade from REQUIRE (ecase lisp ;; ABCL works but is super-slow. Since we now punt on all of 2.x, ;; no need to check anything below 2.26. ((:abcl) (version<= "2.26" tag)) ;; Allegro ships with versions 3*, so give up testing 2 ;; Also, unpatched Allegro 10 has bug updating from 2.26 and before ((:allegro :allegromodern :allegro8 :allegromodern8 :allegro_64 :allegromodern_64 :allegro8_64 :allegromodern8_64 :allegro_s :allegromodern_s :allegro8_s :allegromodern8_s :allegro_64_s :allegromodern_64_s :allegro8_64_s :allegromodern8_64_s) (version<= "2.27" tag)) ;; CCL fasl numbering broke loading of old asdf 2.0, and the punting for 2.26 fails, ;; but who cares since CCL has always been shipping recent versions of ASDF. ((:ccl) (version<= "2.27" tag)) ;; CLASP is only supported as of 3.1.4.3 ((:clasp) (version<= "3.1.4.3" tag)) ;; My old Ubuntu 10.04LTS clisp 2.44.1 came wired in ;; with an antique ASDF 1.374 from CLC that can't be removed. ;; More recent CLISPs work. ;; 2.00[0-7] use UID, which fails on some old CLISPs, ;; but these old ASDF versions still can be loaded and upgraded from. ;; Note that for the longest time, CLISP has included 2.011 in its distribution. ;; However, whether we punt or don't punt, these should all work. ((:clisp) t) ;; CMUCL has problems with 2.32 and earlier because of ;; the redefinition of system's superclass component. ((:cmucl) (version<= "2.33" tag)) ;; Skip many ECL tests, for various ASDF issues ((:ecl :ecl_bytecodes) (version<= "2.21" tag)) ;; GCL 2.7.0 from at least late May 2014 is required, with ASDF 3.1.2 or later. ;; But since GCL doesn't ship with ASDF yet anyway, no need to test upgrade ;; against anything but the latest release. ((:gcl) (version<= "3.1.4" tag)) ;; LispWorks is fine, but ASDF 3.0.3 has a bug and can't be loaded. ((:lispworks) (not (equal "3.0.3" tag))) ;; MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip. ((:mkcl) (version<= "3.1.2" tag)) ;; all clear on these implementations ((:sbcl :scl) t) ;; XCL support starts with ASDF 2.014.2 ;; — It also dies during upgrade trying to show the backtrace. ;; We recommend you replace XCL's asdf using: ;; ./tools/asdf-tools install-asdf xcl ((:xcl) (version<= "2.15" tag))))) (deftestcmd test-upgrade (lisp upgrade-tags upgrade-methods) "run upgrade tests Use the preferred lisp implementation" (nest (with-asdf-dir ()) (let ((log (newlogfile "upgrade" lisp))) ;; Remove stale FASLs from ASDF 1.x, ;; especially since different implementations may have the same fasl type (dolist (pattern '("build/*.*f*" "uiop/*.*f*" "test/*.*f*")) (map () 'delete-file (directory* pattern)))) (loop :for tag :in upgrade-tags :do (loop :for method :in upgrade-methods :for description = (format nil "Testing ASDF upgrade on ~(~A~) from ~A to ~A using method ~(~{~A~^:~}~)" lisp tag (version-from-file) method) :when (valid-upgrade-test-p lisp tag method) :do (success-if (and (extract-tagged-asdf tag) (run-test-lisp description `((load "test/script-support.lisp") (asdf-test::test-upgrade ,@method ,tag)) :lisp lisp :log log)) description)) :finally (progn (log! log "Upgrade test succeeded for ~(~A~)" lisp) (return (success)))))) (defalias u test-upgrade) asdf-3.3.4/tools/version.lisp000066400000000000000000000137011362155115300161600ustar00rootroot00000000000000(in-package :asdf-tools) ;;; Extracting version information (defparameter *version-tag-glob* "[0-9][.][0-9]*") ;; NB: it's a glob, not regex (defun version-from-tag (&optional commit) ;; run-program issue: :output :line closes the fd, which causes the program to die in error. (first (nth-value 2 (git `(describe --tags --match ,*version-tag-glob* ,commit) :output :lines)))) (defun version-from-file (&optional commit) (if commit (nth-value 2 (git `(show (,commit":version.lisp-expr")) :output :form)) (safe-read-file-form (pn "version.lisp-expr")))) (defun debian-version-from-file (&optional commit) (match (if commit ;; run-program issue: :output :line closes the fd, which causes the program to die in error. (first (nth-value 2 (git `(show (,commit":debian/changelog")) :output :lines :error-output nil))) (read-file-line (pn "debian/changelog"))) ((ppcre "^[^(]*\\(([-0-9.:-]+)\\)" ver) ver))) (defun parse-debian-version (&optional (debian-version (debian-version-from-file))) (cl-ppcre:register-groups-bind (epoch ver rel) ("^(?:([0-9]+):)?([0-9.]+)(?:-([0-9]+))$" debian-version) ;; NB: (A) we return version first, not epoch, because it's the primary result! ;; (B) epoch = nil is semantically same as epoch = 0 ;; (C) rel = nil is for debian-native packages, e.g. base-passwd or cowbuilder (values ver epoch rel))) (defun debian-version-string (ver epoch rel) (format nil "~@[~D:~]~A~@[-~A~]" epoch ver rel)) (defun debian-version-without-epoch (version-string) (multiple-value-bind (ver epoch rel) (parse-debian-version version-string) (declare (ignore epoch)) (debian-version-string ver nil rel))) ;;; Bumping the version of ASDF (defparameter *versioned-files* '(("version.lisp-expr" "\"" "\"") ("uiop/version.lisp" "(defparameter *uiop-version* \"" "\")") ("asdf.asd" " :version \"" "\" ;; to be automatically updated by make bump-version") ("header.lisp" "This is ASDF " ": Another System Definition Facility.") ("upgrade.lisp" " (asdf-version \"" "\")") ("doc/asdf.texinfo" "Manual for Version " ""))) ;; NB: two occurrences with this pattern. (defparameter *old-version* :default) (defparameter *new-version* :default) (defun compute-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 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)) ((not (eq *new-version* :default)) *new-version*) ;; Ugly passing of argument from Makefile. (t (let ((old (version-from-file))) (check old (compute-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.~%")))) (success)) (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-all 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 (pn 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)) (success)) (defun test-transform-file (new-version file prefix suffix) (let ((lines (read-file-lines (pn 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 (success))))))) (defun test-transform (new-version) (apply 'test-transform-file new-version (first *versioned-files*))) (defun bump-version (&optional v1 v2) "bump asdf version, do not commit" (with-asdf-dir () (multiple-value-bind (old-version new-version) (versions-from-args v1 v2) (format t "Bumping ASDF version from ~A to ~A~%" old-version new-version) (transform-files new-version) (println "Rebuilding ASDF with bumped version") (build-asdf) new-version))) (defun bump (&optional v1 v2) "bump asdf version, then commit and tag" (let ((v (bump-version v1 v2))) (git `(commit -a -m ("Bump version to ",v))) (git `(tag ,v)) v)) asdf-3.3.4/uiop/000077500000000000000000000000001362155115300134145ustar00rootroot00000000000000asdf-3.3.4/uiop/README.md000066400000000000000000000247561362155115300147110ustar00rootroot00000000000000UIOP, 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](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`, except for those from `UIOP/COMMON-LISP`. We recommend package `UIOP` be used to access all the symbols. The files that constitute UIOP are, in dependency loading order: * [package](package.lisp): deals with packages and their symbols, most notably including `define-package`, a variant of `defpackage` capable of hot-upgrade, or `symbol-call` and `find-symbol*` that are also useful for use in `.asd` files before packages have been defined. * [common-lisp](common-lisp.lisp): lets you paper over various sub-standard implementations. Big offenders are Corman, GCL, Genera, MCL, none of them regularly maintained. Supported without serious issues are: ABCL, Allegro, CCL, CMUCL, CLASP, CLISP, ECL, LispWorks, MKCL, SBCL, SCL, XCL. * [utility](utility.lisp): provides macros and functions that do not involve I/O; it handles control-flow, (p)lists, characters, strings, functions, classes, conditions, "stamps" (real number or boolean for +/- infinity), etc. It also sports `uiop-debug`, a useful tool to help you debug programs. * [version](version.lisp): manages ASDF-style versioning and a related `with-deprecation` facility to gracefully declare that users should stop using some deprecated functions. * [os](os.lisp): extracts information from your environment, including an ABI identifier, features that distinguish Unix vs Windows, `getenv`, `hostname`, `getcwd` and `chdir`, etc. * [pathname](pathname.lisp): overcomes 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. It has a function `merge-pathnames*` to use instead of `merge-pathnames`, or even better, `subpathname` and its variant `subpathname*`; it has also plenty of functions for dealing with pathnames being directory vs file, physical vs logical, absolute vs relative, and more. * [filesystem](filesystem.lisp): provides 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](stream.lisp): portably deals with `*stderr*` vs `*error-output*`, character encodings (external formats), element types, safe `read`ing and `write`ing, opening files, using temporary files, flushing output buffers, providing `format`-like designators for streams, consuming or copying streams, concatenating streams or files, copying files, etc. * [image](image.lisp): portably deals 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. * [lisp-build](lisp-build.lisp): portably compiles Common Lisp code, handles compilation results, muffles uninteresting conditions, saves and restores deferred warnings, runs hooks around compilation (to e.g. control optimizations or syntax), identifies the pathname of the current file, combines FASLs, etc. * [launch-program](launch-program.lisp): semi-portably launches a program as an asynchronous external subprocess. Available functionality may depend on the underlying implementation. * [run-program](run-program.lisp): fully portably runs a program as a synchronous external subprocess, feed it input and capture its output. Most implementations also allow interactive console subprocesses. * [configuration](configuration.lisp): portably locates and parses configuration files, using best practices to define and validate syntax, search standard paths, let users specify pathnames or pathname patterns, etc. * [backward-driver](backward-driver.lisp): provides backward-compatibility with earlier incarnations of this library (i.e. ASDF internals that have leaked, ASDF-UTILS, or older versions of UIOP). * [driver](driver.lisp): reexports 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. You can extract a manual from the docstrings by running `make` in the directory `uiop/doc`. Other automated tools may hopefully extract all that information and make a webpage from it, at which point it would be nice to insert a link here. But many tools fail to extract useful data. Tools with which you can extract all the documentation include [Declt](https://www.lrde.epita.fr/~didier/software/lisp/misc.php#declt) and [HEΛP](http://helambdap.sourceforge.net/). See the Quickref UIOP reference manual as extracted by Declt. There is also a pre-extracted HEΛP documentation page . Note however that the HEΛP interface is not very usable at this time: it isn't obvious at all that you can indeed use a scrollbar on the right of the top left side panel to navigate the many packages; once you click on the package you're interested in, you can see its defined symbols. Another automated documentation tool is quickdocs, but unhappily, at the time of this writing, it only extracts information from the first package (see [bug #24](https://github.com/fukamachi/quickdocs/issues/24)): 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. Every implementation has sported ASDF 3 for years, and if yours only provides ASDF 2, we recommend you install ASDF 3 on top of it, using the facility in [tools/install-asdf.lisp](../tools/install-asdf.lisp). 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, by adding `"uiop"` or some versioned constraint `(:version "uiop" "3.2.0")` in your system's `:depends-on` declaration, or at the REPL using: (asdf:load-system :uiop) When refering to symbols in UIOP, we recommend you either have your package `:use` the package `:uiop` or `:import-from` it, or that you shall use `uiop:` as a prefix to the symbols. Please *DO NOT* refer to specific subpackages such as `uiop/run-program` from the outside of UIOP, because functions may occasionally be moved from one internal package to the other, without notification. They have in the past and will in the future. When to use UIOP ---------------- UIOP is the ideal tool to use when: * You need utilities that are always available, portably, with no installation needed. * You work in a cooperative environment, where the user is a developer who understands what he's doing and is trusted not to be malicious. * You are writing a build system, build tools, developer-facing tools. * You are writing bootstrap scripts, in which you cannot suppose that any third-party library has been installed (yet), much less a C compiler or any external tool. * You are trying to make existing Common Lisp code more robust and portable, or replacing developer "scripts" (in shell, perl, python, ruby, js, and other blub languages) with Common Lisp code, but without concerns about either end-user usability or security (at the very least, you, not end-users, are fully controlling pathnames, and filtering off or portably encoding any unusual character, etc.) UIOP is the wrong tool when: * You need to have total control on syscalls, to use special characters in pathnames, to handle symlinks yourself, or otherwise to have low-level system access. * You work in an adversarial environment, where some users are stupid, uneducated or outright malicious, and cannot be trusted not to try and abuse the system with pathnames, symlinks, race conditions, etc. (or be tricked into it by attackers). * You are writing end-user facing tools that pass along user-provided pathnames, with bad usability implications if a user tries to use weird pathnames, or even security implications if an attackers crafts bad pathnames or filesystem setups. In those latter cases, we recommend you use IOlib, or osicat, or some similar library that isn't as portable as UIOP, but provides fine-grained control over low-level system access. Also, please use extreme caution. Some history ------------ UIOP, formerly known as ASDF-DRIVER (the package and system nicknames are deprecated), 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 completely replaces it with better design and implementation), CL-LAUNCH (UIOP took its image and command-line argument handling), EXTERNAL-PROGRAM, TRIVIAL-SHELL and XCVB-DRIVER (UIOP's `run-program` and now `launch-program` evolved from XCVB-DRIVER, from which UIOP also initially got its condition muffling), SLIME's swank-loader (UIOP has better compilation and ABI 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 or FARE-UTILS. We recommend you use UIOP instead of any of the above, where applicable, since UIOP is more portable, more robust, more ubiquitous, better designed, better documented, etc. If you see any way in which UIOP isn't superior, please tell us: we're interested in improving it so it become so. asdf-3.3.4/uiop/asdf-driver.asd000066400000000000000000000001041362155115300163060ustar00rootroot00000000000000;;; -*- mode: lisp -*- (defsystem :asdf-driver :depends-on (:uiop)) asdf-3.3.4/uiop/backward-driver.lisp000066400000000000000000000065501362155115300173620ustar00rootroot00000000000000;;; ------------------------------------------------------------------------- ;;; Hacks for backward-compatibility with older versions of UIOP (uiop/package:define-package :uiop/backward-driver (:recycle :uiop/backward-driver :asdf/backward-driver :uiop) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version :uiop/pathname :uiop/stream :uiop/os :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration) (:export #:coerce-pathname #:user-configuration-directories #:system-configuration-directories #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory #:version-compatible-p)) (in-package :uiop/backward-driver) (eval-when (:compile-toplevel :load-toplevel :execute) (with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4")) ;; Backward compatibility with ASDF 2.000 to 2.26 ;; For backward-compatibility only, for people using internals ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) ;; Will be removed after 2015-12. (defun coerce-pathname (name &key type defaults) "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead." (parse-unix-namestring name :type type :defaults defaults)) ;; Backward compatibility for ASDF 2.27 to 3.1.4 (defun user-configuration-directories () "Return the current user's list of user configuration directories for configuring common-lisp. DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead." (xdg-config-pathnames "common-lisp")) (defun system-configuration-directories () "Return the list of system configuration directories for common-lisp. DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"), instead." (system-config-pathnames "common-lisp")) (defun in-first-directory (dirs x &key (direction :input)) "Finds the first appropriate file named X in the list of DIRS for I/O in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE). If direction is :INPUT or :PROBE, will return the first extant file named X in one of the DIRS. If direction is :OUTPUT or :IO, will simply return the file named X in the first element of DIRS that exists. DEPRECATED." (find-preferred-file (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs) :direction direction)) (defun in-user-configuration-directory (x &key (direction :input)) "Return the file named X in the user configuration directory for common-lisp. DEPRECATED." (xdg-config-pathname `("common-lisp" ,x) direction)) (defun in-system-configuration-directory (x &key (direction :input)) "Return the pathname for the file named X under the system configuration directory for common-lisp. DEPRECATED." (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)) ;; Backward compatibility with ASDF 1 to ASDF 2.32 (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. DEPRECATED." (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))))))) asdf-3.3.4/uiop/common-lisp.lisp000066400000000000000000000236051362155115300165500ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; 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) (:use :uiop/package) (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp (:export #:logical-pathname #:translate-logical-pathname #:make-broadcast-stream #:file-namestring) #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano 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 allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl) (eval-when (:load-toplevel :compile-toplevel :execute) (when (and #+allegro (member :ics *features*) #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*) #+clozure (member :openmcl-unicode-strings *features*) #+sbcl (member :sb-unicode *features*)) ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (pushnew :asdf-unicode *features*))) #+allegro (eval-when (:load-toplevel :compile-toplevel :execute) ;; We need to disable autoloading BEFORE any mention of package ASDF. ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file ;; or any previous file. (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) (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)) #+clasp (eval-when (:load-toplevel :compile-toplevel :execute) (setf *load-verbose* nil) (defun use-ecl-byte-compiler-p () 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) ;; back in this package. #+cmucl (eval-when (:load-toplevel :compile-toplevel :execute) (setf ext:*gc-verbose* nil) (defun user-homedir-pathname () (first (ext:search-list (cl:user-homedir-pathname))))) #+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 (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* "") #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later. (cond #+gcl ((or (< system::*gcl-major-version* 2) (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 7))) '(error "GCL 2.7 or later required to use ASDF"))))) (eval code) code)) #+genera (eval-when (:load-toplevel :compile-toplevel :execute) (unless (fboundp 'lambda) (defmacro lambda (&whole form &rest bvl-decls-and-body) (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) `#',(cons 'lisp::lambda (cdr form)))) (unless (fboundp 'ensure-directories-exist) (defun ensure-directories-exist (path) (fs:create-directories-recursively (pathname path)))) (unless (fboundp 'read-sequence) (defun read-sequence (sequence stream &key (start 0) end) (scl:send stream :string-in nil sequence start end))) (unless (fboundp 'write-sequence) (defun write-sequence (sequence stream &key (start 0) end) (scl:send stream :string-out sequence start end) sequence))) #+lispworks (eval-when (:load-toplevel :compile-toplevel :execute) ;; lispworks 3 and earlier cannot be checked for so we always assume ;; at least version 4 (unless (member :lispworks4 *features*) (pushnew :lispworks5+ *features*) (unless (member :lispworks5 *features*) (pushnew :lispworks6+ *features*) (unless (member :lispworks6 *features*) (pushnew :lispworks7+ *features*))))) #.(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 #-gcl 3 #+gcl 0) (debug 3))) (let ((length (length string)) (stream nil)) (labels ((emit-string (x &optional (start 0) (end (length x))) (when (< start end) (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~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) #-(or gcl genera) format)) asdf-3.3.4/uiop/configuration.lisp000066400000000000000000000540331362155115300171610ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Generic support for configuration files (uiop/package:define-package :uiop/configuration (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. (:use :uiop/package :uiop/common-lisp :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem #:get-folder-path #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname #: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 #:uiop-directory)) (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 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. By default it will raise an error if the FORM is not valid. Otherwise it will return the validated form. Arguments control the behavior: The configuration FORM should be of the form (TAG . ) Each element of will be checked by first seeing if it's a configuration inheritance directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR on it. In the event of an invalid form, INVALID-FORM-REPORTER will be used to control reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where the configuration form appeared." (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 :form form :location location ;; we throw away the form and location arguments, hence the ~2* ;; this is necessary because of the report in INVALID-CONFIGURATION :format (compatfmt "~@") :arguments '(:inherit-configuration :ignore-inherited-configuration))) (return (nreverse x)))) (defun validate-configuration-file (file validator &key description) "Validate a configuration FILE. The configuration file should have only one s-expression in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error reporting." (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 ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list (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 (null nil) (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 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 (null nil) (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 (truename (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 = (or (resolve-absolute-location first :ensure-directory (and (or dirp rest) t) :wilden (and wilden (null rest))) (return nil)) :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?" ;; NIL means "skip this entry", or as an output translation, same as translation input. ;; T means "any input" for a translation, or as output, same as translation input. (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?" ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support. (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))) (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. Returns NIL when the folder is not defined (e.g., not on Windows)." (or #+(and lispworks os-windows) (sys:get-folder-path folder) ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData (ecase folder (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA") (subpathname* (get-folder-path :appdata) "Local"))) (:appdata (getenv-absolute-directory "APPDATA")) (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) ;; Support for the XDG Base Directory Specification (defun xdg-data-home (&rest more) "Returns an absolute pathname for the directory containing user-specific data files. MORE may contain specifications for a subpath relative to this directory: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (resolve-absolute-location `(,(or (getenv-absolute-directory "XDG_DATA_HOME") (os-cond ((os-windows-p) (get-folder-path :local-appdata)) (t (subpathname (user-homedir-pathname) ".local/share/")))) ,more))) (defun xdg-config-home (&rest more) "Returns a pathname for the directory containing user-specific configuration files. MORE may contain specifications for a subpath relative to this directory: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (resolve-absolute-location `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME") (os-cond ((os-windows-p) (xdg-data-home "config/")) (t (subpathname (user-homedir-pathname) ".config/")))) ,more))) (defun xdg-data-dirs (&rest more) "The preference-ordered set of additional paths to search for data files. Returns a list of absolute directory pathnames. MORE may contain specifications for a subpath relative to these directories: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (mapcar #'(lambda (d) (resolve-location `(,d ,more))) (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS")) (os-cond ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata))) (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))))) (defun xdg-config-dirs (&rest more) "The preference-ordered set of additional base paths to search for configuration files. Returns a list of absolute directory pathnames. MORE may contain specifications for a subpath relative to these directories: subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (mapcar #'(lambda (d) (resolve-location `(,d ,more))) (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS")) (os-cond ((os-windows-p) (xdg-data-dirs "config/")) (t (mapcar 'parse-unix-namestring '("/etc/xdg/"))))))) (defun xdg-cache-home (&rest more) "The base directory relative to which user specific non-essential data files should be stored. Returns an absolute directory pathname. MORE may contain specifications for a subpath relative to this directory: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (resolve-absolute-location `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") (os-cond ((os-windows-p) (xdg-data-home "cache/")) (t (subpathname* (user-homedir-pathname) ".cache/")))) ,more))) (defun xdg-runtime-dir (&rest more) "Pathname for user-specific non-essential runtime files and other file objects, such as sockets, named pipes, etc. Returns an absolute directory pathname. MORE may contain specifications for a subpath relative to this directory: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." ;; The XDG spec says that if not provided by the login system, the application should ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL. (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more))) ;;; NOTE: modified the docstring because "system user configuration ;;; directories" seems self-contradictory. I'm not sure my wording is right. (defun system-config-pathnames (&rest more) "Return a list of directories where are stored the system's default user configuration information. MORE may contain specifications for a subpath relative to these directories: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (declare (ignorable more)) (os-cond ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more)))))) (defun filter-pathname-set (dirs) "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list." (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal)) (defun xdg-data-pathnames (&rest more) "Return a list of absolute pathnames for application data directories. With APP, returns directory for data for that application, without APP, returns the set of directories for storing all application configurations. MORE may contain specifications for a subpath relative to these directories: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (filter-pathname-set `(,(xdg-data-home more) ,@(xdg-data-dirs more)))) (defun xdg-config-pathnames (&rest more) "Return a list of pathnames for application configuration. MORE may contain specifications for a subpath relative to these directories: a subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see also \"Configuration DSL\"\) in the ASDF manual." (filter-pathname-set `(,(xdg-config-home more) ,@(xdg-config-dirs more)))) (defun find-preferred-file (files &key (direction :input)) "Find first file in the list of FILES that exists (for direction :input or :probe) or just the first one (for direction :output or :io). Note that when we say \"file\" here, the files in question may be directories." (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files)) (defun xdg-data-pathname (&optional more (direction :input)) (find-preferred-file (xdg-data-pathnames more) :direction direction)) (defun xdg-config-pathname (&optional more (direction :input)) (find-preferred-file (xdg-config-pathnames more) :direction direction)) (defun compute-user-cache () "Compute (and return) the location of the default user-cache for translate-output objects. Side-effects for cached file location computation." (setf *user-cache* (xdg-cache-home "common-lisp" :implementation))) (register-image-restore-hook 'compute-user-cache) (defun uiop-directory () "Try to locate the UIOP source directory at runtime" (labels ((pf (x) (ignore-errors (probe-file* x))) (sub (x y) (pf (subpathname x y))) (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x)))) ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname) (or ;; Look under uiop if available as source override, under asdf if avaiable as source (ssd "uiop") (sub (ssd "asdf") "uiop/") ;; Look in recommended path for user-visible source installation (sub (user-homedir-pathname) "common-lisp/asdf/uiop/") ;; Look in XDG paths under known package names for user-invisible source installation (xdg-data-pathname "common-lisp/source/asdf/uiop/") (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location ;; The last one below is useful for Fare, primary (sole?) known user (sub (user-homedir-pathname) "cl/asdf/uiop/") (cerror "Configure source registry to include UIOP source directory and retry." "Unable to find UIOP directory") (uiop-directory))))) asdf-3.3.4/uiop/contrib/000077500000000000000000000000001362155115300150545ustar00rootroot00000000000000asdf-3.3.4/uiop/contrib/debug.lisp000066400000000000000000000121761362155115300170420ustar00rootroot00000000000000;;;;; A few essential debugging utilities by fare@tunes.org, ;;;;; 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) "debug macro for print-debugging: TAG is typically a constant string or keyword to identify who is printing, but can be an arbitrary expression returning a tag to be princ'ed 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 expression is *always* evaluated and its multiple 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 was NIL. The macro expansion has relatively low overhead in space or 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) (values-list 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) asdf-3.3.4/uiop/doc/000077500000000000000000000000001362155115300141615ustar00rootroot00000000000000asdf-3.3.4/uiop/doc/.gitignore000066400000000000000000000000101362155115300161400ustar00rootroot00000000000000include asdf-3.3.4/uiop/doc/Makefile000066400000000000000000000026741362155115300156320ustar00rootroot00000000000000uiop := uiop ifeq (${user},) userat := else userat := ${user}@ endif website:=${userat}common-lisp.net:/project/asdf/public_html/ output = ${uiop}.html ${uiop}.pdf webfiles = ${output} .PHONY: clean html pdf include clean-include clean-crap info doc texinfo website all: pdf html info clean-crap website: all rsync -lt --no-g ${webfiles} ${website} clean-include: rm -rf include clean-crap: rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr *.vrs clean: clean-include rm -rf *.pdf *.html *.info ${uiop}.texinfo ${uiop} *.fasl fasl: docstrings.lisp sbcl --no-userinit --eval '(require :asdf)' \ --eval '(compile-file "docstrings.lisp")' \ --eval '(quit)' include: fasl sbcl --no-userinit --eval '(require :asdf)' \ --load docstrings \ --eval '(sb-texinfo:generate-includes "include/" (list :UIOP/PACKAGE :UIOP/COMMON-LISP :UIOP/UTILITY :UIOP/VERSION :UIOP/OS :UIOP/PATHNAME :UIOP/FILESYSTEM :UIOP/STREAM :UIOP/IMAGE :UIOP/LISP-BUILD :UIOP/LAUNCH-PROGRAM :UIOP/RUN-PROGRAM :UIOP/CONFIGURATION :UIOP/BACKWARD-DRIVER))' \ --eval '(quit)' texinfo : include sbcl --no-userinit --eval '(require :asdf)' \ --load docstrings \ --eval "(sb-texinfo:complete-texinfo-template \"template.texinfo\" \"${uiop}.texinfo\" \"include/\")" \ --eval '(quit)' pdf: texinfo texi2pdf ${uiop}.texinfo html: texinfo makeinfo --html --no-split ${uiop}.texinfo htmls: texinfo makeinfo --html ${uiop}.texinfo info: texinfo makeinfo ${uiop}.texinfo asdf-3.3.4/uiop/doc/docstrings.lisp000066400000000000000000001113421362155115300172330ustar00rootroot00000000000000;;; -*- lisp -*- ;;;; A docstring extractor for the sbcl manual. Creates ;;;; @include-ready documentation from the docstrings of exported ;;;; symbols of specified packages. ;;;; This software is part of the SBCL software system. SBCL is in the ;;;; public domain and is provided with absolutely no warranty. See ;;;; the COPYING file for more information. ;;;; ;;;; Written by Rudi Schlatte , mangled ;;;; by Nikodemus Siivola. Tweaked for UIOP by Hugo Ishimaru. ;;;; TODO ;;;; * Verbatim text ;;;; * Quotations ;;;; * Method documentation untested ;;;; * Method sorting, somehow ;;;; * Index for macros & constants? ;;;; * This is getting complicated enough that tests would be good ;;;; * Nesting (currently only nested itemizations work) ;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also ;;;; easily generated) ;;;; FIXME: The description below is no longer complete. This ;;;; should possibly be turned into a contrib with proper documentation. ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): ;;;; ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in ;;;; the argument list of the defun / defmacro. ;;;; ;;;; Lines starting with * or - that are followed by intented lines ;;;; are marked up with @itemize. ;;;; ;;;; Lines containing only a SYMBOL that are followed by indented ;;;; lines are marked up as @table @code, with the SYMBOL as the item. (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-introspect)) (defpackage :sb-texinfo (:use :cl :sb-mop) (:shadow #:documentation) (:export #:generate-includes #:document-package #:complete-texinfo-template #:*not-symbols*) (:documentation "Tools to generate TexInfo documentation from docstrings.")) (in-package :sb-texinfo) ;;;; various specials and parameters (defvar *texinfo-output*) (defvar *texinfo-variables*) (defvar *documentation-package*) (defvar *base-package*) (defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) (defparameter *documentation-types* '(compiler-macro function method-combination setf ;;structure ; also handled by `type' type variable) "A list of symbols accepted as second argument of `documentation'") (defparameter *character-replacements* '((#\* . "star") (#\/ . "slash") (#\+ . "plus") (#\< . "lt") (#\> . "gt") (#\= . "equals")) "Characters and their replacement names that `alphanumize' uses. If the replacements contain any of the chars they're supposed to replace, you deserve to lose.") (defparameter *characters-to-drop* '(#\\ #\` #\') "Characters that should be removed by `alphanumize'.") (defparameter *texinfo-escaped-chars* "@{}" "Characters that must be escaped with #\@ for Texinfo.") (defparameter *itemize-start-characters* '(#\* #\-) "Characters that might start an itemization in docstrings when at the start of a line.") (defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#" "List of characters that make up symbols in a docstring.") (defparameter *symbol-delimiters* " ,.!?;()'\"") (defparameter *ordered-documentation-kinds* '(package type structure condition class macro)) ;;;; utilities (defun flatten (list) (cond ((null list) nil) ((consp (car list)) (nconc (flatten (car list)) (flatten (cdr list)))) ((null (cdr list)) (cons (car list) nil)) (t (cons (car list) (flatten (cdr list)))))) (defun whitespacep (char) (find char #(#\tab #\space #\page))) (defun setf-name-p (name) (or (symbolp name) (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) (defgeneric specializer-name (specializer)) (defmethod specializer-name ((specializer eql-specializer)) (list 'eql (eql-specializer-object specializer))) (defmethod specializer-name ((specializer class)) (class-name specializer)) (defun ensure-class-precedence-list (class) (unless (class-finalized-p class) (finalize-inheritance class)) (class-precedence-list class)) (defun specialized-lambda-list (method) ;; courtecy of AMOP p. 61 (let* ((specializers (method-specializers method)) (lambda-list (method-lambda-list method)) (n-required (length specializers))) (append (mapcar (lambda (arg specializer) (if (eq specializer (find-class 't)) arg `(,arg ,(specializer-name specializer)))) (subseq lambda-list 0 n-required) specializers) (subseq lambda-list n-required)))) (defun string-lines (string) "Lines in STRING as a vector." (coerce (with-input-from-string (s string) (loop for line = (read-line s nil nil) while line collect line)) 'vector)) (defun indentation (line) "Position of first non-SPACE character in LINE." (position-if-not (lambda (c) (char= c #\Space)) line)) (defun docstring (x doc-type) (cl:documentation x doc-type)) (defun flatten-to-string (list) (format nil "~{~A~^-~}" (flatten list))) (defun alphanumize (original) "Construct a string without characters like *`' that will f-star-ck up filename handling. See `*character-replacements*' and `*characters-to-drop*' for customization." (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) (if (listp original) (flatten-to-string original) (string original)))) (chars-to-replace (mapcar #'car *character-replacements*))) (flet ((replacement-delimiter (index) (cond ((or (< index 0) (>= index (length name))) "") ((alphanumericp (char name index)) "-") (t "")))) (loop for index = (position-if #'(lambda (x) (member x chars-to-replace)) name) while index do (setf name (concatenate 'string (subseq name 0 index) (replacement-delimiter (1- index)) (cdr (assoc (aref name index) *character-replacements*)) (replacement-delimiter (1+ index)) (subseq name (1+ index)))))) name)) ;;;; generating various names (defun short-package-name (package) (unless (eq package *base-package*) (car (sort (copy-list (cons (package-name package) (package-nicknames package))) #'< :key #'length)))) (defgeneric name (thing) (:documentation "Name for a documented thing. Names are either symbols or lists of symbols.")) (defmethod name ((symbol symbol)) symbol) (defmethod name ((cons cons)) cons) (defmethod name ((package package)) (short-package-name package)) (defmethod name ((method method)) (list (generic-function-name (method-generic-function method)) (method-qualifiers method) (specialized-lambda-list method))) ;;; Node names for DOCUMENTATION instances (defgeneric name-using-kind/name (kind name doc)) (defmethod name-using-kind/name (kind (name string) doc) (declare (ignore kind doc)) name) (defmethod name-using-kind/name (kind (name symbol) doc) (declare (ignore kind)) (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) (defmethod name-using-kind/name (kind (name list) doc) (declare (ignore kind)) (assert (setf-name-p name)) (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) (defmethod name-using-kind/name ((kind (eql 'method)) name doc) (format nil "~A~{ ~A~} ~A" (name-using-kind/name nil (first name) doc) (second name) (third name))) (defun node-name (doc) "Returns TexInfo node name as a string for a DOCUMENTATION instance." (let ((kind (get-kind doc))) (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) ;;; Definition titles for DOCUMENTATION instances (defgeneric title-using-kind/name (kind name doc)) (defmethod title-using-kind/name (kind (name string) doc) (declare (ignore kind doc)) name) (defmethod title-using-kind/name (kind (name symbol) doc) (declare (ignore kind)) (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) (defmethod title-using-kind/name (kind (name list) doc) (declare (ignore kind)) (assert (setf-name-p name)) (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) (defmethod title-using-kind/name ((kind (eql 'method)) name doc) (format nil "~{~A ~}~A" (second name) (title-using-kind/name nil (first name) doc))) (defun title-name (doc) "Returns a string to be used as name of the definition." (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) (defun render-package-name (package) (nstring-downcase (alphanumize (let ((*base-package* nil)) (short-package-name package))))) (defun include-pathname (doc) (let* ((kind (get-kind doc)) (name (nstring-downcase (if (eq 'package kind) (format nil "package-~A" (alphanumize (get-name doc))) (format nil "~A-~A-~A" (render-package-name (get-package doc)) (case (get-kind doc) ((function generic-function) "fun") (structure "struct") (variable "var") (otherwise (symbol-name (get-kind doc)))) (alphanumize (get-name doc))))))) (make-pathname :name name :type "texinfo"))) ;;;; documentation class and related methods (defclass documentation () ((name :initarg :name :reader get-name) (kind :initarg :kind :reader get-kind) (string :initarg :string :reader get-string) (children :initarg :children :initform nil :reader get-children) (package :initform *documentation-package* :reader get-package))) (defmethod print-object ((documentation documentation) stream) (print-unreadable-object (documentation stream :type t) (princ (list (get-kind documentation) (get-name documentation)) stream))) (defgeneric make-documentation (x doc-type string)) (defmethod make-documentation ((x package) doc-type string) (declare (ignore doc-type)) (make-instance 'documentation :name (name x) :kind 'package :string string)) (defmethod make-documentation (x (doc-type (eql 'function)) string) (declare (ignore doc-type)) (let* ((fdef (and (fboundp x) (fdefinition x))) (name x) (kind (cond ((and (symbolp x) (special-operator-p x)) 'special-operator) ((and (symbolp x) (macro-function x)) 'macro) ((typep fdef 'generic-function) (assert (or (symbolp name) (setf-name-p name))) 'generic-function) (fdef (assert (or (symbolp name) (setf-name-p name))) 'function))) (children (when (eq kind 'generic-function) (collect-gf-documentation fdef)))) (make-instance 'documentation :name (name x) :string string :kind kind :children children))) (defmethod make-documentation ((x method) doc-type string) (declare (ignore doc-type)) (make-instance 'documentation :name (name x) :kind 'method :string string)) (defmethod make-documentation (x (doc-type (eql 'type)) string) (make-instance 'documentation :name (name x) :string string :kind (etypecase (find-class x nil) (structure-class 'structure) (standard-class 'class) (sb-pcl::condition-class 'condition) ((or built-in-class null) 'type)))) (defmethod make-documentation (x (doc-type (eql 'variable)) string) (make-instance 'documentation :name (name x) :string string :kind (if (constantp x) 'constant 'variable))) (defmethod make-documentation (x (doc-type (eql 'setf)) string) (declare (ignore doc-type)) (make-instance 'documentation :name (name x) :kind 'setf-expander :string string)) (defmethod make-documentation (x doc-type string) (make-instance 'documentation :name (name x) :kind doc-type :string string)) (defun maybe-documentation (x doc-type) "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if there is no corresponding docstring." (let ((docstring (docstring x doc-type))) (when docstring (make-documentation x doc-type docstring)))) (defun lambda-list (doc) (case (get-kind doc) ((package constant variable type structure class condition nil) nil) (method (third (get-name doc))) (t ;; KLUDGE: Eugh. ;; ;; believe it or not, the above comment was written before CSR ;; came along and obfuscated this. (2005-07-04) (when (symbolp (get-name doc)) (labels ((clean (x &key optional key) (typecase x (atom x) ((cons (member &optional)) (cons (car x) (clean (cdr x) :optional t))) ((cons (member &key)) (cons (car x) (clean (cdr x) :key t))) ((cons (member &whole &environment)) ;; Skip these (clean (cdr x) :optional optional :key key)) ((cons cons) (cons (cond (key (if (consp (caar x)) (caaar x) (caar x))) (optional (caar x)) (t (clean (car x)))) (clean (cdr x) :key key :optional optional))) (cons (cons (cond ((or key optional) (car x)) (t (clean (car x)))) (clean (cdr x) :key key :optional optional)))))) (clean (sb-introspect:function-lambda-list (get-name doc)))))))) (defun get-string-name (x) (let ((name (get-name x))) (cond ((symbolp name) (symbol-name name)) ((and (consp name) (eq 'setf (car name))) (symbol-name (second name))) ((stringp name) name) (t (error "Don't know which symbol to use for name ~S" name))))) (defun documentation< (x y) (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) (p2 (position (get-kind y) *ordered-documentation-kinds*))) (if (or (not (and p1 p2)) (= p1 p2)) (string< (get-string-name x) (get-string-name y)) (< p1 p2)))) ;;;; turning text into texinfo (defun escape-for-texinfo (string &optional downcasep) "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped with #\@. Optionally downcase the result." (let ((result (with-output-to-string (s) (loop for char across string when (find char *texinfo-escaped-chars*) do (write-char #\@ s) do (write-char char s))))) (if downcasep (nstring-downcase result) result))) (defun empty-p (line-number lines) (and (< -1 line-number (length lines)) (not (indentation (svref lines line-number))))) ;;; line markups (defvar *not-symbols* '("ANSI" "CLHS" "ASDF" "DSL" "OS" "CL" "CR" "LF" "CRLF" "CR+LF" "CPU" "FASL" "POSIX" "GCL" "MCL" "ABCL" "CCL" "CMUCL" "CLASP" "CLISP" "ECL" "MKCL" "SBCL" "SCL" "XCL")) (defun locate-symbols (line) "Return a list of index pairs of symbol-like parts of LINE." ;; This would be a good application for a regex ... (let (result) (flet ((grab (start end) (unless (member (subseq line start end) *not-symbols* :test #'string=) (push (list start end) result)))) (do ((begin nil) (maybe-begin t) (i 0 (1+ i))) ((= i (length line)) ;; symbol at end of line (when (and begin (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))) (grab begin i)) (nreverse result)) ;; (format t "begin: ~A, maybe-begin: ~A, i: ~A~%" begin maybe-begin i) (cond ((and begin (find (char line i) *symbol-delimiters*)) ;; symbol end; remember it if it's not "A" or "I" (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) (grab begin i)) (setf begin nil maybe-begin t)) ((and begin (not (find (char line i) *symbol-characters*))) ;; Not a symbol: abort (setf begin nil)) ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) ;; potential symbol begin at this position (setf begin i maybe-begin nil)) ((find (char line i) *symbol-delimiters*) ;; potential symbol begin after this position (setf maybe-begin t)) (t ;; Not reading a symbol, not at potential start of symbol (setf maybe-begin nil))))))) (defun texinfo-line (line) "Format symbols in LINE texinfo-style: either as code or as variables if the symbol in question is contained in symbols *TEXINFO-VARIABLES*." (with-output-to-string (result) (let ((last 0)) (dolist (symbol/index (locate-symbols line)) (write-string (subseq line last (first symbol/index)) result) (let ((symbol-name (apply #'subseq line symbol/index))) (format result (if (member symbol-name *texinfo-variables* :test #'string=) "@var{~A}" "@code{~A}") (string-downcase symbol-name))) (setf last (second symbol/index))) (write-string (subseq line last) result)))) ;;; lisp sections (defun lisp-section-p (line line-number lines) "Returns T if the given LINE looks like start of lisp code -- ie. if it starts with whitespace followed by a paren or semicolon, and the previous line is empty" (let ((offset (indentation line))) (and offset (plusp offset) (find (find-if-not #'whitespacep line) "(;") (empty-p (1- line-number) lines)))) (defun collect-lisp-section (lines line-number) (let ((lisp (loop for index = line-number then (1+ index) for line = (and (< index (length lines)) (svref lines index)) while (indentation line) collect line))) (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) ;;; itemized sections (defun maybe-itemize-offset (line) "Return NIL or the indentation offset if LINE looks like it starts an item in an itemization." (let* ((offset (indentation line)) (char (when offset (char line offset)))) (and offset (member char *itemize-start-characters* :test #'char=) (char= #\Space (find-if-not (lambda (c) (char= c char)) line :start offset)) offset))) (defun collect-maybe-itemized-section (lines starting-line) ;; Return index of next line to be processed outside (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) (result nil) (lines-consumed 0)) (loop for line-number from starting-line below (length lines) for line = (svref lines line-number) for indentation = (indentation line) for offset = (maybe-itemize-offset line) do (cond ((not indentation) ;; empty line -- inserts paragraph. (push "" result) (incf lines-consumed)) ((and offset (> indentation this-offset)) ;; nested itemization -- handle recursively ;; FIXME: tables in itemizations go wrong (multiple-value-bind (sub-lines-consumed sub-itemization) (collect-maybe-itemized-section lines line-number) (when sub-lines-consumed (incf line-number (1- sub-lines-consumed)) ; +1 on next loop (incf lines-consumed sub-lines-consumed) (setf result (nconc (nreverse sub-itemization) result))))) ((and offset (= indentation this-offset)) ;; start of new item (push (format nil "@item ~A" (texinfo-line (subseq line (1+ offset)))) result) (incf lines-consumed)) ((and (not offset) (> indentation this-offset)) ;; continued item from previous line (push (texinfo-line line) result) (incf lines-consumed)) (t ;; end of itemization (loop-finish)))) ;; a single-line itemization isn't. (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) nil))) ;;; table sections (defun tabulation-body-p (offset line-number lines) (when (< line-number (length lines)) (let ((offset2 (indentation (svref lines line-number)))) (and offset2 (< offset offset2))))) (defun tabulation-p (offset line-number lines direction) (let ((step (ecase direction (:backwards (1- line-number)) (:forwards (1+ line-number))))) (when (and (plusp line-number) (< line-number (length lines))) (and (eql offset (indentation (svref lines line-number))) (or (when (eq direction :backwards) (empty-p step lines)) (tabulation-p offset step lines direction) (tabulation-body-p offset step lines)))))) (defun maybe-table-offset (line-number lines) "Return NIL or the indentation offset if LINE looks like it starts an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an empty line, another tabulation label, or a tabulation body, (3) and followed another tabulation label or a tabulation body." (let* ((line (svref lines line-number)) (offset (indentation line)) (prev (1- line-number)) (next (1+ line-number))) (when (and offset (plusp offset)) (and (or (empty-p prev lines) (tabulation-body-p offset prev lines) (tabulation-p offset prev lines :backwards)) (or (tabulation-body-p offset next lines) (tabulation-p offset next lines :forwards)) offset)))) ;;; FIXME: This and itemization are very similar: could they share ;;; some code, mayhap? (defun collect-maybe-table-section (lines starting-line) ;; Return index of next line to be processed outside (let ((this-offset (maybe-table-offset starting-line lines)) (result nil) (lines-consumed 0)) (loop for line-number from starting-line below (length lines) for line = (svref lines line-number) for indentation = (indentation line) for offset = (maybe-table-offset line-number lines) do (cond ((not indentation) ;; empty line -- inserts paragraph. (push "" result) (incf lines-consumed)) ((and offset (= indentation this-offset)) ;; start of new item, or continuation of previous item (if (and result (search "@item" (car result) :test #'char=)) (push (format nil "@itemx ~A" (texinfo-line line)) result) (progn (push "" result) (push (format nil "@item ~A" (texinfo-line line)) result))) (incf lines-consumed)) ((> indentation this-offset) ;; continued item from previous line (push (texinfo-line line) result) (incf lines-consumed)) (t ;; end of itemization (loop-finish)))) ;; a single-line table isn't. (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) (values lines-consumed `("" "@table @emph" ,@(reverse result) "@end table" "")) nil))) ;;; section markup (defmacro with-maybe-section (index &rest forms) `(multiple-value-bind (count collected) (progn ,@forms) (when count (dolist (line collected) (write-line line *texinfo-output*)) (incf ,index (1- count))))) (defun write-texinfo-string (string &optional lambda-list) "Try to guess as much formatting for a raw docstring as possible." (let ((*texinfo-variables* (flatten lambda-list)) (lines (string-lines (escape-for-texinfo string nil)))) (loop for line-number from 0 below (length lines) for line = (svref lines line-number) do (cond ((with-maybe-section line-number (and (lisp-section-p line line-number lines) (collect-lisp-section lines line-number)))) ((with-maybe-section line-number (and (maybe-itemize-offset line) (collect-maybe-itemized-section lines line-number)))) ((with-maybe-section line-number (and (maybe-table-offset line-number lines) (collect-maybe-table-section lines line-number)))) (t (write-line (texinfo-line line) *texinfo-output*)))))) ;;;; texinfo formatting tools (defun hide-superclass-p (class-name super-name) (let ((super-package (symbol-package super-name))) (or ;; KLUDGE: We assume that we don't want to advertise internal ;; classes in CP-lists, unless the symbol we're documenting is ;; internal as well. (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) (not (eq super-package (symbol-package class-name)))) ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them ;; simply as a matter of convenience. The assumption here is that ;; the inheritance is incidental unless the name of the condition ;; begins with SIMPLE-. (and (member super-name '(simple-error simple-condition)) (let ((prefix "SIMPLE-")) (mismatch prefix (string class-name) :end2 (length prefix))) t ; don't return number from MISMATCH )))) (defun hide-slot-p (symbol slot) ;; FIXME: There is no pricipal reason to avoid the slot docs fo ;; structures and conditions, but their DOCUMENTATION T doesn't ;; currently work with them the way we'd like. (not (and (typep (find-class symbol nil) 'standard-class) (docstring slot t)))) (defun make-macro-name (string) "Make an appropriate name for Texinfo macro." (concatenate 'string "sbtexinfo" (substitute-if #\x (complement #'alpha-char-p) string))) (defun texinfo-anchor (doc) (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) (defparameter *omit-package-prefix* t "Omit package designator from each definition of symbol.") ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" (defun texinfo-begin (doc &aux *print-pretty*) (let ((kind (get-kind doc))) (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%" (case kind ((package constant variable) "defvr") ((structure class condition type) "deftp") (t "deffn")) (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) (if *omit-package-prefix* (get-name doc) (title-name doc)) ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo ;; interactions,so we escape the ampersand -- amusingly for TeX. ;; sbcl.texinfo defines macros that expand @&key and friends to &key. (mapcar (lambda (name) (if (member name (load-time-value (remove '&aux lambda-list-keywords))) (format nil "@~A" (make-macro-name (string-downcase name))) name)) (lambda-list doc))))) (defun texinfo-index (doc) (let ((title (title-name doc))) (case (get-kind doc) ((structure type class condition) (format *texinfo-output* "@tindex ~A~%" title)) ((variable constant) (format *texinfo-output* "@vindex ~A~%" title)) ((compiler-macro function method-combination macro generic-function) (format *texinfo-output* "@findex ~A~%" title))))) (defun texinfo-inferred-body (doc) (when (member (get-kind doc) '(class structure condition)) (let ((name (get-name doc))) ;; class precedence list (format *texinfo-output* "Class precedence list: @code{~(~{~A~^, ~}~)}~%~%" (remove-if (lambda (class) (hide-superclass-p name class)) (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) ;; slots (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) (class-direct-slots (find-class name))))) (when slots (format *texinfo-output* "Slots:~%@itemize~%") (dolist (slot slots) (format *texinfo-output* "@item ~(@code{~A}~#[~:; --- ~]~ ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" (slot-definition-name slot) (remove nil (mapcar (lambda (name things) (if things (list name (length things) things))) '("initarg" "reader" "writer") (list (slot-definition-initargs slot) (slot-definition-readers slot) (slot-definition-writers slot))))) ;; FIXME: Would be neater to handler as children (write-texinfo-string (docstring slot t))) (format *texinfo-output* "@end itemize~%~%")))))) (defun texinfo-body (doc) (write-texinfo-string (get-string doc))) (defun texinfo-end (doc) (write-line (case (get-kind doc) ((package variable constant) "@end defvr") ((structure type class condition) "@end deftp") (t "@end deffn")) *texinfo-output*)) (defun write-texinfo (doc) "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." (texinfo-anchor doc) (texinfo-begin doc) (texinfo-index doc) (texinfo-inferred-body doc) (texinfo-body doc) (texinfo-end doc) ;; FIXME: Children should be sorted one way or another (mapc #'write-texinfo (get-children doc))) ;;;; main logic (defun collect-gf-documentation (gf) "Collects method documentation for the generic function GF" (loop for method in (generic-function-methods gf) for doc = (maybe-documentation method t) when doc collect doc)) (defun collect-name-documentation (name) (loop for type in *documentation-types* for doc = (maybe-documentation name type) when doc collect doc)) (defun collect-symbol-documentation (symbol) "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of the form DOC instances. See `*documentation-types*' for the possible values of doc-type." (nconc (collect-name-documentation symbol) (collect-name-documentation (list 'setf symbol)))) (defun collect-documentation (package) "Collects all documentation for all external symbols of the given package, as well as for the package itself." (let* ((*documentation-package* (find-package package)) (docs nil)) (check-type package package) (do-external-symbols (symbol package) (setf docs (nconc (collect-symbol-documentation symbol) docs))) (let ((doc (maybe-documentation *documentation-package* t))) (when doc (push doc docs))) docs)) (defmacro with-texinfo-file (pathname &body forms) `(with-open-file (*texinfo-output* ,pathname :direction :output :if-does-not-exist :create :if-exists :supersede) ,@forms)) (defun write-ifnottex () ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to ;; define them for info as well. (flet ((macro (name) (let ((string (string-downcase name))) (format *texinfo-output* "@macro ~A~%~A @:~%@end macro~%" (make-macro-name string) string)))) (macro '&allow-other-keys) (macro '&optional) (macro '&rest) (macro '&key) (macro '&body))) (defun generate-includes (directory packages &key (base-package :cl-user)) "Create files in `directory' containing Texinfo markup of all docstrings of each exported symbol in `packages'. `directory' is created if necessary. If you supply a namestring that doesn't end in a slash, you lose. The generated files are of the form \"__.texinfo\" and can be included via @include statements. Texinfo syntax-significant characters are escaped in symbol names, but if a docstring contains invalid Texinfo markup, you lose." (handler-bind ((warning #'muffle-warning)) (let ((directory (merge-pathnames (pathname directory))) (*base-package* (find-package base-package))) (ensure-directories-exist directory) (dolist (package packages) (dolist (doc (collect-documentation (find-package package))) (with-texinfo-file (merge-pathnames (include-pathname doc) directory) (write-texinfo doc)))) (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) (write-ifnottex)) directory))) (defun document-package (package &optional filename) "Create a file containing all available documentation for the exported symbols of `package' in Texinfo format. If `filename' is not supplied, a file \".texinfo\" is generated. The definitions can be referenced using Texinfo statements like @ref{__.texinfo}. Texinfo syntax-significant characters are escaped in symbol names, but if a docstring contains invalid Texinfo markup, you lose." (handler-bind ((warning #'muffle-warning)) (let* ((package (find-package package)) (filename (or filename (make-pathname :name (string-downcase (short-package-name package)) :type "texinfo"))) (docs (sort (collect-documentation package) #'documentation<))) (with-texinfo-file filename (dolist (doc docs) (write-texinfo doc))) filename))) (defparameter *prefix-of-lines-to-be-replaced* "@c REPLACE_ME_WITH ") (defun complete-texinfo-template (template-pathname dest-pathname &optional (include-directory "include/")) "Complete a template Texinfo file by inserting the @include statements to the lines [*PREFIX-OF-LINES-TO-BE-REPLACED*] [package-name]: e.g. @c REPLACE_ME_WITH UIOP/UTILITY The included files are searched in `include-directory', which should be outputted by `generate-includes' beforehand." (let* ((template-pathname (merge-pathnames template-pathname)) (dest-pathname (merge-pathnames dest-pathname)) (include-directory (merge-pathnames include-directory)) (prefix-length (length *prefix-of-lines-to-be-replaced*)) (generated-files (directory (merge-pathnames "*.texinfo" include-directory)))) (with-open-file (in template-pathname) (with-open-file (out dest-pathname :direction :output :if-exists :supersede) (loop for line = (read-line in nil nil) while line if (uiop:string-prefix-p *prefix-of-lines-to-be-replaced* line) do (let* ((package-name (subseq line prefix-length)) (package (or (find-package package-name) (error "No package named ~A." package-name))) (filename-prefix (render-package-name package)) (files (loop for path in generated-files when (uiop:string-prefix-p filename-prefix (file-namestring path)) collect path))) (dolist (file files) (format out "@include ~A~%" file))) else do (write-line line out)))))) asdf-3.3.4/uiop/doc/template.texinfo000066400000000000000000000126331362155115300173770ustar00rootroot00000000000000\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename uiop.info @settitle UIOP Manual @c %**end of header @c for install-info @dircategory Software development @direntry * uiop: (uiop). Utilities for Implementation and OS Portability (for Common Lisp) @end direntry @copying UIOP is a part of @uref{https://common-lisp.net/project/asdf/, ASDF}, which is released under an MIT style License: @quotation Copyright @copyright{} 2001-2019 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. @end quotation @end copying @titlepage @title UIOP Manual @c The following two commands start the copyright page. @page @vskip 0pt plus 1filll @insertcopying @end titlepage @contents @include include/ifnottex.texinfo @ifnottex @node Top @comment node-name, next, previous, up @top UIOP @insertcopying @menu * Introduction:: * UIOP/PACKAGE:: * UIOP/COMMON-LISP:: * UIOP/UTILITY:: * UIOP/VERSION:: * UIOP/OS:: * UIOP/PATHNAME:: * UIOP/FILESYSTEM:: * UIOP/STREAM:: * UIOP/IMAGE:: * UIOP/LISP-BUILD:: * UIOP/LAUNCH-PROGRAM:: * UIOP/RUN-PROGRAM:: * UIOP/CONFIGURATION:: * UIOP/BACKWARD-DRIVER:: * UIOP/DRIVER:: @end menu @end ifnottex @node Introduction @comment node-name, next, previous, up @chapter Introduction 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 @file{pathname.lisp} will define package @code{uiop/pathname} and contain utilities related to the handling of pathname objects. All exported symbols are reexported in a convenience package @code{uiop}, except for those from @code{uiop/common-lisp}. We recommend package @code{uiop} be used to access all the symbols. The following API reference is auto-generated from the docstrings in the code. The chapters are arranged in dependency order. @node UIOP/PACKAGE @comment node-name, next, previous, up @chapter UIOP/PACKAGE @c REPLACE_ME_WITH UIOP/PACKAGE @node UIOP/COMMON-LISP @comment node-name, next, previous, up @chapter UIOP/COMMON-LISP @code{uiop/common-lisp} lets you paper over various sub-standard implementations. This package reexports all the symbols in @code{common-lisp} package. @node UIOP/UTILITY @comment node-name, next, previous, up @chapter UIOP/UTILITY @c REPLACE_ME_WITH UIOP/UTILITY @node UIOP/VERSION @comment node-name, next, previous, up @chapter UIOP/VERSION @c REPLACE_ME_WITH UIOP/VERSION @node UIOP/OS @comment node-name, next, previous, up @chapter UIOP/OS @c REPLACE_ME_WITH UIOP/OS @node UIOP/PATHNAME @comment node-name, next, previous, up @chapter UIOP/PATHNAME @c REPLACE_ME_WITH UIOP/PATHNAME @node UIOP/FILESYSTEM @comment node-name, next, previous, up @chapter UIOP/FILESYSTEM @c REPLACE_ME_WITH UIOP/FILESYSTEM @node UIOP/STREAM @comment node-name, next, previous, up @chapter UIOP/STREAM @c REPLACE_ME_WITH UIOP/STREAM @node UIOP/IMAGE @comment node-name, next, previous, up @chapter UIOP/IMAGE @c REPLACE_ME_WITH UIOP/IMAGE @node UIOP/LISP-BUILD @comment node-name, next, previous, up @chapter UIOP/LISP-BUILD @c REPLACE_ME_WITH UIOP/LISP-BUILD @node UIOP/LAUNCH-PROGRAM @comment node-name, next, previous, up @chapter UIOP/LAUNCH-PROGRAM @code{uiop/launch-program} semi-portably launches a program as an asynchronous external subprocess. Available functionality may depend on the underlying implementation. @c REPLACE_ME_WITH UIOP/LAUNCH-PROGRAM @node UIOP/RUN-PROGRAM @comment node-name, next, previous, up @chapter UIOP/RUN-PROGRAM @code{uiop/run-program} fully portably runs a program as a synchronous external subprocess. @c REPLACE_ME_WITH UIOP/RUN-PROGRAM @node UIOP/CONFIGURATION @comment node-name, next, previous, up @chapter UIOP/CONFIGURATION @c REPLACE_ME_WITH UIOP/CONFIGURATION @node UIOP/BACKWARD-DRIVER @comment node-name, next, previous, up @chapter UIOP/BACKWARD-DRIVER @code{uiop/backward-driver} provides backward-compatibility with earlier incarnations of this library. @c REPLACE_ME_WITH UIOP/BACKWARD-DRIVER @node UIOP/DRIVER @comment node-name, next, previous, up @chapter UIOP/DRIVER @code{uiop/driver} doesn't export any new symbols. It just exists to reexport all the utilities in a single package @code{uiop}. @bye asdf-3.3.4/uiop/driver.lisp000066400000000000000000000016411362155115300156020ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Re-export all the functionality in UIOP (uiop/package:define-package :uiop/driver (:nicknames :uiop :asdf/driver) ;; asdf/driver is obsolete (uiop isn't); ;; but asdf/driver is still used by swap-bytes, static-vectors. (:use :uiop/common-lisp) ;; NB: not reexporting uiop/common-lisp ;; which include all of CL with compatibility modifications on select platforms, ;; that could cause potential conflicts for packages that would :use (cl uiop) ;; or :use (closer-common-lisp uiop), etc. (:use-reexport :uiop/package :uiop/utility :uiop/version :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/launch-program :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) ;; Provide both lowercase and uppercase, to satisfy more people. (provide "uiop") (provide "UIOP") asdf-3.3.4/uiop/filesystem.lisp000066400000000000000000001072631362155115300165020ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp filesystem access (uiop/package:define-package :uiop/filesystem (: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 cmucl scl) (ext:unix-namestring p nil) #+sbcl (sb-ext:native-namestring p) #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (unix-namestring p)) (t (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) #+cmucl (uiop/os::parse-unix-namestring* string) #+sbcl (sb-ext:parse-native-namestring string) #+scl (lisp::parse-unix-namestring string) #-(or clozure cmucl sbcl scl) (os-cond ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) (t (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, avoids logical pathname contexts, and tries both files and directories" (when p (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p)))) (values (or (ignore-errors (truename p)) ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying ;; a trailing directory separator, causes an error on some lisps. #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))) ;; On Genera, truename of a directory pathname will probably fail as Genera ;; will merge in a filename/type/version from *default-pathname-defaults* and ;; will try to get the truename of a file that probably doesn't exist. #+genera (when (directory-pathname-p p) (let ((d (scl:send p :directory-pathname-as-file))) (ensure-directory-pathname (ignore-errors (truename d)) 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 if TRUENAME is true, or the original (parsed) pathname if it is false (the default)." (values (ignore-errors (setf p (funcall 'ensure-pathname p :namestring :lisp :ensure-physical t :ensure-absolute t :defaults 'get-pathname-defaults :want-non-wild t :on-error nil)) (when p #+allegro (probe-file p :follow-symlinks truename) #+gcl (if truename (truename* p) (let ((kind (car (si::stat p)))) (when (eq kind :link) (setf kind (ignore-errors (car (si::stat (truename* p)))))) (ecase kind ((nil) nil) ((:file :link) (cond ((file-pathname-p p) p) ((directory-pathname-p p) (subpathname p (car (last (pathname-directory p))))))) (:directory (ensure-directory-pathname p))))) #+clisp #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) (pp (find-symbol* '#:probe-pathname :ext nil))) `(if truename ,(if pp `(values (,pp p)) '(or (truename* p) (truename* (ignore-errors (ensure-directory-pathname p))))) ,(cond (fs `(and (,fs p) p)) (pp `(nth-value 1 (,pp p))) (t '(or (and (truename* p) p) (if-let (d (ensure-directory-pathname p)) (and (truename* d) d))))))) #-(or allegro clisp gcl) (if truename (probe-file p) (and #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) #+(and lispworks os-unix) (system:get-file-stat p) #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p) p)))))) (defun directory-exists-p (x) "Is X the name of a directory that exists on the filesystem?" #+allegro (excl:probe-directory x) #+clisp (handler-case (ext:probe-directory x) (sys::simple-file-error () nil)) #-(or allegro clisp) (let ((p (probe-file* x :truename t))) (and (directory-pathname-p p) p))) (defun file-exists-p (x) "Is X the name of a file that exists on the filesystem?" (let ((p (probe-file* x :truename t))) (and (file-pathname-p p) p))) (defun directory* (pathname-spec &rest keys &key &allow-other-keys) "Return a list of the entries in a directory by calling DIRECTORY. Try to override the defaults to not resolving symlinks, if implementation allows." (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmucl scl) '(:follow-links nil :truenamep nil) #+lispworks '(:link-transparency nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) (defun filter-logical-directory-results (directory entries merger) "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is, given ENTRIES in the DIRECTORY, remove the entries which are physical yet when transformed by MERGER have a different TRUENAME. Also remove duplicates as may appear with some translation rules. This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames." (if (logical-pathname-p directory) (remove-duplicates ;; on CLISP, querying ~/ will return duplicates ;; 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) :test 'pathname-equal) entries)) (defun directory-files (directory &optional (pattern *wild-file-for-directory*)) "Return a list of the files in a directory according to the PATTERN. Subdirectories should NOT be returned. PATTERN defaults to a pattern carefully chosen based on the implementation; override the default at your own risk. DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this, but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations." (let ((dir (ensure-directory-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) (parameter-error "~S: Invalid wild pattern in logical directory ~S" 'directory-files directory)) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory)) (setf pattern (make-pathname-logical pattern (pathname-host dir)))) (let* ((pat (merge-pathnames* pattern dir)) (entries (ignore-errors (directory* pat)))) (remove-if 'directory-pathname-p (filter-logical-directory-results directory entries #'(lambda (f) (make-pathname :defaults dir :name (make-pathname-component-logical (pathname-name f)) :type (make-pathname-component-logical (pathname-type f)) :version (make-pathname-component-logical (pathname-version f))))))))) (defun subdirectories (directory) "Given a DIRECTORY pathname designator, return a list of the subdirectories under it. The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* #-(or abcl allegro cmucl lispworks sbcl scl xcl) *wild-directory* #+(or abcl allegro cmucl 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 (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) #+(or abcl allegro cmucl 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 cmucl sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d) #+genera (ensure-directory-pathname (first x)) #+(or cmucl 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, when COLLECTP returns true when CALL-FUNCTION'ed with the directory, call-function the COLLECTOR function designator on the directory, and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them. This function will thus let you traverse a filesystem hierarchy, superseding the functionality of CL-FAD:WALK-DIRECTORY. The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." (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 (ignore-errors (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) :name nil :type nil :version nil :defaults p)))) (if-let (simplified (ignore-errors (merge-pathnames* (make-pathname :directory `(:relative ,@down-components) :defaults p) (ensure-directory-pathname parent)))) (return simplified))) (push (pop up-components) down-components) :finally (return p)))))) (defun resolve-symlinks (path) "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." #-allegro (truenamize path) #+allegro (if (physical-pathname-p path) (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 namestring empty-is-nil 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, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively, or else by using CALL-FUNCTION on the NAMESTRING argument; if :UNIX is specified (or NIL, the default, which specifies the same thing), then PARSE-UNIX-NAMESTRING it is called with the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true. The pathname passed or resulting from parsing the string is then subjected to all the checks and transformations below are run. Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. The boolean T is an alias for ERROR. 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: EMPTY-IS-NIL returns NIL if the argument is an empty string. 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 (when (and (emptyp p) empty-is-nil) (return-from ensure-pathname nil)) (setf p (case namestring ((:unix nil) (parse-unix-namestring p :defaults defaults :type type :dot-dot dot-dot :ensure-directory ensure-directory :want-relative want-relative)) ((:native) (parse-native-namestring p)) ((:lisp) (parse-namestring p)) (t (call-function namestring p)))))) (etypecase p (pathname) (null (check want-pathname (pathnamep p) "Expected a pathname, not NIL") (return nil))) (check want-logical (logical-pathname-p p) "Expected a logical pathname") (check want-physical (physical-pathname-p p) "Expected a physical pathname") (transform ensure-physical () (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 (ensure-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?" (os-cond ((os-unix-p) #\:) (t #\;))) (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, where an empty string denotes NIL." (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) :collect (unless (emptyp namestring) (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. Any empty entries in the environment variable X will be returned as NILs." (unless (getf constraints :empty-is-nil t) (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames)) (apply 'split-native-pathnames-string (getenvp x) :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) :empty-is-nil t 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. Any empty entries in the environment variable X will be returned as NILs." (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)) (let ((dir #+abcl extensions:*lisp-home* #+(or allegro clasp ecl mkcl) #p"SYS:" #+clisp custom:*lib-directory* #+clozure #p"ccl:" #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) #+gcl system::*system-directory* #+lispworks lispworks:*lispworks-directory* #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) (funcall it) (getenv-pathname "SBCL_HOME" :ensure-directory t)) #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/"))) #+xcl ext:*xcl-home*)) (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 delete-file-if-exists (x) "Delete a file X if it already exists" (when x (handler-case (delete-file x) (file-error () nil)))) (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." (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t)) (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t))) #+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)) #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic #-clisp (rename-file source target #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t))) (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 cmucl scl) (multiple-value-bind (ok errno) (unix:unix-rmdir (native-namestring directory-pathname)) (unless ok #+cmucl (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) #+(or clasp ecl) (si:rmdir directory-pathname) #+genera (fs:delete-directory 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 clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) (not-implemented-error 'delete-empty-directory "(on your platform)")) ; 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)) (setf directory-pathname (ensure-pathname directory-pathname :want-pathname t :want-non-wild t :want-physical t :want-directory t)) (cond ((not validatep) (parameter-error "~S was asked to delete ~S but was not provided a validation predicate" 'delete-directory-tree directory-pathname)) ((not (call-function validate directory-pathname)) (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" 'delete-directory-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-directory-tree directory-pathname)) (:ignore nil))) #-(or allegro cmucl clozure genera 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 (fs:delete-directory directory-pathname :confirm nil) #+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))))))) asdf-3.3.4/uiop/image.lisp000066400000000000000000000544671362155115300154070ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Starting, Stopping, Dumping a Lisp image (uiop/package:define-package :uiop/image (: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 #:argv0 #:*lisp-interaction* #:fatal-condition #: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")) (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype fatal-condition () `(and serious-condition #+clozure (not ccl:process-reset)))) ;;; 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) #+(or clasp ecl) (si:quit code) #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) #+(or cmucl scl) (unix:unix-exit code) #+gcl (system:quit code) #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit 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 clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (not-implemented-error 'quit "(called with exit code ~S)" 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 condition) "Print a backtrace, directly accessing the implementation" (declare (ignorable stream count condition)) #+abcl (loop :for i :from 0 :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do (safe-format! stream "~&~D: ~A~%" i frame)) #+allegro (let ((*terminal-io* stream) (*standard-output* stream) (tpl:*zoom-print-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 (or count t) :all t)) #+(or clasp ecl mkcl) (let* ((top (si:ihs-top)) (repeats (if count (min top count) top)) (backtrace (loop :for ihs :from 0 :below top :collect (list (si::ihs-fun ihs) (si::ihs-env ihs))))) (loop :for i :from 0 :below repeats :for frame :in (nreverse backtrace) :do (safe-format! stream "~&~D: ~S~%" i frame))) #+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 cmucl scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace (or count most-positive-fixnum) stream)) #+gcl (let ((*debug-io* stream)) (ignore-errors (with-safe-io-syntax () (if condition (conditions::condition-backtrace condition) (system::simple-backtrace))))) #+lispworks (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) (*debug-io* stream) (dbg:*debug-print-level* *print-level*) (dbg:*debug-print-length* *print-length*)) (dbg:bug-backtrace nil)) #+mezzano (let ((*standard-output* stream)) (sys.int::backtrace count)) #+sbcl (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum)) #+xcl (loop :for i :from 0 :below (or count most-positive-fixnum) :for frame :in (extensions:backtrace-as-list) :do (safe-format! stream "~&~D: ~S~%" i frame))) (defun print-backtrace (&rest keys &key stream count condition) "Print a backtrace" (declare (ignore stream count condition)) (with-safe-io-syntax (:package :cl) (let ((*print-readably* nil) (*print-circle* t) (*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 :condition condition) (when condition (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" condition))) (defun fatal-condition-p (condition) "Is the CONDITION fatal?" (typep condition 'fatal-condition)) (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 ((fatal-condition #'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 #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+clisp (coerce (ext:argv) 'list) #+clozure ccl:*command-line-argument-list* #+(or cmucl scl) extensions:*command-line-strings* #+gcl si:*command-args* #+(or genera mcl mezzano) nil #+lispworks sys:*line-arguments-list* #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) (not-implemented-error 'raw-command-line-arguments)) (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." (block nil #+abcl (return arguments) ;; SBCL and Allegro already separate user arguments from implementation arguments. #-(or sbcl allegro) (unless (eq *image-dumped-p* :executable) ;; LispWorks command-line processing isn't transparent to the user ;; unless you create a standalone executable; in that case, ;; we rely on cl-launch or some other script to set the arguments for us. #+lispworks (return *command-line-arguments*) ;; On other implementations, on non-standalone executables, ;; we trust cl-launch or whichever script starts the program ;; to use -- as a delimiter between implementation arguments and user arguments. #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) (rest arguments))) (defun argv0 () "On supported implementations (most that matter), or when invoked by a proper wrapper script, return a string that for the name with which the program was invoked, i.e. argv[0] in C. Otherwise, return NIL." (cond ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! ;; NB: not currently available on ABCL, Corman, Genera, MCL (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) (t ;; argv[0] is the name of the interpreter. ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. (getenvp "__CL_ARGV0")))) (defun setup-command-line-arguments () (setf *command-line-arguments* (command-line-arguments))) (defun restore-image (&key (lisp-interaction *lisp-interaction*) (restore-hook *image-restore-hook*) (prelude *image-prelude*) (entry-point *image-entry-point*) (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) "From a freshly restarted Lisp image, restore the saved Lisp environment by setting appropriate variables, running various hooks, and calling any specified entry point. If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*, call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return immediately to the surrounding restore process if allowed to continue. Then, comes the restore process itself: First, call each function in the RESTORE-HOOK, in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. Second, evaluate the prelude, which is often Lisp text that is read, as per EVAL-INPUT. Third, call the ENTRY-POINT function, if any is specified, with no argument. The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL, any unhandled error leads to a backtrace and an exit with an error status. If LISP-INTERACTION is NIL, the process also exits when no error occurs: if neither restart nor entry function is provided, the program will exit with status 0 (success); if a function was provided, the program will exit after the function returns (if it returns), with status 0 if and only if the primary return value of result is generalized boolean true, and with status 1 if this value is NIL. If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result of the function will be returned rather than interpreted as a boolean designating an exit code." (when *image-restored-p* (if if-already-restored (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) (return-from restore-image))) (with-fatal-condition-handler () (setf *lisp-interaction* lisp-interaction) (setf *image-restore-hook* restore-hook) (setf *image-prelude* prelude) (setf *image-restored-p* :in-progress) (call-image-restore-hook) (standard-eval-thunk prelude) (setf *image-restored-p* t) (let ((results (multiple-value-list (if entry-point (call-function entry-point) t)))) (if lisp-interaction (values-list results) (shell-boolean-exit (first results))))))) ;;; Dumping an image (with-upgradability () (defun dump-image (filename &key output-name executable (postlude *image-postlude*) (dump-hook *image-dump-hook*) #+clozure prepend-symbols #+clozure (purify t) #+sbcl compression #+(and sbcl os-windows) application-type) "Dump an image of the current Lisp environment at pathname FILENAME, with various options. First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK. If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup. Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL, or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ;; Note: at least SBCL saves only global values of variables in the heap image, ;; so make sure things you want to dump are NOT just local bindings shadowing the global values. (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) (setf *image-restored-p* :in-regress) (setf *image-postlude* postlude) (standard-eval-thunk *image-postlude*) (setf *image-dump-hook* dump-hook) (call-image-dump-hook) (setf *image-restored-p* nil) #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) (when executable (not-implemented-error 'dump-image "dumping an executable")) #+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 cmucl scl) (progn (ext:gc :full t) (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) (apply 'ext:save-lisp filename :allow-other-keys t ;; hush SCL and old versions of CMUCL #+(and cmucl executable) :executable #+(and cmucl executable) t (when executable '(:init-function restore-image :process-command-line nil :quiet t :load-init-file nil :site-init 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 (append (when compression (list :compression compression)) ;;--- only save runtime-options for standalone executables (when executable (list :toplevel #'restore-image :save-runtime-options t)) #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. ;; the default is :console - only works with SBCL 1.1.15 or later. (when application-type (list :application-type application-type))))) #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) (not-implemented-error 'dump-image)) (defun create-image (destination lisp-object-files &key kind output-name prologue-code epilogue-code extra-object-files (prelude () preludep) (postlude () postludep) (entry-point () entry-point-p) build-args no-uiop) (declare (ignorable destination lisp-object-files extra-object-files kind output-name prologue-code epilogue-code prelude preludep postlude postludep entry-point entry-point-p build-args no-uiop)) "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. #-(or clasp ecl mkcl) (not-implemented-error 'create-image) #+(or clasp ecl mkcl) (let ((epilogue-code (if no-uiop epilogue-code (let ((forms (append (when epilogue-code `(,epilogue-code)) (when postludep `((setf *image-postlude* ',postlude))) (when preludep `((setf *image-prelude* ',prelude))) (when entry-point-p `((setf *image-entry-point* ',entry-point))) (case kind ((:image) (setf kind :program) ;; to ECL, it's just another program. `((setf *image-dumped-p* t) (si::top-level #+(or clasp ecl) t) (quit))) ((:program) `((setf *image-dumped-p* :executable) (shell-boolean-exit (restore-image)))))))) (when forms `(progn ,@forms)))))) (check-type kind (member :dll :shared-library :lib :static-library :fasl :fasb :program)) (apply #+clasp 'cmp:builder #+clasp kind #+(or ecl mkcl) (ecase kind ((:dll :shared-library) #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library) ((:lib :static-library) #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library) ((:fasl #+ecl :fasb) #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl) #+mkcl ((:fasb) 'compiler:build-bundle) ((:program) #+ecl 'c::build-program #+mkcl 'compiler:build-program)) (pathname destination) #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+(or clasp ecl) extra-object-files) #+ecl :init-name #+ecl (getf build-args :init-name) (append (when prologue-code `(:prologue-code ,prologue-code)) (when epilogue-code `(:epilogue-code ,epilogue-code)) #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) build-args))))) ;;; Some universal image restore hooks (with-upgradability () (map () 'register-image-restore-hook '(setup-stdin setup-stdout setup-stderr setup-command-line-arguments setup-temporary-directory #+abcl detect-os))) asdf-3.3.4/uiop/launch-program.lisp000066400000000000000000001015531362155115300172310ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; launch-program - semi-portably spawn asynchronous subprocesses (uiop/package:define-package :uiop/launch-program (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export ;;; Escaping the command invocation madness #:easy-sh-character-p #:escape-sh-token #:escape-sh-command #:escape-windows-token #:escape-windows-command #:escape-shell-token #:escape-shell-command #:escape-token #:escape-command ;;; launch-program #:launch-program #:close-streams #:process-alive-p #:terminate-process #:wait-process #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid)) (in-package :uiop/launch-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) (parameter-error "~S: only one of good-chars and bad-chars can be provided" 'requires-escaping-p)) ((typep good-chars 'function) (complement good-chars)) ((typep bad-chars 'function) 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 (parameter-error "~S: no good-char criterion" 'requires-escaping-p))) 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 easy-windows-character-p (x) "Is X an \"easy\" character that does not require quoting by the shell?" (or (alphanumericp x) (find x "+-_.,@:/="))) (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 :good-chars #'easy-windows-character-p :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" (os-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))) (with-upgradability () ;;; Internal helpers for run-program (defun %normalize-io-specifier (specifier &optional role) "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent argument to pass to the internal RUN-PROGRAM" (declare (ignorable role)) (typecase specifier (null (or #+(or allegro lispworks) (null-device-pathname))) (string (parse-native-namestring specifier)) (pathname specifier) (stream specifier) ((eql :stream) :stream) ((eql :interactive) #+(or allegro lispworks) nil #+clisp :terminal #+(or abcl clozure cmucl ecl mkcl sbcl scl) t #-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp) (not-implemented-error :interactive-output "On this lisp implementation, cannot interpret ~a value of ~a" specifier role)) ((eql :output) (cond ((eq role :error-output) #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) :output #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) (not-implemented-error :error-output-redirect "Can't send ~a to ~a on this lisp implementation." role specifier)) (t (parameter-error "~S IO specifier invalid for ~S" specifier role)))) (otherwise (parameter-error "Incorrect I/O specifier ~S for ~S" specifier role)))) (defun %interactivep (input output error-output) (member :interactive (list input output error-output))) (defun %signal-to-exit-code (signum) (+ 128 signum)) (defun %code-to-status (exit-code signal-code) (cond ((null exit-code) :running) ((null signal-code) (values :exited exit-code)) (t (values :signaled signal-code)))) #+mkcl (defun %mkcl-signal-to-number (signal) (require :mk-unix) (symbol-value (find-symbol signal :mk-unix))) (defclass process-info () (;; The process field is highly platform-, implementation-, and ;; even version-dependent. ;; Prior to LispWorks 7, the only information that ;; `sys:run-shell-command` with `:wait nil` was certain to return ;; is a PID (e.g. when all streams are nil), hence we stored it ;; and used `sys:pid-exit-status` to obtain an exit status ;; later. That is still what we do. ;; From LispWorks 7 on, if `sys:run-shell-command` does not ;; return a proper stream, we are instead given a dummy stream. ;; We can thus always store a stream and use ;; `sys:pipe-exit-status` to obtain an exit status later. ;; The advantage of dealing with streams instead of PID is the ;; availability of functions like `sys:pipe-kill-process`. (process :initform nil) (input-stream :initform nil) (output-stream :initform nil) (bidir-stream :initform nil) (error-output-stream :initform nil) ;; For backward-compatibility, to maintain the property (zerop ;; exit-code) <-> success, an exit in response to a signal is ;; encoded as 128+signum. (exit-code :initform nil) ;; If the platform allows it, distinguish exiting with a code ;; >128 from exiting in response to a signal by setting this code (signal-code :initform nil))) ;;;--------------------------------------------------------------------------- ;;; The following two helper functions take care of handling the IF-EXISTS and ;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the ;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master ;;; function to treat input and output files unconditionally for reading and ;;; writing. ;;;--------------------------------------------------------------------------- (defun %handle-if-exists (file if-exists) (when (or (stringp file) (pathnamep file)) (ecase if-exists ((:append :supersede :error) (with-open-file (dummy file :direction :output :if-exists if-exists) (declare (ignorable dummy))))))) (defun %handle-if-does-not-exist (file if-does-not-exist) (when (or (stringp file) (pathnamep file)) (ecase if-does-not-exist ((:create :error) (with-open-file (dummy file :direction :probe :if-does-not-exist if-does-not-exist) (declare (ignorable dummy))))))) (defun process-info-error-output (process-info) (slot-value process-info 'error-output-stream)) (defun process-info-input (process-info) (or (slot-value process-info 'bidir-stream) (slot-value process-info 'input-stream))) (defun process-info-output (process-info) (or (slot-value process-info 'bidir-stream) (slot-value process-info 'output-stream))) (defun process-info-pid (process-info) (let ((process (slot-value process-info 'process))) (declare (ignorable process)) #+abcl (symbol-call :sys :process-pid process) #+allegro process #+clozure (ccl:external-process-id process) #+ecl (ext:external-process-pid process) #+(or cmucl scl) (ext:process-pid process) #+lispworks7+ (sys:pipe-pid process) #+(and lispworks (not lispworks7+)) process #+mkcl (mkcl:process-id process) #+sbcl (sb-ext:process-pid process) #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl) (not-implemented-error 'process-info-pid))) (defun %process-status (process-info) (if-let (exit-code (slot-value process-info 'exit-code)) (return-from %process-status (if-let (signal-code (slot-value process-info 'signal-code)) (values :signaled signal-code) (values :exited exit-code)))) #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl) (not-implemented-error '%process-status) (if-let (process (slot-value process-info 'process)) (multiple-value-bind (status code) (progn #+allegro (multiple-value-bind (exit-code pid signal-code) (sys:reap-os-subprocess :pid process :wait nil) (assert pid) (%code-to-status exit-code signal-code)) #+clozure (ccl:external-process-status process) #+(or cmucl scl) (let ((status (ext:process-status process))) (if (member status '(:exited :signaled)) ;; Calling ext:process-exit-code on ;; processes that are still alive ;; yields an undefined result (values status (ext:process-exit-code process)) status)) #+ecl (ext:external-process-status process) #+lispworks ;; a signal is only returned on LispWorks 7+ (multiple-value-bind (exit-code signal-code) (symbol-call :sys #+lispworks7+ :pipe-exit-status #-lispworks7+ :pid-exit-status process :wait nil) (%code-to-status exit-code signal-code)) #+mkcl (let ((status (mk-ext:process-status process))) (if (eq status :exited) ;; Only call mk-ext:process-exit-code when ;; necessary since it leads to another waitpid() (let ((code (mk-ext:process-exit-code process))) (if (stringp code) (values :signaled (%mkcl-signal-to-number code)) (values :exited code))) status)) #+sbcl (let ((status (sb-ext:process-status process))) (if (eq status :running) :running ;; sb-ext:process-exit-code can also be ;; called for stopped processes to determine ;; the signal that stopped them (values status (sb-ext:process-exit-code process))))) (case status (:exited (setf (slot-value process-info 'exit-code) code)) (:signaled (let ((%code (%signal-to-exit-code code))) (setf (slot-value process-info 'exit-code) %code (slot-value process-info 'signal-code) code)))) (if code (values status code) status)))) (defun process-alive-p (process-info) "Check if a process has yet to exit." (unless (slot-value process-info 'exit-code) #+abcl (sys:process-alive-p (slot-value process-info 'process)) #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process)) #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process)) #-(or abcl cmucl sbcl scl) (find (%process-status process-info) '(:running :stopped :continued :resumed)))) (defun wait-process (process-info) "Wait for the process to terminate, if it is still running. Otherwise, return immediately. An exit code (a number) will be returned, with 0 indicating success, and anything else indicating failure. If the process exits after receiving a signal, the exit code will be the sum of 128 and the (positive) numeric signal code. A second value may be returned in this case: the numeric signal code itself. Any asynchronously spawned process requires this function to be run before it is garbage-collected in order to free up resources that might otherwise be irrevocably lost." (if-let (exit-code (slot-value process-info 'exit-code)) (if-let (signal-code (slot-value process-info 'signal-code)) (values exit-code signal-code) exit-code) (let ((process (slot-value process-info 'process))) #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) (not-implemented-error 'wait-process) (when process ;; 1- wait #+clozure (ccl::external-process-wait process) #+(or cmucl scl) (ext:process-wait process) #+sbcl (sb-ext:process-wait process) ;; 2- extract result (multiple-value-bind (exit-code signal-code) (progn #+abcl (sys:process-wait process) #+allegro (multiple-value-bind (exit-code pid signal) (sys:reap-os-subprocess :pid process :wait t) (assert pid) (values exit-code signal)) #+clozure (multiple-value-bind (status code) (ccl:external-process-status process) (if (eq status :signaled) (values nil code) code)) #+(or cmucl scl) (let ((status (ext:process-status process)) (code (ext:process-exit-code process))) (if (eq status :signaled) (values nil code) code)) #+ecl (multiple-value-bind (status code) (ext:external-process-wait process t) (if (eq status :signaled) (values nil code) code)) #+lispworks (symbol-call :sys #+lispworks7+ :pipe-exit-status #-lispworks7+ :pid-exit-status process :wait t) #+mkcl (let ((code (mkcl:join-process process))) (if (stringp code) (values nil (%mkcl-signal-to-number code)) code)) #+sbcl (let ((status (sb-ext:process-status process)) (code (sb-ext:process-exit-code process))) (if (eq status :signaled) (values nil code) code))) (if signal-code (let ((%exit-code (%signal-to-exit-code signal-code))) (setf (slot-value process-info 'exit-code) %exit-code (slot-value process-info 'signal-code) signal-code) (values %exit-code signal-code)) (progn (setf (slot-value process-info 'exit-code) exit-code) exit-code))))))) ;; WARNING: For signals other than SIGTERM and SIGKILL this may not ;; do what you expect it to. Sending SIGSTOP to a process spawned ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used ;; to run the command (via `sh -c command`) but not the actual ;; command. #+os-unix (defun %posix-send-signal (process-info signal) #+allegro (excl.osi:kill (slot-value process-info 'process) signal) #+clozure (ccl:signal-external-process (slot-value process-info 'process) signal :error-if-exited nil) #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal) #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal) #-(or allegro clozure cmucl sbcl scl) (if-let (pid (process-info-pid process-info)) (symbol-call :uiop :run-program (format nil "kill -~a ~a" signal pid) :ignore-error-status t))) ;;; this function never gets called on Windows, but the compiler cannot tell ;;; that. [2016/09/25:rpg] #+os-windows (defun %posix-send-signal (process-info signal) (declare (ignore process-info signal)) (values)) (defun terminate-process (process-info &key urgent) "Cause the process to exit. To that end, the process may or may not be sent a signal, which it will find harder (or even impossible) to ignore if URGENT is T. On some platforms, it may also be subject to race conditions." (declare (ignorable urgent)) #+abcl (sys:process-kill (slot-value process-info 'process)) ;; On ECL, this will only work on versions later than 2016-09-06, ;; but we still want to compile on earlier versions, so we use symbol-call #+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent) #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process)) #+mkcl (mk-ext:terminate-process (slot-value process-info 'process) :force urgent) #-(or abcl ecl lispworks7+ mkcl) (os-cond ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15))) ((os-windows-p) (if-let (pid (process-info-pid process-info)) (symbol-call :uiop :run-program (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid) :ignore-error-status t))) (t (not-implemented-error 'terminate-process)))) (defun close-streams (process-info) "Close any stream that the process might own. Needs to be run whenever streams were requested by passing :stream to :input, :output, or :error-output." (dolist (stream (cons (slot-value process-info 'error-output-stream) (if-let (bidir-stream (slot-value process-info 'bidir-stream)) (list bidir-stream) (list (slot-value process-info 'input-stream) (slot-value process-info 'output-stream))))) (when stream (close stream)))) (defun launch-program (command &rest keys &key input (if-input-does-not-exist :error) output (if-output-exists :supersede) error-output (if-error-output-exists :supersede) (element-type #-clozure *default-stream-element-type* #+clozure 'character) (external-format *utf-8-external-format*) directory #+allegro separate-streams &allow-other-keys) "Launch 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) _asynchronously_. If OUTPUT is a pathname, a string designating a pathname, or NIL (the default) designating the null device, the file at that path is used as output. If it's :INTERACTIVE, output is inherited from the current process; beware that this may be different from your *STANDARD-OUTPUT*, and under SLIME will be on your *inferior-lisp* buffer. If it's T, output goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new stream will be made available that can be accessed via PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value that the underlying lisp implementation knows how to handle. IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the default). The meaning of these values and their effect on the case where OUTPUT does not exist, is analogous to the IF-EXISTS parameter to OPEN with :DIRECTION :OUTPUT. ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*, :OUTPUT means redirecting the error output to the output stream, and :STREAM causes a stream to be made available via PROCESS-INFO-ERROR-OUTPUT. IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it affects ERROR-OUTPUT rather than OUTPUT. INPUT is similar to OUTPUT, except that T designates the *STANDARD-INPUT* and a stream requested through the :STREAM keyword would be available through PROCESS-INFO-INPUT. IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string or a pathname, can take the values :CREATE and :ERROR (the default). The meaning of these values is analogous to the IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp implementation, when applicable, for creation of the output stream. LAUNCH-PROGRAM returns a PROCESS-INFO object." #-(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) (progn command keys input output error-output directory element-type external-format if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore (not-implemented-error 'launch-program)) #+allegro (when (some #'(lambda (stream) (and (streamp stream) (not (file-stream-p stream)))) (list input output error-output)) (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp" 'launch-program)) #+(or abcl clisp lispworks) (when (some #'streamp (list input output error-output)) (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp" 'launch-program)) #+clisp (unless (eq error-output :interactive) (parameter-error "~S: The only admissible value for ~S is ~S on this lisp" 'launch-program :error-output :interactive)) #+ecl (when (some #'(lambda (stream) (and (streamp stream) (not (file-or-synonym-stream-p stream)))) (list input output error-output)) (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp" 'launch-program)) #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) (nest (progn ;; see comments for these functions (%handle-if-does-not-exist input if-input-does-not-exist) (%handle-if-exists output if-output-exists) (%handle-if-exists error-output if-error-output-exists)) #+ecl (let ((*standard-input* *stdin*) (*standard-output* *stdout*) (*error-output* *stderr*))) (let ((process-info (make-instance 'process-info)) (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)) (command (etypecase command #+os-unix (string `("/bin/sh" "-c" ,command)) #+os-unix (list command) #+os-windows (string ;; 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 ecl) (nest #+(or ecl sbcl) (unless (find-symbol* :escape-arguments #+ecl :ext #+sbcl :sb-impl nil)) (parameter-error "~S doesn't support string commands on Windows on this Lisp" 'launch-program command)) ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified ;; when the command contains spaces or special characters: ;; IIUC, the system will use space as a separator, ;; but the C++ argv-decoding libraries won't, and ;; you're supposed to use an extra argument to CreateProcess to bridge the gap, ;; yet neither allegro nor clisp provide access to that argument. #+(or allegro clisp) (strcat "cmd /c " 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 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304 ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13) #+(or clozure ecl sbcl) (cons "cmd" (strcat "/c " command))) #+os-windows (list #+allegro (escape-windows-command command) #-allegro command))))) #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl) (let ((program (car command)) #-allegro (arguments (cdr command)))) #+(and (or ecl sbcl) os-windows) (multiple-value-bind (arguments escape-arguments) (if (listp arguments) (values arguments t) (values (list arguments) nil))) #-(or allegro mkcl sbcl) (with-current-directory (directory)) (multiple-value-bind #+(or abcl clozure cmucl sbcl scl) (process) #+allegro (in-or-io out-or-err err-or-pid pid-or-nil) #+ecl (stream code process) #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) #+mkcl (stream process code) #.`(apply #+abcl 'sys:run-program #+allegro ,@'('excl:run-shell-command #+os-unix (coerce (cons program command) 'vector) #+os-windows command) #+clozure 'ccl:run-program #+(or cmucl ecl scl) 'ext:run-program #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed #+mkcl 'mk-ext:run-program #+sbcl 'sb-ext:run-program #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments) #+(and (or ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments) :input input :if-input-does-not-exist :error :output output :if-output-exists :append ,(or #+(or allegro lispworks) :error-output :error) error-output ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append :wait nil :element-type element-type :external-format external-format :allow-other-keys t #+allegro ,@`(:directory directory #+os-windows ,@'(:show-window (if interactive nil :hide))) #+lispworks ,@'(:save-exit-status t) #+mkcl ,@'(:directory (native-namestring directory)) #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys))))) (labels ((prop (key value) (setf (slot-value process-info key) value))) #+allegro (cond (separate-streams (prop 'process pid-or-nil) (when (eq input :stream) (prop 'input-stream in-or-io)) (when (eq output :stream) (prop 'output-stream out-or-err)) (when (eq error-output :stream) (prop 'error-stream err-or-pid))) (t (prop 'process err-or-pid) (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) (0) (1 (prop 'input-stream in-or-io)) (2 (prop 'output-stream in-or-io)) (3 (prop 'bidir-stream in-or-io))) (when (eq error-output :stream) (prop 'error-stream out-or-err)))) #+(or abcl clozure cmucl sbcl scl) (progn (prop 'process process) (when (eq input :stream) (nest (prop 'input-stream) #+abcl (symbol-call :sys :process-input) #+clozure (ccl:external-process-input-stream) #+(or cmucl scl) (ext:process-input) #+sbcl (sb-ext:process-input) process)) (when (eq output :stream) (nest (prop 'output-stream) #+abcl (symbol-call :sys :process-output) #+clozure (ccl:external-process-output-stream) #+(or cmucl scl) (ext:process-output) #+sbcl (sb-ext:process-output) process)) (when (eq error-output :stream) (nest (prop 'error-output-stream) #+abcl (symbol-call :sys :process-error) #+clozure (ccl:external-process-error-stream) #+(or cmucl scl) (ext:process-error) #+sbcl (sb-ext:process-error) process))) #+(or ecl mkcl) (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) code ;; ignore (unless (zerop mode) (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)) (prop 'process process)) #+lispworks ;; See also the comments on the process-info class (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (cond ((or (plusp mode) (eq error-output :stream)) (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil) (when (plusp mode) (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) io-or-pid)) (when (eq error-output :stream) (prop 'error-stream err-or-nil))) ;; Prior to Lispworks 7, this returned (pid); now it ;; returns (io err pid) of which we keep io. (t (prop 'process io-or-pid))))) process-info))) asdf-3.3.4/uiop/lisp-build.lisp000066400000000000000000001257221362155115300163620ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Support to build (compile and load) Lisp files (uiop/package:define-package :uiop/lisp-build (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp (: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* #:*usual-uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* ;; Types #+sbcl #:sb-grovel-unknown-constant-condition ;; Functions & Macros #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions #:reify-simple-sexp #:unreify-simple-sexp #: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* #:*compile-check* #: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") (defparameter +optimization-variables+ ;; TODO: allegro genera corman mcl (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*) #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*) #+(or cmucl scl) '(c::*default-cookie*) #+clasp nil #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) #+lispworks '(compiler::*optimization-level*) #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*) #+sbcl '(sb-c::*policy*))) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) #+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*)) #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) #.`(loop #+(or allegro clozure) ,@'(:with info = #+allegro (sys:declaration-information 'optimize) #+clozure (ccl:declaration-information 'optimize nil)) :for x :in settings ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order #+clisp (gethash x system::*optimize* 1) #+(or abcl ecl mkcl xcl) (symbol-value v) #+(or cmucl scl) (slot-value c::*default-cookie* (case x (compilation-speed 'c::cspeed) (otherwise x))) #+lispworks (slot-value compiler::*optimization-level* x) #+sbcl (sb-c::policy-quality sb-c::*policy* x)) :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)))) (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body) #+(or allegro clasp clisp) (let ((previous-settings (gensym "PREVIOUS-SETTINGS")) (reset-settings (gensym "RESET-SETTINGS"))) `(let* ((,previous-settings (get-optimization-settings)) (,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings)) ,@(when settings `((proclaim `(optimize ,@,settings)))) (unwind-protect (progn ,@body) (proclaim `(optimize ,@,reset-settings))))) #-(or allegro clasp clisp) `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v)) ,@(when settings `((proclaim `(optimize ,@,settings)))) ,@body))) ;;; 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) #+cmucl '("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-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 #+sbcl (let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil))) (when condition (list condition))) '("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 cmucl 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) ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we ;; handle deferred warnings must change... TODO: when enough time has ;; gone by, just assume all versions of SBCL are adequately ;; up-to-date, and cut this material.[2018/05/30:rpg] (mapcar #'(lambda (frob) ;; the lexenv slot can be ignored for reporting purposes `( #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) ,@`(: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)) #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) ,@ `(:%enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) :%source ,(sb-c::compiler-error-context-source frob) :original-form ,(sb-c::compiler-error-context-original-form 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 cmucl 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 cmucl 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 cmucl 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 () (let ((*read-eval* t)) (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 containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS, re-intern and raise any warnings that are still meaningful." (let ((file-errors nil) (failure-p nil) (warnings-p nil)) (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 (with-safe-io-syntax () (let ((*read-eval* t)) (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 &key source-namestring) "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK and save those warnings to the given file for latter use, possibly in a different process. Otherwise just call THUNK." (declare (ignorable source-namestring)) (if warnings-file (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring) (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 &key source-namestring) &body body) "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring))) ;;; from ASDF (with-upgradability () (defun current-lisp-file-pathname () "Portably return the PATHNAME of the current Lisp source file being compiled or loaded" (or *compile-file-pathname* *load-pathname*)) (defun load-pathname () "Portably return the LOAD-PATHNAME of the current source file or fasl. May return a relative pathname." *load-pathname*) ;; magic no longer needed for GCL. (defun lispize-pathname (input-file) "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" (make-pathname :type "lisp" :defaults input-file)) (defun compile-file-type (&rest keys) "pathname TYPE for lisp FASt Loading files" (declare (ignorable keys)) #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) #+(or clasp 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 `(#+(or (and allegro (not (version>= 8 2)))) :external-format ,@(unless output-file '(:output-file))) keys))) (if (absolute-pathname-p output-file) ;; what cfp should be doing, w/ mp* instead of mp (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))))) (defvar *compile-check* nil "A hook for user-defined compile-time invariants") (defun* (compile-file*) (input-file &rest keys &key (compile-check *compile-check*) output-file warnings-file #+clisp lib-file #+(or clasp 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. It also checks an optional user-provided consistency function COMPILE-CHECK to determine success; 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, it will consider that 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." #+(or clasp 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 clasp ecl mkcl) :object-file) keys)) (output-file (or output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))) (physical-output-file (physicalize-pathname output-file)) #+(or clasp ecl) (object-file (unless (use-ecl-byte-compiler-p) (or object-file #+ecl (compile-file-pathname output-file :type :object) #+clasp (compile-file-pathname output-file :output-type :object)))) #+mkcl (object-file (or object-file (compile-file-pathname output-file :fasl-p nil))) (tmp-file (tmpize-pathname physical-output-file)) #+clasp (tmp-object-file (compile-file-pathname tmp-file :output-type :object)) #+sbcl (cfasl-file (etypecase emit-cfasl (null nil) ((eql t) (make-pathname :type "cfasl" :defaults physical-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-enough-pathname (input-file :defaults *base-build-directory*) (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) (with-muffled-compiler-conditions () (or #-(or clasp ecl mkcl) (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) (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))) #+clasp (apply 'compile-file input-file :output-file (if object-file (list* tmp-object-file :output-type :object #|: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 clasp ecl mkcl) (when (and #+(or clasp ecl) object-file) (setf output-truename (compiler::build-fasl tmp-file #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file)))) (or (not compile-check) (apply compile-check input-file :output-file output-truename keywords)))) (delete-file-if-exists physical-output-file) (when output-truename ;; see CLISP bug 677 #+clisp (progn (setf tmp-lib (make-pathname :type "lib" :defaults output-truename)) (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file))) (rename-file-overwriting-target tmp-lib lib-file)) #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) #+clasp (progn ;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now #+:target-os-darwin (let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf"))) (target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf")))) (when (probe-file temp-dwarf) (rename-file-overwriting-target temp-dwarf target-dwarf))) ;;; need to rename the bc or ll file as well or test-bundle.script fails ;;; They might not exist with parallel compilation (let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode)) (bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode))) (when (probe-file bitcode-src) (rename-file-overwriting-target bitcode-src bitcode-target))) (rename-file-overwriting-target tmp-object-file object-file)) (rename-file-overwriting-target output-truename physical-output-file) (setf output-truename (truename physical-output-file))) #+clasp (delete-file-if-exists tmp-file) #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677 (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup (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." (with-muffled-loader-conditions () (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) (etypecase x ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) (apply 'load x keys)) ;; Genera can't load from a string-input-stream ;; ClozureCL 1.6 can only load from file input stream ;; Allegro 5, I don't remember but it must have been broken when I tested. #+(or allegro clozure genera) (stream ;; make do this way (let ((*package* *package*) (*readtable* *readtable*) (*load-pathname* nil) (*load-truename* nil)) (eval-input x))))))) (defun load-from-string (string) "Portably read and evaluate forms from a STRING." (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 cmucl lispworks sbcl scl xcl) (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output) #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 #+(or allegro clisp cmucl 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 :force t)) (loop :for f :in fasls :do (ignore-errors (delete-file f))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) asdf-3.3.4/uiop/os.lisp000066400000000000000000000432621362155115300147350ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Access to the Operating System (uiop/package:define-package :uiop/os (: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 #:os-cond #: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 (parameter-error "~S: malformed feature specification ~S" 'featurep x)))) ;; Starting with UIOP 3.1.5, these are runtime tests. ;; You may bind *features* with a copy of what your target system offers to test its properties. (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. (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos)))) (defun os-unix-p () "Is the underlying operating system some Unix variant?" (or (featurep '(:or :unix :cygwin)) (os-macosx-p))) (defun os-windows-p () "Is the underlying operating system Microsoft Windows?" (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64)))) (defun os-genera-p () "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" (featurep :genera)) (defun os-oldmac-p () "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" (featurep :mcl)) (defun os-haiku-p () "Is the underlying operating system Haiku?" (featurep :haiku)) (defun os-mezzano-p () "Is the underlying operating system Mezzano?" (featurep :mezzano)) (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-macosx . os-macosx-p) (:os-windows . os-windows-p) (:genera . os-genera-p) (:os-oldmac . os-oldmac-p) (:haiku . os-haiku-p) (:mezzano . os-mezzano-p)) :when (and (or (not o) (eq feature :os-macosx)) (funcall detect)) :do (setf o feature) (pushnew feature *features*) :else :do (setf *features* (remove feature *features*)) :finally (return (or o (error "Congratulations for trying ASDF on an operating system~%~ that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) (defmacro os-cond (&rest clauses) #+abcl `(cond ,@clauses) #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body))) (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 clasp clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+cmucl (unix:unix-getenv x) #+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) #+(or genera mezzano) 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 clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) (not-implemented-error 'getenv)) (defsetf getenv (x) (val) "Set an environment variable." (declare (ignorable x val)) #+allegro `(setf (sys:getenv ,x) ,val) #+clasp `(ext:setenv ,x ,val) #+clisp `(system::setenv ,x ,val) #+clozure `(ccl:setenv ,x ,val) #+cmucl `(unix:unix-setenv ,x ,val 1) #+(or ecl clasp) `(ext:setenv ,x ,val) #+lispworks `(setf (lispworks:environment-variable ,x) ,val) #+mkcl `(mkcl:setenv ,x ,val) #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) '(not-implemented-error '(setf 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) :clasp :ecl :gcl (:lwpe :lispworks-personal-edition) (:lw :lispworks) :mcl :mezzano :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 :dragonfly) :unix :genera :mezzano))) (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)) #+cmucl (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))) (unless (equal vcs-id "UNKNOWN") (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 " #+mezzano (format nil "~A-~D" (subseq s 0 (position #\space s)) ; strip commit hash sys.int::*llf-version*) ;; seems like there should be a shorter way to do this, like ACALL. #+mkcl (or (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) (when (and fname (fboundp fname)) (funcall fname))) s) 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)) (lisp-version-string) (or (operating-system) (software-type)) (or (architecture) (machine-type)))))) ;;;; Other system information (with-upgradability () (defun hostname () "return the hostname of the current host" #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano 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 () #+cmucl (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 #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical! #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) #+(or cmucl scl) (#+cmucl 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? #+(or clasp ecl) (ext:getcwd) #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) #+lispworks (hcl:get-working-directory) #+mkcl (mk-ext:getcwd) #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) #+xcl (extensions:current-directory) (not-implemented-error 'getcwd))) (defun chdir (x) "Change current directory, as per POSIX chdir(2), to a given pathname object" (if-let (x (pathname x)) #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical! #+allegro (excl:chdir x) #+clisp (ext:cd x) #+clozure (setf (ccl:current-directory) x) #+(or cmucl 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) #+clasp (ext:chdir x t) #+gcl (system:chdir x) #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) (not-implemented-error 'chdir)))) ;;;; ----------------------------------------------------------------- ;;;; 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))))) asdf-3.3.4/uiop/package.lisp000066400000000000000000001112521362155115300157020ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; 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; unlike 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 (list (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 (copy-list 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 (t t t &optional t) t) ensure-exported)) (defun ensure-exported-to-user (name symbol to-package &optional recycle) (check-type name string) (check-type symbol symbol) (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) #+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)) #-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 :use-reexport) :append args :into use :and :append args :into reexport :and :do (setf use-p t) :else :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport :and :do (setf use-p t) :else :when (eq kw :unintern) :append args :into unintern :else :do (error "unrecognized define-package keyword ~S" kw) :finally (return `(',package :nicknames ',nicknames :documentation ',documentation :use ',(if use-p use '(:common-lisp)) :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 :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 `(prog1 (funcall 'ensure-package ,@(parse-define-package-form package clauses)) #+sbcl (setf (sb-impl::package-source-location (find-package ',package)) (sb-c:source-location))))) `(progn #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form)))) asdf-3.3.4/uiop/pathname.lisp000066400000000000000000001117601362155115300161100ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; 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) ;; deprecated. Used by ceramic (: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 #: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-file-for-directory* #:*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." (cond #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) #+gcl ((consp directory) (cons :relative directory)) (t (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>") 'normalize-pathname-directory-component 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" directory-component) (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 cmucl lispworks sbcl scl) :unspecific #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") (defun make-pathname* (&rest keys &key directory host device 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. DEPRECATED: just use MAKE-PATHNAME." (declare (ignore host device directory name type version defaults)) (apply 'make-pathname 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 (or #+(and mkcl os-unix) :unspecific) :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost") #+scl ,@'(:scheme nil :scheme-specific-part nil :username nil :password nil :parameters nil :query nil :fragment nil) ;; the default shouldn't matter, but we really want something physical #-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* is as specified, where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory." `(let ((*default-pathname-defaults* ,(or defaults #-(or abcl genera xcl) '*nil-pathname* #+(or abcl genera xcl) '*default-pathname-defaults*))) ,@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) #-(and mkcl os-unix) (=? pathname-device) (=? normalize-pathname-directory-component pathname-directory) (=? pathname-name) (=? pathname-type) #-mkcl (=? 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))) (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) (member (pathname-type pathname) '(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 ;; I tried using Allegro's excl:file-directory-p, but this cannot be done, ;; because it rejects apparently legal pathnames as ;; ill-formed. [2014/02/10:rpg] (let ((pathname (pathname pathname))) (flet ((check-one (x) (member x '(nil :unspecific) :test 'equal))) (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 (handler-case (make-pathname :directory (append (or (normalize-pathname-directory-component (pathname-directory pathspec)) (list :relative)) (list #-genera (file-namestring pathspec) ;; On Genera's native filesystem (LMFS), ;; directories have a type and version ;; which must be ignored when converting ;; to a directory pathname #+genera (if (typep pathspec 'fs:lmfs-pathname) (pathname-name pathspec) (file-namestring pathspec)))) :name nil :type nil :version nil :defaults pathspec) (error (c) (call-function on-error (compatfmt "~@") pathspec c))))))) ;;; Parsing filenames (with-upgradability () (declaim (ftype function ensure-pathname)) ; forward reference (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 colon 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 reliably usable only for relative pathnames. This function is especially useful to manipulate relative pathnames portably, where 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 or 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 () (parameter-error "~S: invalid unix-namestring ~S" 'unix-namestring pathname))) (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) (name (pathname-name pathname)) (name (and (not (eq name :unspecific)) name)) (type (pathname-type pathname)) (type (and (not (eq type :unspecific)) type))) (cond ((member dir '(nil :unspecific))) ((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 (unless (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 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)))) (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 (*nil-pathname*) (let ((enough (enough-namestring maybe-subpath base-pathname))) (and (relative-pathname-p enough) (pathname enough)))))) (defun enough-pathname (maybe-subpath base-pathname) "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." (let ((sub (when maybe-subpath (pathname maybe-subpath))) (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) (or (and base (subpathp sub base)) sub))) (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH given DEFAULTS-PATHNAME as a base pathname." (let ((enough (enough-pathname maybe-subpath defaults-pathname)) (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) (funcall thunk enough))) (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) (defaults *default-pathname-defaults*)) &body body) "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))) ;;; Wildcard pathnames (with-upgradability () (defparameter *wild* (or #+cormanlisp "*" :wild) "Wild component for use with MAKE-PATHNAME") (defparameter *wild-directory-component* (or :wild) "Wild directory component for use with MAKE-PATHNAME") (defparameter *wild-inferiors-component* (or :wild-inferiors) "Wild-inferiors directory component for use with MAKE-PATHNAME") (defparameter *wild-file* (make-pathname :directory nil :name *wild* :type *wild* :version (or #-(or allegro abcl xcl) *wild*)) "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME") (defparameter *wild-file-for-directory* (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*) :version (or #-(or allegro abcl clisp gcl xcl) *wild*)) "A pathname object with wildcards for matching any file with 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." (os-cond ((os-unix-p) (when (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)) (parameter-error "~S: Invalid destination" 'translate-pathname*)) ((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.")) asdf-3.3.4/uiop/run-program.lisp000066400000000000000000000735011362155115300165640ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. (uiop/package:define-package :uiop/run-program (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program) (:export #:run-program #:slurp-input-stream #:vomit-output-stream #:subprocess-error #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process) (:import-from :uiop/launch-program #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep #:input-stream #:output-stream #:error-output-stream)) (in-package :uiop/run-program) ;;;; 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.")) #-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))) #-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) (slurp-stream-string stream :stripped stripped)) (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) (slurp-stream-string stream :stripped stripped)) (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) (slurp-stream-lines stream :count count)) (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) (slurp-stream-line stream :at at)) (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) (slurp-stream-forms stream :count count)) (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) (slurp-stream-form stream :at at)) (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) (apply 'slurp-input-stream *standard-output* stream keys)) (defmethod slurp-input-stream ((x null) (stream t) &key) nil) (defmethod slurp-input-stream ((pathname pathname) input &key (element-type *default-stream-element-type*) (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 #+genera ((functionp x) (funcall x stream)) #+genera ((output-stream-p x) (copy-stream-to-stream stream x :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (t (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x))))) ;;;; Vomiting a stream, typically into the input of another program. (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.")) #-genera (defmethod vomit-output-stream ((function function) output-stream &key) (funcall function output-stream)) (defmethod vomit-output-stream ((list cons) output-stream &key) (apply (first list) output-stream (rest list))) #-genera (defmethod vomit-output-stream ((input-stream stream) output-stream &key linewise prefix (element-type 'character) buffer-size) (copy-stream-to-stream input-stream output-stream :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (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) (apply 'vomit-output-stream *standard-input* stream keys)) (defmethod vomit-output-stream ((x null) (stream t) &key) (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 #+genera ((functionp x) (funcall x stream)) #+genera ((input-stream-p x) (copy-stream-to-stream x stream :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (t (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x))))) ;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output. (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~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]" (subprocess-error-process condition) (subprocess-error-command condition) (subprocess-error-code condition))))) (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 %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 cmucl (and sbcl os-unix) scl) (or stream (eql t)) #+lispworks file-stream)))) (defun %run-program (command &rest keys &key &allow-other-keys) "DEPRECATED. Use LAUNCH-PROGRAM instead." (apply 'launch-program command keys)) (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner &key (element-type #-clozure *default-stream-element-type* #+clozure 'character) (external-format *utf-8-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) (parameter-error "~S does not allow ~S as a ~S spec" 'run-program :output 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 cmucl (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-launch-program (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) (progn command keys input output error-output ignore-error-status ;; ignore (not-implemented-error '%use-launch-program)) (when (member :stream (list input output error-output)) (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" 'run-program :stream)) (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))) output-result error-output-result exit-code process-info) (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)) (setf process-info (apply 'launch-program command :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 (slot-value process-info stream-name) (when fallbackp (slot-value 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))) (close-streams process-info) (setf exit-code (wait-process process-info))))))) (%check-result exit-code :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 (os-cond ((os-unix-p) (cons "exec" command)) (t command)))))) (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM (flet ((redirect (spec operator) (let ((pathname (typecase spec (null (null-device-pathname)) (string (parse-native-namestring spec)) (pathname spec) ((eql :output) (unless (equal operator " 2>>") (parameter-error "~S: only the ~S argument can be ~S" 'run-program :error-output :output)) (return-from redirect '(" 2>&1")))))) (when pathname (list operator " " (escape-shell-token (native-namestring pathname))))))) (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>"))) (normalized (%normalize-system-command command)) (directory (or directory #+(or abcl xcl) (getcwd))) (chdir (when directory (let ((dir-arg (escape-shell-token (native-namestring directory)))) (os-cond ((os-unix-p) `("cd " ,dir-arg " ; ")) ((os-windows-p) `("cd /d " ,dir-arg " & "))))))) (reduce/strcat (os-cond ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized)) ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")"))))))) (defun %system (command &rest keys &key directory input (if-input-does-not-exist :error) output (if-output-exists :supersede) error-output (if-error-output-exists :supersede) &allow-other-keys) "A portable abstraction of a low-level call to libc's system()." (declare (ignorable keys directory input if-input-does-not-exist output if-output-exists error-output if-error-output-exists)) (when (member :stream (list input output error-output)) (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" 'run-program :stream)) #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) (let (#+(or abcl ecl mkcl) (version (parse-version #-abcl (lisp-implementation-version) #+abcl (second (split-string (implementation-identifier) :separator '(#\-)))))) (nest #+abcl (unless (lexicographic< '< version '(1 4 0))) #+ecl (unless (lexicographic<= '< version '(16 0 0))) #+mkcl (unless (lexicographic<= '< version '(1 1 9))) (return-from %system (wait-process (apply 'launch-program (%normalize-system-command command) keys))))) #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) ;; see comments for these functions (%handle-if-does-not-exist input if-input-does-not-exist) (%handle-if-exists output if-output-exists) (%handle-if-exists error-output if-error-output-exists) #+abcl (ext:run-shell-command %command) #+(or clasp ecl) (let ((*standard-input* *stdin*) (*standard-output* *stdout*) (*error-output* *stderr*)) (ext:system %command)) #+clisp (let ((raw-exit-code (or #.`(#+os-windows ,@'(ext:run-shell-command %command) #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command)) :wait t :input :terminal :output :terminal) 0))) (if (minusp raw-exit-code) (- 128 raw-exit-code) raw-exit-code)) #+cormanlisp (win32:system %command) #+gcl (system:system %command) #+genera (not-implemented-error '%system) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) #+mkcl (mkcl:system %command) #+xcl (system:%run-shell-command %command))) (defun %use-system (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using %system (let (output-result error-output-result exit-code) (with-program-output ((reduced-output) output :keys keys :setf output-result) (with-program-error-output ((reduced-error-output) error-output :keys keys :setf error-output-result) (with-program-input ((reduced-input) input :keys keys) (setf exit-code (apply '%system command :input reduced-input :output reduced-output :error-output reduced-error-output keys))))) (%check-result exit-code :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 nil force-shell-suppliedp) input (if-input-does-not-exist :error) output (if-output-exists :supersede) error-output (if-error-output-exists :supersede) (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); _synchronously_ process its output as specified and return the processing results when the program and its output processing are complete. Always call a shell (rather than directly execute the command when possible) if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is specified to be NIL. 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 (the default) designating the null device, the file at that path is used as output. If it's :INTERACTIVE, output is inherited from the current process; beware that this may be different from your *STANDARD-OUTPUT*, and under SLIME will be on your *inferior-lisp* buffer. If it's T, output goes to your current *STANDARD-OUTPUT* stream. Otherwise, OUTPUT should be a value that is a suitable first argument to SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. In this case, RUN-PROGRAM will create a temporary stream for the program output; the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). The primary value resulting from that call (or NIL if no call was needed) will be the first value returned by RUN-PROGRAM. E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string stripped of any ending newline. IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the default). The meaning of these values and their effect on the case where OUTPUT does not exist, is analogous to the IF-EXISTS parameter to OPEN with :DIRECTION :OUTPUT. ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. Also :OUTPUT means redirecting the error output to the output stream, in which case NIL is returned. IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it affects ERROR-OUTPUT rather than OUTPUT. INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, no value is returned, and T designates the *STANDARD-INPUT*. IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string or a pathname, can take the values :CREATE and :ERROR (the default). The meaning of these values is analogous to the IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp implementation, when applicable, for creation of the output stream. One and only one of the stream slurping or vomiting may or may not happen in parallel in parallel with the subprocess, depending on options and implementation, and with priority being given to output processing. Other streams are completely produced or consumed before or after the subprocess is spawned, using temporary files. RUN-PROGRAM returns 3 values: 0- the result of the OUTPUT slurping if any, or NIL 1- the result of the ERROR-OUTPUT slurping if any, or NIL 2- either 0 if the subprocess exited with success status, or an indication of failure via the EXIT-CODE of the process" (declare (ignorable input output error-output if-input-does-not-exist if-output-exists if-error-output-exists element-type external-format ignore-error-status)) #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) (not-implemented-error 'run-program) (apply (if (or force-shell ;; Per doc string, set FORCE-SHELL to T if we get command as a string. ;; But don't override user's specified preference. [2015/06/29:rpg] (and (stringp command) (or (not force-shell-suppliedp) #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t)))) #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program #+ecl #.(if-let (ver (parse-version (lisp-implementation-version))) (lexicographic<= '< ver '(16 0 0))) #+(and lispworks os-unix) (%interactivep input output error-output)) '%use-system '%use-launch-program) command keys))) asdf-3.3.4/uiop/stream.lisp000066400000000000000000001040141362155115300156000ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams (uiop/package:define-package :uiop/stream (: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 #:input-string #: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 #:file-stream-p #:file-or-synonym-stream-p ;; 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 cmucl 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 cmucl scl) 'system:*stdin* #+(or clasp 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 cmucl scl) 'system:*stdout* #+(or clasp 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 cmucl scl) 'system:*stderr* #+(or clasp 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 helpers (with-upgradability () (defun call-with-output-file (pathname thunk &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :error) (if-does-not-exist :create)) "Open FILE for input with given recognizes options, call THUNK with the resulting stream. Other keys are accepted but discarded." (with-open-file (s pathname :direction :output :element-type element-type :external-format external-format :if-exists if-exists :if-does-not-exist if-does-not-exist) (funcall thunk s))) (defmacro with-output-file ((var pathname &rest keys &key element-type external-format if-exists if-does-not-exist) &body body) (declare (ignore element-type external-format if-exists if-does-not-exist)) `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)) (defun call-with-output (output function &key keys) "Calls FUNCTION with an actual stream argument, behaving like FORMAT with respect to how stream designators are interpreted: If OUTPUT is a STREAM, use it as the stream. If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream. If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE -- this latter as an extension since ASDF 3.1. Otherwise, signal an error." (etypecase output (null (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))) (pathname (apply 'call-with-output-file output function keys)))) (defmacro with-output ((output-var &optional (value output-var)) &body body) "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR) 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-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." (with-open-file (s pathname :direction :input :element-type element-type :external-format 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-input (input function &key keys) "Calls FUNCTION with an actual stream argument, interpreting stream designators like READ, but also coercing strings to STRING-INPUT-STREAM, and PATHNAME to FILE-STREAM. If INPUT is a STREAM, use it as the stream. If INPUT is NIL, use a *STANDARD-INPUT* as the stream. If INPUT is T, use *TERMINAL-IO* as the stream. If INPUT is a STRING, use it as a string-input-stream. If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE -- the latter is an extension since ASDF 3.1. Otherwise, signal an error." (etypecase input (null (funcall function *standard-input*)) ((eql t) (funcall function *terminal-io*)) (stream (funcall function input)) (string (with-input-from-string (stream input) (funcall function stream))) (pathname (apply 'call-with-input-file input function keys)))) (defmacro with-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 input-string (&optional input) "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string and return that" (if (stringp input) input (with-input (input) (funcall 'slurp-stream-string input))))) ;;; 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" (os-cond ((os-unix-p) #p"/dev/null") ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? (t (error "No /dev/null on your OS")))) (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist) "Call FUN with an input stream from the null device; pass keyword arguments to OPEN." (declare (ignore element-type external-format if-does-not-exist)) (apply 'call-with-input-file (null-device-pathname) fun keys)) (defmacro with-null-input ((var &rest keys &key element-type external-format if-does-not-exist) &body body) (declare (ignore element-type external-format if-does-not-exist)) "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device. Pass keyword arguments to OPEN." `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) (defun call-with-null-output (fun &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :overwrite) (if-does-not-exist :error)) "Call FUN with an output stream to the null device; pass keyword arguments to OPEN." (call-with-output-file (null-device-pathname) fun :element-type element-type :external-format external-format :if-exists if-exists :if-does-not-exist if-does-not-exist)) (defmacro with-null-output ((var &rest keys &key element-type external-format if-does-not-exist if-exists) &body body) "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device. Pass keyword arguments to OPEN." (declare (ignore element-type external-format if-exists if-does-not-exist)) `(call-with-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) :with 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) #+allegro (excl.osi:copy-file input output) #+ecl (ext:copy-file input output) #-(or allegro ecl) (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. 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" (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 (values-list 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) (finish-output stream) (values)) (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) "Variant of WRITE that also calls TERPRI afterwards" (apply 'write x keys) (terpri stream) (finish-output stream) (values))) ;;; Using temporary files (with-upgradability () (defun default-temporary-directory () "Return a default directory to use for temporary files" (os-cond ((os-unix-p) (or (getenv-pathname "TMPDIR" :ensure-directory t) (parse-native-namestring "/tmp/"))) ((os-windows-p) (getenv-pathname "TEMP" :ensure-directory t)) (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)) #+gcl (setf system::*tmp-dir* *temporary-directory*)) (defun call-with-temporary-file (thunk &key (want-stream-p t) (want-pathname-p t) (direction :io) keep after directory (type "tmp" typep) prefix (suffix (when typep "-tmp")) (element-type *default-stream-element-type*) (external-format *utf-8-external-format*)) "Call a THUNK with stream and/or pathname arguments identifying a temporary file. The temporary file's pathname will be based on concatenating PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string, and optional SUFFIX (defaults to \"-tmp\" if a type was provided) and TYPE (defaults to \"tmp\", using a dot as separator if not NIL), within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute. The file will be open with specified DIRECTION (defaults to :IO), ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), and stream will be closed after the THUNK exits (either normally or abnormally). If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned. Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true." #+xcl (declare (ignorable typep)) (check-type direction (member :output :io)) (assert (or want-stream-p want-pathname-p)) (loop :with prefix-pn = (ensure-absolute-pathname (or prefix "tmp") (or (ensure-pathname directory :namestring :native :ensure-directory t :ensure-physical t) #'temporary-directory)) :with prefix-nns = (native-namestring prefix-pn) :with results = (progn (ensure-directories-exist prefix-pn) ()) :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) :for pathname = (parse-native-namestring (format nil "~A~36R~@[~A~]~@[.~A~]" prefix-nns counter suffix (unless (eq type :unspecific) type))) :for okp = nil :do ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL ;; TODO: on Unix, use CFFI and mkstemp -- ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. ;; Can we at least design some hook? (unwind-protect (progn (ensure-directories-exist pathname) (with-open-file (stream pathname :direction direction :element-type element-type :external-format external-format :if-exists nil :if-does-not-exist :create) (when stream (setf okp pathname) (when want-stream-p ;; Note: can't return directly from within with-open-file ;; or the non-local return causes the file creation to be undone. (setf results (multiple-value-list (if want-pathname-p (funcall thunk stream pathname) (funcall thunk stream))))))) (cond ((not okp) nil) (after (return (call-function after okp))) ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp))) (t (return (values-list results))))) (when (and okp (not (call-function keep))) (ignore-errors (delete-file-if-exists okp)))))) (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) (pathname (gensym "PATHNAME") pathnamep) directory prefix suffix type 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. At least one of STREAM or PATHNAME must be specified. If the STREAM is not specified, it will be closed before the BODY is evaluated. If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY, separates forms run before and after the stream is closed. The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned. Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE." (check-type stream symbol) (check-type pathname symbol) (assert (or streamp pathnamep)) (let* ((afterp (position :close-stream body)) (before (if afterp (subseq body 0 afterp) body)) (after (when afterp (subseq body (1+ afterp)))) (beforef (gensym "BEFORE")) (afterf (gensym "AFTER"))) `(flet (,@(when before `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@(when after `((declare (ignorable ,pathname)))) ,@before))) ,@(when after (assert pathnamep) `((,afterf (,pathname) ,@after)))) #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf)))) (call-with-temporary-file ,(when before `#',beforef) :want-stream-p ,streamp :want-pathname-p ,pathnamep ,@(when direction `(:direction ,direction)) ,@(when directory `(:directory ,directory)) ,@(when prefix `(:prefix ,prefix)) ,@(when suffix `(:suffix ,suffix)) ,@(when type `(:type ,type)) ,@(when keep `(:keep ,keep)) ,@(when after `(:after #',afterf)) ,@(when element-type `(:element-type ,element-type)) ,@(when external-format `(:external-format ,external-format)))))) (defun get-temporary-file (&key directory prefix suffix type) (with-temporary-file (:pathname pn :keep t :directory directory :prefix prefix :suffix suffix :type type) pn)) ;; Temporary pathnames in simple cases where no contention is assumed (defun add-pathname-suffix (pathname suffix &rest keys) "Add a SUFFIX to the name of a PATHNAME, return a new pathname. Further KEYS can be passed to MAKE-PATHNAME." (apply 'make-pathname :name (strcat (pathname-name pathname) suffix) :defaults pathname keys)) (defun tmpize-pathname (x) "Return a new pathname modified from X by adding a trivial random suffix. A new empty file with said temporary pathname is created, to ensure there is no clash with any concurrent process attempting the same thing." (let* ((px (ensure-pathname x :ensure-physical t)) (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) (directory (pathname-directory-pathname px))) (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)))) (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. NB: this protects only against failure of the program, not against concurrent attempts. For the latter case, we ought pick a random suffix and atomically open it." (let* ((pathname (pathname pathname)) (staging (tmpize-pathname pathname))) (unwind-protect (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) "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) (with-upgradability () (defun file-stream-p (stream) (typep stream 'file-stream)) (defun file-or-synonym-stream-p (stream) (or (file-stream-p stream) (and (typep stream 'synonym-stream) (file-or-synonym-stream-p (symbol-value (synonym-stream-symbol stream))))))) asdf-3.3.4/uiop/uiop.asd000066400000000000000000000045601362155115300150660ustar00rootroot00000000000000;;; -*- mode: lisp -*- (in-package :asdf) #-asdf3 (unless (or #+asdf2 (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 #+cmucl kernel:simple-style-warning #-(or allegro clozure cmucl) warning) #'muffle-warning)) (funcall thunk))) (defsystem "uiop" #+asdf3 :long-name #+asdf3 "Utilities for Implementation- and OS- Portability" :description "Portability library for Common Lisp programs" :long-description "UIOP provides runtime support for Common Lisp programs: Basic general-purpose utilities that are in such a need that you can't portably construct a complete program without using some of them. UIOP replaces ASDF/DRIVER and ASDF-UTILS, and offers a superset of the functionality provided by CL-FAD, EXTERNAL-PROGRAM, TRIVIAL-SHELL, TRIVIAL-BACKTRACE and a lot of the functionality formerly provided by CL-LAUNCH, XCVB-DRIVER, TRIVIAL-FEATURES, plus a tiny subset of functionality from ALEXANDRIA and FARE-UTILS. It is transcluded into asdf.lisp together with ASDF/DEFSYSTEM, so if you did (require \"asdf\") you already have a matching UIOP loaded." :author "Francois-Rene Rideau" :licence "MIT" :components ((:static-file "contrib/debug.lisp") (:file "package") (:file "common-lisp" :depends-on ("package")) (:file "utility" :depends-on ("common-lisp")) (:file "version" :depends-on ("utility")) (: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 "lisp-build" :depends-on ("image")) (:file "launch-program" :depends-on ("stream")) (:file "run-program" :depends-on ("launch-program" "version")) (:file "configuration" :depends-on ("image")) (:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration" "version")) (:file "driver" :depends-on ("backward-driver"))) . #-asdf3 () #+asdf3 (:encoding :utf-8 :around-compile call-without-redefinition-warnings . #-asdf3.1 () #+asdf3.1 (:class package-system :version (:read-file-form "version.lisp" :at (2 2 2))))) asdf-3.3.4/uiop/utility.lisp000066400000000000000000000734031362155115300160170ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF (uiop/package:define-package :uiop/utility (: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 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt #+(or clasp 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* #:with-upgradability ;; (un)defining functions in an upgrade-friendly way #:defun* #:defgeneric* #:nest #:if-let ;; basic flow control #:parse-body ;; macro definition helper #: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 #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols #:coerce-class ;; CLOS #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f #:list-to-hash-set #:ensure-gethash ;; hash-table #:ensure-function #:access-at #:access-at-count ;; functions #:call-function #:call-functions #:register-hook-function #:lexicographic< #:lexicographic<= ;; version #:simple-style-warning #:style-warn ;; simple style warnings #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions #:not-implemented-error #:parameter-error #:symbol-test-to-feature-expression #:boolean-to-feature-expression)) (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) (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 ;; 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. ,@(when supersede `((fmakunbound ',name))) ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl `((declaim (notinline ,name)))) (,',def ,name ,formals ,@rest)))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) (defmacro with-upgradability ((&optional) &body body) "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified to also declare the functions NOTINLINE and to accept a wrapping the function name specification into a list with keyword argument SUPERSEDE (which defaults to T if the name is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION to supersede any previous definition." `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(loop :for form :in body :collect (if (consp form) (destructuring-bind (car . cdr) form (case car ((defun) `(defun* ,@cdr)) ((defgeneric) `(defgeneric* ,@cdr)) (otherwise form))) form))))) ;;; Magic debugging help. See contrib/debug.lisp (with-upgradability () (defvar *uiop-debug-utility* '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp") "form that evaluates to the pathname to your favorite debugging utilities") (defmacro uiop-debug (&rest keys) "Load the UIOP debug utility at compile-time as well as runtime" `(eval-when (:compile-toplevel :load-toplevel :execute) (load-uiop-debug-utility ,@keys))) (defun load-uiop-debug-utility (&key package utility-file) "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*). Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)." (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 nest (&rest things) "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer (reduce #'(lambda (outer inner) `(,@outer ,inner)) things :from-end t)) (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria ;; bindings can be (var form) or ((var1 form1) ...) (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) (list bindings) bindings)) (variables (mapcar #'car binding-list))) `(let ,binding-list (if (and ,@variables) ,then-form ,else-form))))) ;;; Macro definition helper (with-upgradability () (defun parse-body (body &key documentation whole) ;; from alexandria "Parses BODY into (values remaining-forms declarations doc-string). Documentation strings are recognized only if DOCUMENTATION is true. Syntax errors in body are signalled and WHOLE is used in the signal arguments when given." (let ((doc nil) (decls nil) (current nil)) (tagbody :declarations (setf current (car body)) (when (and documentation (stringp current) (cdr body)) (if doc (error "Too many documentation strings in ~S." (or whole body)) (setf doc (pop body))) (go :declarations)) (when (and (listp current) (eql (first current) 'declare)) (push (pop body) decls) (go :declarations))) (values body (nreverse decls) doc)))) ;;; 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. ;; NB: We assume a total order on character types. ;; If that's not true... this code will need to be updated. (defparameter +character-types+ ;; assuming a simple hierarchy #.(coerce (loop* :for (type next) :on '(;; In SCL, all characters seem to be 16-bit base-char ;; Yet somehow character fails to be a subtype of base-char #-scl base-char ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER #+lispworks7+ lw:bmp-char #+lispworks lw:simple-char character) :unless (and next (subtypep next type)) :collect type) 'vector)) (defparameter +max-character-type-index+ (1- (length +character-types+))) (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+)) (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) (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 (flet ((consider (i) (cond ((= i ,+max-character-type-index+) (return i)) ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i))))))) (cond ((emptyp s)) ;; NIL or empty string ((characterp s) (consider (character-type-index s))) ((stringp s) (let ((string-type-index (character-type-index (array-element-type s)))) (unless (>= index string-type-index) (loop :for c :across s :for i = (character-type-index c) :do (consider i) ,@(when (> +max-character-type-index+ 1) `((when (= i string-type-index) (return)))))))) (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))))) (defun standard-case-symbol-name (name-designator) "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING; if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\" platform such as Allegro with modern syntax." (check-type name-designator (or string symbol)) (cond ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)) (string name-designator)) ;; Should we be doing something on CLISP? (t (string-upcase name-designator)))) (defun find-standard-case-symbol (name-designator package-designator &optional (error t)) "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR, where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings. If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." (find-symbol* (standard-case-symbol-name name-designator) (etypecase package-designator ((or package symbol) package-designator) (string (standard-case-symbol-name package-designator))) error))) ;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype timestamp () '(or real boolean))) (with-upgradability () (defun timestamp< (x y) (etypecase x ((eql t) (not (eql y t))) (real (etypecase y ((eql t) nil) (real (< x y)) (null t))) (null nil))) (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :always (timestamp< x y))) (defun timestamp*< (&rest list) (timestamps< list)) (defun timestamp<= (x y) (not (timestamp< y x))) (defun earlier-timestamp (x y) (if (timestamp< x y) x y)) (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :initial-value nil)) (defun earliest-timestamp (&rest list) (timestamps-earliest list)) (defun later-timestamp (x y) (if (timestamp< x y) y x)) (defun timestamps-latest (list) (reduce 'later-timestamp list :initial-value t)) (defun latest-timestamp (&rest list) (timestamps-latest list)) (define-modify-macro latest-timestamp-f (&rest timestamps) latest-timestamp)) ;;; 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)) (hash-table #'(lambda (x) (gethash x fun))) (symbol (fdefinition fun)) (cons (if (eq 'lambda (car fun)) (eval fun) #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) (string (eval `(function ,(with-standard-io-syntax (let ((*package* (find-package package))) (read-from-string fun)))))))) (defun access-at (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)))) ;;; CLOS (with-upgradability () (defun coerce-class (class &key (package :cl) (super t) (error 'error)) "Coerce CLASS to a class that is subclass of SUPER if specified, or invoke ERROR handler as per CALL-FUNCTION. A keyword designates the name a symbol, which when found in either PACKAGE, designates a class. -- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. A string is read as a symbol while in PACKAGE, the symbol designates a class. A class object designates itself. NIL designates itself (no class). A symbol otherwise designates a class by name." (let* ((normalized (typecase class (keyword (or (find-symbol* class package nil) (find-symbol* class *package* nil))) (string (symbol-call :uiop :safe-read-from-string class :package package)) (t class))) (found (etypecase normalized ((or standard-class built-in-class) normalized) ((or null keyword) nil) (symbol (find-class normalized nil nil)))) (super-class (etypecase super ((or standard-class built-in-class) super) ((or null keyword) nil) (symbol (find-class super nil nil))))) #+allegro (when found (mop:finalize-inheritance found)) (or (and found (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class)) found) (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super))))) ;;; Hash-tables (with-upgradability () (defun ensure-gethash (key table default) "Lookup the TABLE for a KEY as by GETHASH, but if not present, call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, set the corresponding entry to the result in the table. Return two values: the entry after its optional computation, and whether it was found" (multiple-value-bind (value foundp) (gethash key table) (values (if foundp value (setf (gethash key table) (call-function default))) foundp))) (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) "Convert a LIST into hash-table that has the same elements when viewed as a set, up to the given equality TEST" (dolist (x list h) (setf (gethash x h) t)))) ;;; Lexicographic comparison of lists of numbers (with-upgradability () (defun lexicographic< (element< x y) "Lexicographically compare two lists of using the function element< to compare elements. element< is a strict total order; the resulting order on X and Y will also be strict." (cond ((null y) nil) ((null x) t) ((funcall element< (car x) (car y)) t) ((funcall element< (car y) (car x)) nil) (t (lexicographic< element< (cdr x) (cdr y))))) (defun lexicographic<= (element< x y) "Lexicographically compare two lists of using the function element< to compare elements. element< is a strict total order; the resulting order on X and Y will be a non-strict total order." (not (lexicographic< element< y x)))) ;;; Simple style warnings (with-upgradability () (define-condition simple-style-warning #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning) ()) (defun style-warn (datum &rest arguments) (etypecase datum (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments))) (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments)) (style-warning (apply 'warn datum arguments))))) ;;; Condition control (with-upgradability () (defparameter +simple-condition-format-control-slot+ #+abcl 'system::format-control #+allegro 'excl::format-control #+(or clasp ecl mkcl) 'si::format-control #+clisp 'system::$format-control #+clozure 'ccl::format-control #+(or cmucl scl) 'conditions::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl 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 cmucl 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) "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) ;;; Conditions (with-upgradability () (define-condition not-implemented-error (error) ((functionality :initarg :functionality) (format-control :initarg :format-control) (format-arguments :initarg :format-arguments)) (:report (lambda (condition stream) (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]" (nth-value 1 (symbol-call :uiop :implementation-type)) (slot-value condition 'functionality) (slot-value condition 'format-control) (slot-value condition 'format-arguments))))) (defun not-implemented-error (functionality &optional format-control &rest format-arguments) "Signal an error because some FUNCTIONALITY is not implemented in the current version of the software on the current platform; it may or may not be implemented in different combinations of version of the software and of the underlying platform. Optionally, report a formatted error message." (error 'not-implemented-error :functionality functionality :format-control format-control :format-arguments format-arguments)) (define-condition parameter-error (error) ((functionality :initarg :functionality) (format-control :initarg :format-control) (format-arguments :initarg :format-arguments)) (:report (lambda (condition stream) (apply 'format stream (slot-value condition 'format-control) (slot-value condition 'functionality) (slot-value condition 'format-arguments))))) ;; Note that functionality MUST be passed as the second argument to parameter-error, just after ;; the format-control. If you want it to not appear in first position in actual message, use ;; ~* and ~:* to adjust parameter order. (defun parameter-error (format-control functionality &rest format-arguments) "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying platform does not accept a given parameter or combination of parameters. Report a formatted error message, that takes the functionality as its first argument (that can be skipped with ~*)." (error 'parameter-error :functionality functionality :format-control format-control :format-arguments format-arguments))) (with-upgradability () (defun boolean-to-feature-expression (value) "Converts a boolean VALUE to a form suitable for testing with #+." (if value '(:and) '(:or))) (defun symbol-test-to-feature-expression (name package) "Check if a symbol with a given NAME exists in PACKAGE and returns a form suitable for testing with #+." (boolean-to-feature-expression (find-symbol* name package nil)))) asdf-3.3.4/uiop/version.lisp000066400000000000000000000222471362155115300160010ustar00rootroot00000000000000(uiop/package:define-package :uiop/version (:recycle :uiop/version :uiop/utility :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export #:*uiop-version* #:parse-version #:unparse-version #:version< #:version<= ;; version support, moved from uiop/utility #:next-version #:deprecated-function-condition #:deprecated-function-name ;; deprecation control #:deprecated-function-style-warning #:deprecated-function-warning #:deprecated-function-error #:deprecated-function-should-be-deleted #:version-deprecation #:with-deprecation)) (in-package :uiop/version) (with-upgradability () (defparameter *uiop-version* "3.3.4") (defun unparse-version (version-list) "From a parsed version (a list of natural numbers), compute the version string" (format nil "~{~D~^.~}" version-list)) (defun parse-version (version-string &optional on-error) "Parse a VERSION-STRING as a series of natural numbers 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 next-version (version) "When VERSION is not nil, it is a string, then parse it as a version, compute the next version and return it as a string." (when version (let ((version-list (parse-version version))) (incf (car (last version-list))) (unparse-version version-list)))) (defun version< (version1 version2) "Given two version strings, return T if the second is strictly newer" (let ((v1 (parse-version version1 nil)) (v2 (parse-version version2 nil))) (lexicographic< '< v1 v2))) (defun version<= (version1 version2) "Given two version strings, return T if the second is newer or the same" (not (version< version2 version1)))) (with-upgradability () (define-condition deprecated-function-condition (condition) ((name :initarg :name :reader deprecated-function-name))) (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ()) (define-condition deprecated-function-warning (deprecated-function-condition warning) ()) (define-condition deprecated-function-error (deprecated-function-condition error) ()) (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ()) (defun deprecated-function-condition-kind (type) (ecase type ((deprecated-function-style-warning) :style-warning) ((deprecated-function-warning) :warning) ((deprecated-function-error) :error) ((deprecated-function-should-be-deleted) :delete))) (defmethod print-object ((c deprecated-function-condition) stream) (let ((name (deprecated-function-name c))) (cond (*print-readably* (let ((fmt "#.(make-condition '~S :name ~S)") (args (list (type-of c) name))) (if *read-eval* (apply 'format stream fmt args) (error "Can't print ~?" fmt args)))) (*print-escape* (print-unreadable-object (c stream :type t) (format stream ":name ~S" name))) (t (let ((*package* (find-package :cl)) (type (type-of c))) (format stream (if (eq type 'deprecated-function-should-be-deleted) "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete" "~A: Using deprecated function ~S -- please update your code to use a newer API.~ ~@[~%The docstring for this function says:~%~A~%~]") type name (when (symbolp name) (documentation name 'function)))))))) (defun notify-deprecated-function (status name) (ecase status ((nil) nil) ((:style-warning) (style-warn 'deprecated-function-style-warning :name name)) ((:warning) (warn 'deprecated-function-warning :name name)) ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name)))) (defun version-deprecation (version &key (style-warning nil) (warning (next-version style-warning)) (error (next-version warning)) (delete (next-version error))) "Given a VERSION string, and the starting versions for notifying the programmer of various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION that is the highest level that has a declared version older than the specified version. Each start version for a level of deprecation can be specified by a keyword argument, or if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation." (cond ((and delete (version<= delete version)) :delete) ((and error (version<= error version)) :error) ((and warning (version<= warning version)) :warning) ((and style-warning (version<= style-warning version)) :style-warning))) (defmacro with-deprecation ((level) &body definitions) "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function when it is compiled or called. Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet), :STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used), :ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while at that level). Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD from instrumentation by enclosing it in a PROGN." (let ((level (eval level))) (check-type level (member nil :style-warning :warning :error :delete)) (when (eq level :delete) (error 'deprecated-function-should-be-deleted :name (mapcar 'second (remove-if-not #'(lambda (x) (member x '(defun defmethod))) definitions :key 'first)))) (labels ((instrument (name head body whole) (if level (let ((notifiedp (intern (format nil "*~A-~A-~A-~A*" :deprecated-function level name :notified-p)))) (multiple-value-bind (remaining-forms declarations doc-string) (parse-body body :documentation t :whole whole) `(progn (defparameter ,notifiedp nil) ;; tell some implementations to use the compiler-macro (declaim (inline ,name)) (define-compiler-macro ,name (&whole form &rest args) (declare (ignore args)) (notify-deprecated-function ,level ',name) form) (,@head ,@(when doc-string (list doc-string)) ,@declarations (unless ,notifiedp (setf ,notifiedp t) (notify-deprecated-function ,level ',name)) ,@remaining-forms)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (compiler-macro-function ',name) nil)) (declaim (notinline ,name)) (,@head ,@body))))) `(progn ,@(loop :for form :in definitions :collect (cond ((and (consp form) (eq (car form) 'defun)) (instrument (second form) (subseq form 0 3) (subseq form 3) form)) ((and (consp form) (eq (car form) 'defmethod)) (let ((body-start (if (listp (third form)) 3 4))) (instrument (second form) (subseq form 0 body-start) (subseq form body-start) form))) (t form)))))))) asdf-3.3.4/upgrade.lisp000066400000000000000000000247171362155115300147730ustar00rootroot00000000000000;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 (uiop/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 #:defparameter* #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:with-asdf-deprecation #:intern*) (:import-from :uiop/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")))))) ;; This (private) variable contains a list of versions of previously loaded variants of ASDF, ;; from which ASDF was upgraded. ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly. (defvar *previous-asdf-versions* (let ((previous (asdf-version))) (when previous ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package. (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. (let ((away (format nil "~A-~A" :asdf previous))) (rename-package :asdf away) (when *load-verbose* (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))) (list previous)))) ;; This public variable will be bound shortly to the currently loaded version of ASDF. (defvar *asdf-version* nil) ;; We need to clear systems from versions older than the one in this (private) parameter. ;; The latest incompatible defclass is 2.32.13 renaming a slot in component, ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses). ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below). (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2") ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages (defvar *verbose-out* nil) ;; Private function by which ASDF outputs progress messages and warning messages: (defun asdf-message (format-string &rest format-args) (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: (defvar *post-upgrade-cleanup-hook* ()) ;; Private function to detect whether the current upgrade counts as an incompatible ;; data schema upgrade implying the need to drop data. (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) (and *previous-asdf-versions* (version< (first *previous-asdf-versions*) oldest-compatible-version))) ;; Private variant of defparameter that works in presence of incompatible upgrades: ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change), ;; but behaves like defparameter if in presence of an incompatible upgrade. (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) (let* ((name (string-trim "*" var)) (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) `(progn (defun ,valfun () ,value) (defvar ,var (,valfun) ,@(ensure-list docstring)) (when (upgrading-p ,version) (setf ,var (,valfun)))))) ;; Private macro to declare sections of code that are only compiled and run when upgrading. ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects, ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs. (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) (upgrading-p `(upgrading-p ,version)) when) &body body) "A wrapper macro for code that should only be run when upgrading a previously-loaded version of ASDF." `(with-upgradability () (when (and ,upgrading-p ,@(when when `(,when))) (handler-bind ((style-warning #'muffle-warning)) (eval '(progn ,@body)))))) ;; Only now can we safely update the version. (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 asdf.lisp. ;; "3.4" would be the general branch for major version 3, minor version 4. ;; "3.4.5" would be an official release in the 3.4 branch. ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 (asdf-version "3.3.4") (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))))) ;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined (when-upgrading () (let* ((previous-version (first *previous-asdf-versions*)) (redefined-functions ;; List of functions that changed incompatibly since 2.27: ;; gf signature changed (should NOT happen), defun that became a generic function, ;; method removed that will mess up with new ones (especially :around :before :after, ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. ;; NB: it's too late to do anything about functions in UIOP! ;; If you introduce some critical incompatibility there, you must change the function name. ;; Note that we don't need do anything about functions that changed incompatibly ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. ;; Also note that we don't include the defgeneric=>defun, because they are ;; done directly with defun* and need not trigger a punt on data. ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 `(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) (redefined-classes ;; redefining the classes causes interim circularities ;; with the old ASDF during upgrade, and many implementations bork #-clozure () #+clozure '((#:compile-concatenated-source-op (#:operation) ()) (#:compile-bundle-op (#:operation) ()) (#:concatenate-source-op (#:operation) ()) (#:dll-op (#:operation) ()) (#:lib-op (#:operation) ()) (#:monolithic-compile-bundle-op (#:operation) ()) (#:monolithic-concatenate-source-op (#:operation) ())))) (loop :for name :in redefined-functions :for sym = (find-symbol* name :asdf nil) :do (when sym (fmakunbound sym))) (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf)) (find-symbol* s p nil))) (asyms (l) (mapcar #'asym l))) (loop* :for (name superclasses slots) :in redefined-classes :for sym = (find-symbol* name :asdf nil) :when (and sym (find-class sym)) :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) ;;; Self-upgrade functions (with-upgradability () ;; This private function is called at the end of asdf/footer and ensures that, ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called. (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)) ;; In case the previous version was too old to be forward-compatible, clear systems. ;; TODO: if needed, we may have to define a separate hook to run ;; in case of forward-compatible upgrade. ;; Or to move the tests forward-compatibility test inside each hook function? (unless (version<= *oldest-forward-compatible-asdf-version* old-version) (call-functions (reverse *post-upgrade-cleanup-hook*))) t)))) (defun upgrade-asdf () "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)))) (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body) `(with-upgradability () (with-deprecation ((version-deprecation *asdf-version* ,@keys)) ,@body)))) asdf-3.3.4/user.lisp000066400000000000000000000011511362155115300143050ustar00rootroot00000000000000;;;; --------------------------------------------------------------------------- ;;;; ASDF-USER, where the action happens. (uiop/package:define-package :asdf/user (:nicknames :asdf-user) ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below. ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop. ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo. ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package ;; that only :use's :cl and :asdf (:use :uiop/common-lisp :uiop :asdf/interface)) asdf-3.3.4/version.lisp-expr000066400000000000000000000000111362155115300157620ustar00rootroot00000000000000"3.3.4"