Skip to content
Snippets Groups Projects
Commit 5e8b50cd authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files
parents 6a7f5896 304923f7
No related branches found
No related tags found
No related merge requests found
......@@ -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)))
......
"2.32.20"
"2.32.25"
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment