Commit 6782f5eb authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.102: fix issues on ECL, maybe CLISP too, improve version bumper.

Move things around and rename functions to improve backward compatibility.
The driver now has its own backward-compatibility file.
parent 639faf17
...@@ -41,7 +41,7 @@ XCL ?= xcl ...@@ -41,7 +41,7 @@ XCL ?= xcl
# website, tag, install # website, tag, install
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 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 backward-driver.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 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: # Making ASDF itself should be our first, default, target:
......
...@@ -25,4 +25,5 @@ that you can't portably construct a complete program without using them." ...@@ -25,4 +25,5 @@ that you can't portably construct a complete program without using them."
(:file "run-program" :depends-on ("os")) (:file "run-program" :depends-on ("os"))
(:file "lisp-build" :depends-on ("image")) (:file "lisp-build" :depends-on ("image"))
(:file "configuration" :depends-on ("image")) (:file "configuration" :depends-on ("image"))
(:file "driver" :depends-on ("lisp-build" "run-program" "configuration")))) (:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration"))
(:file "driver" :depends-on ("backward-driver"))))
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.100" ;; to be automatically updated by bin/bump-revision :version "2.26.102" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
;;;; -------------------------------------------------------------------------
;;; Hacks for backward-compatibility of the driver
(asdf/package:define-package :asdf/backward-driver
(:recycle :asdf/backward-driver :asdf)
(:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image
:asdf/run-program :asdf/lisp-build
:asdf/configuration)
(:export
#:coerce-pathname #:component-name-to-pathname-components))
(in-package :asdf/backward-driver)
;;;; Backward compatibility with various pathname functions.
(defun* coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals
;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
;; Will be removed after 2014-01-16.
;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(defun* component-name-to-pathname-components (unix-style-namestring
&key force-directory force-relative)
;; Will be removed after 2014-01-16.
;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
(multiple-value-bind (relabs path filename file-only)
(split-unix-namestring-directory-components
unix-style-namestring :want-directory force-directory)
(declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
unix-style-namestring))
(values relabs path filename)))
...@@ -21,13 +21,6 @@ ...@@ -21,13 +21,6 @@
;; Old deprecated name for the same thing. Please update your software. ;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component)) (component-sibling-dependencies component))
(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. (defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
......
...@@ -2,30 +2,14 @@ ...@@ -2,30 +2,14 @@
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*- ":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;; Really runs on any decent Common Lisp implementation ;;; Really runs on any decent Common Lisp implementation
(setf *load-verbose* nil *load-print* nil (load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
*compile-verbose* nil *compile-print* nil) :verbose nil :print nil)
(format t "Loading your implementation's ASDF... ~%")
(require :asdf)
(in-package :asdf)
#-asdf2 (error "Not ASDF2, you lose!")
(format t "Initializing the source registry... ~%")
(initialize-source-registry)
(format t "Upgrading to the latest ASDF... ~%")
(upgrade-asdf)
(format t "Now loading some dependencies... ~%")
(load-systems :cl-ppcre :fare-utils)
(in-package :fare-utils) (in-package :fare-utils)
(format t "And the debug utilities... ~%") (defvar *adir* (asdf:system-relative-pathname :asdf nil))
(asdf-debug)
(DBG "There we are!") (defun afile (x) (subpathname *adir* x))
(restore-image)
(defun afile (x)
(asdf:system-relative-pathname :asdf x))
(defparameter *version-file* (defparameter *version-file*
(afile "version.lisp-expr")) (afile "version.lisp-expr"))
...@@ -73,18 +57,41 @@ ...@@ -73,18 +57,41 @@
(clobber-file-with-vector file written-contents :external-format external-format) (clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%"))))) (format t "done.~%")))))
(defun version-transform (text) (defun version-transformer (new-version file prefix suffix)
(flet ((v1 (ver) (format nil "~S" ver)) (let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(v2 (ver) (format nil "This is ASDF ~A:" ver)) (versionrx "([0-9]+(\\.[0-9]+)+)")
(f (fun text) (qsuffix (cl-ppcre:quote-meta-chars suffix))
(cl-ppcre:regex-replace-all (regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
(funcall fun *old-version*) text (funcall fun *new-version*)))) (replacement
(f #'v2 (f #'v1 text)))) (constantly (strcat prefix new-version suffix))))
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
(unless (or foundp t)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
(defparameter *versioned-files* (defparameter *versioned-files*
'("version.lisp-expr" "asdf.asd" "header.lisp" "build/asdf.lisp" "upgrade.lisp")) '(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
(defun transform-file (x) ("header.lisp" "This is ASDF " ": Another System Definition Facility.")
(maybe-replace-file (afile x) #'version-transform)) ("upgrade.lisp" " (asdf-version \"" "\")")))
(map () 'transform-file *versioned-files*) (defun transform-file (new-version file prefix suffix)
(maybe-replace-file (afile file) (version-transformer new-version file prefix suffix)))
(defun transform-files ()
(loop :for f :in *versioned-files* :do (apply 'transform-file *new-version* f)))
(defun test-transform-file (new-version file prefix suffix)
(let ((lines (read-file-lines (afile file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
(funcall (version-transformer new-version file prefix suffix) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(return t))))))
(defun z () (apply 'test-transform-file *new-version* (first *versioned-files*)))
(transform-files)
#!/bin/sh ":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;;;; Really runs on any decent Common Lisp implementation
# create tarball and tagged asdf.lisp file in tmp/ using the most recent (load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
# annotated tag :verbose nil :print nil)
;;;;; create tarball for the current version.
tag=`git describe --tags --match '[0-9].[0-9][0-9]'` (in-package :asdf)
if [ "$tag" == "" ]; then
echo "Unable to find most recent tag, exiting" (asdf-debug)
exit 1
fi (describe (find-system :asdf))
(defparameter *ad* (find-system :asdf-driver))
(defparameter *asdf-directory* (system-source-directory *ad*))
(defparameter *version*
(safe-read-first-file-form (subpathname *asdf-directory* "version.lisp-expr")))
(DBG :foo *ad* *version* (asdf-version))
(defparameter *files*
(append
(loop :for c :in (operated-components *ad*
:goal-operation 'load-op
:keep-operation 'load-op)
:for n = (enough-namestring (component-pathname c) *asdf-directory*)
:when (typep c 'cl-source-file)
:collect n)
(list "version.lisp-expr" "asdf-driver.asd")))
;; make asdf:
;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp"))
#|
if [ -d "tmp" ]; then if [ -d "tmp" ]; then
rm -r tmp rm -r tmp
fi fi
...@@ -19,3 +42,4 @@ archive_file="tmp/asdf-$tag.tar.gz" ...@@ -19,3 +42,4 @@ archive_file="tmp/asdf-$tag.tar.gz"
echo "Create tmp/asdf.tar.gz with tag $tag" echo "Create tmp/asdf.tar.gz with tag $tag"
git archive $tag --prefix="asdf/" --format=tar | \ git archive $tag --prefix="asdf/" --format=tar | \
gzip > $archive_file gzip > $archive_file
|#
\ No newline at end of file
...@@ -9,13 +9,13 @@ ...@@ -9,13 +9,13 @@
(:export (:export
#:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op #:monolithic-op #:monolithic-bundle-op #:dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
#:program-op #:program-system #:program-op #:program-system
#:compiled-file #:precompiled-system #:prebuilt-system #:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p #:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p #:user-system-p #:user-system #:trivial-system-p
#:gather-actions #:gather-components #:gather-actions #:operated-components
#+ecl #:make-build #+mkcl #:bundle-system #+ecl #:make-build #+mkcl #:bundle-system
#:register-pre-built-system #:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
...@@ -215,13 +215,14 @@ ...@@ -215,13 +215,14 @@
(defun* bundlable-file-p (pathname) (defun* bundlable-file-p (pathname)
(let ((type (pathname-type pathname))) (let ((type (pathname-type pathname)))
(declare (ignorable type))
(or #+ecl (or (equal type (compile-file-type :object)) (or #+ecl (or (equal type (compile-file-type :object))
(equal type (compile-file-type :static-library))) (equal type (compile-file-type :static-library)))
#+mkcl (equal type (compile-file-type :fasl-p nil)) #+mkcl (equal type (compile-file-type :fasl-p nil))
#+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) #+(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) (defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
(component-type t) other-systems) (component-type t) other-systems)
(let ((goal-op (make-operation goal-operation))) (let ((goal-op (make-operation goal-operation)))
(flet ((filter (o c) (flet ((filter (o c)
(declare (ignore o)) (declare (ignore o))
...@@ -253,15 +254,15 @@ ...@@ -253,15 +254,15 @@
(defmethod component-depends-on ((o monolithic-lib-op) (c system)) (defmethod component-depends-on ((o monolithic-lib-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
`((lib-op ,@(gather-components c :other-systems t :component-type 'system `((lib-op ,@(operated-components c :other-systems t :component-type 'system
:goal-operation 'load-op :goal-operation 'load-op
:keep-operation 'load-op)))) :keep-operation 'load-op))))
(defmethod component-depends-on ((o monolithic-fasl-op) (c system)) (defmethod component-depends-on ((o monolithic-fasl-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
`((fasl-op ,@(gather-components c :other-systems t :component-type 'system `((fasl-op ,@(operated-components c :other-systems t :component-type 'system
:goal-operation 'load-fasl-op :goal-operation 'load-fasl-op
:keep-operation 'load-fasl-op)))) :keep-operation 'load-fasl-op))))
(defmethod component-depends-on ((o program-op) (c system)) (defmethod component-depends-on ((o program-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
...@@ -278,9 +279,9 @@ ...@@ -278,9 +279,9 @@
(defmethod component-depends-on ((o lib-op) (c system)) (defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
`((compile-op ,@(gather-components c :other-systems nil :component-type '(not system) `((compile-op ,@(operated-components c :other-systems nil :component-type '(not system)
:goal-operation 'load-op :goal-operation 'load-op
:keep-operation 'load-op)))) :keep-operation 'load-op))))
(defmethod component-depends-on ((o fasl-op) (c system)) (defmethod component-depends-on ((o fasl-op) (c system))
(declare (ignorable o)) (declare (ignorable o))
...@@ -295,12 +296,15 @@ ...@@ -295,12 +296,15 @@
(declare (ignorable o c)) (declare (ignorable o c))
nil) nil)
(defmethod input-files ((o bundle-op) (c system)) (defun* dependency-files (o c &key (test 'identity) (key 'output-files))
(while-collecting (collect) (while-collecting (collect)
(visit-dependencies (visit-dependencies
() o c #'(lambda (sub-o sub-c) () o c #'(lambda (sub-o sub-c)
(loop :for f :in (output-files sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c)
:when (bundlable-file-p f) :do (collect f)))))) :when (funcall test f) :do (collect f))))))
(defmethod input-files ((o bundle-op) (c system))
(dependency-files o c :test 'bundlable-file-p :key 'output-files))
(defun* select-bundle-operation (type &optional monolithic) (defun* select-bundle-operation (type &optional monolithic)
(ecase type (ecase type
......
...@@ -47,11 +47,10 @@ ...@@ -47,11 +47,10 @@
:with other-encodings = '() :with other-encodings = '()
:with around-compile = (around-compile-hook s) :with around-compile = (around-compile-hook s)
:with other-around-compile = '() :with other-around-compile = '()
:for c :in (gather-components s :for c :in (operated-components
:goal-operation 'compile-op s :goal-operation 'compile-op
:keep-operation 'compile-op :keep-operation 'compile-op
:component-type 'component :other-systems (operation-monolithic-p operation))
:other-systems (operation-monolithic-p operation))
:append :append
(when (typep c 'cl-source-file) (when (typep c 'cl-source-file)
(let ((e (component-encoding c))) (let ((e (component-encoding c)))
...@@ -71,24 +70,14 @@ ...@@ -71,24 +70,14 @@
(return inputs))) (return inputs)))
(defmethod input-files ((o load-concatenated-source-op) (s system)) (defmethod input-files ((o load-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s)) (dependency-files o s))
(defmethod input-files ((o compile-concatenated-source-op) (s system)) (defmethod input-files ((o compile-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s)) (dependency-files o s))
(defmethod output-files ((o compile-concatenated-source-op) (s system)) (defmethod output-files ((o compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s)))) (let ((input (first (input-files o s))))
(list (compile-file-pathname input)))) (list (compile-file-pathname input))))
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'compile-concatenated-source-op) s)) (dependency-files o 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)) (defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s)) (let ((inputs (input-files o s))
......
...@@ -237,7 +237,8 @@ directive.") ...@@ -237,7 +237,8 @@ directive.")
r))) r)))
(ensure-pathname w :want-absolute t))) (ensure-pathname w :want-absolute t)))
(defun* resolve-location (x &key want-directory wilden) (defun* resolve-location (x &key want-directory wilden directory)
(when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16.
(if (atom x) (if (atom x)
(resolve-absolute-location-component x :want-directory want-directory :wilden wilden) (resolve-absolute-location-component x :want-directory want-directory :wilden wilden)
(loop :with path = (resolve-absolute-location-component (loop :with path = (resolve-absolute-location-component
......
...@@ -2,12 +2,12 @@ ...@@ -2,12 +2,12 @@
;;;; Re-export all the functionality in asdf/driver ;;;; Re-export all the functionality in asdf/driver
(asdf/package:define-package :asdf/driver (asdf/package:define-package :asdf/driver
(:nicknames :d :asdf-driver) (:nicknames :d :asdf-driver :asdf-utils)
(:use :common-lisp (:use :common-lisp
:asdf/package :asdf/compatibility :asdf/utility :asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image :asdf/pathname :asdf/stream :asdf/os :asdf/image
:asdf/run-program :asdf/lisp-build :asdf/run-program :asdf/lisp-build
:asdf/configuration) :asdf/configuration :asdf/backward-driver)
(:reexport (:reexport
:asdf/package :asdf/compatibility :asdf/utility :asdf/package :asdf/compatibility :asdf/utility
:asdf/pathname :asdf/stream :asdf/os :asdf/image :asdf/pathname :asdf/stream :asdf/os :asdf/image
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
;;;; Configure ;;;; Configure
(setf asdf/utility:*asdf-debug-utility* (setf asdf/utility:*asdf-debug-utility*
'(asdf:system-relative-pathname :asdf "contrib/debug.lisp")) '(asdf/interface:system-relative-pathname :asdf "contrib/debug.lisp"))
;;;; Hook ASDF into the implementation's REQUIRE and other entry points. ;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.102: 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 ())
...@@ -19,8 +19,8 @@ ...@@ -19,8 +19,8 @@
#:call-with-asdf-compilation-unit #:with-asdf-compilation-unit #:call-with-asdf-compilation-unit #:with-asdf-compilation-unit
#:current-lisp-file-pathname #:lispize-pathname #:compile-file-type #:call-around-hook #:current-lisp-file-pathname #:lispize-pathname #:compile-file-type #:call-around-hook
#:compile-file* #:compile-file-pathname* #:compile-file* #:compile-file-pathname*
#:load* #:load-from-string #:load* #:load-from-string #:combine-fasls)
#:combine-fasls)) (:intern #:defaults #:failure-p #:warnings-p))
(in-package :asdf/lisp-build) (in-package :asdf/lisp-build)
(defvar *compile-file-warnings-behaviour* (defvar *compile-file-warnings-behaviour*
...@@ -202,20 +202,20 @@ it will filter them appropriately." ...@@ -202,20 +202,20 @@ it will filter them appropriately."
(output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords)) (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
#+ecl #+ecl
(object-file (object-file
(when (use-ecl-byte-compiler-p) (unless (use-ecl-byte-compiler-p)
(or object-file (or object-file
(compile-file-pathname output-file :type :object)))) (compile-file-pathname output-file :type :object))))
#+mkcl #+mkcl
(object-file (object-file
(or object-file (or object-file
(compile-file-pathname output-file #+mkcl :fasl-p #+mkcl nil))) (compile-file-pathname output-file :fasl-p nil)))
(tmp-file (make-pathname :type "fasl-tmp" :defaults output-file))) (tmp-file (tmpize-pathname output-file)))
(multiple-value-bind (output-truename warnings-p failure-p) (multiple-value-bind (output-truename warnings-p failure-p)
(or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
#+ecl (apply 'compile-file input-file #+ecl (apply 'compile-file input-file :output-file
(if object-file (if object-file
(list* :output-file object-file :type :object keywords) (list* object-file :system-p t keywords)
keywords)) (list* output-file keywords)))
#+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords)) #+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords))
(cond (cond
((and output-truename ((and output-truename
...@@ -225,7 +225,7 @@ it will filter them appropriately." ...@@ -225,7 +225,7 @@ it will filter them appropriately."
(check-flag warnings-p *compile-file-warnings-behaviour*))) (check-flag warnings-p *compile-file-warnings-behaviour*)))
(progn (progn
#+(or ecl mkcl) #+(or ecl mkcl)
(when (and (eq status :success) #+ecl object-file) (when (and #+ecl object-file)
(setf output-truename (setf output-truename
(compiler::build-fasl (compiler::build-fasl
tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
......
...@@ -74,7 +74,10 @@ or when loading the package is optional." ...@@ -74,7 +74,10 @@ or when loading the package is optional."
(defun symbol-shadowing-p (symbol package) (defun symbol-shadowing-p (symbol package)
(and (member symbol (package-shadowing-symbols package)) t)) (and (member symbol (package-shadowing-symbols package)) t))
(defun home-package-p (symbol package) (defun home-package-p (symbol package)
(eq (symbol-package symbol) (find-package* package)))) (and package (let ((sp (symbol-package symbol)))
(and sp (let ((pp (find-package* package)))
(and pp (eq sp pp))))))))
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defun symbol-package-name (symbol) (defun symbol-package-name (symbol)
...@@ -213,10 +216,10 @@ or when loading the package is optional." ...@@ -213,10 +216,10 @@ or when loading the package is optional."
(defun ensure-package-unused (package) (defun ensure-package-unused (package)
(loop :for p :in (package-used-by-list package) :do (loop :for p :in (package-used-by-list package) :do
(unuse-package package p))) (unuse-package package p)))
(defun delete-package* (package &optional nuke) (defun delete-package* (package &key nuke)
(let ((p (find-package package))) (let ((p (find-package package)))
(when p (when p
(when nuke (do-symbols (s p) (when (eq p (symbol-package s)) (nuke-symbol s)))) (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
(ensure-package-unused p) (ensure-package-unused p)
(delete-package package)))) (delete-package package))))
(defun fresh-package-name (&optional (prefix :%TO-BE-DELETED) (defun fresh-package-name (&optional (prefix :%TO-BE-DELETED)
...@@ -236,8 +239,12 @@ or when loading the package is optional." ...@@ -236,8 +239,12 @@ or when loading the package is optional."
;;; Communicable representation of symbol and package information ;;; Communicable representation of symbol and package information
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defun package-definition-form (package-designator &key internp (nicknamesp t) (error t)) (defun package-definition-form (package-designator
(let* ((package (find-package* package-designator error)) &key (nicknamesp t) (usep t)
(shadowp t) (shadowing-import-p t)
(exportp t) (importp t) internp (error t))
(let* ((package (or (find-package* package-designator error)
(return-from package-definition-form nil)))
(name (package-name package)) (name (package-name package))
(nicknames (package-nicknames package)) (nicknames (package-nicknames package))
(use (mapcar #'package-name (package-use-list package))) (use (mapcar #'package-name (package-use-list package)))
...@@ -281,11 +288,11 @@ or when loading the package is optional." ...@@ -281,11 +288,11 @@ or when loading the package is optional."
:collect `(,key ,i ,@(sort-names (gethash i table)))))) :collect `(,key ,i ,@(sort-names (gethash i table))))))
`(defpackage ,name `(defpackage ,name
,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
(:use ,@(sort-names use)) (:use ,@(and usep (sort-names use)))
,@(when-relevant :shadow (sort-names shadow)) ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
,@(import-options :shadowing-import-from shadowing-import) ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
,@(import-options :import-from import) ,@(import-options :import-from (and importp import))
,@(when-relevant :export (sort-names export)) ,@(when-relevant :export (and exportp (sort-names export)))
,@(when-relevant :intern (and internp (sort-names intern))))))))) ,@(when-relevant :intern (and internp (sort-names intern)))))))))
...@@ -573,15 +580,17 @@ or when loading the package is optional." ...@@ -573,15 +580,17 @@ or when loading the package is optional."
:mix ,mix :reexport ,reexport :unintern ,unintern))))) :mix ,mix :reexport ,reexport :unintern ,unintern)))))
(defmacro define-package (package &rest clauses) (defmacro define-package (package &rest clauses)
`(eval-when (:compile-toplevel :load-toplevel :execute) (let ((ensure-form
#+(or ecl gcl) (defpackage ,package (:use)) `(apply 'ensure-package ',(parse-define-package-form package clauses))))
#+clisp (eval ensure-form)
(macrolet ((foo () `(progn
(apply 'ensure-package ',(parse-define-package-form package clauses)) #+clisp
(package-definition-form ',package :nicknamesp nil))) (eval-when (:compile-toplevel :load-toplevel :execute)
(foo)) ,ensure-form)
(apply 'ensure-package ',(parse-define-package-form package clauses)))) #+(or ecl gcl) (defpackage ,package (:use))
#+clisp ,(package-definition-form package :error nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
,ensure-form))))
;;;; Final tricks to keep various implementations happy. ;;;; Final tricks to keep various implementations happy.
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
...@@ -590,14 +599,3 @@ or when loading the package is optional." ...@@ -590,14 +599,3 @@ or when loading the package is optional."
(remove "asdf" excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car))) :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")))
(when (find-package :asdf)
(delete-package* :asdf t))
(make-package :asdf :use ())))
...@@ -21,6 +21,7 @@ ...@@ -21,6 +21,7 @@
;; Parsing filenames and lists thereof ;; Parsing filenames and lists thereof
#:component-name-to-pathname-components #:component-name-to-pathname-components
#:split-name-type #:parse-unix-namestring #:unix-namestring #:split-name-type #:parse-unix-namestring #:unix-namestring
#:split-unix-namestring-directory-components
#:subpathname #:subpathname* #:subpathname #:subpathname*
;; Resolving symlinks somewhat ;; Resolving symlinks somewhat
#:truenamize #:resolve-symlinks #:resolve-symlinks* #:truenamize #:resolve-symlinks #:resolve-symlinks*
...@@ -429,11 +430,12 @@ with given pathname and if it exists return its truename." ...@@ -429,11 +430,12 @@ with given pathname and if it exists return its truename."