Commit aa5cba5d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.100: checkpointing a lot of progress.

* Pathname support has been cleaned up, yet again,
 extending and renaming COERCE-PATHNAME into PARSE-UNIX-NAMESTRING,
 also ENSURE-PATHNAME, many docstrings, and plenty of small enhancements.
* Bundles were refactored to take advantage of the new, more sensible,
 component-depends-on semantics.
* Image support was cleaned up again, and program-op was implemented
 to produce a standalone executable on supported platforms;
 a working hello-world-example is included amongst tests.
* The *compile-file-function* indirection was removed, with the
 ECL and MKCL object file support
 being folded into compile-file* instead.
* systems now can have NIL as component-pathname,
 instead of providing a non-sensible bogus pathname
 when no sensible pathname was determined.
 Most of our pathname functions have sensible default behavior
 when provided NIL instead of a pathname as an argument.
parent 0af76dd1
......@@ -37,6 +37,7 @@ tmp/
*.~*~
test/try-reloading-dependency.asd
test/fileMissing.lisp
test/hello-world-example
build-stamp
debian/cl-asdf.debhelper.log
......
......@@ -4,17 +4,24 @@ webhome_public := "http://common-lisp.net/project/asdf/"
clnet_home := "/project/asdf/public_html/"
sourceDirectory := $(shell pwd)
#### Common Lisp implementations available for testing.
## export ASDF_TEST_LISPS to override the default list of such implementations,
## or specify a lisps= argument at the make command-line
ifdef ASDF_TEST_LISPS
lisps ?= ${ASDF_TEST_LISPS}
else
lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern xcl gcl
endif
## NOT SUPPORTED BY OUR AUTOMATED TESTS:
## cormancl genera lispworks-personal-edition mkcl rmcl
## Some are manually tested once in a while.
## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
## Make sure testing remains within the confines of this filesystem tree
export ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/build/fasls" :implementation)) :ignore-inherited-configuration)
export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration)
## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but upstream fails to compile.
## NOT SUPPORTED BY OUR TESTS: cormancl genera lispworks-personal-edition mkcl rmcl. Manually tested once in a while.
lisp ?= sbcl
......@@ -37,10 +44,15 @@ XCL ?= xcl
driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp driver.lisp
asdf_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
# Making ASDF itself should be our first, default, target:
build/asdf.lisp: $(wildcard *.lisp)
mkdir -p build
cat $(driver_lisp) $(asdf_lisp) > $@
# This quickly locates such mistakes as unbalanced parentheses:
load:
rlwrap sbcl `for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done`
install: archive-copy
archive:
......@@ -56,18 +68,13 @@ archive-copy: archive build/asdf.lisp
${MAKE} push
git checkout master
### Count lines separately for asdf-driver and asdf itself:
wc:
@wc $(driver_lisp) | sort -n ; echo ; \
wc $(asdf_lisp) | sort -n ; \
echo ; \
wc $(driver_lisp) $(asdf_lisp) | tail -n 1
wc-driver:
wc $(driver_lisp)
wc-asdf:
wc $(asdf_lisp)
push:
git status
git push --tags cl.net release master
......@@ -136,12 +143,12 @@ debian-package: mrproper
: $${RELEASE:="$$(git tag -l '2.[0-9][0-9]' | tail -n 1)"} ; \
git-buildpackage --git-debian-branch=release --git-upstream-branch=$$RELEASE --git-tag --git-retag --git-ignore-branch
# Replace SBCL's ASDF with the current one. -- Not recommended now that SBCL has ASDF2.
# Replace SBCL's ASDF with the current one. -- NOT recommended now that SBCL has ASDF2.
# for casual users, just use (asdf:load-system :asdf)
replace-sbcl-asdf: build/asdf.lisp
${SBCL} --eval '(compile-file "$<" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)'
# Replace CCL's ASDF with the current one. -- Not recommended now that CCL has ASDF2.
# Replace CCL's ASDF with the current one. -- NOT recommended now that CCL has ASDF2.
# for casual users, just use (asdf:load-system :asdf)
replace-ccl-asdf: build/asdf.lisp
${CCL} --eval '(progn(compile-file "$<" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))'
......@@ -150,6 +157,7 @@ WRONGFUL_TAGS := 1.37 1.1720 README RELEASE STABLE
# Delete wrongful tags from local repository
fix-local-git-tags:
for i in ${WRONGFUL_TAGS} ; do git tag -d $$i ; done
git tag 1.37 c7738c62 # restore the *correct* 1.37 tag.
# Delete wrongful tags from remote repository
fix-remote-git-tags:
......
......@@ -112,10 +112,17 @@ You can put together sentences using this phrase."))
"Translate output files, unless asked not to"
operation component ;; hush genera, not convinced by declare ignorable(!)
(values
(multiple-value-bind (files fixedp) (call-next-method)
(if fixedp
files
(mapcar *output-translation-function* files)))
(multiple-value-bind (pathnames fixedp) (call-next-method)
;; 1- Make sure we have absolute pathnames
(let* ((directory (pathname-directory-pathname (component-pathname component)))
(absolute-pathnames
(loop :for pathname :in pathnames
:collect (ensure-pathname
(subpathname directory pathname) :want-absolute t))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t))
(defmethod output-files ((o operation) (c component))
(declare (ignorable o c))
......
;;; -*- mode: lisp -*-
(defpackage :asdf-driver-system (:use :cl :asdf))
(defun call-without-redefinition-warnings (thunk)
(handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning))
(funcall thunk)))
(defsystem :asdf-driver
:licence "MIT"
......@@ -6,6 +11,8 @@
:long-description "Basic general-purpose utilities that is in such a need
that you can't portably construct a complete program without using them."
#+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr")
:defsystem-depends-on (#+(and (not asdf2.27) (or clisp xcl)) :asdf)
:around-compile call-without-redefinition-warnings
:components
((:file "header")
(:file "package")
......
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.99" ;; to be automatically updated by bin/bump-revision
:version "2.26.100" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
......@@ -10,7 +10,6 @@
#:*asdf-verbose*
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
#:merge-component-name-type
#:operation-forced
#:operation-on-failure
#:operation-on-warnings
......@@ -22,11 +21,12 @@
;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component))
(defun* merge-component-name-type (name &key type defaults)
;; For backward-compatibility only, for people using internals.
;; Will be removed in a future release, e.g. 2.016.
(warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
(coerce-pathname name :type type :defaults defaults))
(defun* coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;; Will be removed in a future release, e.g. 2.30.
(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
......@@ -71,7 +71,7 @@ if that's whay you mean." ;;)
#+(or clisp ecl mkcl)
(when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((fasl-type (fasl-type))
(let* ((fasl-type (compile-file-type))
(mapped-files (if map-all-source-files *wild-file*
(make-pathname :type fasl-type :defaults *wild-file*)))
(destination-directory
......
This diff is collapsed.
......@@ -138,10 +138,11 @@ another pathname in a degenerate way."))
pathname)))
(defmethod component-relative-pathname ((component component))
(coerce-pathname
(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)) ;; backward-compatibility
:defaults (component-parent-pathname component)))
......
......@@ -17,76 +17,59 @@
#:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
#:concatenated-source-system
#:system-concatenated-source-file
#:system-translate-output-p
#:translate-output-p #:concatenated-source-file))
#:component-concatenated-source-file
#:concatenated-source-file))
(in-package :asdf/concatenate-source)
;;;
;;; Concatenate sources
;;;
(defclass concatenate-source-op (operation) ())
(defclass load-concatenated-source-op (basic-load-op operation) ())
(defclass compile-concatenated-source-op (basic-compile-op operation) ())
(defclass load-compiled-concatenated-source-op (basic-load-op operation) ())
(defclass concatenate-source-op (bundle-op)
((bundle-type :initform "lisp")))
(defclass load-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass compile-concatenated-source-op (basic-compile-op bundle-op)
((bundle-type :initform :fasl)))
(defclass load-compiled-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
(defclass concatenated-source-system (system)
((concatenated-source-file
:initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file)
(translate-output-p
:initform t :initarg :translate-output-p :reader system-translate-output-p)))
(defmethod system-concatenated-source-file ((s system))
(declare (ignorable s))
nil)
(defmethod system-translate-output-p ((s system))
(declare (ignorable s))
t)
(defclass concatenated-source-system (bundle-system)
((bundle-pathname :initarg :concatenated-source-file)
(bundle-operation :initform :load-compiled-concatenated-source-op)))
(defmethod input-files ((o concatenate-source-op) (s system))
(loop :with op = (make-operation 'compile-op)
:with components = (gather-components op s
:include-self nil
:filter-type 'source-file
:other-systems (operation-monolithic-p o))
:with non-cl-source-files = nil
:with encoding = (or (component-encoding s) *default-encoding*)
(defmethod input-files ((operation 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 (o . c) :in components
:do (cond
((typep c 'cl-source-file)
(let ((e (component-encoding c)))
(unless (equal e encoding)
(pushnew e other-encodings :test 'equal)))
(let ((a (around-compile-hook c)))
(unless (equal a around-compile)
(pushnew a other-around-compile :test 'equal))))
(t
(push c non-cl-source-files)))
:append (input-files o c) :into inputs
:for c :in (gather-components s
:goal-operation 'compile-op
:keep-operation 'compile-op
:component-type 'component
:other-systems (operation-monolithic-p operation))
:append
(when (typep c 'cl-source-file)
(let ((e (component-encoding c)))
(unless (equal e encoding)
(pushnew e other-encodings :test 'equal)))
(let ((a (around-compile-hook c)))
(unless (equal a around-compile)
(pushnew a other-around-compile :test 'equal)))
(input-files (make-operation 'compile-op) c)) :into inputs
:finally
(when non-cl-source-files
(warn "~S depends on these non CL source files: ~A"
'concatenated-source-op non-cl-source-files))
(when other-encodings
(warn "~S uses encoding ~A but has sources that use these encodings: ~A"
'concatenated-source-op encoding other-encodings))
operation encoding other-encodings))
(when other-around-compile
(warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
'concatenated-source-op around-compile other-around-compile))
operation around-compile other-around-compile))
(return inputs)))
(defmethod output-files ((o concatenate-source-op) (s system))
(declare (ignorable o))
(let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp")))
(top (system-translate-output-p s)))
(values (list (system-relative-pathname s of)) (not top))))
(defmethod input-files ((o load-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s))
(defmethod input-files ((o compile-concatenated-source-op) (s system))
......@@ -97,6 +80,16 @@
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'compile-concatenated-source-op) s))
(defmethod input-files ((o monolithic-load-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-concatenate-source-op) s))
(defmethod input-files ((o monolithic-compile-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-concatenate-source-op) s))
(defmethod output-files ((o monolithic-compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(defmethod input-files ((o monolithic-load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-compile-concatenated-source-op) s))
(defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s))
(output (output-file o s)))
......
This diff is collapsed.
......@@ -91,32 +91,55 @@ cl-asdf (2:2.27-1) unstable; urgency=low
to manage the same effects while making every effort to
Do The Right Thing(tm) in case of hot upgrade.
* 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.
* 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.
ASDF provides initial implementations of an operation program-op
to create standalone executables (if available on your implementation).
* 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.
Several internal accessors were renamed.
Many internal accessors were renamed, after checking on Quicklisp
that no one was using them.
* Portability updates were done for
ABCL, CLISP, CMUCL, ECL, LispWorks Personal Edition, MKCL, XCL.
ABCL, CLISP, Clozure CL, CMUCL, ECL, LispWorks Personal Edition, MKCL, XCL.
Working support for GCL 2.6 was restored, with notable limitations
including lack of support for output-translations or logical-pathnames.
* Documentation received some small updates.
* Tests were updated, notably including support for asdf-bundle.
* Tests were updated, notably including support for bundles and encodings.
They were successfully run on ccl clisp sbcl ecl ecl_bytecodes
cmucl abcl scl allegro lispworks allegromodern xcl.
Manual tests were run on lispworks-personal-edition genera.
Untested were cormancl mkcl rmcl.
* POIU was updated. This extension is distributed separately from ASDF.
It is now much simplified and made more correct by construction by
* 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.
On platforms that cannot fork it will gracefully fall back
to serial compilation.
Where forking is not possible or not supported,
it will gracefully fall back to serial compilation.
* SLIME support for ASDF was significantly enhanced.
It is distributed separately from ASDF, with SLIME.
......
......@@ -9,25 +9,32 @@
:asdf/backward-internals)
#+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of)
(:export
#:defsystem #:*default-component-class*
#:class-for-type #:do-defsystem
#:determine-system-pathname #:parse-component-form
#:defsystem #:register-system-definition
#:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form
#:duplicate-names #:sysdef-error-component #:check-component-input))
(in-package :asdf/defsystem)
;;; Pathname
(defun* determine-system-pathname (pathname)
;; The defsystem macro calls us to determine
(defun* determine-system-directory (pathname)
;; The defsystem macro calls this function to determine
;; the pathname of a system as follows:
;; 1. the one supplied,
;; 2. derived from *load-pathname* via load-pathname
;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
(or (and pathname (subpathname directory-pathname pathname :type :directory))
directory-pathname
(default-directory))))
;; 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 CURRENT-LISP-FILE-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 WANT-DIRECTORY T)
;; and merged into that DIRECTORY as per SUBPATHNAME.
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
(or (and (pathnamep pathname) (absolute-pathname-p pathname))
(let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname))))
(when (absolute-pathname-p lisp-file-pathname)
(subpathname lisp-file-pathname pathname :type :directory)))))
;;; Component class
......@@ -149,9 +156,9 @@
(when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails ret))
ret)))
(defun* do-defsystem (name &rest options
&key pathname (class 'system)
defsystem-depends-on &allow-other-keys)
(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.
......@@ -160,17 +167,17 @@
;; we also need to remember it in a special variable *systems-being-defined*.
(with-system-definitions ()
(let* ((name (coerce-name name))
(load-pathname (load-pathname))
(source-file (if sfp source-file (current-lisp-file-pathname)))
(registered (system-registered-p name))
(registered! (if registered
(rplaca registered (safe-file-write-date load-pathname))
(register-system (make-instance 'system :name name :source-file load-pathname))))
(rplaca registered (safe-file-write-date source-file))
(register-system (make-instance 'system :name name :source-file source-file))))
(system (reset-system (cdr registered!)
:name name :source-file load-pathname))
(component-options (remove-keys '(:class) options)))
:name name :source-file source-file))
(component-options (remove-keyword :class options)))
(setf (gethash name *systems-being-defined*) system)
(apply 'load-systems defsystem-depends-on)
;; We change-class (when necessary) AFTER we load the defsystem-dep's
;; 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 (eq (type-of system) class)
......@@ -178,8 +185,8 @@
(parse-component-form
nil (list*
:module name
:pathname (determine-system-pathname pathname)
:pathname (determine-system-directory pathname)
component-options)))))
(defmacro defsystem (name &body options)
`(apply 'do-defsystem ',name ',options))
`(apply 'register-system-definition ',name ',options))
......@@ -3163,12 +3163,10 @@ 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
calls the @code{*compile-op-compile-file-function*}
(usually @code{compile-file*})
with proper arguments;
the around-compile hook may supply additional arguments
to pass to that @code{*compile-op-compile-file-function*}.
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},
......
......@@ -2,7 +2,7 @@
;;;; Re-export all the functionality in asdf/driver
(asdf/package:define-package :asdf/driver
(:nicknames :d)
(:nicknames :d :asdf-driver)
(:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image
......
......@@ -14,7 +14,8 @@
#:*system-definition-search-functions* #:search-for-system-definition
#:*central-registry* #:probe-asd #:sysdef-central-registry-search
#:make-temporary-package #:find-system-if-being-defined #:*systems-being-defined*
#:find-system-fallback #:sysdef-find-asdf
#:find-system-fallback #:sysdef-find-asdf #:contrib-sysdef-search
#:system-find-pre-loaded-system #:*pre-loaded-systems*
#:make-defined-systems-table #:*defined-systems*
;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
......@@ -109,18 +110,21 @@ called with an object of type asdf:system."
(defvar *system-definition-search-functions* '())
(setf *system-definition-search-functions*
(append
;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
(remove 'contrib-sysdef-search *system-definition-search-functions*)
;; Tuck our defaults at the end of the list if they were absent.
;; This is imperfect, in case they were removed on purpose,
;; but then it will be the responsibility of whoever does that
;; to upgrade asdf before he does such a thing rather than after.
(remove-if #'(lambda (x) (member x *system-definition-search-functions*))
'(sysdef-central-registry-search
sysdef-source-registry-search
sysdef-find-asdf))))
(defun cleanup-system-definition-search-functions ()
(setf *system-definition-search-functions*
(append
;; Remove known-incompatible sysdef functions from old versions of asdf.
(remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf)))
*system-definition-search-functions*)
;; Tuck our defaults at the end of the list if they were absent.
;; This is imperfect, in case they were removed on purpose,
;; but then it will be the responsibility of whoever does that
;; to upgrade asdf before he does such a thing rather than after.
(remove-if #'(lambda (x) (member x *system-definition-search-functions*))
'(sysdef-central-registry-search
sysdef-source-registry-search
sysdef-find-pre-loaded-systems)))))
(cleanup-system-definition-search-functions)
(defun* search-for-system-definition (system)
(some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
......@@ -202,13 +206,7 @@ Going forward, we recommend new users should be using the source-registry.
(subseq *central-registry* (1+ position))))))))))
(defun* make-temporary-package ()
(flet ((try (counter)
(ignore-errors
(make-package (format nil "~A~D" :asdf counter)
:use '(:cl :asdf/interface)))))
(do* ((counter 0 (+ counter 1))
(package (try counter) (try counter)))
(package package))))
(make-package (fresh-package-name :asdf 0) :use '(:cl :asdf/interface)))
(defmethod find-system ((name null) &optional (error-p t))
(declare (ignorable name))
......@@ -237,7 +235,7 @@ Going forward, we recommend new users should be using the source-registry.
(defun* load-sysdef (name pathname)
;; Tries to load system definition with canonical NAME from PATHNAME.
(with-system-definitions ()
(let ((package (make-temporary-package)))
(let ((package (make-temporary-package))) ;; ASDF3: get rid of that.
(unwind-protect
(handler-bind
((error #'(lambda (condition)
......@@ -322,9 +320,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(when (equal requested fallback)
(let ((registered (cdr (gethash fallback *defined-systems*))))
(or registered
(apply 'make-instance 'system
:name fallback :source-file source-file keys)))))
(apply 'make-instance 'system :name fallback :source-file source-file keys)))))
(defun* sysdef-find-asdf (name)
;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
(find-system-fallback name "asdf" :version (asdf-version)))
(defvar *pre-loaded-systems* `(("asdf") ("asdf-driver")))
(defun* sysdef-find-pre-loaded-systems (requested)
(loop :for (provided . keys) :in *pre-loaded-systems*
:thereis (apply 'find-system-fallback requested provided keys)))
......@@ -10,6 +10,10 @@
:asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
(in-package :asdf/footer)
;;;; Configure
(setf asdf/utility:*asdf-debug-utility*
'(asdf:system-relative-pathname :asdf "contrib/debug.lisp"))
;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
#+(or abcl clisp clozure cmu ecl mkcl sbcl)
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.99: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; Note first that the canonical source for ASDF is presently
;;; <URL:http://common-lisp.net/project/asdf/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
;;; bugs. There are usually two "supported" revisions - the git master
;;; branch is the latest development version, whereas the git release
;;; branch may be slightly older but is considered `stable'
;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;
;;; -- LICENSE END
;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it. Hence, all in one file.
#+xcvb (module ())
......@@ -16,7 +16,7 @@
#:shell-boolean-exit
#:register-image-restore-hook #:register-image-dump-hook
#:call-image-restore-hook #:call-image-dump-hook
#:initialize-asdf-utilities #:restore-image #:dump-image
#:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
))
(in-package :asdf/image)
......@@ -220,14 +220,10 @@ if we are not called from a directly executable image dumped by XCVB."
((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
((:restore-hook *image-restore-hook*) *image-restore-hook*)
((:prelude *image-prelude*) *image-prelude*)
((:entry-point *image-entry-point*) *image-entry-point*)
((:package *package*) *package*))
((:entry-point *image-entry-point*) *image-entry-point*))
(with-fatal-condition-handler ()
(call-image-restore-hook)
(when *image-prelude*
(with-safe-io-syntax (:package *package*)
(let ((*read-eval* t))
(eval-text *image-prelude*))))
(standard-eval-thunk *image-prelude*)
(let ((results (multiple-value-list
(if *image-entry-point*
(apply *image-entry-point* *command-line-arguments*)
......@@ -242,14 +238,10 @@ if we are not called from a directly executable image dumped by XCVB."
#-(or ecl mkcl)
(defun* dump-image (filename &key output-name executable
((:postlude *image-postlude*) *image-postlude*)
((:dump-hook *image-dump-hook*) *image-dump-hook*)
((:package *package*) *package*))
((:dump-hook *image-dump-hook*) *image-dump-hook*))
(declare (ignorable filename output-name executable))
(setf *image-dumped-p* (if executable :executable t))
(when *image-postlude*
(with-safe-io-syntax ()
(let ((*read-eval* t))
(eval-text *image-postlude*))))
(standard-eval-thunk *image-postlude*)
(call-image-dump-hook)
#-(or clisp clozure cmu lispworks sbcl)
(when executable
......@@ -298,6 +290,26 @@ if we are not called from a directly executable image dumped by XCVB."
filename (nth-value 1 (implementation-type))))
#+ecl
(defun create-image (destination object-files
&key kind output-name
(prelude () preludep) (entry-point () entry-point-p))
;; 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.
;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
(check-type kind (member :program :shared-library))
(c::builder
kind (pathname destination)
:lisp-files object-files
:init-name (c::compute-init-name (or output-name destination) :kind kind)
:epilogue-code
(when (eq kind :program)
`(restore-image ;; default behavior would be (si::top-level)
,@(when preludep `(:prelude ',prelude))
,@(when entry-point-p `(:entry-point ',entry-point))))))
;;; Some universal image restore hooks
(map () 'register-image-restore-hook
'(setup-temporary-directory setup-stderr setup-command-line-arguments))
......@@ -24,17 +24,31 @@
#:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems
#:require-system #:test-system #:clear-system
#:operation #:upward-operation #:downward-operation