*.~*~
test/try-reloading-dependency.asd
test/fileMissing.lisp
+test/hello-world-example
build-stamp
debian/cl-asdf.debhelper.log
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
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:
${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
: $${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))'
# 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:
"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"
: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")
: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))))
#:*asdf-verbose*
#:component-load-dependencies
#:enable-asdf-binary-locations-compatibility
- #:merge-component-name-type
#:operation-forced
#:operation-on-failure
#:operation-on-warnings
;; 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))
#+(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
:asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
(:export
- #:bundle-op #:bundle-op-build-args
+ #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
- #:program-op #:compiled-file #:precompiled-system #:prebuild-system
+ #:program-op #:program-system
+ #:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p
- #:bundle-sub-operations #:gather-components
- #+ecl #:make-build
- #+mkcl #:mkcl-bundle-sub-operations #+mkcl #:files-to-bundle #+mkcl #:bundle-system
- #+(or ecl mkcl) #:register-pre-built-system
+ #:gather-actions #:gather-components
+ #+ecl #:make-build #+mkcl #:bundle-system
+ #:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
- #:system-fasl))
+ #:component-translate-output-p #:translate-output-p
+ #:component-bundle-pathname #:bundle-pathname
+ #:component-bundle-operation #:bundle-operation
+ #:component-entry-point #:entry-point))
(in-package :asdf/bundle)
(defclass bundle-op (operation)
((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
(name-suffix :initarg :name-suffix :initform nil)
- #+ecl (type :reader bundle-op-type)
+ (bundle-type :reader bundle-type)
#+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
#+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
#+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
(defclass fasl-op (bundle-op)
- ((type :initform :fasl)))
+ ;; create a single fasl for the entire library
+ ((bundle-type :initform :fasl)))
-(defclass load-fasl-op (basic-load-op) ())
+(defclass load-fasl-op (basic-load-op)
+ ;; load a single fasl for the entire library
+ ())
(defclass lib-op (bundle-op)
- ((type :initform :lib)))
+ ;; On ECL: compile the system and produce linkable .a library for it.
+ ;; On others: just compile the system.
+ ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
(defclass dll-op (bundle-op)
- ((type :initform :dll)))
+ ;; Link together all the dynamic library used by this system into a single one.
+ ((bundle-type :initform :dll)))
(defclass binary-op (bundle-op)
+ ;; On ECL: produce lib and fasl for the system.
+ ;; On "normal" Lisps: produce just the fasl.
())
(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
(epilogue-code :accessor monolithic-op-epilogue-code)))
(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
+ ;; On ECL: produce lib and fasl for combined system and dependencies.
+ ;; On "normal" Lisps: produce an image file from system and dependencies.
())
-(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ())
+(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
+ ;; Create a single fasl for the system and its dependencies.
+ ())
(defclass monolithic-lib-op (monolithic-bundle-op lib-op)
- ((type :initform :lib)))
+ ;; ECL: Create a single linkable library for the system and its dependencies.
+ ((bundle-type :initform :lib)))
(defclass monolithic-dll-op (monolithic-bundle-op dll-op)
- ((type :initform :dll)))
+ ((bundle-type :initform :dll)))
(defclass program-op (monolithic-bundle-op)
- ((type :initform :program)))
+ ;; All: create an executable file from the system and its dependencies
+ ((bundle-type :initform :program)))
+
+(defgeneric* component-bundle-pathname (component))
+(defgeneric* component-translate-output-p (component))
+(defgeneric* component-entry-point (component))
+
+(defmethod component-bundle-pathname ((c component))
+ (declare (ignorable c))
+ nil)
+(defmethod component-translate-output-p ((c component))
+ (declare (ignorable c))
+ t)
+(defmethod component-entry-point ((c component))
+ (declare (ignorable c))
+ nil)
+
+(defclass bundle-system (system)
+ ((bundle-pathname
+ :initform nil :initarg :bundle-pathname :accessor component-bundle-pathname)
+ (bundle-operation
+ :initarg :bundle-operation :accessor component-bundle-operation)
+ (entry-point
+ :initform nil :initarg :entry-point :accessor component-entry-point)
+ (translate-output-p
+ :initform nil :initarg :translate-output-p :accessor component-translate-output-p)))
+
+(defclass program-system (bundle-system)
+ ((bundle-pathname :initarg :executable-name)
+ (bundle-operation :initform 'program-op)))
+
+(defun* bundle-pathname-type (bundle-type)
+ (etypecase bundle-type
+ ((eql :no-output-file) nil) ;; should we error out instead?
+ ((or null string) bundle-type)
+ ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
+ #+ecl
+ ((member :binary :dll :lib :static-library :program :object)
+ (compile-file-type :type bundle-type))
+ ((eql :binary) "image")
+ ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
+ ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
+ ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+
+(defun* bundle-output-files (o c)
+ (let ((bundle-type (bundle-type o)))
+ (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
+ (let ((name (or (component-bundle-pathname c)
+ (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
+ (type (bundle-pathname-type bundle-type)))
+ (values (list (subpathname (component-pathname c) name :type type))
+ (not (component-translate-output-p c)))))))
+
+(defmethod output-files ((o bundle-op) (c system))
+ (bundle-output-files o c))
+
+#-(or ecl mkcl)
+(progn
+ (defmethod perform ((o program-op) (c system))
+ (let ((output-file (output-file o c)))
+ (setf *image-entry-point* (ensure-function (component-entry-point c)))
+ (dump-image output-file :executable t)))
+
+ (defmethod perform ((o monolithic-binary-op) (c system))
+ (let ((output-file (output-file o c)))
+ (dump-image output-file))))
(defclass compiled-file (file-component)
- ((type :initform #-(or ecl mkcl) (fasl-type) #+(or ecl mkcl) "fasb")))
+ ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
(defclass precompiled-system (system)
- ((fasl :initarg :fasl :reader %system-fasl)))
+ ((bundle-pathname :initarg :fasl)))
(defclass prebuilt-system (system)
- ((static-library :accessor prebuilt-system-static-library :initarg :lib)))
+ ((bundle-pathname :initarg :static-library :initarg :lib
+ :accessor prebuilt-system-static-library)))
;;;
;;; BUNDLE-OP
&key (name-suffix nil name-suffix-p)
&allow-other-keys)
(declare (ignorable initargs name-suffix))
- (format t "IIBO a ~S with ~S" (type-of instance) initargs)
(unless name-suffix-p
(setf (slot-value instance 'name-suffix)
- (if (operation-monolithic-p instance) ".all-systems" ".system")))
+ (unless (typep instance 'program-op)
+ (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system"))))
(when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&rest original-initargs
&key lisp-files prologue-code epilogue-code
(remove-keys '(lisp-files epilogue-code prologue-code) original-initargs)
(monolithic-op-prologue-code instance) prologue-code
(monolithic-op-epilogue-code instance) epilogue-code)
- #-ecl (assert (null lisp-files))
+ #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
#+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
(setf (bundle-op-build-args instance)
(remove-keys '(type monolithic name-suffix)
(remf args :ld-flags)
args))
-(defun* gather-components (operation system
- &key other-systems filter-type include-self)
- ;; This function creates a list of actions pairing the operation with sub-components of system
- ;; and its dependencies if requested.
+(defclass filtered-sequential-plan (sequential-plan)
+ ((action-filter :initarg :action-filter :reader plan-action-filter)))
+
+(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
+ (and (funcall (plan-action-filter plan) o c) (call-next-method)))
+
+(defun* gather-actions (operation component &key other-systems (filter t))
+ ;; This function creates a list of sub-actions performed
+ ;; while building the targeted action.
;; This list may be restricted to sub-components of SYSTEM
- ;; if GATHER-ALL = NIL (default), and it may include the system itself.
- (let ((tree (traverse-sequentially (make-operation 'load-op) system
- :force (if other-systems :all t)
- :force-not (if other-systems nil :all))))
- `(,@(loop :for (op . component) :in tree
- :when (and (typep op 'load-op)
- (typep component filter-type))
- :collect (progn
- (when (eq component system) (setf include-self nil))
- `(,operation . ,component)))
- ,@(and include-self `((,operation . ,system))))))
+ ;; if OTHER-SYSTEMS is NIL (default).
+ (traverse operation component
+ :plan-class 'filtered-sequential-plan
+ :action-filter (ensure-function filter)
+ :force (if other-systems :all t)
+ :force-not (if other-systems nil :all)))
+
+(defun* bundlable-file-p (pathname)
+ (let ((type (pathname-type pathname)))
+ (or #+ecl (or (equal type (compile-file-type :object))
+ (equal type (compile-file-type :static-library)))
+ #+mkcl (equal type (compile-file-type :fasl-p nil))
+ #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
+
+(defun* gather-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
+ (component-type t) other-systems)
+ (let ((goal-op (make-operation goal-operation)))
+ (flet ((filter (o c)
+ (declare (ignore o))
+ (or (eq c system)
+ (typep c component-type))))
+ (loop :for (o . c) :in (gather-actions goal-op system
+ :other-systems other-systems
+ :filter #'filter)
+ :when (typep o keep-operation)
+ :collect c))))
(defgeneric* trivial-system-p (component))
(deftype user-system () '(and system (satisfies user-system-p)))
;;;
-;;; BUNDLE-SUB-OPERATIONS
-;;;
-;;; Builds a list of pairs (operation . component)
-;;; which contains all the dependencies of this bundle.
-;;; This list is used by TRAVERSE and also by INPUT-FILES.
-;;; The dependencies depend on the strategy, as explained below.
-;;;
-(defgeneric* bundle-sub-operations (operation component))
-;;;
;;; First we handle monolithic bundles.
;;; These are standalone systems which contain everything,
;;; including other ASDF systems required by the current one.
;;;
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
-;;; Gather the static libraries of all components.
-;;;
-(defmethod bundle-sub-operations ((o monolithic-bundle-op) c)
- (gather-components (find-operation o 'lib-op) c :filter-type 'user-system :include-self t))
-;;;
-;;; STATIC LIBRARIES
-;;;
-;;; Gather the object files of all components
-;;; and, if monolithic, also of systems and subsystems.
-;;;
-(defmethod bundle-sub-operations ((o lib-op) c)
- (gather-components (find-operation o 'compile-op) c
- :other-systems (operation-monolithic-p o)
- :filter-type '(not system)))
-;;;
-;;; SHARED LIBRARIES
-;;;
-;;; Gather the dynamically linked libraries of all components.
-;;; They will be linked into this new shared library,
-;;; together with the static library of this module.
-;;;
-(defmethod bundle-sub-operations ((o dll-op) c)
- `((,(find-operation o 'lib-op) . ,c)))
-;;;
-;;; FASL FILES
-;;;
-;;; Gather the statically linked library of this component.
-;;;
-(defmethod bundle-sub-operations ((o fasl-op) c)
- `((,(find-operation o 'lib-op) . ,c)))
+(defmethod component-depends-on ((o monolithic-lib-op) (c system))
+ (declare (ignorable o))
+ `((lib-op ,@(gather-components c :other-systems t :component-type 'system
+ :goal-operation 'load-op
+ :keep-operation 'load-op))))
-#-mkcl
-(defmethod component-depends-on ((o bundle-op) (c system))
- `(,@(loop :for (op . dep) :in (bundle-sub-operations o c)
- :when (user-system-p dep) :collect (list op dep))
- ,@(call-next-method)))
+(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
+ (declare (ignorable o))
+ `((fasl-op ,@(gather-components c :other-systems t :component-type 'system
+ :goal-operation 'load-fasl-op
+ :keep-operation 'load-fasl-op))))
+
+(defmethod component-depends-on ((o program-op) (c system))
+ (declare (ignorable o))
+ `((#+(or ecl mkcl) monolithic-lib-op #-(or ecl mkcl) load-op ,c)))
+
+(defmethod component-depends-on ((o binary-op) (c system))
+ (declare (ignorable o))
+ `((fasl-op ,c)
+ (lib-op ,c)))
+
+(defmethod component-depends-on ((o monolithic-binary-op) (c system))
+ `((,(find-operation o 'monolithic-fasl-op) ,c)
+ (,(find-operation o 'monolithic-lib-op) ,c)))
(defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o))
- `((compile-op ,c) ,@(call-next-method)))
+ `((compile-op ,@(gather-components c :other-systems nil :component-type '(not system)
+ :goal-operation 'load-op
+ :keep-operation 'load-op))))
+
+(defmethod component-depends-on ((o fasl-op) (c system))
+ (declare (ignorable o))
+ #+ecl `((lib-op ,c))
+ #-ecl
+ (component-depends-on (find-operation o 'lib-op) c))
+
+(defmethod component-depends-on ((o dll-op) c)
+ (component-depends-on (find-operation o 'lib-op) c))
(defmethod component-depends-on ((o bundle-op) c)
(declare (ignorable o c))
nil)
-#-mkcl
(defmethod input-files ((o bundle-op) (c system))
- (loop :for (sub-op . sub-c) :in (bundle-sub-operations o c)
- :nconc (output-files sub-op sub-c)))
+ (while-collecting (collect)
+ (visit-dependencies
+ () o c #'(lambda (sub-o sub-c)
+ (loop :for f :in (output-files sub-o sub-c)
+ :when (bundlable-file-p f) :do (collect f))))))
-#-mkcl
-(defmethod output-files ((o bundle-op) (c system))
- (list (compile-file-pathname
- (make-pathname
- :name (strcat (component-name c) (slot-value o 'name-suffix)
- #|"-" (string-downcase (implementation-type))|#)
- :type "lisp"
- :defaults (system-source-directory c))
- #+ecl :type #+ecl (bundle-op-type o))))
-
-(defun* select-operation (monolithic type)
+(defun* select-bundle-operation (type &optional monolithic)
(ecase type
((:binary)
(if monolithic 'monolithic-binary-op 'binary-op))
(defun* make-build (system &rest args &key (monolithic nil) (type :fasl)
(move-here nil move-here-p)
&allow-other-keys)
- (let* ((operation-name (select-operation monolithic type))
+ (let* ((operation-name (select-bundle-operation type monolithic))
(move-here-path (if (and move-here
(typep move-here '(or pathname string)))
(pathname move-here)
(defmethod component-depends-on ((o load-fasl-op) (c system))
(declare (ignorable o))
- `((load-fasl-op ,@(loop :for dep :in (component-sibling-dependencies c)
- :collect (resolve-dependency-spec c dep)))
+ `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
+ :collect (resolve-dependency-spec c dep)))
(,(if (user-system-p c) 'fasl-op 'load-op) ,c)
,@(call-next-method)))
(perform-lisp-load-fasl o c))
(defmethod mark-operation-done :after ((o load-fasl-op) (c system))
- (mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components?
+ (mark-operation-done (find-operation o 'load-op) c))
;;;
;;; PRECOMPILED FILES
(declare (ignorable s))
t)
-(defmethod output-files ((o lib-op) (c prebuilt-system))
- (declare (ignorable o))
- (values (list (prebuilt-system-static-library c))
- t)) ; Advertise that we do not want this path renamed by asdf-output-translations
-
(defmethod perform ((o lib-op) (c prebuilt-system))
- (first (output-files o c)))
-
-(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
nil)
-(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system))
+(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
nil)
-(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system))
+(defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
(declare (ignorable o))
- (error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c))
-
-(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system))
- (declare (ignorable o c))
nil)
+
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
-(defun* binary-op-dependencies (o s)
- (multiple-value-bind (lib-op fasl-op)
- (if (operation-monolithic-p o)
- (values 'monolithic-lib-op 'monolithic-fasl-op)
- (values 'lib-op 'fasl-op))
- `((,(find-operation o lib-op) ,s)
- (,(find-operation o fasl-op) ,s))))
-
-(defmethod component-depends-on ((o binary-op) (s system))
- `(,@(loop :for dep :in (binary-op-dependencies o s)
- :append (apply #'component-depends-on dep))
- ,@(call-next-method)))
-
-(defmethod input-files ((o binary-op) (s system))
- (loop :for dep :in (binary-op-dependencies o s)
- :append (apply #'input-files dep)))
(defmethod output-files ((o binary-op) (s system))
- (list* (merge-pathnames* (make-pathname :name (component-name s)
- :type "asd")
- (component-relative-pathname s))
- (loop :for dep :in (binary-op-dependencies o s)
- :append (apply #'output-files dep))))
+ (list (make-pathname :name (component-name s) :type "asd"
+ :defaults (component-pathname s))))
(defmethod perform ((o binary-op) (s system))
- (let* ((dependencies (binary-op-dependencies o s))
- (library (first (apply #'output-files (first dependencies))))
- (fasl (first (apply #'output-files (second dependencies))))
- (filename (first (output-files o s)))
- (name (component-name s))
+ (let* ((dependencies (component-depends-on o s))
+ (fasl (first (apply #'output-files (first dependencies))))
+ (library (first (apply #'output-files (second dependencies))))
+ (asd (first (output-files o s)))
+ (name (pathname-name asd))
(name-keyword (intern (string name) (find-package :keyword))))
- (dolist (dep dependencies)
- (apply #'perform dep))
- (with-open-file (s filename :direction :output :if-exists :supersede
+ (with-open-file (s asd :direction :output :if-exists :supersede
:if-does-not-exist :create)
(format s ";;; Prebuilt ASDF definition for system ~A" name)
(format s ";;; Built for ~A ~A on a ~A/~A ~A"
(pprint `(defsystem ,name-keyword
:class prebuilt-system
:components ((:compiled-file ,(pathname-name fasl)))
- :lib ,(make-pathname :name (pathname-name library)
- :type (pathname-type library)))
+ :lib ,(and library (file-namestring library)))
s)))))
#-(or ecl mkcl)
-(defmethod perform ((o bundle-op) (c system))
+(defmethod perform ((o fasl-op) (c system))
(let* ((input-files (input-files o c))
- (fasl-files (remove (fasl-type) input-files :key #'pathname-type :test-not #'string=))
- (non-fasl-files (remove (fasl-type) input-files :key #'pathname-type :test #'string=))
+ (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=))
+ (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
(output-files (output-files o c))
(output-file (first output-files)))
(when input-files
(with-staging-pathname (output-file)
(combine-fasls fasl-files output-file)))))
-(defmethod output-files ((o fasl-op) (c source-file))
- (declare (ignorable o c))
- nil)
-
-(defmethod input-files ((o fasl-op) (c source-file))
- (declare (ignorable o c))
- nil)
-
-(defgeneric* system-fasl (system))
-(defmethod system-fasl ((system precompiled-system))
- (let* ((f (%system-fasl system))
- (p (etypecase f
- ((or pathname string) f)
- (function (funcall f))
- (cons (eval f)))))
- (pathname p)))
-
(defmethod input-files ((o load-op) (s precompiled-system))
(declare (ignorable o))
- (list (system-fasl s)))
+ (bundle-output-files (find-operation o 'fasl-op) s))
(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
(declare (ignorable o))
|#
#+ecl
-(defmethod output-files ((o fasl-op) (c system))
- (declare (ignorable o c))
- (loop :for file :in (call-next-method)
- :collect (make-pathname :type "fasb" :defaults file)))
-
-#+ecl
(defmethod perform ((o bundle-op) (c system))
(let* ((object-files (remove "fas" (input-files o c)
:key #'pathname-type :test #'string=))
(output (output-files o c)))
- (apply #'c::builder (bundle-op-type o) (first output)
+ (apply #'c::builder (bundle-type o) (first output)
:lisp-files (append object-files (bundle-op-lisp-files o))
(append (bundle-op-build-args o)
+ (when (typep o 'program-op)
+ `(:prologue-code
+ (restore-image :entry-point ,(component-entry-point c))))
(when (and (typep o 'monolithic-bundle-op)
(monolithic-op-prologue-code o))
`(:prologue-code ,(monolithic-op-prologue-code o)))
#+mkcl
(progn
-;;;
-;;; BUNDLE-SUB-OPERATIONS
-;;;
-;;; Builds a list of pairs (operation . component) which contains all the
-;;; dependencies of this bundle.
-;;;
-
-(defun* mkcl-bundle-sub-operations (op sys)
- (gather-components (find-operation op 'compile-op) sys
- :other-systems nil
- :filter-type '(not system)))
-
-(defun* files-to-bundle (operation system)
- (loop :for (o . c) :in (mkcl-bundle-sub-operations operation system)
- :for sub-files = (output-files o c)
- :when sub-files :collect (first sub-files)))
+ (defmethod perform ((o lib-op) (s system))
+ (apply #'compiler::build-static-library (first output)
+ :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-(defmethod component-depends-on ((o bundle-op) (c system))
- (declare (ignorable o))
- `((compile-op ,c) ,@(call-next-method)))
-
-(defmethod output-files ((o bundle-op) (c system))
- (let* ((name (component-name c))
- (static-lib-name (merge-pathnames
- (compiler::builder-internal-pathname name :static-library)
- (component-relative-pathname c)))
- (fasl-bundle-name (merge-pathnames
- (compiler::builder-internal-pathname name :fasb)
- (component-relative-pathname c))))
- (list static-lib-name fasl-bundle-name)))
+ (defmethod perform ((o fasl-op) (s system))
+ (apply #'compiler::build-bundle (second output)
+ :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-(defmethod perform ((o bundle-op) (c system))
- (let ((object-files (files-to-bundle o c))
- (output (output-files o c)))
- (when (bundle-op-do-static-library-p o)
- (apply #'compiler::build-static-library (first output)
- :lisp-object-files object-files (bundle-op-build-args o)))
- (when (bundle-op-do-fasb-p o)
- (apply #'compiler::build-bundle (second output)
- :lisp-object-files object-files (bundle-op-build-args o)))))
-
-(defun* bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
- (declare (ignore force verbose version))
- (apply #'operate 'bundle-op system args))
-);mkcl
+ (defun* bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
+ (declare (ignore force verbose version))
+ (apply #'operate 'binary-op system args)))
#+(or ecl mkcl)
(defun* register-pre-built-system (name)
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)))
#: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))
(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)))
values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors
(remove-if
- 'hidden-file-p
+ 'hidden-pathname-p
(directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
#'string< :key #'namestring)))
`(,tag
:do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
-(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
- (values (or null pathname) &optional))
- resolve-location))
-
-(defun* resolve-relative-location-component (x &key directory wilden)
- (let ((r (etypecase x
- (pathname x)
- (string (coerce-pathname x :type (when directory :directory)))
- (cons
- (if (null (cdr x))
- (resolve-relative-location-component
- (car x) :directory directory :wilden wilden)
- (let* ((car (resolve-relative-location-component
- (car x) :directory t :wilden nil)))
- (merge-pathnames*
- (resolve-relative-location-component
- (cdr x) :directory directory :wilden wilden)
- car))))
- ((eql :default-directory) (nil-pathname)) ;; OBSOLETE
- ((eql :*/) *wild-directory*)
- ((eql :**/) *wild-inferiors*)
- ((eql :*.*.*) *wild-file*)
- ((eql :implementation)
- (coerce-pathname (implementation-identifier) :type :directory))
- ((eql :implementation-type)
- (coerce-pathname (string-downcase (implementation-type)) :type :directory))
- ((eql :hostname)
- (coerce-pathname (hostname) :type :directory)))))
- (when (absolute-pathname-p r)
- (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
- (if (or (pathnamep x) (member x '(:*/ :**/ :*.*.*)) (not wilden))
- r (wilden r))))
+(defun* resolve-relative-location-component (x &key want-directory wilden)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string (parse-unix-namestring
+ x :want-directory want-directory))
+ (cons
+ (if (null (cdr x))
+ (resolve-relative-location-component
+ (car x) :want-directory want-directory :wilden wilden)
+ (let* ((car (resolve-relative-location-component
+ (car x) :want-directory t :wilden nil)))
+ (merge-pathnames*
+ (resolve-relative-location-component
+ (cdr x) :want-directory want-directory :wilden wilden)
+ car))))
+ ((eql :*/) *wild-directory*)
+ ((eql :**/) *wild-inferiors*)
+ ((eql :*.*.*) *wild-file*)
+ ((eql :implementation)
+ (parse-unix-namestring
+ (implementation-identifier) :want-directory t))
+ ((eql :implementation-type)
+ (parse-unix-namestring
+ (string-downcase (implementation-type)) :want-directory t))
+ ((eql :hostname)
+ (parse-unix-namestring (hostname) :want-directory t))))
+ (w (if (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
+ (wilden r)
+ r)))
+ (ensure-pathname w :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*
- (flet ((try (x &rest sub) (and x `(,x ,@sub))))
- (or
- (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
- (when (os-windows-p)
- (try (or (get-folder-path :local-appdata)
- (get-folder-path :appdata))
- "common-lisp" "cache" :implementation))
- '(:home ".cache" "common-lisp" :implementation))))
+(defvar *user-cache* nil
+ "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
-(defun* resolve-absolute-location-component (x &key directory wilden)
- (let* ((r
- (etypecase x
- (pathname x)
- (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
- #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
- (if directory (ensure-directory-pathname p) p)))
- (cons
- (return-from resolve-absolute-location-component
- (if (null (cdr x))
- (resolve-absolute-location-component
- (car x) :directory directory :wilden wilden)
- (merge-pathnames*
- (resolve-relative-location-component
- (cdr x) :directory directory :wilden wilden)
- (resolve-absolute-location-component
- (car x) :directory t :wilden nil)))))
- ((eql :root)
- ;; special magic! we encode such paths as relative pathnames,
- ;; but it means "relative to the root of the source pathname's host and device".
- (return-from resolve-absolute-location-component
- (let ((p (make-pathname* :directory '(:relative))))
- (if wilden (wilden p) p))))
- ((eql :home) (user-homedir))
- ((eql :here)
- (resolve-location (or *here-directory*
- ;; give semantics in the case of use interactively
- :default-directory)
- :directory t :wilden nil))
- ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
- ((eql :system-cache)
- (error "Using the :system-cache is deprecated. ~%~
-Please remove it from your ASDF configuration"))
- ((eql :default-directory) (default-directory))))
- (s (if (and wilden (not (or (pathnamep x))))
+(defun compute-user-cache ()
+ (setf *user-cache*
+ (flet ((try (x &rest sub) (and x `(,x ,@sub))))
+ (or
+ (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
+ (when (os-windows-p)
+ (try (or (get-folder-path :local-appdata)
+ (get-folder-path :appdata))
+ "common-lisp" "cache" :implementation))
+ '(:home ".cache" "common-lisp" :implementation)))))
+(register-image-restore-hook 'compute-user-cache)
+
+(defun* resolve-absolute-location-component (x &key want-directory wilden)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string
+ (let ((p #-mcl (parse-namestring x)
+ #+mcl (probe-posix x)))
+ #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+ (if want-directory (ensure-directory-pathname p) p)))
+ (cons
+ (return-from resolve-absolute-location-component
+ (if (null (cdr x))
+ (resolve-absolute-location-component
+ (car x) :want-directory want-directory :wilden wilden)
+ (merge-pathnames*
+ (resolve-relative-location-component
+ (cdr x) :want-directory want-directory :wilden wilden)
+ (resolve-absolute-location-component
+ (car x) :want-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-component
+ (let ((p (make-pathname* :directory '(:relative))))
+ (if wilden (wilden p) p))))
+ ((eql :home) (user-homedir))
+ ((eql :here) (resolve-absolute-location-component
+ *here-directory* :want-directory t :wilden nil))
+ ((eql :user-cache) (resolve-absolute-location-component
+ *user-cache* :want-directory t :wilden nil))))
+ (w (if (and wilden (not (pathnamep x)))
(wilden r)
r)))
- (unless (absolute-pathname-p s)
- (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
- s))
+ (ensure-pathname w :want-absolute t)))
-(defun* resolve-location (x &key directory wilden)
+(defun* resolve-location (x &key want-directory wilden)
(if (atom x)
- (resolve-absolute-location-component x :directory directory :wilden wilden)
+ (resolve-absolute-location-component x :want-directory want-directory :wilden wilden)
(loop :with path = (resolve-absolute-location-component
- (car x) :directory (and (or directory (cdr x)) t)
+ (car x) :want-directory (and (or want-directory (cdr x)) t)
:wilden (and wilden (null (cdr x))))
:for (component . morep) :on (cdr x)
- :for dir = (and (or morep directory) t)
+ :for dir = (and (or morep want-directory) t)
:for wild = (and wilden (not morep))
:do (setf path (merge-pathnames*
(resolve-relative-location-component
- component :directory dir :wilden wild)
+ component :want-directory dir :wilden wild)
path))
:finally (return path))))
(defun* location-designator-p (x)
(flet ((absolute-component-p (c)
(typep c '(or string pathname
- (member :root :home :here :user-cache :system-cache :default-directory))))
+ (member :root :home :here :user-cache))))
(relative-component-p (c)
(typep c '(or string pathname
- (member :default-directory :*/ :**/ :*.*.*
- :implementation :implementation-type)))))
+ (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))))))
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.
: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
(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.
;; 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)
(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))
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},
;;;; 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
#:*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))
(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)))
(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))
(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)
(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)))
: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 ())
#: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)
((: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*)
#-(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
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))
#:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems
#:require-system #:test-system #:clear-system
- #:operation #:upward-operation #:downward-operation
- #:load-op #:prepare-op #:compile-op #:load-fasl-op
+ #:operation #:upward-operation #:downward-operation #:make-operation
+ #:load-op #:prepare-op #:compile-op #:load-fasl-op #:fasl-op
#:prepare-source-op #:load-source-op #:test-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain #:component-sibling-dependencies
+ #:needed-in-image-p
#:run-program/ ; the recommended replacement for run-shell-command
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
#:precompiled-system #:compiled-file
#+ecl #:make-build #+mkcl #:bundle-system
+ #:program-op #:program-system
+ #:concatenate-source-op
+ #:load-concatenated-source-op
+ #:compile-concatenated-source-op
+ #:load-compiled-concatenated-source-op
+ #:monolithic-concatenate-source-op
+ #:monolithic-load-concatenated-source-op
+ #:monolithic-compile-concatenated-source-op
+ #:monolithic-load-compiled-concatenated-source-op
+ #:concatenated-source-system
+ #:component-concatenated-source-file
+ #:concatenated-source-file
+ #:operation-monolithic-p
#:component #:parent-component #:child-component #:system #:module
#:source-file #:c-source-file #:java-source-file
(call-with-around-compile-hook
c #'(lambda (&rest flags)
(with-muffled-compiler-conditions ()
- (apply *compile-file-function* input-file
+ (apply 'compile-file* input-file
:output-file output-file
:external-format (component-external-format c)
(append flags (compile-op-flags o))))))
(:export
;; Variables
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
- #:*compile-file-function* #:*output-translation-function*
+ #:*output-translation-function*
#:*optimization-settings* #:*previous-optimization-settings*
#:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
#:*deferred-warnings*
#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
- #:lispize-pathname #:fasl-type #:call-around-hook
+ #:current-lisp-file-pathname #:lispize-pathname #:compile-file-type #:call-around-hook
#:compile-file* #:compile-file-pathname*
- #+(or ecl mkcl) #:compile-file-keeping-object
#:load* #:load-from-string
#:combine-fasls))
(in-package :asdf/lisp-build)
when compiling a file? Valid values are :error, :warn, and :ignore.
Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
-(defvar *compile-file-function* 'compile-file*
- "Function used to compile lisp files.")
-
;;; Optimization settings
;;; from ASDF
+(defun* current-lisp-file-pathname ()
+ (or *compile-file-pathname* *load-pathname*))
+
(defun* lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file))
-(defun* fasl-type (&rest keys)
+(defun* compile-file-type (&rest keys)
"pathname TYPE for lisp FASt Loading files"
(declare (ignorable keys))
- #-ecl (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
- #+ecl (pathname-type (apply 'compile-file-pathname "foo.lisp" keys)))
+ #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
+ #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo.lisp" keys)))
(defun* call-around-hook (hook function)
(call-function (or hook 'funcall) function))
-(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
+(defun* compile-file* (input-file &rest keys
+ &key compile-check output-file #+(or ecl mkcl) object-file
+ &allow-other-keys)
+ "This function provides a portable wrapper around COMPILE-FILE.
+It ensures that the OUTPUT-FILE value is only returned and
+the file only actually created if the compilation was successful,
+even though your implementation may not do that, and including
+an optional call to an user-provided consistency check function COMPILE-CHECK;
+it will call this function if not NIL at the end of the compilation
+with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
+where TMP-FILE is the name of a temporary output-file.
+It also checks two flags (with legacy british spelling from ASDF1),
+*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
+with appropriate implementation-dependent defaults,
+and if a failure (respectively warnings) are reported by COMPILE-FILE
+with consider it an error unless the respective behaviour flag
+is one of :SUCCESS :WARN :IGNORE.
+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."
(let* ((keywords (remove-keys
- `(:compile-check #+gcl<2.7 ,@'(:external-format :print :verbose)) keys))
+ `(:compile-check
+ #+gcl<2.7 ,@'(:external-format :print :verbose)) keys))
(output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
- (tmp-file (tmpize-pathname output-file))
- (status :error))
+ #+ecl
+ (object-file
+ (when (use-ecl-byte-compiler-p)
+ (or object-file
+ (compile-file-pathname output-file :type :object))))
+ #+mkcl
+ (object-file
+ (or object-file
+ (compile-file-pathname output-file #+mkcl :fasl-p #+mkcl nil)))
+ (tmp-file (make-pathname :type "fasl-tmp" :defaults output-file)))
(multiple-value-bind (output-truename warnings-p failure-p)
- (apply 'compile-file input-file :output-file tmp-file keywords)
- (cond
- (failure-p
- (setf status *compile-file-failure-behaviour*))
- (warnings-p
- (setf status *compile-file-warnings-behaviour*))
- (t
- (setf status :success)))
+ (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
+ #+ecl (apply 'compile-file input-file
+ (if object-file
+ (list* :output-file object-file :type :object keywords)
+ keywords))
+ #+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords))
(cond
- ((and (ecase status
- ((:success :warn :ignore) t)
- ((:error nil)))
- (or (not compile-check)
- (apply compile-check input-file :output-file tmp-file keywords)))
+ ((and output-truename
+ (flet ((check-flag (flag behaviour)
+ (or (not flag) (member behaviour '(:success :warn :ignore)))))
+ (and (check-flag failure-p *compile-file-failure-behaviour*)
+ (check-flag warnings-p *compile-file-warnings-behaviour*)))
+ (progn
+ #+(or ecl mkcl)
+ (when (and (eq status :success) #+ecl object-file)
+ (setf output-truename
+ (compiler::build-fasl
+ tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
+ (list object-file))))
+ (or (not compile-check)
+ (apply compile-check input-file :output-file tmp-file keywords))))
(delete-file-if-exists output-file)
(when output-truename
(rename-file-overwriting-target output-truename output-file)
- (setf output-truename output-file)))
+ (setf output-truename (truename output-file))))
(t ;; error or failed check
(delete-file-if-exists output-truename)
- (setf output-truename nil failure-p t)))
+ (setf output-truename nil)))
(values output-truename warnings-p failure-p))))
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
,@(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 'fasl-type keys)))
+ (let* ((type (pathname-type (apply 'compile-file-type keys)))
(defaults (make-pathname
:type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults))
"Portably read and evaluate forms from a STRING."
(with-input-from-string (s string) (load* s)))
-;;; In ECL and MKCL, compilation produces *both*
-;; a loadable FASL file and the linkable object file that it was built from.
-;; Having both of them allows us to later on reuse the object files
-;; when linking bundles, libraries, standalone executables, etc.
-#+(or ecl mkcl)
-(progn
- (setf *compile-file-function* 'compile-file-keeping-object)
-
- (defun* compile-file-keeping-object (input-file &rest keys &key output-file &allow-other-keys)
- (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys)
- #+mkcl progn
- (let ((object-file
- (compile-file-pathname
- output-file #+ecl :type #+ecl :object #+mkcl :fasl-p #+mkcl nil)))
- (multiple-value-bind (result flags1 flags2)
- (apply 'compile-file* input-file
- #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil
- :output-file object-file keys)
- (values (and (equal result object-file)
- (compiler::build-fasl
- output-file #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file))
- object-file)
- flags1
- flags2))))))
-
;;; Links FASLs together
(defun* combine-fasls (inputs output)
#-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
(:export
#:featurep #:os-unix-p #:os-windows-p ;; features
#:getenv #:getenvp ;; environment variables
- #:inter-directory-separator #:split-pathnames*
+ #:native-namestring #:parse-native-namestring
+ #:inter-directory-separator #:split-native-pathnames-string
#:getenv-pathname #:getenv-pathnames
#:getenv-absolute-directory #:getenv-absolute-directories
#:implementation-identifier ;; implementation identifier
then returning the non-empty string value of the variable"
(let ((g (getenv x))) (and (not (emptyp g)) g)))
+
+;;; Native vs Lisp syntax
+
+(defun* native-namestring (x)
+ "From a CL pathname, a return namestring suitable for passing to the operating system"
+ (when x
+ (let ((p (pathname x)))
+ #+clozure (with-pathname-defaults ((root-pathname))
+ (ccl:native-translated-namestring p)) ; see ccl bug 978
+ #+(or cmu scl) (ext:unix-namestring p nil)
+ #+sbcl (sb-ext:native-namestring p)
+ #-(or clozure cmu sbcl scl)
+ (if (os-unix-p) (unix-namestring p)
+ (namestring p)))))
+
+(defun* parse-native-namestring (string &rest constraints &key want-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 ((root-pathname))
+ #+clozure (ccl:native-to-pathname string)
+ #+sbcl (sb-ext:parse-native-namestring string)
+ #-(or clozure sbcl)
+ (if (os-unix-p)
+ (parse-unix-namestring string :type (when want-directory :directory))
+ (parse-namestring string)))))
+ (pathname
+ (if want-directory
+ (and pathname (ensure-directory-pathname pathname))
+ pathname)))
+ (apply 'ensure-pathname pathname constraints)))
+
+
+;;; Native pathnames in environment
(defun* inter-directory-separator ()
(if (os-unix-p) #\: #\;))
-(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
- (loop :for dir :in (split-string
- x :separator (string (inter-directory-separator)))
- :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
-(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
- (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
-(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
- (and (plusp (length s))
- (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
+(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
+ (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
+ :collect (apply 'parse-native-namestring namestring constraints)))
+(defun* getenv-pathname (x &rest constraints &key (error-arguments () eap) &allow-other-keys)
+ (declare (ignore error-arguments))
+ (apply 'parse-native-namestring (getenvp x)
+ (if eap constraints
+ (list* :error-arguments '("~? from (getenv ~S)") constraints))))
+(defun* getenv-pathnames (x &rest constraints &key (error-arguments () eap) &allow-other-keys)
+ (declare (ignore error-arguments))
+ (apply 'split-native-pathnames-string (getenvp x)
+ (if eap constraints
+ (list* :error-arguments '("~? from (getenv ~S)") constraints))))
(defun* getenv-absolute-directory (x)
(getenv-pathname x :want-absolute t :want-directory t))
(defun* getenv-absolute-directories (x)
;;; Using temporary files
(defun* default-temporary-directory ()
- (flet ((f (s v d) (format nil "~A~A" (or (getenvp v) d (error "No temporary directory!")) s)))
- (let ((dir (cond
- ((os-unix-p) (f #\/ "TMPDIR" "/tmp"))
- ((os-windows-p) (f #\\ "TEMP" nil))))
- #+mcl (dir (probe-posix dir)))
- (or (parse-native-namestring dir) (default-directory)))))
+ (or
+ (when (os-unix-p)
+ (or (getenv-pathname "TMPDIR" :want-directory t)
+ (parse-native-namestring "/tmp/")))
+ (when (os-windows-p)
+ (getenv-pathname "TEMP" :want-directory t))
+ (subpathname (user-homedir) "tmp/")))
(defvar *temporary-directory* nil)
"Undoes any initialization of the output translations."
(setf *output-translations* '())
(values))
-(register-clear-configuration-hook 'clear-source-registry)
+(register-clear-configuration-hook 'clear-output-translations)
(defun* validate-output-translations-directive (directive)
(or (member directive '(:enable-user-cache :disable-cache nil))
;; We enable the user cache by default, and here is the place we do:
:enable-user-cache))
-(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
-(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
+(defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
+(defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
(defun* user-output-translations-pathname (&key (direction :input))
(in-user-configuration-directory *output-translations-file* :direction direction))
(process-output-translations (pathname dst) :inherit nil :collect collect))
(when src
(let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :directory t :wilden t)))
+ (let ((loc (resolve-location src :want-directory t :wilden t)))
(if (absolute-pathname-p loc) (truenamize loc) loc)))))
(cond
((location-function-p dst)
(funcall collect (list trusrc t)))
(t
(let* ((trudst (if dst
- (resolve-location dst :directory t :wilden t)
+ (resolve-location dst :want-directory t :wilden t)
trusrc)))
(funcall collect (list trudst t))
(funcall collect (list trusrc trudst)))))))))))
(:use :common-lisp)
(:export
#:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* #:make-symbol*
- #:symbol-shadowing-p #:rehome-symbol
- #:delete-package* #:package-names #:packages-from-names
- #:reify-symbol #:unreify-symbol
- #:package-definition-form #:ensure-package #:define-package))
+ #:symbol-shadowing-p #:home-package-p #:rehome-symbol
+ #:symbol-package-name #:standard-common-lisp-symbol-p
+ #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
+ #:nuke-symbol-in-package #:nuke-symbol
+ #:ensure-package-unused #:delete-package*
+ #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names
+ #:package-definition-form #:parse-define-package-form
+ #:ensure-package #:define-package))
(in-package :asdf/package)
;;;; Final tricks to keep various implementations happy.
(eval-when (:load-toplevel :compile-toplevel :execute)
- #+allegro
+ #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
- :test 'equalp :key 'car)) ; We need that BEFORE any mention of package ASDF.
- #+(or clisp xcl)
+ :test 'equalp :key 'car)))
+
+;; Note that this massive package destruction makes it impossible
+;; to use asdf/driver on top of an old ASDF on these implementations
+#+(or clisp xcl)
+(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (let ((vs (find-symbol* 'version-satisfies :asdf nil))
(av (find-symbol* 'asdf-version :asdf nil)))
(and vs av (funcall vs (funcall av) "2.26.59")))
(delete-package* :asdf t))
(make-package :asdf :use ())))
-
#:*resolve-symlinks*
;; Making and merging pathnames, portably
#:normalize-pathname-directory-component #:denormalize-pathname-directory-component
- #:merge-pathname-directory-components #:make-pathname*
+ #:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type*
#:make-pathname-component-logical #:make-pathname-logical
#:merge-pathnames*
;; Directories
#:pathname-directory-pathname #:pathname-parent-directory-pathname
#:directory-pathname-p #:ensure-directory-pathname
;; Absolute vs relative pathnames
- #:absolute-pathname-p #:ensure-pathname-absolute
+ #:ensure-pathname-absolute
#:relativize-directory-component #:relativize-pathname-directory
;; Parsing filenames and lists thereof
#:component-name-to-pathname-components
- #:split-name-type #:coerce-pathname #:subpathname #:subpathname* #:ensure-pathname*
- #:hidden-file-p
+ #:split-name-type #:parse-unix-namestring #:unix-namestring
+ #:subpathname #:subpathname*
;; Resolving symlinks somewhat
#:truenamize #:resolve-symlinks #:resolve-symlinks*
;; Wildcard pathnames
#:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
;; Pathname host and its root
+ #:absolute-pathname-p #:hidden-pathname-p
#:pathname-root #:directory-separator-for-host
#:directorize-pathname-host-device
;; defaults
#:delete-file-if-exists
;; Translate a pathname
#:translate-pathname*
- #:native-namestring #:parse-native-namestring
;; temporary
#:add-pathname-suffix #:tmpize-pathname
#:call-with-staging-pathname #:with-staging-pathname
- ;; basic pathnames
- #:load-pathname #:default-directory #:root-pathname
;; physical pathnames
- #:physical-pathname-p #:sane-physical-pathname
+ #:physical-pathname-p #:sane-physical-pathname #:root-pathname
;; Windows shortcut support
#:read-null-terminated-string #:read-little-endian
#:parse-file-location-info #:parse-windows-shortcut
+ ;; Checking constraints
+ #:ensure-pathname
;; Output translations
#:*output-translation-function*))
Defaults to T.")
+
;;; The hell of portably making and merging pathnames!
(defun* normalize-pathname-directory-component (directory)
:do (pop reldir) (pop defrev)
:finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
+;; Giving :unspecific as :type argument to make-pathname is not portable.
+;; See CLHS make-pathname and 19.2.2.2.3.
+;; This will be :unspecific if supported, or NIL if not.
+(defparameter *unspecific-pathname-type*
+ #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
+ #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
+
(defun* make-pathname* (&rest keys &key (directory nil directoryp)
host (device () devicep) name type version defaults
#+scl &allow-other-keys)
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
then the HOST and DEVICE both come from the SPECIFIED.
-Also, if either argument is NIL, then the other argument is returned unmodified."
+This is what users want on a modern Unix or Windows operating system,
+unlike the MERGE-PATHNAME behavior.
+Also, if either argument is NIL, then the other argument is returned unmodified;
+this is unlike MERGE-PATHNAME 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
:type (funcall unspecific-handler type)
:version (funcall unspecific-handler version))))))
+;;; Some pathname predicates
+
+(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* hidden-pathname-p (pathname)
+ (and pathname (equal (first-char (pathname-name pathname)) #\.)))
+
;;; Directories
(defun* pathname-directory-pathname (pathname)
(collect-sub*directories subdir collectp recursep collector))))
-
;;; Parsing filenames and lists thereof
-(defun* component-name-to-pathname-components (s &key force-directory force-relative)
- "Splits the path string S, returning three values:
+(defun* component-name-to-pathname-components (unix-style-namestring &key want-directory dot-dot)
+ "Splits the path string UNIX-STYLE-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, suitable for
- use with MAKE-PATHNAME when prepended with the flag
- value.
-A filename with type extension, possibly NIL in the
- case of a directory pathname.
-FORCE-DIRECTORY forces S to be interpreted as a directory
-pathname \(third return value will be NIL, final component
-of S will be treated as part of the directory path.
+ 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.
+WANT-DIRECTORY forces the namestring to be interpreted as a directory pathname:
+the third return value will be NIL, and final component of the namestring
+will be treated as part of the directory path.
+
+An empty string is thus read as meaning a pathname object with all fields nil.
+
+Note that : characters will NOT be interpreted as host specification.
+Absolute pathnames are only appropriate on Unix-style systems.
The intention of this function is to support structured component names,
-e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
-pathnames."
- (check-type s string)
- (when (find #\: s)
- (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
- (let* ((components (split-string s :separator "/"))
- (last-comp (car (last components))))
- (multiple-value-bind (relative components)
- (if (equal (first components) "")
- (if (equal (first-char s) #\/)
- (progn
- (when force-relative
- (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
- (values :absolute (cdr components)))
- (values :relative nil))
- (values :relative components))
- (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
- (setf components (substitute :back ".." components :test #'equal))
- (cond
- ((equal last-comp "")
- (values relative components nil)) ; "" already removed
- (force-directory
- (values relative components nil))
- (t
- (values relative (butlast components) last-comp))))))
+e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
+ (check-type unix-style-namestring string)
+ (check-type dot-dot (member nil :back :up))
+ (if (and (not (find #\/ unix-style-namestring)) (not want-directory)
+ (plusp (length unix-style-namestring)))
+ (values :relative () unix-style-namestring t)
+ (let* ((components (split-string unix-style-namestring :separator "/"))
+ (last-comp (car (last components))))
+ (multiple-value-bind (relative components)
+ (if (equal (first components) "")
+ (if (equal (first-char unix-style-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
+ (want-directory
+ (values relative components nil nil))
+ (t
+ (values relative (butlast components) last-comp nil)))))))
(defun* split-name-type (filename)
- (let ((unspecific
- ;; Giving :unspecific as argument to make-pathname is not portable.
- ;; See CLHS make-pathname and 19.2.2.2.3.
- ;; We only use it on implementations that support it,
- #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
- #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
- (destructuring-bind (name &optional (type unspecific))
- (split-string filename :max 2 :separator ".")
- (if (equal name "")
- (values filename unspecific)
- (values name type)))))
-
-(defun* coerce-pathname (name &key type defaults)
- "coerce NAME into a PATHNAME.
-When given a string, portably decompose it into a relative pathname:
-#\\/ separates subdirectories. The last #\\/-separated string is as follows:
-if TYPE is NIL, its last #\\. if any separates name and type from from type;
-if TYPE is a string, it is the type, and the whole string is the name;
-if TYPE is :DIRECTORY, the string is a directory component;
-if the string is empty, it's a directory.
-Any directory named .. is read as :BACK.
-Host, device and version components are taken from DEFAULTS."
- ;; The defaults are required notably because they provide the default host
- ;; to the below make-pathname, which may crucially matter to people using
- ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
- ;; NOTE that the host and device slots will be taken from the defaults,
- ;; but that should only matter if you later merge relative pathnames with
- ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
- (etypecase name
- ((or null pathname)
- name)
- (symbol
- (coerce-pathname (string-downcase name) :type type :defaults defaults))
- (string
- (multiple-value-bind (relative path filename)
- (component-name-to-pathname-components name :force-directory (eq type :directory)
- :force-relative t)
- (multiple-value-bind (name type)
+ "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 want-directory
+ &allow-other-keys)
+ "Coerce NAME into a PATHNAME using standard Unix syntax.
+
+Unix syntax is used whether or not the underlying system is Unix;
+on such non-Unix systems it is only usable but for relative pathnames;
+but especially to manipulate relative pathnames portably, it is of crucial
+to possess a portable pathname syntax independent of the underlying OS.
+This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
+
+When given a PATHNAME object, just return it untouched.
+When given NIL, just return NIL.
+When given a non-null SYMBOL, first downcase its name and treat it as a string.
+When given a STRING, portably decompose it into a pathname as below.
+
+#\\/ separates directory components.
+
+The last #\\/-separated substring is interpreted as follows:
+if TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
+are separated by SPLIT-NAME-TYPE.
+if TYPE is a string, it is the given TYPE, and the whole string is the NAME;
+if TYPE is :DIRECTORY, 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.
+
+Directory components with an empty name the name . are removed.
+Any directory named .. is read as DOT-DOT, which defaults to :BACK (not :UP).
+
+HOST, DEVICE and VERSION components are taken from DEFAULTS,
+which itself defaults to (ROOT-PATHNAME).
+No host or device can be specified in the string itself,
+which might make it unsuitable for absolute pathnames on Windows.
+
+For relative pathnames, these defaults won't matter if you use MERGE-PATHNAMES*
+but will matter if you use MERGE-PATHNAMES (which you shouldn't).
+
+Arbitrary keys are accepted, that are finally passed to ENSURE-PATHNAME,
+removing TYPE DEFAULTS and DOT-DOT.
+we recommend you use :WANT-RELATIVE T to throw an error if the pathname is absolute
+when you're running portable code and the OS may not be Unixish."
+ (block nil
+ (check-type type (or null string (eql :directory)))
+ (setf want-directory (or want-directory (eq type :directory)))
+ (etypecase name
+ ((or null pathname) (return name))
+ (symbol
+ (setf name (string-downcase name)))
+ (string))
+ (multiple-value-bind (relative path filename file-only)
+ (component-name-to-pathname-components
+ name :dot-dot dot-dot :want-directory want-directory)
+ (multiple-value-bind (name type)
+ (cond
+ ((or want-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 defaults (nil-pathname)))
+ (remove-keys '(:type :dot-dot :defaults) keys))))))
+
+(defun* unix-namestring (pathname)
+ "Given a non-wild PATHNAME, return a Unix-style namestring for it.
+If the PATHNAME is NIL or a STRING, return it unchanged.
+
+This only considers the DIRECTORY, NAME and TYPE components of the pathname.
+This is a portable solution for representing relative pathnames,
+But unless you are running on a Unix system, it is not a general solution
+to representing native pathnames.
+
+An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
+or if it is a PATHNAME but some of its components are not recognized."
+ (etypecase pathname
+ ((or null string) pathname)
+ (pathname
+ (with-output-to-string (s)
+ (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
+ (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
+ (name (pathname-name pathname))
+ (type (pathname-type pathname))
+ (type (and (not (eq type :unspecific)) type)))
(cond
- ((or (eq type :directory) (null filename))
- (values nil nil))
- (type
- (values filename type))
+ ((eq dir ()))
+ ((eq dir '(:relative)) (princ "./" s))
+ ((consp dir)
+ (destructuring-bind (relabs &rest dirs) dir
+ (or (member relabs '(:relative :absolute)) (err))
+ (when (eq relabs :absolute) (princ #\/ s))
+ (loop :for x :in dirs :do
+ (cond
+ ((member x '(:back :up)) (princ "../" s))
+ ((equal x "") (err))
+ ;;((member x '("." "..") :test 'equal) (err))
+ ((stringp x) (format s "~A/" x))
+ (t (err))))))
+ (t (err)))
+ (cond
+ (name
+ (or (and (stringp name) (or (null type) (stringp type))) (err))
+ (format s "~A~@[.~A~]" name type))
(t
- (split-name-type filename)))
- (apply 'make-pathname* :directory (cons relative path) :name name :type type
- (when defaults `(:defaults ,defaults))))))))
+ (or (null type) (err))))))))))
(defun* subpathname (pathname subpath &key type)
- (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
- (pathname-directory-pathname pathname))))
+ "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* absolute-pathname-p (pathspec)
- (and (typep pathspec '(or pathname string))
- (eq :absolute (car (normalize-pathname-directory-component
- (pathname-directory (pathname pathspec)))))))
-
-(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
- (when (plusp (length x))
- (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
- (when want-absolute
- (unless (absolute-pathname-p p)
- (cerror "ignore relative pathname"
- "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
- (return-from ensure-pathname* nil)))
- p)))
-
-(defun* hidden-file-p (pathname)
- (equal (first-char (pathname-name pathname)) #\.))
-
-
;;; Pathname host and its root
(defun* pathname-root (pathname)
(make-pathname* :directory '(:absolute)
(eql x separator)))
root-namestring)))
(multiple-value-bind (relative path filename)
- (component-name-to-pathname-components root-string :force-directory t)
+ (component-name-to-pathname-components root-string :want-directory t)
(declare (ignore relative filename))
(let ((new-base
(make-pathname* :defaults root :directory `(:absolute ,@path))))
(defun* resolve-symlinks (path)
#-allegro (truenamize path)
- #+allegro (if (typep path 'logical-pathname)
- path
- (excl:pathname-resolve-symbolic-links path)))
+ #+allegro
+ (if (physical-pathname-p path)
+ (excl:pathname-resolve-symbolic-links path)
+ path))
(defun* resolve-symlinks* (path)
(if *resolve-symlinks*
(translate-pathname path absolute-source destination))))
-;;; Native vs Lisp syntax
-
-(defun* native-namestring (x)
- "From a CL pathname, a namestring suitable for use by the OS shell"
- (let ((p (pathname x)))
- #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
- #+(or cmu scl) (ext:unix-namestring p nil)
- #+sbcl (sb-ext:native-namestring p)
- #-(or clozure cmu sbcl scl) (namestring p)))
-
-(defun* parse-native-namestring (x)
- "From a native namestring suitable for use by the OS shell, a CL pathname"
- (check-type x string)
- #+clozure (ccl:native-to-pathname x)
- #+sbcl (sb-ext:parse-native-namestring x)
- #-(or clozure sbcl) (parse-namestring x))
-
-
;;; Temporary pathnames
(defun* add-pathname-suffix (pathname suffix)
(make-pathname :name (strcat (pathname-name pathname) suffix)
`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
;;; Basic pathnames
-(defun* load-pathname ()
- (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
-
-(defun* default-directory () ;; A default absolute directory when all else fails.
- (pathname-root (nil-pathname)))
-
(defun* physical-pathname-p (x)
(and (pathnamep x) (not (typep x 'logical-pathname))))
-(defun* sane-physical-pathname (defaults &key (keep t) fallback must-exist)
+(defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing)
(flet ((sanitize (x)
(setf x (and x (ignore-errors (translate-logical-pathname x))))
(when (pathnamep x)
((:root) (pathname-root x))
((:host) (pathname-host-pathname x))
((nil) (nil-pathname x))))
- (when must-exist ;; CCL's probe-file will choke if d-p-d is logical
+ (when want-existing ;; CCL's probe-file will choke if d-p-d is logical
(setf x (and (probe-file* x) x)))
(and (physical-pathname-p x) x))))
(or (sanitize defaults)
(when fallback
- (or (sanitize (ignore-errors (user-homedir-pathname)))
- (sanitize (nil-pathname))))
- (error "Could not find a sanitize ~S ~:[~;or a fallback ~] into a physical pathname"
+ (or (sanitize (nil-pathname))
+ (sanitize (ignore-errors (user-homedir-pathname)))))
+ (error "Could not find a sane a physical pathname~
+ ~@[ from ~S~]~@[~:*~@[ or~*~] fallbacks~]"
defaults fallback))))
+(defun* root-pathname ()
+ "On a Unix system, this will presumably be the root pathname /.
+Otherwise, this will be the root of some implementation-dependent filesystem host."
+ (sane-physical-pathname :keep :root :fallback t))
+
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
(declare (ignore c))
nil)))))
+
+;;; Check pathname constraints
+
+(defun* ensure-pathname
+ (pathname &key want-pathname want-existing
+ want-absolute want-relative want-directory want-file
+ want-wild want-non-wild want-truename truenamize
+ error-arguments)
+ "Coerces its argument into a PATHNAME, and checks 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-NAMESTRING.
+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 ERROR-ARGUMENTS arguments, if provided,
+will be passed on to the error primitive, together with three arguments:
+a string describing the error, that should be followed by a space and
+the pathname to report the error, the keyword that corresponds to that
+constraint name, and the pathname;
+this makes it usable whether you are using the short or long variants of ERROR,
+modulo your error object having to recognize the suitable keyword argument
+in case you use the long variant."
+ (block nil
+ (flet ((report-error (on-error keyword description)
+ (let ((err (append (or error-arguments '("Invalid pathname: ~A~* ~S"))
+ (list description keyword pathname))))
+ (ecase on-error
+ ((error t) (apply 'error err))
+ ((cerror) (apply 'cerror "ignore pathname constraint" err))
+ ((ignore) (return nil))))))
+ (macrolet ((err (constraint format)
+ `(report-error ,constraint ',(intern* constraint :keyword) ,format)))
+ (etypecase pathname
+ (null
+ (when want-pathname
+ (err want-pathname "Expected a pathname, got"))
+ (return nil))
+ (string
+ (setf pathname (parse-namestring pathname)))
+ (pathname))
+ (when want-absolute
+ (unless (absolute-pathname-p pathname)
+ (err want-absolute "Expected an absolute pathname, got")))
+ (when want-relative
+ (when (absolute-pathname-p pathname)
+ (err want-relative "Expected a relative pathname, got")))
+ (when want-directory
+ (unless (directory-pathname-p pathname)
+ (err want-directory "Expected a directory pathname, got")))
+ (when want-file
+ (unless (pathname-name pathname)
+ (err want-file "Expected a file pathname, got")))
+ (when want-wild
+ (unless (wild-pathname-p pathname)
+ (err want-wild "Expected a wildcard pathname, got")))
+ (when (or want-non-wild want-existing)
+ (when (wild-pathname-p pathname)
+ (err want-non-wild "Expected a non-wildcard pathname, got")))
+ (when want-existing
+ (let ((existing (probe-file* pathname)))
+ (if existing
+ (err want-existing "Expected an existing pathname, got")
+ (when (or want-truename truenamize)
+ (return existing)))))
+ (when want-truename
+ (let ((truename (truename* pathname)))
+ (if truename
+ (return truename)
+ (err want-truename "Can't get a truename for pathname"))))
+ (when truenamize
+ (return (truenamize pathname)))
+ pathname))))
+
+
;;; Hook for output translations
(defvar *output-translation-function* 'identity)
#:planned-action-status #:plan-action-status #:action-already-done-p
#:circular-dependency #:circular-dependency-actions
#:node-for #:needed-in-image-p
- #:action-index #:action-planned-p
+ #:action-index #:action-planned-p #:action-valid-p
#:plan-record-dependency #:visiting-action-p
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#:visit-dependencies #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action
- #:traverse-sequentially #:traverse
- #:perform-plan #:plan-operates-on-p))
+ #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p))
(in-package :asdf/plan)
;;;; Planned action status
(etypecase x
((member nil :all) x)
(cons (list-to-hash-set (mapcar #'coerce-name x)))
- ((eql t) (list-to-hash-set (list (coerce-name system))))))
+ ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
(defun* action-override-p (plan operation component override-accessor)
(declare (ignorable operation))
(defclass sequential-plan (plan-traversal)
((actions-r :initform nil :accessor plan-actions-r)))
+(defgeneric* plan-actions (plan))
+(defmethod plan-actions ((plan sequential-plan))
+ (reverse (plan-actions-r plan)))
+
(defmethod plan-record-dependency ((plan sequential-plan)
(operation operation) (component component))
(declare (ignorable plan operation component))
(when (action-planned-p new-status)
(push (cons o c) (plan-actions-r p))))
-(defun* traverse-sequentially (operation component &rest keys &key &allow-other-keys)
- (let ((plan (apply 'make-instance 'sequential-plan :system (component-system component) keys)))
- (traverse-action plan operation component t)
- (reverse (plan-actions-r plan))))
-
;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
(defgeneric* perform-plan (plan &key))
(defgeneric* plan-operates-on-p (plan component))
-(defmethod traverse ((o operation) (c component) &rest keys &key &allow-other-keys)
- (apply 'traverse-sequentially o c keys))
+(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
+ (let ((plan (apply 'make-instance
+ (or plan-class 'sequential-plan)
+ :system (component-system c) (remove-keyword :plan-class keys))))
+ (traverse-action plan o c t)
+ (plan-actions plan)))
(defmethod perform-plan ((steps list) &key)
(let ((*package* *package*)
system-source-registry-directory
default-source-registry))
-(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
-(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
+(defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
+(defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
(defun* wrapping-source-registry ()
`(:source-registry
((:directory)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (resolve-location pathname :directory t)))))
+ (funcall register (resolve-location pathname :want-directory t)))))
((:tree)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (resolve-location pathname :directory t)
+ (funcall register (resolve-location pathname :want-directory t)
:recurse t :exclude *source-registry-exclusions*))))
((:exclude)
(setf *source-registry-exclusions* rest))
#:slurp-stream-string #:slurp-stream-lines
#:slurp-stream-forms #:read-file-string
#:read-file-lines #:read-file-forms
- #:safe-read-first-file-form #:eval-input #:eval-text
+ #:safe-read-first-file-form #:eval-input #:eval-thunk #:standard-eval-thunk
#: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*))
:do (setf results (multiple-value-list (eval form)))
:finally (return (apply 'values results)))))
-(defun* eval-text (text)
- "Evaluate a form, or if a string, read and evaluate from the string."
- (etypecase text
- ((or cons symbol) (eval text))
- (string (eval-input text))))
+(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)))))
;;; Encodings
(:intern #:children #:children-by-name #:default-component-class
#:author #:maintainer #:licence #:source-file #:defsystem-depends-on)
(:export
- #:child-component #:parent-component #:module #:system
+ #:child-component #:parent-component #:module #:system #:proto-system
#:component-children-by-name #:component-children #:compute-children-by-name
#:module-default-component-class
#:system-source-file #:system-source-directory #:system-relative-pathname
;;;; Pathnames
(defmethod component-pathname ((system system))
- (if (or (slot-boundp system 'relative-pathname)
- (slot-boundp system 'absolute-pathname)
- (slot-value system 'source-file))
- (call-next-method)
- (default-directory)))
+ (and (or (slot-boundp system 'relative-pathname)
+ (slot-boundp system 'absolute-pathname)
+ (slot-value system 'source-file))
+ (call-next-method)))
(defgeneric* system-source-file (system)
(:documentation "Return the source file in which system is defined."))
;;; -*- Lisp -*-
(load "script-support.lisp")
+(in-package :asdf-test)
(load-asdf)
+;;(setf *unspecific-pathname-type* nil)
+
#+gcl (trace asdf:compile-file-pathname*)
;;; test asdf pathname specifications
(*print-pretty* nil)
(start-time 0))
- (with-open-file (result-stream (asdf::subpathname
+ (with-open-file (result-stream (subpathname
*build-directory*
(format nil "results/~(~A~)-pathnames.txt" *implementation*))
:direction :output
"module2/module3"
"module2/module3/"
,@(when support-absolute-string-pathnames
- `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1")
- ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/")
- ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/")
- ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/module3/")
- ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/")))))))
+ `(,(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
,(make-pathname :directory '(:relative) :name "untyped-file" :type nil)
"file"
(dolist (module-pathname modules)
(dolist (file-pathname files)
(let ((configuration (list system-pathname module-pathname file-pathname))
- (system-definition `(asdf:defsystem :system1 :pathname ,system-pathname
- :components ((:module :module1 :pathname ,module-pathname
- :components ((:file "file" :pathname ,file-pathname)
- (:file "module2/file" :pathname ,file-pathname)
- ,@(unless (or (typep system-pathname 'logical-pathname)
- (typep module-pathname 'logical-pathname))
- `((:file "typed-file.type" :pathname ,file-pathname)
- (:static-file "static-file.type" :pathname ,file-pathname)
- (:file "module2/typed-file.type" :pathname ,file-pathname)
- (:static-file "module2/static-file.type" :pathname ,file-pathname)
- ,@(when support-absolute-string-pathnames
- `((:static-file ,(concatenate 'string root-directory-namestring
- "asdf-src/system1/module1/file.lisp")
- :pathname ,file-pathname)))))))))))
+ (system-definition
+ `(defsystem :system1
+ :pathname ,system-pathname
+ :source-file ,(subpathname system-pathname "nosuchfile.asd")
+ :components
+ ((:module :module1 :pathname ,module-pathname
+ :components
+ ((:file "file" :pathname ,file-pathname)
+ (:file "module2/file" :pathname ,file-pathname)
+ ,@(unless (or (typep system-pathname 'logical-pathname)
+ (typep module-pathname 'logical-pathname))
+ `((:file "typed-file.type" :pathname ,file-pathname)
+ (:static-file "static-file.type" :pathname ,file-pathname)
+ (:file "module2/typed-file.type" :pathname ,file-pathname)
+ (:static-file "module2/static-file.type" :pathname ,file-pathname)
+ ,@(when support-absolute-string-pathnames
+ `((:static-file ,(strcat root-directory-namestring "asdf-src/system1/module1/file.lisp")
+ :pathname ,file-pathname)))))))))))
(block :test-system
(handler-bind
- ((error (lambda (c)
+ ((error (lambda (c)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
- (asdf::print-condition-backtrace c :stream *error-output*)
+ (print-condition-backtrace c :stream *error-output*)
(format result-stream "~&~%***~%error: ~a~%~s"
c system-definition)
(return-from :test-system))))
pathname))
(test-module (module)
(incf directory-count)
- (unless (asdf::probe-file* (asdf:component-pathname module))
+ (unless (probe-file* (asdf:component-pathname module))
(incf directory-failures)
(push (list (type-of module) (asdf:component-name module)
(translate-if-needed (asdf:component-pathname module))
(error "Not the same: ~S vs ~S" s1 s2))))
(macrolet ((x (s1 s2) `(same ',s1 ',s2 ,s1 ,s2)))
;; we're testing with unix, are we not?
- (x (asdf::resolve-location '(:home)) (truename (user-homedir-pathname)))
- (x (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")
- (x (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/")
- (x (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/"))
- (x (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/"))
+ (x (resolve-location '(:home)) (truename (user-homedir-pathname)))
+ (x (resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")
+ (x (resolve-location '("/foo" "bar" "baz") :want-directory t) #p"/foo/bar/baz/")
+ (x (resolve-location '("/foo" "bar" "baz") :want-directory t :wilden t) (wilden #p"/foo/bar/baz/"))
+ (x (resolve-location '("/foo" "bar" "baz") :want-directory nil :wilden t) (wilden #p"/foo/bar/"))
#-gcl
- (x (asdf::resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))
+ (x (resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :want-directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))
#-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
(or (test-component-pathnames :delete-host t :support-string-pathnames nil)
--- /dev/null
+;; Example executable program
+
+(defsystem :hello-world-example
+ :class :program-system
+ :entry-point "hello:main"
+ :depends-on (:asdf-driver)
+ :translate-output-p nil
+ :components ((:file "hello")))
--- /dev/null
+(defpackage :hello
+ (:use :cl :asdf/driver)
+ (:export #:main))
+
+(in-package :hello)
+
+(defun main (&rest arguments)
+ (format t "hello, world~%")
+ (when arguments
+ (format t "You passed ~D arguments:~%~{ ~S~%~}" (length arguments) arguments)))
--- /dev/null
+;;; -*- Lisp -*-
+(load "script-support.lisp")
+(load-asdf)
+
+(with-test ()
+ (operate 'program-op :hello-world-example))
exit 43
fi
-ASDFDIR="$(cd .. ; /bin/pwd)"
+ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)"
export CL_SOURCE_REGISTRY="${ASDFDIR}"
export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)"
return 1
}
run_upgrade_tests () {
+ cd ${ASDFDIR}
su=test/script-support.lisp
for tag in `upgrade_tags` ; do
for method in `upgrade_methods` ; do
fi ; done ; done 2>&1 | tee build/results/${lisp}-upgrade.text
}
run_tests () {
+ cd ${ASDFDIR}/test
create_config
mkdir -p ../build/results
echo failure > ../build/results/status
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 asdf/driver or asdf,
+ so we may use-package them during testing.
|#
(defpackage :asdf-test
#:with-test #:test-asdf #:debug-asdf
#:assert-compare
#:assert-equal
- #:leave-test
+ #:leave-test #:def-test-system
#:quietly))
(in-package :asdf-test)
(defun acall (name &rest args)
(apply (asym name) args))
-(defun finish-outputs ()
+(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)
+ (finish-outputs*)
(setf *error-output* *standard-output*
*trace-output* *standard-output*))
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
- (finish-outputs)
+ (finish-outputs*)
#+(or abcl xcl) (ext:quit :status code)
#+allegro (excl:exit code :quiet t)
#+clisp (ext:quit code)
#+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)))
+ (quit* (find-symbol "QUIT" :sb-ext)))
(cond
(exit `(,exit :code code :abort t))
- (quit `(,quit :unix-status code :recklessly-p t))))
+ (quit* `(,quit* :unix-status code :recklessly-p t))))
#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
(defun leave-test (message return)
- (finish-outputs)
+ (finish-outputs*)
(fresh-line *error-output*)
(when message
(format *error-output* message)
(fresh-line *error-output*))
- (finish-outputs)
+ (finish-outputs*)
(throw :asdf-test-done return))
(defmacro with-test ((&optional) &body body)
((error (lambda (c)
(ignore-errors
(format *error-output* "~&TEST ABORTED: ~A~&" c))
- (finish-outputs)
+ (finish-outputs*)
(cond
(*debug-asdf*
(format t "~&It's your baby, fix it!~%")
(defun load-asdf (&optional tag)
(load-asdf-fasl tag)
(use-package :asdf :asdf-test)
+ (use-package :asdf/driver :asdf-test)
(configure-asdf)
(setf *package* (find-package :asdf-test)))
;; Actual scripts rely on this function:
(defun common-lisp-user::load-asdf () (load-asdf))
+(setf *package* (find-package :asdf-test))
+
+(defmacro def-test-system (name &rest rest)
+ `(apply (asym :register-system-definition) ',name :pathname ,*test-directory*
+ :source-file nil ',rest))
+
;; These are shorthands for interactive debugging of test scripts:
(!a
common-lisp-user::debug-asdf debug-asdf
(funcall thunk)))
(with-test ()
- (defsystem test-around-compile
- :around-compile call-in-base-2
- ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that.
- :components ((:file "test")))
- (load-system 'test-around-compile :force t)
- (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2
+ (def-test-system test-around-compile
+ :around-compile call-in-base-2
+ ;; :depends-on ((:version :asdf "2.017.18")) ; no :around-compile before that.
+ :components ((:file "test")))
+ (load-system 'test-around-compile :force t)
+ (assert (= 3 (funcall 'add10 1)))) ;; add10 must have been compiled in base 2
(with-test ()
(format t "~D~%" (asdf:asdf-version))
- (defsystem test-builtin-source-file-type-1
+ (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
'("lisp" "cl"))
(delete-package :test-package)
- (defsystem test-builtin-source-file-type-2
+ (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
(asdf:load-system 'test-builtin-source-file-type-2 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
- (defsystem test-builtin-source-file-type-3
+ (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
'("lisp" "cl"))
(delete-package :test-package)
- (defsystem test-builtin-source-file-type-4
+ (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
;;; Check to see if the bundle functionality is doing something.
;;;---------------------------------------------------------------------------
-
(with-test ()
- (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration))
- (asdf:clear-system :test-bundle-1)
- (asdf:clear-system :test-bundle-2)
- (when (find-package :test-package) (delete-package :test-package))
- (asdf:defsystem :test-bundle-1 :components ((:file "file1") (:file "file3")))
- (asdf:defsystem :test-bundle-2 :depends-on (:test-bundle-1) :components ((:file "file2")))
- #-(or abcl (and ecl ecl-bytecmp) gcl)
- (let* ((op (make-instance 'asdf::fasl-op))
- (bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
- (bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
- (DBG :test-bundle bundle-1 bundle-2)
- (asdf::delete-file-if-exists bundle-1)
- (asdf::delete-file-if-exists bundle-2)
- (asdf:operate 'asdf:load-fasl-op :test-bundle-2)
- ;; Check that the bundles were indeed created.
- (assert (probe-file bundle-1))
- (assert (probe-file bundle-2))
- ;; Check that the files were indeed loaded.
- (assert (symbol-value (asdf::find-symbol* :*file1* :test-package)))
- (assert (symbol-value (asdf::find-symbol* :*file3* :test-package)))))
+ (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration))
+ (asdf:clear-system :test-bundle-1)
+ (asdf:clear-system :test-bundle-2)
+ (when (find-package :test-package) (delete-package :test-package))
+ (eval `(def-test-system :test-bundle-1
+ :pathname ,*test-directory*
+ :components ((:file "file1") (:file "file3"))))
+ (eval `(def-test-system :test-bundle-2
+ :pathname ,*test-directory*
+ :depends-on (:test-bundle-1) :components ((:file "file2"))))
+ #-(or abcl (and ecl ecl-bytecmp) gcl)
+ (let* ((op (make-instance 'asdf::fasl-op))
+ (bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
+ (bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
+ (DBG :test-bundle bundle-1 bundle-2)
+ (asdf::delete-file-if-exists bundle-1)
+ (asdf::delete-file-if-exists bundle-2)
+ (asdf:operate 'asdf:load-fasl-op :test-bundle-2)
+ ;; Check that the bundles were indeed created.
+ (assert (probe-file bundle-1))
+ (assert (probe-file bundle-2))
+ ;; Check that the files were indeed loaded.
+ (assert (symbol-value (asdf::find-symbol* :*file1* :test-package)))
+ (assert (symbol-value (asdf::find-symbol* :*file3* :test-package)))))
(load-asdf)
(with-test ()
- (defsystem :test-concatenate-source
+ (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))))))
- (let ((mcso (asdf::make-operation 'asdf::monolithic-concatenate-source-op))
- (mccso (asdf::make-operation 'asdf::monolithic-compile-concatenated-source-op))
- (mlccso (asdf::make-operation 'asdf::monolithic-load-compiled-concatenated-source-op))
+ (let ((mcso (make-operation 'monolithic-concatenate-source-op))
+ (mccso (make-operation 'monolithic-compile-concatenated-source-op))
+ (mlccso (make-operation 'monolithic-load-compiled-concatenated-source-op))
(sys (find-system :test-concatenate-source)))
- (assert (asdf::operation-monolithic-p mcso))
+ (assert (operation-monolithic-p mcso))
(assert-equal ;; on CLISP, we get un-equal pathnames with same namestrings. Sigh.
(princ-to-string (input-files mcso sys))
(princ-to-string (loop :for n :in '(3 1 2)
- :collect (asdf::subpathname *test-directory* (format nil "file~D.lisp" n)))))
+ :collect (subpathname *test-directory* (format nil "file~D.lisp" n)))))
(assert-equal
(output-file mcso sys)
- (apply-output-translations (asdf::subpathname *test-directory* "test-concatenate-source.lisp")))
+ (apply-output-translations
+ (subpathname *test-directory*
+ "test-concatenate-source.all-systems.lisp")))
(assert-equal
(output-files mcso sys)
(input-files mccso sys))
(assert-equal ;; on ECL, we get un-equal pathnames.
(princ-to-string (output-file mccso sys))
- (princ-to-string (apply-output-translations (compile-file-pathname (asdf::subpathname *test-directory* "test-concatenate-source.lisp")))))
+ (princ-to-string (apply-output-translations
+ (compile-file-pathname
+ (subpathname *test-directory*
+ "test-concatenate-source.all-systems.lisp")))))
(assert-equal
(output-files mccso sys)
(input-files mlccso sys))
- (operate 'asdf::monolithic-load-compiled-concatenated-source-op sys)
- (assert (symbol-value (asdf::find-symbol* :*file3* :test-package)))))
+ (operate 'monolithic-load-compiled-concatenated-source-op sys)
+ (assert (symbol-value (find-symbol* :*file3* :test-package)))))
#+sbcl sb-impl::*default-external-format*
#-(or clozure sbcl) (error "can't determine default external-format")))))
-(defmacro with-encoding-test ((encoding &key (op 'asdf:load-source-op) (path "lambda")) defsystem &body body)
- (let ((sys (second defsystem)))
+(defmacro with-encoding-test ((encoding &key (op 'asdf:load-source-op) (path "lambda")) def-test-system &body body)
+ (let ((sys (second def-test-system)))
`(progn
(format t "~&Test ~A: should be ~A~%" ',sys ',encoding)
(setf *lambda-string* nil)
- ,defsystem
+ ,def-test-system
(let ((c (asdf:find-component ',sys ',path)))
(assert-equal (asdf:component-encoding c) ',encoding)
(loop :for o :in (asdf:output-files (asdf::make-operation 'asdf:compile-op) c)
:do (asdf::delete-file-if-exists o)))
,@(when op
- `((asdf:operate ',op ',(second defsystem))))
+ `((asdf:operate ',op ',(second def-test-system))))
,@body
(eval `(assert-equal (string-char-codes ,*lambda-string*)
(expected-char-codes ',',encoding))))))
(with-test ()
(with-encoding-test (:utf-8)
- (defsystem :test-encoding-explicit-u8
+ (def-test-system :test-encoding-explicit-u8
:components ((:file "lambda" :encoding :utf-8))))
#-asdf-unicode
(progn
#+sbcl (setf sb-impl::*default-external-format* :latin-3)
(with-encoding-test (:default)
- (defsystem :test-encoding-explicit-default
+ (def-test-system :test-encoding-explicit-default
:components ((:file "lambda" :encoding :default))))
(with-encoding-test (:default)
- (defsystem :test-encoding-implicit-default
+ (def-test-system :test-encoding-implicit-default
:components ((:file "lambda")))))
- ;; BEWARE: For testing purposes, we assume ASDF-ENCODINGS is under the same root as ASDF.
- (pushnew (asdf::subpathname *asdf-directory* "../asdf-encodings/") asdf:*central-registry*)
+ ;; Try to load asdf-encodings
+ (setf *central-registry*
+ (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF
+ ;; try finding asdf-encodings it right next to asdf.
+ (subpathname *asdf-directory* "../asdf-encodings/")))
(unless (find-system :asdf-encodings nil)
- (leave-test "ASDF-ENCODINGS is not installed next to ASDF. Skipping the rest the test." 0))
+ ;; 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))
+
(asdf:load-system :asdf-encodings)
#-lispworks
(with-encoding-test (:latin-2)
- (defsystem :test-encoding-implicit-autodetect
+ (def-test-system :test-encoding-implicit-autodetect
:components ((:file "lambda"))))
#+sbcl
(with-encoding-test (:koi8-r)
- (defsystem :test-encoding-explicit-koi8-r
+ (def-test-system :test-encoding-explicit-koi8-r
:components ((:file "lambda" :encoding :koi8-r))))
(with-encoding-test (:utf-8)
- (defsystem :test-file-encoding-u8
+ (def-test-system :test-file-encoding-u8
:encoding :latin-1
:components ((:file "lambda" :encoding :utf-8))))
(with-encoding-test (:latin-1)
- (defsystem :test-file-encoding-l1
+ (def-test-system :test-file-encoding-l1
:encoding :utf-8
:components ((:file "lambda" :encoding :latin-1))))
(with-encoding-test (:utf-8 :op asdf:load-source-op)
- (defsystem :test-system-encoding-u8
+ (def-test-system :test-system-encoding-u8
:encoding :utf-8
:components ((:file "lambda"))))
(with-encoding-test (:utf-8 :op asdf:load-op)
- (defsystem :test-system-encoding-u8-load-op
+ (def-test-system :test-system-encoding-u8-load-op
:encoding :utf-8
:components ((:file "lambda"))))
(with-encoding-test (:latin-1)
- (defsystem :test-system-encoding-l1
+ (def-test-system :test-system-encoding-l1
:encoding :latin-1
:components ((:file "lambda"))))
#-ecl-bytecmp
(with-encoding-test (:latin-1 :op asdf:load-op)
- (defsystem :test-system-encoding-l1-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"))
- (defsystem :test-module-encoding-u8
+ (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"))
- (defsystem :test-module-encoding-l1
+ (def-test-system :test-module-encoding-l1
:encoding :utf-8
:components
((:module "foo" :pathname "" :encoding :latin-1
(load-asdf)
(with-test ()
- (asdf:defsystem test-missing-lisp-file
+ (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")))
(with-test ()
- (defsystem :test-module-excessive-depend
+ (def-test-system :test-module-excessive-depend
:components ((:file "file1")
(:module "quux"
:pathname ""
(with-test ()
(asdf:load-system 'test-module-pathnames)
(flet ((pathname-foo (x)
- (list (or (asdf::normalize-pathname-directory-component (pathname-directory x)) '(:relative))
+ (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"))))
() "symbol `*file-tmp*` has wrong value")
(assert (probe-file
- (asdf::apply-output-translations
- (asdf::merge-pathnames*
- (asdf::make-pathname*
+ (apply-output-translations
+ (merge-pathnames*
+ (make-pathname*
:name "file1"
- :type (asdf::fasl-type)
+ :type (compile-file-type)
:directory '(:relative "sources" "level1"))
*test-directory*)))
() "compiled file not found")
() "symbol `*file-tmp2*` has wrong value")
(assert (probe-file
- (asdf::apply-output-translations
- (asdf::merge-pathnames*
- (asdf::make-pathname*
+ (apply-output-translations
+ (merge-pathnames*
+ (make-pathname*
:name "file2"
- :type (asdf::fasl-type)
+ :type (compile-file-type)
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found"))
--- /dev/null
+;;; -*- Lisp -*-
+(load "script-support.lisp")
+(load-asdf)
+
+(with-test ()
+
+ (DBG :foo (current-lisp-file-pathname))
+
+ (let ((exe (output-file (make-operation 'program-op) (find-system :hello-world-example))))
+ (assert (absolute-pathname-p exe))
+
+ (unless (and #-(or clisp clozure cmu ecl lispworks sbcl) nil
+ #+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))
+
+ ;; Try to load lisp-invocation from xcvb
+ (setf *central-registry*
+ (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF
+ ;; try finding xcvb's lisp-invocation right next to asdf.
+ (subpathname *asdf-directory* "../xcvb/")))
+ (unless (find-system :lisp-invocation nil)
+ ;; try harder by enabling the user's source-registry
+ (initialize-source-registry ""))
+ (unless (find-system :lisp-invocation nil)
+ (leave-test "Couldn't find lisp-invocation. Skipping the rest the test." 0))
+ (load-system :lisp-invocation)
+ ;; Disable any user source registry.
+ (initialize-source-registry `(:source-registry :ignore-inherited-configuration))
+
+ (delete-file-if-exists exe)
+ (run-program/
+ (symbol-call :lisp-invocation :lisp-invocation-arglist
+ :load (subpathname *test-directory* "make-hello-world.lisp")))
+ (assert (probe-file* exe))
+
+ (assert-equal (run-program/ (unix-namestring exe) :output :lines)
+ '("hello, world"))
+
+ t))
(with-test ()
- (let ((s '(defsystem static-and-serial
+ (let ((s '(def-test-system static-and-serial
:version "0.1"
:serial t
:components
() "symbol `*file-tmp*` has wrong value")
(assert (probe-file
- (asdf::apply-output-translations
- (asdf::merge-pathnames*
- (asdf::make-pathname*
+ (apply-output-translations
+ (merge-pathnames*
+ (make-pathname*
:name "file1"
- :type (asdf::fasl-type)
+ :type (compile-file-type)
:directory '(:relative "sources" "level1"))
*test-directory*)))
() "compiled file not found")
nil "symbol `*file-tmp2*` has wrong value")
(assert (probe-file
- (asdf::apply-output-translations
- (asdf::merge-pathnames*
- (asdf::make-pathname*
+ (apply-output-translations
+ (merge-pathnames*
+ (make-pathname*
:name "file2"
- :type (asdf::fasl-type)
+ :type (compile-file-type)
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found"))
(make-pathname* :type "" :directory '(:absolute "tmp"))
;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
;; and some implementations will enforce it.
-;; (make-pathname :type :unspecific :directory '(:absolute "tmp"))
-;; (make-pathname :name :unspecific :directory '(:absolute "tmp"))
-;; (make-pathname :name :unspecific :directory '(:absolute "tmp"))
- )))
+ (make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp"))
+ (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))
+ (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
(assert
(every (complement #'directory-pathname-p)
(list
(make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
(make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
-;; These are funky and non portable. Omit from tests.
+;; These are funky and non portable, omit from tests:
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
-(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory t))
- '(:relative nil nil)))
-(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory nil))
- '(:relative nil nil)))
-(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory t))
- '(:absolute nil nil)))
-(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory nil))
- '(:absolute nil nil)))
-(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory t))
- '(:absolute ("aa" "ba") nil)))
-(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory nil))
- '(:absolute ("aa") "ba")))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "" :want-directory t))
+ '(:relative nil nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "" :want-directory nil))
+ '(:relative nil nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :want-directory t))
+ '(:absolute nil nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :want-directory nil))
+ '(:absolute nil nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :want-directory t))
+ '(:absolute ("aa" "ba") nil nil)))
+(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :want-directory nil))
+ '(:absolute ("aa") "ba" nil)))
(assert
(version-satisfies (asdf-version) (asdf-version)))
(assert
(version-satisfies (asdf-version) "2.000"))
(assert
(not (version-satisfies (asdf-version) "666")))
-(assert
- (equal (asdf::split-pathnames* "foo:bar" nil nil "baz") '(#p"foo" #p"bar")))
-(assert
- (equal (asdf::split-pathnames* "foo:bar" nil t "baz") '(#p"foo/" #p"bar/")))
-(assert
- (equal (asdf::split-pathnames* "/foo:/bar" t nil "baz") '(#p"/foo" #p"/bar")))
-(assert
- (equal (asdf::split-pathnames* "/foo:/bar" t t "baz") '(#p"/foo/" #p"/bar/")))
-(assert (equal (mapcar 'asdf::location-function-p
- '((:function f)
- (:function (lambda (path absolute-source)
- (declare (ignore absolute-source))
- path))
- (function previous-isnt-keyword)
- (:function f too many arguments)
- (:function (:lambda isnt lambda))
- (:function (lambda (too many args) blah))))
- '(t t nil nil nil nil)))
-)
+(assert-equal
+ (mapcar 'namestring (split-native-pathnames-string "foo:bar"))
+ '("foo" "bar"))
+(assert-equal
+ (mapcar 'namestring (split-native-pathnames-string "foo:bar" :want-directory t))
+ '("foo/" "bar/"))
+(assert-equal
+ (mapcar 'namestring (split-native-pathnames-string "/foo:/bar" :want-absolute t))
+ '("/foo" "/bar"))
+(assert-equal
+ (mapcar 'namestring (split-native-pathnames-string "/foo:/bar" :want-absolute t :want-directory t))
+ '("/foo/" "/bar/"))
+(assert-equal
+ (mapcar 'location-function-p
+ '((:function f)
+ (:function (lambda (path absolute-source)
+ (declare (ignore absolute-source))
+ path))
+ (function previous-isnt-keyword)
+ (:function f too many arguments)
+ (:function (:lambda isnt lambda))
+ (:function (lambda (too many args) blah))))
+ '(t t nil nil nil nil)))
(setf *central-registry* '(*default-pathname-defaults*))
(with-test ()
- (defsystem :versioned-system-1
+ (def-test-system :versioned-system-1
:pathname #.*default-pathname-defaults*
:version "1.0")
- (defsystem :versioned-system-2
+ (def-test-system :versioned-system-2
:pathname #.*default-pathname-defaults*
:version "1.1")
- (defsystem :versioned-system-3
+ (def-test-system :versioned-system-3
:pathname #.*default-pathname-defaults*
:version "1.2")
(load-asdf)
(with-test ()
(load (asdf::subpathname *asdf-directory* "contrib/wild-modules.lisp"))
- (asdf:defsystem :wild-module
+ (def-test-system :wild-module
:version "0.0"
:components ((:wild-module "systems" :pathname #p"*.asd")))
#-gcl<2.7
#:ensure-function #:call-function #:call-functions #:register-hook-function ;; functions
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
- #:eval-text #:load-string #:load-stream
+ #:load-string #:load-stream
#:parse-version #:unparse-version #:version-compatible-p)) ;; version
(in-package :asdf/utility)
;;; Magic debugging help. See contrib/debug.lisp
(defvar *asdf-debug-utility*
- '(symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp")
+ '(ignore-errors (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
"form that evaluates to the pathname to your favorite debugging utilities")
-(defmacro asdf-debug (&optional package utility-file)
+(defmacro asdf-debug (&rest keys)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (load-asdf-debug-utility ',package ',utility-file)))
+ (load-asdf-debug-utility ,@keys)))
-(defun* load-asdf-debug-utility (&optional package utility-file)
+(defun* load-asdf-debug-utility (&key package utility-file)
(let* ((*package* (if package (find-package package) *package*))
(keyword (read-from-string
(format nil ":DBG-~:@(~A~)" (package-name *package*)))))
common-lisp.net / projects/asdf/asdf.git / commitdiff
