Commit 5e8b50cd authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files
parents 6a7f5896 304923f7
......@@ -74,7 +74,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.32.20" ;; to be automatically updated by make bump-version
:version "2.32.25" ;; to be automatically updated by make bump-version
:depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system.
......
......@@ -30,8 +30,12 @@
#+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 bundle-compile-op (bundle-op basic-compile-op)
()
(:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
;; create a single fasl for the entire library
(defclass basic-fasl-op (bundle-op basic-compile-op)
(defclass basic-fasl-op (bundle-compile-op)
((bundle-type :initform :fasl)))
(defclass prepare-fasl-op (sideway-operation)
((sideway-operation :initform 'load-fasl-op)))
......@@ -45,19 +49,19 @@
;; we'd have to have the monolithic-op not inherit from the main op,
;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
;; On ECL: compile the system and produce linkable ".a" library for it.
;; On others: just compile the system.
(defclass lib-op (bundle-op basic-compile-op)
((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
(defclass lib-op (bundle-compile-op)
((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
(:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
#-(or ecl mkcl) "just compile the system"))
(defclass dll-op (bundle-op basic-compile-op)
;; Link together all the dynamic library used by this system into a single one.
((bundle-type :initform :dll)))
((bundle-type :initform :dll))
(:documentation "Link together all the dynamic library used by this system into a single one."))
(defclass binary-op (bundle-op basic-compile-op selfward-operation)
;; On ECL: produce lib and fasl for the system.
;; On "normal" Lisps: produce just the fasl.
((selfward-operation :initform '(lib-op fasl-op))))
((selfward-operation :initform '(lib-op fasl-op)))
(:documentation #+(or ecl mkcl) "produce lib and fasl for the system."
#-(or ecl mkcl) "produce a fasl for the system"))
(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
......@@ -65,27 +69,34 @@
((prologue-code :accessor monolithic-op-prologue-code)
(epilogue-code :accessor monolithic-op-epilogue-code)))
(defclass monolithic-binary-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
;; On ECL: produce lib and fasl for combined system and dependencies.
;; On "normal" Lisps: produce an image file from system and dependencies.
((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))))
(defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
()
(:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
;; Create a single fasl for the system and its dependencies.
(defclass monolithic-fasl-op (monolithic-bundle-op basic-fasl-op) ())
(defclass monolithic-binary-op (monolithic-bundle-compile-op sideway-operation selfward-operation)
((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
(:documentation
#+ecl "produce lib and fasl for combined system and dependencies."
#-ecl "produce an image file from system and dependencies (not implemented)."))
(defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
(:documentation "Create a single fasl for the system and its dependencies."))
(defclass monolithic-lib-op (monolithic-bundle-op basic-compile-op)
;; ECL: Create a single linkable library for the system and its dependencies.
((bundle-type :initform :lib)))
(defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op)
((bundle-type :initform :lib))
(:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
#-(or ecl mkcl) "Compile a system and its dependencies."))
(defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation)
((bundle-type :initform :dll)
(selfward-operation :initform 'dll-op)
(sideway-operation :initform 'dll-op)))
(defclass program-op (monolithic-bundle-op selfward-operation)
;; All: create an executable file from the system and its dependencies
(defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
#-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
((bundle-type :initform :program)
(selfward-operation :initform #+(or mkcl ecl) 'monolithic-lib-op #-(or mkcl ecl) 'load-op)))
#-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
(:documentation "create an executable file from the system and its dependencies"))
(defun bundle-pathname-type (bundle-type)
(etypecase bundle-type
......@@ -101,13 +112,14 @@
((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-build-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))
(eq (type-of o) (component-build-operation c)))))))
(when (input-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-build-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))
(eq (type-of o) (component-build-operation c))))))))
(defmethod output-files ((o bundle-op) (c system))
(bundle-output-files o c))
......@@ -202,36 +214,16 @@
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
(with-upgradability ()
(defmethod component-depends-on ((o monolithic-lib-op) (c system))
(declare (ignorable o))
`((lib-op ,@(required-components c :other-systems t :component-type 'system
:goal-operation (find-operation o 'load-op)
:keep-operation 'compile-op))
,@(call-next-method)))
(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
(declare (ignorable o))
`((#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
,@(required-components c :other-systems t :component-type 'system
:goal-operation (find-operation o 'load-fasl-op)
:keep-operation 'fasl-op))
,@(call-next-method)))
(defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o))
`((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
:goal-operation (find-operation o 'load-op)
:keep-operation 'compile-op))
,@(call-next-method)))
#-ecl
(defmethod component-depends-on ((o fasl-op) (c system))
`(,@(component-depends-on (find-operation o 'lib-op) c)
,@(call-next-method)))
(defmethod component-depends-on ((o dll-op) c)
`(,@(component-depends-on (find-operation o 'lib-op) c)
(defmethod component-depends-on ((o bundle-compile-op) (c system))
`(,(if (operation-monolithic-p o)
`(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
,@(required-components c :other-systems t :component-type 'system
:goal-operation (find-operation o 'load-op)
:keep-operation 'compile-op))
`(compile-op
,@(required-components c :other-systems nil :component-type '(not system)
:goal-operation (find-operation o 'load-op)
:keep-operation 'compile-op)))
,@(call-next-method)))
(defmethod component-depends-on :around ((o bundle-op) (c component))
......@@ -249,7 +241,7 @@
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(defmethod input-files ((o bundle-op) (c system))
(defmethod input-files ((o bundle-compile-op) (c system))
(direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
(defun select-bundle-operation (type &optional monolithic)
......@@ -311,7 +303,8 @@
nil)
(defmethod perform ((o load-fasl-op) (c system))
(perform-lisp-load-fasl o c))
(when (input-files o c)
(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)))
......@@ -395,13 +388,13 @@
s)))))
#-(or ecl mkcl)
(defmethod perform ((o basic-fasl-op) (c system))
(defmethod perform ((o bundle-compile-op) (c system))
(let* ((input-files (input-files o c))
(fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
(non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
(output-files (output-files o c))
(output-file (first output-files)))
(unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
;;(unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
(when input-files
(assert output-files)
(when non-fasl-files
......@@ -432,22 +425,23 @@
#+ecl
(with-upgradability ()
(defmethod perform ((o bundle-op) (c system))
(defmethod perform ((o bundle-compile-op) (c system))
(let* ((object-files (input-files o c))
(output (output-files o c))
(bundle (first output))
(kind (bundle-type o)))
(create-image
bundle (append object-files (bundle-op-lisp-files o))
:kind kind
:entry-point (component-entry-point c)
:prologue-code
(when (typep o 'monolithic-bundle-op)
(monolithic-op-prologue-code o))
:epilogue-code
(when (typep o 'monolithic-bundle-op)
(monolithic-op-epilogue-code o))
:build-args (bundle-op-build-args o)))))
(when output
(create-image
bundle (append object-files (bundle-op-lisp-files o))
:kind kind
:entry-point (component-entry-point c)
:prologue-code
(when (typep o 'monolithic-bundle-op)
(monolithic-op-prologue-code o))
:epilogue-code
(when (typep o 'monolithic-bundle-op)
(monolithic-op-epilogue-code o))
:build-args (bundle-op-build-args o))))))
#+mkcl
(with-upgradability ()
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.32.20: Another System Definition Facility.
;;; This is ASDF 2.32.25: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -2,11 +2,17 @@
#+lispworks (lispworks:load-all-patches)
(load (make-pathname :name "script-support" :defaults *load-pathname*))
(load-asdf)
(asdf-test::frob-packages)
#+ecl (require :cmp)
#+ecl (trace uiop:compile-file* uiop:load*)
(asdf-test::register-directory asdf-test::*asdf-directory*) ;; we need asdf-driver, and ECL can dump.
(asdf-test::register-directory asdf-test::*uiop-directory*)
(asdf:upgrade-asdf) ;; may recompile and rename away package asdf?
(asdf-test::frob-packages)
(with-test ()
(register-directory *asdf-directory*) ;; we need asdf-driver, and ECL can dump.
(register-directory *uiop-directory*)
;;(dolist (s '(:asdf :asdf/driver :asdf/defsystem :uiop)) (DBG :foo s (asdf::builtin-system-p (find-system s))))
(trace perform-plan perform)
(operate 'load-fasl-op :hello-world-example)
(operate 'program-op :hello-world-example))
......@@ -25,13 +25,13 @@ usage () {
unset DEBUG_ASDF_TEST upgrade clean_load load_systems test_interactively extract_all
SHELL=/bin/sh
export SHELL
export SHELL DEBUG_ASDF_TEST GCL_ANSI ASDF_OUTPUT_TRANSLATIONS
while getopts "cdtHulhu" OPTION
do
case $OPTION in
d)
export DEBUG_ASDF_TEST=t
DEBUG_ASDF_TEST=t
;;
u)
upgrade=t
......@@ -183,12 +183,12 @@ case "$lisp" in
flags="-norc -eval (ext::install-bytecodes-compiler)"
eval="-eval" ;;
gcl)
export GCL_ANSI=t
GCL_ANSI=t
command="${GCL:-gcl}"
flags="-batch"
eval="-eval" ;;
gclcvs)
export GCL_ANSI=t
GCL_ANSI=t
command="${GCLCVS:-gclcvs}"
flags="-batch"
eval="-eval" ;;
......@@ -332,7 +332,6 @@ run_upgrade_tests () {
mkdir -p build/results/
rm -f build/*.*f* uiop/*.*f* test/*.*f* ## Remove stale FASLs from ASDF 1.x, especially when different implementations have same name
ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls/\" :implementation \"asdf/\")) (t (\"${ASDFDIR}/build/fasls/\" :implementation \"root/\")) :ignore-inherited-configuration)"
export ASDF_OUTPUT_TRANSLATIONS
su=test/script-support.lisp
for tag in `upgrade_tags` ; do
for method in `upgrade_methods` ; do
......
......@@ -64,3 +64,9 @@
(defsystem :test-asdf/test-source-directory-2
:pathname "some/relative/pathname/with-file.type")
(defsystem :test-asdf/bundle-1
:components ((:file "file1") (:file "file3")))
(defsystem :test-asdf/bundle-2
:depends-on (:test-asdf/bundle-1) :components ((:file "file2")))
......@@ -8,26 +8,22 @@
;;;---------------------------------------------------------------------------
(asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(asdf:clear-system :test-bundle-1)
(asdf:clear-system :test-bundle-2)
(asdf:clear-system :test-asdf/bundle-1)
(asdf:clear-system :test-asdf/bundle-2)
(when (find-package :test-package) (delete-package :test-package))
(def-test-system :test-bundle-1
:components ((:file "file1") (:file "file3")))
(def-test-system :test-bundle-2
:depends-on (:test-bundle-1) :components ((:file "file2")))
#+(or abcl (and ecl ecl-bytecmp) gcl)
(leave-test "bundles not on this implementation" 0)
(defparameter *bundle-1* (output-file 'fasl-op :test-bundle-1))
(defparameter *bundle-2* (output-file 'fasl-op :test-bundle-2))
(defparameter *mono-bundle-2* (output-file 'monolithic-fasl-op :test-bundle-2))
(defparameter *bundle-1* (output-file 'fasl-op :test-asdf/bundle-1))
(defparameter *bundle-2* (output-file 'fasl-op :test-asdf/bundle-2))
(defparameter *mono-bundle-2* (output-file 'monolithic-fasl-op :test-asdf/bundle-2))
(DBG :test-bundle *bundle-1* *bundle-2*)
(assert-equal (list *bundle-2*)
(input-files 'load-fasl-op :test-bundle-2))
(input-files 'load-fasl-op :test-asdf/bundle-2))
(delete-file-if-exists *bundle-1*)
(delete-file-if-exists *bundle-2*)
(delete-file-if-exists *mono-bundle-2*)
(operate 'load-fasl-op :test-bundle-2)
(operate 'load-fasl-op :test-asdf/bundle-2)
(DBG "Check that the bundles were indeed created.")
(assert (probe-file *bundle-2*))
(assert (probe-file *bundle-1*))
......@@ -35,5 +31,5 @@
(assert (symbol-value (find-symbol* :*file1* :test-package)))
(assert (symbol-value (find-symbol* :*file3* :test-package)))
(DBG "Now for the mono-fasl")
(operate 'monolithic-fasl-op :test-bundle-2)
(operate 'monolithic-fasl-op :test-asdf/bundle-2)
(assert (probe-file *mono-bundle-2*))
......@@ -135,14 +135,15 @@
asdf/lisp-action:try-recompiling
;; types
asdf/bundle:user-system
#+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
;; on some implementations only
asdf/bundle:bundle-system
asdf/bundle:register-pre-built-system
asdf/bundle:static-library
asdf/os:parse-file-location-info
asdf/os:parse-windows-shortcut
asdf/os:read-little-endian
asdf/os:read-null-terminated-string
uiop/os:parse-file-location-info
uiop/os:parse-windows-shortcut
uiop/os:read-little-endian
uiop/os:read-null-terminated-string
;; backward compatibility upgrade only
asdf/backward-internals:make-sub-operation
asdf/find-system:contrib-sysdef-search
......@@ -196,3 +197,27 @@
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))))
#+(and sbcl sb-unicode) (assert +non-base-chars-exist-p+)
#+(or clozure (and sbcl (not sb-unicode))) (assert (not +non-base-chars-exist-p+))
(assert (base-string-p (make-string 10 :element-type 'base-char)))
(assert-equal "abcd" (strcat "a" NIL "bc" "d"))
(assert-equal "abcd" (reduce/strcat '("a" NIL "bc" "d")))
#-non-base-chars-exist-p
(progn
(assert (base-string-p (make-string 10 :element-type 'character))))
(defun basify (s) (coerce s 'base-string))
#+non-base-chars-exist-p
(progn
(assert (not (base-string-p (make-string 10 :element-type 'character))))
(assert (not (base-string-p "abc")))
(assert (base-string-p (basify "abc")))
(assert (not (base-string-p (strcat "a" NIL #\b "cd"))))
(assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" NIL "cd")))))
(assert (base-string-p (strcat (basify "ab") (basify "cd"))))
(assert (not (base-string-p (strcat (basify "ab") #\c "d"))))
(assert (base-string-p (strcat (basify "ab") #\c #\d))))
......@@ -15,6 +15,8 @@
#:compile-warned-warning #:compile-failed-warning
#:check-lisp-compile-results #:check-lisp-compile-warnings
#:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
;; Types
#+sbcl #:sb-grovel-unknown-constant-condition
;; Functions & Macros
#:get-optimization-settings #:proclaim-optimization-settings
#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
......
......@@ -18,7 +18,9 @@
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
#:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
#:strcat #:first-char #:last-char #:split-string ;; strings
#:+non-base-chars-exist-p+ ;; characters
#:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
......@@ -183,10 +185,42 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(or (null x) (and (vectorp x) (zerop (length x))))))
;;; Characters
(with-upgradability ()
(defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
;;; Strings
(with-upgradability ()
(defun base-string-p (string)
(declare (ignorable string))
(and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
(defun strings-common-element-type (strings)
(declare (ignorable strings))
#-non-base-chars-exist-p 'character
#+non-base-chars-exist-p
(if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
'base-char 'character))
(defun reduce/strcat (strings &key key start end)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
NIL is interpreted as an empty string. A character is interpreted as a string of length one."
(when (or start end) (setf strings (subseq strings start end)))
(when key (setf strings (mapcar key strings)))
(loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
:element-type (strings-common-element-type strings))
:with pos = 0
:for input :in strings
:do (etypecase input
(null)
(character (setf (char output pos) input) (incf pos))
(string (replace output input :start1 pos) (incf pos (length input))))
:finally (return output)))
(defun strcat (&rest strings)
(apply 'concatenate 'string strings))
(reduce/strcat strings))
(defun first-char (s)
(and (stringp s) (plusp (length s)) (char s 0)))
......
......@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "2.32.20")
(asdf-version "2.32.25")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment