diff --git a/.gitignore b/.gitignore index 08d5a1db688868a96b7618717c83bb90d3e547e2..5fb9699049bc031545bf278c639b57465c3c4a50 100644 --- a/.gitignore +++ b/.gitignore @@ -37,6 +37,7 @@ tmp/ *.~*~ test/try-reloading-dependency.asd test/fileMissing.lisp +test/hello-world-example build-stamp debian/cl-asdf.debhelper.log diff --git a/Makefile b/Makefile index 4f0b416c8e457d648c2e406b7ce9273496993299..7283ab1f62129a30d68c8097c53f7a5a20762096 100644 --- a/Makefile +++ b/Makefile @@ -4,17 +4,24 @@ webhome_public := "http://common-lisp.net/project/asdf/" clnet_home := "/project/asdf/public_html/" sourceDirectory := $(shell pwd) +#### Common Lisp implementations available for testing. +## export ASDF_TEST_LISPS to override the default list of such implementations, +## or specify a lisps= argument at the make command-line ifdef ASDF_TEST_LISPS lisps ?= ${ASDF_TEST_LISPS} else lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern xcl gcl endif +## NOT SUPPORTED BY OUR AUTOMATED TESTS: +## cormancl genera lispworks-personal-edition mkcl rmcl +## Some are manually tested once in a while. +## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen. +## grep for #+/#- features in the test/ directory to see plenty of disabled tests. +## Make sure testing remains within the confines of this filesystem tree export ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/build/fasls" :implementation)) :ignore-inherited-configuration) export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration) -## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but upstream fails to compile. -## NOT SUPPORTED BY OUR TESTS: cormancl genera lispworks-personal-edition mkcl rmcl. Manually tested once in a while. lisp ?= sbcl @@ -37,10 +44,15 @@ XCL ?= xcl driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp driver.lisp asdf_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp +# Making ASDF itself should be our first, default, target: build/asdf.lisp: $(wildcard *.lisp) mkdir -p build cat $(driver_lisp) $(asdf_lisp) > $@ +# This quickly locates such mistakes as unbalanced parentheses: +load: + rlwrap sbcl `for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done` + install: archive-copy archive: @@ -56,18 +68,13 @@ archive-copy: archive build/asdf.lisp ${MAKE} push git checkout master +### Count lines separately for asdf-driver and asdf itself: wc: @wc $(driver_lisp) | sort -n ; echo ; \ wc $(asdf_lisp) | sort -n ; \ echo ; \ wc $(driver_lisp) $(asdf_lisp) | tail -n 1 -wc-driver: - wc $(driver_lisp) - -wc-asdf: - wc $(asdf_lisp) - push: git status git push --tags cl.net release master @@ -136,12 +143,12 @@ debian-package: mrproper : $${RELEASE:="$$(git tag -l '2.[0-9][0-9]' | tail -n 1)"} ; \ git-buildpackage --git-debian-branch=release --git-upstream-branch=$$RELEASE --git-tag --git-retag --git-ignore-branch -# Replace SBCL's ASDF with the current one. -- Not recommended now that SBCL has ASDF2. +# Replace SBCL's ASDF with the current one. -- NOT recommended now that SBCL has ASDF2. # for casual users, just use (asdf:load-system :asdf) replace-sbcl-asdf: build/asdf.lisp ${SBCL} --eval '(compile-file "$<" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)' -# Replace CCL's ASDF with the current one. -- Not recommended now that CCL has ASDF2. +# Replace CCL's ASDF with the current one. -- NOT recommended now that CCL has ASDF2. # for casual users, just use (asdf:load-system :asdf) replace-ccl-asdf: build/asdf.lisp ${CCL} --eval '(progn(compile-file "$<" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))' @@ -150,6 +157,7 @@ WRONGFUL_TAGS := 1.37 1.1720 README RELEASE STABLE # Delete wrongful tags from local repository fix-local-git-tags: for i in ${WRONGFUL_TAGS} ; do git tag -d $$i ; done + git tag 1.37 c7738c62 # restore the *correct* 1.37 tag. # Delete wrongful tags from remote repository fix-remote-git-tags: diff --git a/action.lisp b/action.lisp index 9fb908c343d8b8317c86935857873860db175845..ad0d6dfb9a86602e8ddad2e774fa3c37a5298d45 100644 --- a/action.lisp +++ b/action.lisp @@ -112,10 +112,17 @@ You can put together sentences using this phrase.")) "Translate output files, unless asked not to" operation component ;; hush genera, not convinced by declare ignorable(!) (values - (multiple-value-bind (files fixedp) (call-next-method) - (if fixedp - files - (mapcar *output-translation-function* files))) + (multiple-value-bind (pathnames fixedp) (call-next-method) + ;; 1- Make sure we have absolute pathnames + (let* ((directory (pathname-directory-pathname (component-pathname component))) + (absolute-pathnames + (loop :for pathname :in pathnames + :collect (ensure-pathname + (subpathname directory pathname) :want-absolute t)))) + ;; 2- Translate those pathnames as required + (if fixedp + absolute-pathnames + (mapcar *output-translation-function* absolute-pathnames)))) t)) (defmethod output-files ((o operation) (c component)) (declare (ignorable o c)) diff --git a/asdf-driver.asd b/asdf-driver.asd index 425dfe004c0244d52c6da09eb2504863bdf12dbe..183f35ca90d15ffd0fe4f31fd71e0b4c66a83843 100644 --- a/asdf-driver.asd +++ b/asdf-driver.asd @@ -1,4 +1,9 @@ ;;; -*- mode: lisp -*- +(defpackage :asdf-driver-system (:use :cl :asdf)) + +(defun call-without-redefinition-warnings (thunk) + (handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning)) + (funcall thunk))) (defsystem :asdf-driver :licence "MIT" @@ -6,6 +11,8 @@ :long-description "Basic general-purpose utilities that is in such a need that you can't portably construct a complete program without using them." #+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr") + :defsystem-depends-on (#+(and (not asdf2.27) (or clisp xcl)) :asdf) + :around-compile call-without-redefinition-warnings :components ((:file "header") (:file "package") diff --git a/asdf.asd b/asdf.asd index 3fba33a41e8f4c1b2fad09ee8ec9e6393d991750..10fff7e75e9fa24ca5e0a9b4a6aa9d1ba647f9dd 100644 --- a/asdf.asd +++ b/asdf.asd @@ -15,7 +15,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.99" ;; to be automatically updated by bin/bump-revision + :version "2.26.100" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) diff --git a/backward-interface.lisp b/backward-interface.lisp index f77e566c6fd6e515bb6398fde4ef57ba06ba3db5..55945008c8e4a314d5338fd88e8fe738f42465a7 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -10,7 +10,6 @@ #:*asdf-verbose* #:component-load-dependencies #:enable-asdf-binary-locations-compatibility - #:merge-component-name-type #:operation-forced #:operation-on-failure #:operation-on-warnings @@ -22,11 +21,12 @@ ;; Old deprecated name for the same thing. Please update your software. (component-sibling-dependencies component)) -(defun* merge-component-name-type (name &key type defaults) - ;; For backward-compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.016. - (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") - (coerce-pathname name :type type :defaults defaults)) +(defun* coerce-pathname (name &key type defaults) + ;; For backward-compatibility only, for people using internals + ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb + ;; Will be removed in a future release, e.g. 2.30. + (warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.") + (parse-unix-namestring name :type type :defaults defaults)) (defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader. (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) @@ -71,7 +71,7 @@ if that's whay you mean." ;;) #+(or clisp ecl mkcl) (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) - (let* ((fasl-type (fasl-type)) + (let* ((fasl-type (compile-file-type)) (mapped-files (if map-all-source-files *wild-file* (make-pathname :type fasl-type :defaults *wild-file*))) (destination-directory diff --git a/bundle.lisp b/bundle.lisp index 93e3f0c66e867a22467e08591c8e26d1f9d0f83e..49e929aa9ee20cc9d354887a0069e90f3b50ae40 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -7,41 +7,52 @@ :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 @@ -51,27 +62,98 @@ (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 @@ -89,10 +171,10 @@ &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 @@ -102,7 +184,7 @@ (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) @@ -114,22 +196,42 @@ (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)) @@ -140,15 +242,6 @@ (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, @@ -157,68 +250,59 @@ ;;; ;;; 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)) @@ -234,7 +318,7 @@ (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) @@ -263,8 +347,8 @@ (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))) @@ -280,7 +364,7 @@ (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 @@ -315,68 +399,36 @@ (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" @@ -389,15 +441,14 @@ (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 @@ -412,26 +463,9 @@ (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)) @@ -442,20 +476,17 @@ (asdf:load-system :precompiled-asdf-utils) |# -#+ecl -(defmethod output-files ((o fasl-op) (c system)) - (declare (ignorable o c)) - (loop :for file :in (call-next-method) - :collect (make-pathname :type "fasb" :defaults file))) - #+ecl (defmethod perform ((o bundle-op) (c system)) (let* ((object-files (remove "fas" (input-files o c) :key #'pathname-type :test #'string=)) (output (output-files o c))) - (apply #'c::builder (bundle-op-type o) (first output) + (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))) @@ -465,51 +496,17 @@ #+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) diff --git a/component.lisp b/component.lisp index 3648e9a560e79f833a4a3dff7f29de8bc4ac645c..3cc8bef7d7ca40ba034cbaf73e862553450ec0f6 100644 --- a/component.lisp +++ b/component.lisp @@ -138,10 +138,11 @@ another pathname in a degenerate way.")) pathname))) (defmethod component-relative-pathname ((component component)) - (coerce-pathname + (parse-unix-namestring (or (and (slot-boundp component 'relative-pathname) (slot-value component 'relative-pathname)) (component-name component)) + :want-relative t :type (source-file-type component (component-system component)) ;; backward-compatibility :defaults (component-parent-pathname component))) diff --git a/concatenate-source.lisp b/concatenate-source.lisp index b150d5efbb8b2ce54890589c19a4e3d27302af32..8aa596b420aa4a48683c2b4842e94009be20d8e9 100644 --- a/concatenate-source.lisp +++ b/concatenate-source.lisp @@ -17,76 +17,59 @@ #:monolithic-compile-concatenated-source-op #:monolithic-load-compiled-concatenated-source-op #:concatenated-source-system - #:system-concatenated-source-file - #:system-translate-output-p - #:translate-output-p #:concatenated-source-file)) + #:component-concatenated-source-file + #:concatenated-source-file)) (in-package :asdf/concatenate-source) ;;; ;;; Concatenate sources ;;; -(defclass concatenate-source-op (operation) ()) -(defclass load-concatenated-source-op (basic-load-op operation) ()) -(defclass compile-concatenated-source-op (basic-compile-op operation) ()) -(defclass load-compiled-concatenated-source-op (basic-load-op operation) ()) +(defclass concatenate-source-op (bundle-op) + ((bundle-type :initform "lisp"))) +(defclass load-concatenated-source-op (basic-load-op operation) + ((bundle-type :initform :no-output-file))) +(defclass compile-concatenated-source-op (basic-compile-op bundle-op) + ((bundle-type :initform :fasl))) +(defclass load-compiled-concatenated-source-op (basic-load-op operation) + ((bundle-type :initform :no-output-file))) + (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) -(defclass concatenated-source-system (system) - ((concatenated-source-file - :initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file) - (translate-output-p - :initform t :initarg :translate-output-p :reader system-translate-output-p))) - -(defmethod system-concatenated-source-file ((s system)) - (declare (ignorable s)) - nil) -(defmethod system-translate-output-p ((s system)) - (declare (ignorable s)) - t) +(defclass concatenated-source-system (bundle-system) + ((bundle-pathname :initarg :concatenated-source-file) + (bundle-operation :initform :load-compiled-concatenated-source-op))) -(defmethod input-files ((o concatenate-source-op) (s system)) - (loop :with op = (make-operation 'compile-op) - :with components = (gather-components op s - :include-self nil - :filter-type 'source-file - :other-systems (operation-monolithic-p o)) - :with non-cl-source-files = nil - :with encoding = (or (component-encoding s) *default-encoding*) +(defmethod input-files ((operation concatenate-source-op) (s system)) + (loop :with encoding = (or (component-encoding s) *default-encoding*) :with other-encodings = '() :with around-compile = (around-compile-hook s) :with other-around-compile = '() - :for (o . c) :in components - :do (cond - ((typep c 'cl-source-file) - (let ((e (component-encoding c))) - (unless (equal e encoding) - (pushnew e other-encodings :test 'equal))) - (let ((a (around-compile-hook c))) - (unless (equal a around-compile) - (pushnew a other-around-compile :test 'equal)))) - (t - (push c non-cl-source-files))) - :append (input-files o c) :into inputs + :for c :in (gather-components s + :goal-operation 'compile-op + :keep-operation 'compile-op + :component-type 'component + :other-systems (operation-monolithic-p operation)) + :append + (when (typep c 'cl-source-file) + (let ((e (component-encoding c))) + (unless (equal e encoding) + (pushnew e other-encodings :test 'equal))) + (let ((a (around-compile-hook c))) + (unless (equal a around-compile) + (pushnew a other-around-compile :test 'equal))) + (input-files (make-operation 'compile-op) c)) :into inputs :finally - (when non-cl-source-files - (warn "~S depends on these non CL source files: ~A" - 'concatenated-source-op non-cl-source-files)) (when other-encodings (warn "~S uses encoding ~A but has sources that use these encodings: ~A" - 'concatenated-source-op encoding other-encodings)) + operation encoding other-encodings)) (when other-around-compile (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" - 'concatenated-source-op around-compile other-around-compile)) + operation around-compile other-around-compile)) (return inputs))) -(defmethod output-files ((o concatenate-source-op) (s system)) - (declare (ignorable o)) - (let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp"))) - (top (system-translate-output-p s))) - (values (list (system-relative-pathname s of)) (not top)))) (defmethod input-files ((o load-concatenated-source-op) (s system)) (output-files (find-operation o 'concatenate-source-op) s)) (defmethod input-files ((o compile-concatenated-source-op) (s system)) @@ -97,6 +80,16 @@ (defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) (output-files (find-operation o 'compile-concatenated-source-op) s)) +(defmethod input-files ((o monolithic-load-concatenated-source-op) (s system)) + (output-files (find-operation o 'monolithic-concatenate-source-op) s)) +(defmethod input-files ((o monolithic-compile-concatenated-source-op) (s system)) + (output-files (find-operation o 'monolithic-concatenate-source-op) s)) +(defmethod output-files ((o monolithic-compile-concatenated-source-op) (s system)) + (let ((input (first (input-files o s)))) + (list (compile-file-pathname input)))) +(defmethod input-files ((o monolithic-load-compiled-concatenated-source-op) (s system)) + (output-files (find-operation o 'monolithic-compile-concatenated-source-op) s)) + (defmethod perform ((o concatenate-source-op) (s system)) (let ((inputs (input-files o s)) (output (output-file o s))) diff --git a/configuration.lisp b/configuration.lisp index e84c263689d9ddff9902b21ad68659209ea2d9c6..a44b5211ad48c0de45a21c96c823d578570f8632 100644 --- a/configuration.lisp +++ b/configuration.lisp @@ -132,7 +132,7 @@ be applied to the results to yield a configuration form. Current values of TAG include :source-registry and :output-translations." (let ((files (sort (ignore-errors (remove-if - 'hidden-file-p + 'hidden-pathname-p (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) #'string< :key #'namestring))) `(,tag @@ -151,118 +151,114 @@ values of TAG include :source-registry and :output-translations." :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)))))) diff --git a/debian/changelog b/debian/changelog index d87e4bcc25d449b06766bb5994701771d73c41c6..8e893836eee6593aa591c4df0c1650a3474e379d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -91,32 +91,55 @@ cl-asdf (2:2.27-1) unstable; urgency=low to manage the same effects while making every effort to Do The Right Thing(tm) in case of hot upgrade. + * ASDF-DRIVER is a separately-usable library for Common Lisp runtime support. + It is transcluded in asdf.lisp (i.e. when delivering ASDF as a separate + bootstrap file, the contents of ASDF-DRIVER have been included in it), + but can also be used as a separate ASDF system on top of an old ASDF + (within limits: CLISP and XCL still need a recent ASDF). + The package ASDF/DRIVER (with short nickname :D) re-exports + all the functions that ASDF needed to run portably. + + * Pathnames are a notable part of ASDF-DRIVER, required to deal + portably with pathnames despite the many bugs and variations + from platform to platform. See notably in pathname.lisp, + MERGE-PATHNAMES*, SUBPATHNAME, PARSE-UNIX-NAMESTRING, + PARSE-NATIVE-NAMESTRING, ENSURE-PATHNAME, and many many more. + + * Image lifecycle support is included in ASDF-DRIVER (and thus ASDF); + this standardizes things like access to *COMMAND-LINE-ARGUMENTS*, + declaring an entry-point to a program, hook functions and/or a prelude + to run before to start the main entry, and a postlude and/or hook functions + to run before to dump an image, dumping or creating an image, etc. + ASDF provides initial implementations of an operation program-op + to create standalone executables (if available on your implementation). + * Internals have been refactored, and some sorry features were excised. The semantics of OPERATION-DONE-P is simplified and now well-specified. FIND-COMPONENT will pass component objects through, and a corresponding FIND-OPERATION replaces MAKE-SUB-OPERATION. - Several internal accessors were renamed. + Many internal accessors were renamed, after checking on Quicklisp + that no one was using them. * Portability updates were done for - ABCL, CLISP, CMUCL, ECL, LispWorks Personal Edition, MKCL, XCL. + ABCL, CLISP, Clozure CL, CMUCL, ECL, LispWorks Personal Edition, MKCL, XCL. Working support for GCL 2.6 was restored, with notable limitations including lack of support for output-translations or logical-pathnames. * Documentation received some small updates. - * Tests were updated, notably including support for asdf-bundle. + * Tests were updated, notably including support for bundles and encodings. They were successfully run on ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern xcl. Manual tests were run on lispworks-personal-edition genera. Untested were cormancl mkcl rmcl. - * POIU was updated. This extension is distributed separately from ASDF. - It is now much simplified and made more correct by construction by + * POIU was updated. This extension is still distributed separately from ASDF. + It is now much simplified and made correct by construction by reusing the new TRAVERSE infrastructure of ASDF and now being able to assume the ASDF object model is a complete description of dependencies. On SBCL it will handle deferred warnings from background compilations. - On platforms that cannot fork it will gracefully fall back - to serial compilation. + Where forking is not possible or not supported, + it will gracefully fall back to serial compilation. * SLIME support for ASDF was significantly enhanced. It is distributed separately from ASDF, with SLIME. diff --git a/defsystem.lisp b/defsystem.lisp index 555e09ef0ecb697a65fc548b4d1f23421877cbae..9cc5a8765ac031aaa897b643cf9bda82de0b71ae 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -9,25 +9,32 @@ :asdf/backward-internals) #+gcl<2.7 (:shadowing-import-from :asdf/compatibility #:type-of) (:export - #:defsystem #:*default-component-class* - #:class-for-type #:do-defsystem - #:determine-system-pathname #:parse-component-form + #:defsystem #:register-system-definition + #:class-for-type #:*default-component-class* + #:determine-system-directory #:parse-component-form #:duplicate-names #:sysdef-error-component #:check-component-input)) (in-package :asdf/defsystem) ;;; Pathname -(defun* determine-system-pathname (pathname) - ;; The defsystem macro calls us to determine +(defun* determine-system-directory (pathname) + ;; The defsystem macro calls this function to determine ;; the pathname of a system as follows: - ;; 1. the one supplied, - ;; 2. derived from *load-pathname* via load-pathname - ;; 3. taken from the *default-pathname-defaults* via default-directory - (let* ((file-pathname (load-pathname)) - (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) - (or (and pathname (subpathname directory-pathname pathname :type :directory)) - directory-pathname - (default-directory)))) + ;; 1. if the pathname argument is an pathname object (NOT a namestring), + ;; that is already an absolute pathname, return it. + ;; 2. otherwise, the directory containing the CURRENT-LISP-FILE-PATHNAME + ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and + ;; if it is indeed available and an absolute pathname, then + ;; the PATHNAME argument is normalized to a relative pathname + ;; as per PARSE-UNIX-NAMESTRING (with WANT-DIRECTORY T) + ;; and merged into that DIRECTORY as per SUBPATHNAME. + ;; If no absolute pathname was found, we return NIL. + (check-type pathname (or null string pathname)) + (or (and (pathnamep pathname) (absolute-pathname-p pathname)) + (let* ((lisp-file-pathname (resolve-symlinks* (current-lisp-file-pathname)))) + (when (absolute-pathname-p lisp-file-pathname) + (subpathname lisp-file-pathname pathname :type :directory))))) + ;;; Component class @@ -149,9 +156,9 @@ (when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails ret)) ret))) -(defun* do-defsystem (name &rest options - &key pathname (class 'system) - defsystem-depends-on &allow-other-keys) +(defun* register-system-definition + (name &rest options &key pathname (class 'system) (source-file () sfp) + defsystem-depends-on &allow-other-keys) ;; The system must be registered before we parse the body, ;; otherwise we recur when trying to find an existing system ;; of the same name to reuse options (e.g. pathname) from. @@ -160,17 +167,17 @@ ;; we also need to remember it in a special variable *systems-being-defined*. (with-system-definitions () (let* ((name (coerce-name name)) - (load-pathname (load-pathname)) + (source-file (if sfp source-file (current-lisp-file-pathname))) (registered (system-registered-p name)) (registered! (if registered - (rplaca registered (safe-file-write-date load-pathname)) - (register-system (make-instance 'system :name name :source-file load-pathname)))) + (rplaca registered (safe-file-write-date source-file)) + (register-system (make-instance 'system :name name :source-file source-file)))) (system (reset-system (cdr registered!) - :name name :source-file load-pathname)) - (component-options (remove-keys '(:class) options))) + :name name :source-file source-file)) + (component-options (remove-keyword :class options))) (setf (gethash name *systems-being-defined*) system) (apply 'load-systems defsystem-depends-on) - ;; We change-class (when necessary) AFTER we load the defsystem-dep's + ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. (let ((class (class-for-type nil class))) (unless (eq (type-of system) class) @@ -178,8 +185,8 @@ (parse-component-form nil (list* :module name - :pathname (determine-system-pathname pathname) + :pathname (determine-system-directory pathname) component-options))))) (defmacro defsystem (name &body options) - `(apply 'do-defsystem ',name ',options)) + `(apply 'register-system-definition ',name ',options)) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index d644666ac35af88c11125ae75fe6dfe24c31b42e..54f183e442647939102a922af0e8017dfc5354a1 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -3163,12 +3163,10 @@ because it prevents the introspection done by e.g. asdf-dependency-grovel), or a string that when @code{read} yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. A non-nil value designates a function of one argument -that will be called with a function that -calls the @code{*compile-op-compile-file-function*} -(usually @code{compile-file*}) -with proper arguments; -the around-compile hook may supply additional arguments -to pass to that @code{*compile-op-compile-file-function*}. +that will be called with a function that will +invoke @code{compile-file*} with various arguments; +the around-compile hook may supply additional keyword arguments +to pass to that call to @code{compile-file*}. One notable argument that is heeded by @code{compile-file*} is @code{:compile-check}, diff --git a/driver.lisp b/driver.lisp index c4f6e7b2c35ed6521f7f0a5ef0d98329453bafb8..e8dd0e4111f75d453388cf8cb29145ad01d27ea0 100644 --- a/driver.lisp +++ b/driver.lisp @@ -2,7 +2,7 @@ ;;;; Re-export all the functionality in asdf/driver (asdf/package:define-package :asdf/driver - (:nicknames :d) + (:nicknames :d :asdf-driver) (:use :common-lisp :asdf/package :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/image diff --git a/find-system.lisp b/find-system.lisp index a4096d2cd53fa89a93fd3babdba90e8cf579c715..f448eb54a804be9234256cbcf82c5643fc0ceee9 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -14,7 +14,8 @@ #:*system-definition-search-functions* #:search-for-system-definition #:*central-registry* #:probe-asd #:sysdef-central-registry-search #:make-temporary-package #:find-system-if-being-defined #:*systems-being-defined* - #:find-system-fallback #:sysdef-find-asdf + #:find-system-fallback #:sysdef-find-asdf #:contrib-sysdef-search + #:system-find-pre-loaded-system #:*pre-loaded-systems* #:make-defined-systems-table #:*defined-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) @@ -109,18 +110,21 @@ called with an object of type asdf:system." (defvar *system-definition-search-functions* '()) -(setf *system-definition-search-functions* - (append - ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. - (remove 'contrib-sysdef-search *system-definition-search-functions*) - ;; Tuck our defaults at the end of the list if they were absent. - ;; This is imperfect, in case they were removed on purpose, - ;; but then it will be the responsibility of whoever does that - ;; to upgrade asdf before he does such a thing rather than after. - (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)))) +(defun cleanup-system-definition-search-functions () + (setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from old versions of asdf. + (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf))) + *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-pre-loaded-systems))))) +(cleanup-system-definition-search-functions) (defun* search-for-system-definition (system) (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) @@ -202,13 +206,7 @@ Going forward, we recommend new users should be using the source-registry. (subseq *central-registry* (1+ position)))))))))) (defun* make-temporary-package () - (flet ((try (counter) - (ignore-errors - (make-package (format nil "~A~D" :asdf counter) - :use '(:cl :asdf/interface))))) - (do* ((counter 0 (+ counter 1)) - (package (try counter) (try counter))) - (package package)))) + (make-package (fresh-package-name :asdf 0) :use '(:cl :asdf/interface))) (defmethod find-system ((name null) &optional (error-p t)) (declare (ignorable name)) @@ -237,7 +235,7 @@ Going forward, we recommend new users should be using the source-registry. (defun* load-sysdef (name pathname) ;; Tries to load system definition with canonical NAME from PATHNAME. (with-system-definitions () - (let ((package (make-temporary-package))) + (let ((package (make-temporary-package))) ;; ASDF3: get rid of that. (unwind-protect (handler-bind ((error #'(lambda (condition) @@ -322,9 +320,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (when (equal requested fallback) (let ((registered (cdr (gethash fallback *defined-systems*)))) (or registered - (apply 'make-instance 'system - :name fallback :source-file source-file keys))))) + (apply 'make-instance 'system :name fallback :source-file source-file keys))))) -(defun* sysdef-find-asdf (name) - ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. - (find-system-fallback name "asdf" :version (asdf-version))) +(defvar *pre-loaded-systems* `(("asdf") ("asdf-driver"))) + +(defun* sysdef-find-pre-loaded-systems (requested) + (loop :for (provided . keys) :in *pre-loaded-systems* + :thereis (apply 'find-system-fallback requested provided keys))) diff --git a/footer.lisp b/footer.lisp index 41cb7e124c5f24c1bdf15ff0ffda3ab2911238d7..af8ba23324799b13b2c651ae4826977b8c218b62 100644 --- a/footer.lisp +++ b/footer.lisp @@ -10,6 +10,10 @@ :asdf/backward-internals :asdf/defsystem :asdf/backward-interface)) (in-package :asdf/footer) +;;;; Configure +(setf asdf/utility:*asdf-debug-utility* + '(asdf:system-relative-pathname :asdf "contrib/debug.lisp")) + ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. #+(or abcl clisp clozure cmu ecl mkcl sbcl) diff --git a/header.lisp b/header.lisp index b878ff31581f30df60ff6461fc456e508401bfa9..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 100644 --- a/header.lisp +++ b/header.lisp @@ -1,48 +0,0 @@ -;; -*- 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 ()) diff --git a/image.lisp b/image.lisp index 1cfad50109ccbb525d6c861959ca4473a092ea7e..8be8220336da9e24d130804d54a9fe65d1e6c60a 100644 --- a/image.lisp +++ b/image.lisp @@ -16,7 +16,7 @@ #:shell-boolean-exit #:register-image-restore-hook #:register-image-dump-hook #:call-image-restore-hook #:call-image-dump-hook - #:initialize-asdf-utilities #:restore-image #:dump-image + #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image )) (in-package :asdf/image) @@ -220,14 +220,10 @@ if we are not called from a directly executable image dumped by XCVB." ((:lisp-interaction *lisp-interaction*) *lisp-interaction*) ((:restore-hook *image-restore-hook*) *image-restore-hook*) ((:prelude *image-prelude*) *image-prelude*) - ((:entry-point *image-entry-point*) *image-entry-point*) - ((:package *package*) *package*)) + ((:entry-point *image-entry-point*) *image-entry-point*)) (with-fatal-condition-handler () (call-image-restore-hook) - (when *image-prelude* - (with-safe-io-syntax (:package *package*) - (let ((*read-eval* t)) - (eval-text *image-prelude*)))) + (standard-eval-thunk *image-prelude*) (let ((results (multiple-value-list (if *image-entry-point* (apply *image-entry-point* *command-line-arguments*) @@ -242,14 +238,10 @@ if we are not called from a directly executable image dumped by XCVB." #-(or ecl mkcl) (defun* dump-image (filename &key output-name executable ((:postlude *image-postlude*) *image-postlude*) - ((:dump-hook *image-dump-hook*) *image-dump-hook*) - ((:package *package*) *package*)) + ((:dump-hook *image-dump-hook*) *image-dump-hook*)) (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) - (when *image-postlude* - (with-safe-io-syntax () - (let ((*read-eval* t)) - (eval-text *image-postlude*)))) + (standard-eval-thunk *image-postlude*) (call-image-dump-hook) #-(or clisp clozure cmu lispworks sbcl) (when executable @@ -298,6 +290,26 @@ if we are not called from a directly executable image dumped by XCVB." filename (nth-value 1 (implementation-type)))) +#+ecl +(defun create-image (destination object-files + &key kind output-name + (prelude () preludep) (entry-point () entry-point-p)) + ;; Is it meaningful to run these in the current environment? + ;; only if we also track the object files that constitute the "current" image, + ;; and otherwise simulate dump-image, including quitting at the end. + ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook) + (check-type kind (member :program :shared-library)) + (c::builder + kind (pathname destination) + :lisp-files object-files + :init-name (c::compute-init-name (or output-name destination) :kind kind) + :epilogue-code + (when (eq kind :program) + `(restore-image ;; default behavior would be (si::top-level) + ,@(when preludep `(:prelude ',prelude)) + ,@(when entry-point-p `(:entry-point ',entry-point)))))) + + ;;; Some universal image restore hooks (map () 'register-image-restore-hook '(setup-temporary-directory setup-stderr setup-command-line-arguments)) diff --git a/interface.lisp b/interface.lisp index c4fc4dcaac81c3a72d59c9ed2b56f6a8886a72e3..2f02f9ecd089146792d23c4bc6b5ae0d23aafd5f 100644 --- a/interface.lisp +++ b/interface.lisp @@ -24,17 +24,31 @@ #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:require-system #:test-system #:clear-system - #:operation #:upward-operation #:downward-operation - #: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 diff --git a/lisp-action.lisp b/lisp-action.lisp index 35c3c350d609cb21e961aed8009e72b4bf2c651a..701df7131cbeb58a15119dcbd91c3414f6c40073 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -94,7 +94,7 @@ (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)))))) diff --git a/lisp-build.lisp b/lisp-build.lisp index 071a8b1cc474986c8ba4729186adab1086170a12..5f1f325af021cc3f60b816c836514599031c2fe0 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -8,7 +8,7 @@ (: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* @@ -17,9 +17,8 @@ #: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) @@ -35,9 +34,6 @@ Valid values are :error, :warn, and :ignore.") 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 @@ -165,46 +161,84 @@ for processing later (possibly in a different process)." ;;; 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) @@ -213,7 +247,7 @@ for processing later (possibly in a different process)." ,@(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)) @@ -240,31 +274,6 @@ for processing later (possibly in a different process)." "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) diff --git a/os.lisp b/os.lisp index 59d731ff9aea344904661a0d67d888ab873fdba9..a608bd6c4261169286e64739efa23245dc268c96 100644 --- a/os.lisp +++ b/os.lisp @@ -7,7 +7,8 @@ (: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 @@ -81,17 +82,57 @@ that is neither Unix, nor Windows.~%Now you port it."))))) 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) @@ -266,12 +307,13 @@ then returning the non-empty string value of the variable" ;;; 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) diff --git a/output-translations.lisp b/output-translations.lisp index 5cff98558c318d5b3ad3d6ee12f703c8fd03eac9..d1366f49f415ed92cecf98a784541fb6266963a1 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -55,7 +55,7 @@ and the order is by decreasing length of namestring of the source pathname.") "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)) @@ -148,8 +148,8 @@ and the order is by decreasing length of namestring of the source pathname.") ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) -(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) -(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) +(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)) @@ -186,7 +186,7 @@ and the order is by decreasing length of namestring of the source pathname.") (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) @@ -199,7 +199,7 @@ and the order is by decreasing length of namestring of the source pathname.") (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))))))))))) diff --git a/package.lisp b/package.lisp index 37535648834249bf0be68221f776b27d5144ac76..c455ea04bc4847d67b0e3669c6947a828bb09536 100644 --- a/package.lisp +++ b/package.lisp @@ -14,10 +14,14 @@ (: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) @@ -581,11 +585,15 @@ or when loading the package is optional." ;;;; 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"))) @@ -593,4 +601,3 @@ or when loading the package is optional." (delete-package* :asdf t)) (make-package :asdf :use ()))) - diff --git a/pathname.lisp b/pathname.lisp index 962e298777f357fe39dad87b3ee4c38bae1ee638..1ae22f7573c01b89783bc5d57ea679f03d018c9c 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -9,24 +9,25 @@ #:*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 @@ -41,17 +42,16 @@ #: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*)) @@ -63,6 +63,7 @@ Defaults to T.") + ;;; The hell of portably making and merging pathnames! (defun* normalize-pathname-directory-component (directory) @@ -116,6 +117,13 @@ Defaults to T.") :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) @@ -154,7 +162,11 @@ if the SPECIFIED pathname does not have an absolute directory, then the HOST and DEVICE both come from the DEFAULTS, whereas if the SPECIFIED pathname does have an absolute directory, then the HOST and DEVICE both come from the SPECIFIED. -Also, if either argument is NIL, then the other argument is returned unmodified." +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 @@ -185,6 +197,22 @@ Also, if either argument is NIL, then the other argument is returned unmodified. :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) @@ -400,124 +428,194 @@ with given pathname and if it exists return its truename." (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) @@ -551,7 +649,7 @@ Host, device and version components are taken from DEFAULTS." (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)))) @@ -621,9 +719,10 @@ Host, device and version components are taken from DEFAULTS." (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* @@ -692,24 +791,6 @@ Host, device and version components are taken from DEFAULTS." (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) @@ -737,16 +818,10 @@ For the latter case, we ought pick random suffix and atomically open it." `(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) @@ -757,16 +832,22 @@ For the latter case, we ought pick random suffix and atomically open it." ((: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: @@ -843,5 +924,81 @@ For the latter case, we ought pick random suffix and atomically open it." (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) diff --git a/plan.lisp b/plan.lisp index af784bb292d77a6832f0fb9cb77797f4e150c810..77511fd00655a56ce513f51940f3a1529fcfd12d 100644 --- a/plan.lisp +++ b/plan.lisp @@ -16,14 +16,13 @@ #: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 @@ -82,7 +81,7 @@ the action of OPERATION on COMPONENT in the PLAN")) (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)) @@ -290,6 +289,10 @@ the action of OPERATION on COMPONENT in the PLAN")) (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)) @@ -300,11 +303,6 @@ the action of OPERATION on COMPONENT in the PLAN")) (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 @@ -318,8 +316,12 @@ processed in order by OPERATE.")) (defgeneric* perform-plan (plan &key)) (defgeneric* plan-operates-on-p (plan component)) -(defmethod traverse ((o operation) (c component) &rest keys &key &allow-other-keys) - (apply 'traverse-sequentially o c keys)) +(defmethod 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*) diff --git a/source-registry.lisp b/source-registry.lisp index f1d665bf313a2d8312778de696dfdf0b55c4126e..480853727608d21756aab4e2ea7af53c736fe171 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -148,8 +148,8 @@ system names to pathnames of .asd files") 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 @@ -198,11 +198,11 @@ system names to pathnames of .asd files") ((: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)) diff --git a/stream.lisp b/stream.lisp index ec94de9d51c0b5d283cda463dfae2db9ef3989a2..903a0598f5ccdd016f4845efbb91c01b1f70f54e 100644 --- a/stream.lisp +++ b/stream.lisp @@ -17,7 +17,7 @@ #: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*)) @@ -237,11 +237,25 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" :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 diff --git a/system.lisp b/system.lisp index c483d1812ca19dfeda22618b00b861107e27ce99..4659fad10beb8b3fc554757fe577dc376eafe7eb 100644 --- a/system.lisp +++ b/system.lisp @@ -7,7 +7,7 @@ (: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 @@ -104,11 +104,10 @@ ;;;; 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.")) diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index 3667de57ef694841b50d2e9b22a072d70e29b2e0..d849121ccae33793cf79edd8821f3f778730faa9 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -1,7 +1,10 @@ ;;; -*- 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 @@ -49,7 +52,7 @@ (*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 @@ -99,11 +102,11 @@ "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" @@ -203,27 +206,31 @@ (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)))) @@ -242,7 +249,7 @@ 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)) @@ -320,13 +327,13 @@ (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) diff --git a/test/hello-world-example.asd b/test/hello-world-example.asd new file mode 100644 index 0000000000000000000000000000000000000000..51559697bd918b13c82d4fc006ea051cf77697b7 --- /dev/null +++ b/test/hello-world-example.asd @@ -0,0 +1,8 @@ +;; 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"))) diff --git a/test/hello.lisp b/test/hello.lisp new file mode 100644 index 0000000000000000000000000000000000000000..cec8eca843b6ed8ea2fc5122ea71bfaf431741d6 --- /dev/null +++ b/test/hello.lisp @@ -0,0 +1,10 @@ +(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))) diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f9e0c1d32864b2ad2708ddd10608827dccb2b944 --- /dev/null +++ b/test/make-hello-world.lisp @@ -0,0 +1,6 @@ +;;; -*- Lisp -*- +(load "script-support.lisp") +(load-asdf) + +(with-test () + (operate 'program-op :hello-world-example)) diff --git a/test/run-tests.sh b/test/run-tests.sh index 57c41ce3235fb46c3245af177d10a61b2e0887a8..0c3e9cf7e4e784957d17654f7119406a61810114 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -194,7 +194,7 @@ if ! type "$command" > /dev/null ; then 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)" @@ -272,6 +272,7 @@ valid_upgrade_test_p () { return 1 } run_upgrade_tests () { + cd ${ASDFDIR} su=test/script-support.lisp for tag in `upgrade_tags` ; do for method in `upgrade_methods` ; do @@ -284,6 +285,7 @@ run_upgrade_tests () { 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 diff --git a/test/script-support.lisp b/test/script-support.lisp index e3f9c9606177fba4c09f54e34cea0ba099cb672c..9c807e99ee11de05bd7d1247be987f675b2c0d8d 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -6,6 +6,8 @@ Some constraints: 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 @@ -20,7 +22,7 @@ Some constraints: #:with-test #:test-asdf #:debug-asdf #:assert-compare #:assert-equal - #:leave-test + #:leave-test #:def-test-system #:quietly)) (in-package :asdf-test) @@ -75,11 +77,11 @@ Some constraints: (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*)) @@ -167,7 +169,7 @@ Some constraints: (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) @@ -181,21 +183,21 @@ Some constraints: #+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) @@ -212,7 +214,7 @@ is bound, write a message and exit on an error. If ((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!~%") @@ -383,6 +385,7 @@ is bound, write a message and exit on an error. If (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))) @@ -396,6 +399,12 @@ is bound, write a message and exit on an error. If ;; 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 diff --git a/test/test-around-compile.script b/test/test-around-compile.script index 6f240bc9d4fbacd3454fb806d3dc08915d3518e3..729b254f71ceb8c81206f018eb2f8998e3d1c023 100644 --- a/test/test-around-compile.script +++ b/test/test-around-compile.script @@ -7,9 +7,9 @@ (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 diff --git a/test/test-builtin-source-file-type.script b/test/test-builtin-source-file-type.script index a31ce7dc9dedad59833b1ee3de015afccadf8367..30d9f4c4534671aa332ab275cf4ead5a3fa3c1be 100644 --- a/test/test-builtin-source-file-type.script +++ b/test/test-builtin-source-file-type.script @@ -7,7 +7,7 @@ (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 @@ -20,7 +20,8 @@ '("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 @@ -28,7 +29,7 @@ (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 @@ -41,7 +42,7 @@ '("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 diff --git a/test/test-bundle.script b/test/test-bundle.script index b6c8988bc5cdc6ebd239bca15f17caa1ac9898c2..cb5ea453ec1f7666f11f5a9470aeb4b7991fffc4 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -6,25 +6,28 @@ ;;; 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))))) diff --git a/test/test-concatenate-source.script b/test/test-concatenate-source.script index 4c8d7911ae85eb98d6f02b265414c37b83f66b6b..0e5e91c38c232680c2c7011077b11ccaea4b71e9 100644 --- a/test/test-concatenate-source.script +++ b/test/test-concatenate-source.script @@ -3,33 +3,38 @@ (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))))) diff --git a/test/test-encodings.script b/test/test-encodings.script index 6ccd11e52230ccdd5c78f692a14e3dccae0c56ce..665cfa76b0ad4389f2a289612afb69560a59b70f 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -21,18 +21,18 @@ #+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)))))) @@ -40,7 +40,7 @@ (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 @@ -52,60 +52,69 @@ (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 diff --git a/test/test-missing-lisp-file.script b/test/test-missing-lisp-file.script index 99cbe67dc3f3ef7edc32a076797c4411a3405bf7..cc9bb33d0e740919e1af285b45d48af055ab3d86 100644 --- a/test/test-missing-lisp-file.script +++ b/test/test-missing-lisp-file.script @@ -10,7 +10,7 @@ (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"))) diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script index fe6a5e43d8edb160aebd40a8748bbbbbaf8df6a2..96671dea5979e423b31b33fb67f33900d2c2f5e5 100644 --- a/test/test-module-excessive-depend.script +++ b/test/test-module-excessive-depend.script @@ -16,7 +16,7 @@ (with-test () - (defsystem :test-module-excessive-depend + (def-test-system :test-module-excessive-depend :components ((:file "file1") (:module "quux" :pathname "" diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index e3aedb703314817de9d125ecfa3910f55c31fb7b..06f3f6fbc4ebb715ab0635d103a55da1cddca05b 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -5,7 +5,7 @@ (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")))) @@ -21,11 +21,11 @@ () "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") @@ -36,10 +36,10 @@ () "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")) diff --git a/test/test-program.script b/test/test-program.script new file mode 100644 index 0000000000000000000000000000000000000000..28aa9f10d9a6846077ba81988a1e77cd35ed338a --- /dev/null +++ b/test/test-program.script @@ -0,0 +1,42 @@ +;;; -*- 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)) diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index 79a33d503fd16b07e9241b0131b0c8000236deec..35488516c3fd89c1246af6e3ee5b7def550865d9 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -10,7 +10,7 @@ don't cause full rebuilds all the time... (with-test () - (let ((s '(defsystem static-and-serial + (let ((s '(def-test-system static-and-serial :version "0.1" :serial t :components diff --git a/test/test-system-pathnames.script b/test/test-system-pathnames.script index 3ba40d71792fab19e339f699420d18c2c15e1fea..4cfc02db98c40490a23f82aa9aa778e6cd61c84a 100644 --- a/test/test-system-pathnames.script +++ b/test/test-system-pathnames.script @@ -12,11 +12,11 @@ () "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") @@ -27,10 +27,10 @@ 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")) diff --git a/test/test-utilities.script b/test/test-utilities.script index 420297539bcf39f39a34b9caafad252014958606..167439f341d2897e0de353044ebe1a62b7008472 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -15,52 +15,55 @@ (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))) diff --git a/test/test-version.script b/test/test-version.script index 6cf95d99f87c0de4342c0ef962575e3809aa9888..0cff0028be249768e14363c47e79f8a87caf2123 100644 --- a/test/test-version.script +++ b/test/test-version.script @@ -5,15 +5,15 @@ (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") diff --git a/test/wild-module.script b/test/wild-module.script index f6d14ade8f16887711087318547028f7aa3c7dc7..adc0c5d18c306bc561cbdd71a4539092caabe659 100644 --- a/test/wild-module.script +++ b/test/wild-module.script @@ -3,7 +3,7 @@ (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 diff --git a/utility.lisp b/utility.lisp index 3e1cc79fd635613d9ecd37c23c75a47ec20a3970..224a2869e2ebd39751a3360407a67ee84c98e4f4 100644 --- a/utility.lisp +++ b/utility.lisp @@ -21,7 +21,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) @@ -68,14 +68,14 @@ ;;; 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*))))) diff --git a/version.lisp-expr b/version.lisp-expr index ed17e9f99b40a5ca45c76698100819130c63032c..8f3b63babc9a10c86d11ae5210888faf83c0c3b7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.99" +"2.26.100"