diff --git a/action.lisp b/action.lisp index 59810e77cadb444e0f183510f03cc14fccc054d1..2c1b4471655259d0d36ec970b57d2a9d2a016684 100644 --- a/action.lisp +++ b/action.lisp @@ -18,7 +18,6 @@ #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan #:action-path #:find-action #:stamp #:done-p #:operation-definition-warning #:operation-definition-error ;; condition - #:build-op ;; THE generic operation )) (in-package :asdf/action) @@ -66,7 +65,10 @@ `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) `(,function ,@prefix ,o ,c ,@suffix)))) `(progn - (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args) + (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args) + (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on + ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component))) + (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args) (if ,operation ,(next-method (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. @@ -177,9 +179,7 @@ depends on each of (S . D) where D is a declared dependency of C. E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, each of its declared dependencies must first be loaded as by LOAD-OP.")) (defun sideway-operation-depends-on (o c) - `((,(or (sideway-operation o) o) - ,@(loop :for dep :in (component-sideway-dependencies c) - :collect (resolve-dependency-spec c dep))))) + `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c)))) (defmethod component-depends-on ((o sideway-operation) (c component)) `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) @@ -222,7 +222,6 @@ dependencies."))) (:documentation "Error condition related to definition of incorrect OPERATION objects.")) (defmethod initialize-instance :before ((o operation) &key) - ;; build-op is a special case. (unless (typep o '(or downward-operation upward-operation sideway-operation selfward-operation non-propagating-operation)) (warn 'operation-definition-warning @@ -399,15 +398,3 @@ in some previous image, or T if it needs to be done.") (action-description operation component))) (mark-operation-done operation component) (return)))))) - -;;; Generic build operation -(with-upgradability () - ;; BUILD-OP was intended to be the default "master" operation to invoke on a system in ASDF3 - ;; (LOAD-OP typically serves that function now). - ;; This feature has not yet been fully implemented yet, and is not used by anyone yet. - ;; This is a path forward, and its default below is to backward compatibly depend on LOAD-OP. - ;; [2014/01/26:rpg] - (defclass build-op (non-propagating-operation) ()) - (defmethod component-depends-on ((o build-op) (c component)) - `((,(or (component-build-operation c) 'load-op) ,c)))) - diff --git a/asdf.asd b/asdf.asd index f477493bf3b34feed215f49d845caaa825c2be58..5d2260c9aea8d67dfa93c9c57f1cdf650fb4f3c2 100644 --- a/asdf.asd +++ b/asdf.asd @@ -49,7 +49,7 @@ (:file "cache" :depends-on ("upgrade")) (:file "find-system" :depends-on ("system" "cache")) (:file "find-component" :depends-on ("find-system")) - (:file "operation" :depends-on ("upgrade")) + (:file "operation" :depends-on ("find-system")) (:file "action" :depends-on ("find-component" "operation")) (:file "lisp-action" :depends-on ("action")) (:file "plan" :depends-on ("lisp-action")) diff --git a/bundle.lisp b/bundle.lisp index b97f643e5e988a02888053fc035d0e83c1035c88..e46a668eed06a4292fa42c389397d6f6bdc47d1e 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -7,7 +7,7 @@ :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export - #:bundle-op #:bundle-op-build-args #:bundle-type + #:bundle-op #:bundle-type #:program-system #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op @@ -18,17 +18,16 @@ #:deliver-asd-op #:monolithic-deliver-asd-op #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p - #+ecl #:make-build - #:register-pre-built-system + #:make-build #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (with-upgradability () (defclass bundle-op (basic-compile-op) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + ((build-args :initarg :args :initform nil :accessor extra-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files))) + #+ecl (lisp-files :initform nil :accessor extra-object-files))) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its @@ -39,29 +38,28 @@ itself.")) ;; operation on a system and its dependencies (defclass monolithic-bundle-op (monolithic-op bundle-op) ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation - ((prologue-code :accessor prologue-code) - (epilogue-code :accessor epilogue-code))) + ((prologue-code :initform nil :accessor prologue-code) + (epilogue-code :initform nil :accessor epilogue-code))) - (defclass bundle-system (system) + (defclass program-system (system) ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system - ((prologue-code :accessor prologue-code) - (epilogue-code :accessor epilogue-code))) - - #+mkcl - (defclass program (bundle-system) - ((prologue-code :initarg :prologue-code :initform nil :accessor prologue-code) - (epilogue-code :initarg :epilogue-code :initform nil :accessor epilogue-code) + ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) + (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) (prefix-lisp-object-files :initarg :prefix-lisp-object-files - :initform nil :accessor program-prefix-lisp-object-files) + :initform nil :accessor prefix-lisp-object-files) (postfix-lisp-object-files :initarg :postfix-lisp-object-files - :initform nil :accessor program-postfix-lisp-object-files) - (object-files :initarg :object-files - :initform nil :accessor program-object-files) + :initform nil :accessor postfix-lisp-object-files) + (extra-object-files :initarg :extra-object-files + :initform nil :accessor extra-object-files) (extra-build-args :initarg :extra-build-args - :initform nil :accessor program-extra-build-args))) + :initform nil :accessor extra-build-args))) (defmethod prologue-code ((x t)) nil) (defmethod epilogue-code ((x t)) nil) + (defmethod prefix-lisp-object-files ((x t)) nil) + (defmethod postfix-lisp-object-files ((x t)) nil) + (defmethod extra-object-files ((x t)) nil) + (defmethod extra-build-args ((x t)) nil) (defclass link-op (bundle-op) () (:documentation "Abstract operation for linking files together")) @@ -97,7 +95,8 @@ itself.")) ;; operation on a system and its dependencies ((bundle-type :initform :lib)) (:documentation "compile the system and produce linkable (.a) library for it.")) - (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation #+ecl link-op #-ecl gather-op) + (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation + #+(or ecl mkcl) link-op #-ecl gather-op) ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class))) (defclass load-bundle-op (basic-load-op selfward-operation) @@ -123,7 +122,7 @@ itself.")) ;; operation on a system and its dependencies (:documentation "produce fasl and asd files for combined system and dependencies.")) (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op - #+ecl link-op gather-op non-propagating-operation) + #+(or ecl mkcl) link-op gather-op non-propagating-operation) ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) @@ -139,7 +138,7 @@ itself.")) ;; operation on a system and its dependencies (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) (defclass image-op (monolithic-bundle-op selfward-operation - #+ecl link-op #+(or ecl mkcl) gather-op) + #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op) ((bundle-type :initform :image) (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) @@ -217,8 +216,8 @@ itself.")) ;; operation on a system and its dependencies (setf (prologue-code instance) prologue-code (epilogue-code instance) epilogue-code) #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code))) - #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) - (setf (bundle-op-build-args instance) + #+ecl (setf (extra-object-files instance) lisp-files))) + (setf (extra-build-args instance) (remove-plist-keys '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files) (operation-original-initargs instance)))) @@ -252,11 +251,6 @@ itself.")) ;; operation on a system and its dependencies ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () - (defmethod component-depends-on :around ((o bundle-op) (c component)) - (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) - `((,op ,c)) - (call-next-method))) - (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) ;; This file selects output files from direct dependencies; ;; your component-depends-on method better gathered the correct dependencies in the correct order. @@ -283,7 +277,7 @@ itself.")) ;; operation on a system and its dependencies ((:program) 'program-op))) - ;; This is originally from asdf-ecl.lisp. Does anyone use it? + ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it? (defun make-build (system &rest args &key (monolithic nil) (type :fasl) (move-here nil move-here-p) &allow-other-keys) @@ -306,7 +300,12 @@ itself.")) ;; operation on a system and its dependencies :defaults dest-path) :do (rename-file-overwriting-target f new-f) :collect new-f) - files)))) + files))) + + ;; DEPRECATED. Does anyone use this? + (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'deliver-asd-op system args))) ;;; ;;; LOAD-BUNDLE-OP @@ -315,8 +314,7 @@ itself.")) ;; operation on a system and its dependencies ;;; (with-upgradability () (defmethod component-depends-on ((o load-bundle-op) (c system)) - `((,o ,@(loop :for dep :in (component-sideway-dependencies c) - :collect (resolve-dependency-spec c dep))) + `((,o ,@(component-sideway-dependencies c)) (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) ,@(call-next-method))) @@ -461,38 +459,37 @@ itself.")) ;; operation on a system and its dependencies (asdf:load-system :precompiled-asdf-utils) |# -#+ecl -(with-upgradability () - (defun uiop-library-file () - (or (and (find-system :uiop nil) - (system-source-directory :uiop) - (progn - (operate 'lib-op :uiop) - (output-file 'lib-op :uiop))) - (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib)))) - (defmethod input-files :around ((o program-op) (c system)) - (let ((files (call-next-method)) - (plan (traverse-sub-actions o c :plan-class 'sequential-plan))) - (unless (or (and (system-source-directory :uiop) - (plan-operates-on-p plan '("uiop"))) - (and (system-source-directory :asdf) - (plan-operates-on-p plan '("asdf")))) - (pushnew (uiop-library-file) files :test 'pathname-equal)) - files))) - #+(or ecl mkcl) (with-upgradability () - (defun register-pre-built-system (name) - (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) - -#+ecl -(with-upgradability () - ;; I think that Juanjo intended for this to be. - ;; But it might break systems with missing dependencies, - ;; and there is a weird bug in test-xach-update-bug.script - ;;(unless (use-ecl-byte-compiler-p) + ;; I think that Juanjo intended for this to be, + ;; but beware the weird bug in test-xach-update-bug.script, + ;; and also it makes mkcl fail test-logical-pathname.script, + ;; and ecl fail test-bundle.script. + ;;(unless (or #+ecl (use-ecl-byte-compiler-p)) ;; (setf *load-system-operation* 'load-bundle-op)) + (defun asdf-library-pathname () + #+ecl (compile-file-pathname "sys:asdf" :type :lib) + #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf")) + + (defun make-library-system (name pathname) + (make-instance 'prebuilt-system :name name :static-library (resolve-symlinks* pathname))) + + (defmethod component-depends-on :around ((o image-op) (c system)) + (destructuring-bind ((lib-op . deps)) (call-next-method) + (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))) + `((,lib-op + #+mkcl ,@(unless (has-it-p "cmp") + `(,(make-library-system + "cmp" (make-pathname :type (bundle-pathname-type :lib) + :defaults #p"sys:cmp")))) + ,@(unless (or (has-it-p "asdf") (has-it-p "uiop")) + `(,(cond + ((system-source-directory :uiop) (find-system :uiop)) + ((system-source-directory :asdf) (find-system :asdf)) + (t (make-fake-asdf-system "asdf" (asdf-library-pathname)))))) + ,@deps))))) + (defmethod perform ((o link-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) @@ -501,41 +498,17 @@ itself.")) ;; operation on a system and its dependencies (kind (bundle-type o))) (when output (apply 'create-image - bundle (append object-files (bundle-op-lisp-files o)) + bundle (append + (when programp (prefix-lisp-object-files c)) + object-files + (when programp (postfix-lisp-object-files c))) :kind kind :prologue-code (or (prologue-code o) (when programp (prologue-code c))) :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c))) - :build-args (bundle-op-build-args o) + :build-args (or (extra-build-args o) (when programp (extra-build-args c))) + :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c))) (when programp `(:entry-point ,(component-entry-point c)))))))) -#+mkcl -(with-upgradability () - (defmethod perform ((o dll-op) (s system)) - (apply #'compiler::build-shared-library (output-file o s) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) - - (defmethod perform ((o lib-op) (s system)) - (apply #'compiler::build-static-library (output-file o s) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) - - (defmethod perform ((o basic-compile-bundle-op) (s system)) - (apply #'compiler::build-bundle (output-file o s) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) - - (defmethod perform ((o program-op) (s system)) - (apply #'compiler::build-program (output-file o s) - :lisp-object-files (append (program-prefix-lisp-object-files s) - (input-files o s) - (program-postfix-lisp-object-files s)) - :object-files (program-object-files s) - :prologue-code (prologue-code s) - :epilogue-code (epilogue-code s) - (program-extra-build-args s))) - - (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'deliver-asd-op system args))) - #+(and (not asdf-use-unsafe-mac-bundle-op) (or (and ecl darwin) (and abcl darwin (not abcl-bundle-op-supported)))) diff --git a/interface.lisp b/interface.lisp index 4170f865a229d1d823195b4d641dfdc138bf5bac..13d052231f812b898bb76f8a4413a1ed1dd8b5cd 100644 --- a/interface.lisp +++ b/interface.lisp @@ -25,7 +25,7 @@ #:operation #:make-operation #:find-operation #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation - #:build-system #:build-op + #:build-op #:make #:load-op #:prepare-op #:compile-op #:prepare-source-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf @@ -35,7 +35,7 @@ #:needed-in-image-p #:component-load-dependencies #:run-shell-command ; deprecated, do not use #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system - #+ecl #:make-build + #:program-system #:make-build #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op diff --git a/operate.lisp b/operate.lisp index 4e040d58d0a1a7c838c6747af6e15e7c84a0f5c1..74aa5c539f5fc26102e07d076068fa286c1c160a 100644 --- a/operate.lisp +++ b/operate.lisp @@ -9,7 +9,7 @@ (:export #:operate #:oos #:*systems-being-operated* - #:build-system + #:build-op #:make #:load-system #:load-systems #:load-systems* #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf @@ -55,11 +55,13 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (on-failure *compile-file-failure-behaviour*) &allow-other-keys) (let* ((systems-being-operated *systems-being-operated*) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) - (operation-name (reify-symbol (etypecase operation - (operation (type-of operation)) - (symbol operation)))) - (operation-initargs (operation-original-initargs operation)) - (component-path (typecase component + (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) + (etypecase operation + (operation (let ((name (type-of operation)) + (initargs (operation-original-initargs operation))) + #'(lambda () (make-operation name :original-initargs initargs initargs)))) + ((or symbol string) (constantly operation)))) + (component-path (typecase component ;; to remake the component after ASDF upgrade (component (component-find-path component)) (t component)))) ;; Before we operate on any system, make sure ASDF is up-to-date, @@ -69,11 +71,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ;; If we were upgraded, restart OPERATE the hardest of ways, for ;; its function may have been redefined, its symbol uninterned, its package deleted. (return-from operate - (apply (find-symbol* 'operate :asdf) - (apply (find-symbol* 'make-operation :asdf) - (unreify-symbol operation-name) - :original-initargs operation-initargs operation-initargs) - component-path keys)))) + (apply 'operate (funcall operation-remaker) component-path keys)))) ;; Setup proper bindings around any operate call. (with-asdf-cache () (let* ((*verbose-out* (and verbose *standard-output*)) @@ -106,14 +104,32 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (with-upgradability () (defvar *load-system-operation* 'load-op "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. -You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, +You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken. -This may change in the future as we will implement component-based strategy -for how to load or compile stuff") - - (defun build-system (system &rest keys) - "Shorthand for `(operate 'asdf:build-op system)`." +The default operation may change in the future if we implement a +component-directed strategy for how to load or compile systems.") + + (defmethod component-depends-on ((o prepare-op) (s system)) + `((,*load-system-operation* ,@(component-sideway-dependencies s)))) + + (defclass build-op (non-propagating-operation) () + (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, +to operate by default on a system or component, via the function BUILD. +Its meaning is configurable via the :BUILD-OPERATION option of a component. +which typically specifies the name of a specific operation to which to delegate the build, +as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on); +if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION* +that will load the system in the current image, and its typically LOAD-OP.")) + (defmethod component-depends-on ((o build-op) (c component)) + `((,(or (component-build-operation c) *load-system-operation*) ,c))) + + (defun make (system &rest keys) + "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). +It will build system FOO using the operation BUILD-OP, +the meaning of which is configurable by the system, and +defaults to *LOAD-SYSTEM-OPERATION*, usually LOAD-OP, +to load it in current image." (apply 'operate 'build-op system keys) t) diff --git a/operation.lisp b/operation.lisp index 9521bcc5b65cc687f95a30694c5db6927d849f68..a192a95c50383b72f17bc0b6e975c4cebf65fb4d 100644 --- a/operation.lisp +++ b/operation.lisp @@ -3,7 +3,7 @@ (uiop/package:define-package :asdf/operation (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. - (:use :uiop/common-lisp :uiop :asdf/upgrade) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) (:export #:operation #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. @@ -42,8 +42,10 @@ (defparameter* *operations* (make-hash-table :test 'equal)) (defun make-operation (operation-class &rest initargs) - (ensure-gethash (cons operation-class initargs) *operations* - (list* 'make-instance operation-class initargs))) + (let ((class (coerce-class operation-class + :package :asdf/interface :super 'operation :error 'sysdef-error))) + (ensure-gethash (cons class initargs) *operations* + (list* 'make-instance class initargs)))) (defgeneric find-operation (context spec) (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) @@ -52,6 +54,8 @@ (defmethod find-operation (context (spec symbol)) (when spec ;; NIL designates itself, i.e. absence of operation (apply 'make-operation spec (operation-original-initargs context)))) + (defmethod find-operation (context (spec string)) + (apply 'make-operation spec (operation-original-initargs context))) (defmethod operation-original-initargs ((context symbol)) (declare (ignorable context)) nil)) diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp index 75d911b957def9d04ce37f04a3dbcdf7fb9597fc..49f2e12b1862129306367bb5c7d395bf6b055f6c 100644 --- a/parse-defsystem.lisp +++ b/parse-defsystem.lisp @@ -48,22 +48,14 @@ (defvar *default-component-class* 'cl-source-file) (defun class-for-type (parent type) - (or (loop :for symbol :in (list - type - (find-symbol* type *package* nil) - (find-symbol* type :asdf/interface nil) - (and (stringp type) (safe-read-from-string type :package :asdf/interface))) - :for class = (and symbol (symbolp symbol) (find-class* symbol nil)) - :when (and class - (#-cormanlisp subtypep #+cormanlisp cl::subclassp - class (find-class* 'component))) - :return class) - (and (eq type :file) - (find-class* - (or (loop :for p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) - *default-component-class*) nil)) - (sysdef-error "don't recognize component type ~A" type)))) + (or (coerce-class type :package :asdf/interface :super 'component :error nil) + (and (eq type :file) + (coerce-class + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) + :package :asdf/interface :super 'component :error nil)) + (sysdef-error "don't recognize component type ~S" type)))) ;;; Check inputs diff --git a/test/l-file.lisp b/test/l-file.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2e39c99e2ada48245b536f5baf0cab6e9eed1ed0 --- /dev/null +++ b/test/l-file.lisp @@ -0,0 +1,10 @@ +(defpackage :l-file + (:use :asdf :uiop :cl) ;; asdf/package-system dependencies + (:export #:cl-source-file.l)) + +(in-package :l-file) + +(defclass cl-source-file.l (cl-source-file) + ((type :initform "l"))) + +(defclass asdf::cl-source-file.l (cl-source-file.cl) ()) diff --git a/test/l-operation.lisp b/test/l-operation.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b9017563ea5458213494c2feac3646032b78ed72 --- /dev/null +++ b/test/l-operation.lisp @@ -0,0 +1,12 @@ +(cl:defpackage :l-operation + (:use :asdf :uiop :cl) ;; asdf/package-system dependencies + (:export #:op #:*x*)) + +(cl:in-package :l-operation) + +(defparameter *x* 0) + +(defclass op (load-op) ()) + +(defmethod perform :after ((o op) (c t)) + (incf *x*)) diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp index 48cfd706f044a14c41fdf0420ec93ba24abe7245..bc3126907a0c88544b3f6900a51686afffe04dfe 100644 --- a/test/make-hello-world.lisp +++ b/test/make-hello-world.lisp @@ -10,16 +10,25 @@ (asdf-test::frob-packages) -(defun make-hello-image () +#+mkcl +(defun add-mkcl-dll (pathname) + ;; make sure mkcl-X.X.X.dll is the same directory as the executable + (let* ((dll-orig (subpathname (si::self-truename) + (strcat #-windows "../lib/" + "mkcl_" (lisp-implementation-version) + "." (asdf/bundle:bundle-pathname-type :shared-library)))) + (dll-dest (subpathname pathname (strcat #-windows "../lib/" (file-namestring dll-orig))))) + (ensure-directories-exist dll-dest) + (copy-file dll-orig dll-dest))) + + +(defun make-hello-bundle (operation) (operate 'load-fasl-op :hello-world-example) - (operate 'image-op :hello-world-example)) + (operate operation :hello-world-example) + #+mkcl (add-mkcl-dll (asdf::output-file operation :hello-world-example))) + +(defun make-hello-image () + (make-hello-bundle 'image-op)) (defun make-hello-program () - (operate 'load-fasl-op :hello-world-example) - (operate 'program-op :hello-world-example) - #+(and mkcl windows) ;; make sure mkcl-X.X.X.dll is the same directory as the executable - (let* ((dll-orig (subpathname (si::self-truename) - (strcat "mkcl_" (lisp-implementation-version) ".dll"))) - (exe (asdf::output-file 'program-op :hello-world-example)) - (dll-dest (subpathname exe dll-orig))) - (copy-file dll-orig dll-dest))) + (make-hello-bundle 'program-op)) diff --git a/test/test-bundle.script b/test/test-bundle.script index da8c2658ac98fe34b32e2c985598c896940bb569..fe30636e38fbc3dfaf2386c52c5e8de9ccb4fbf8 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -52,6 +52,7 @@ ;;; Test dll-op and monolithic-dll-op on ECL and MKCL #+(or ecl mkcl) (progn + #+ecl (trace c::builder) (require 'sockets) ;; Test the pre-compiled system feature (operate 'dll-op :test-asdf/dll-test) (let ((dll (first (output-files 'dll-op :test-asdf/dll-test)))) diff --git a/test/test-defsystem-depends-on.script b/test/test-defsystem-depends-on.script new file mode 100644 index 0000000000000000000000000000000000000000..9c2099cdc5d0b0bb0f295ecf47cdbc6b3bcb3e2f --- /dev/null +++ b/test/test-defsystem-depends-on.script @@ -0,0 +1,30 @@ +;;-*- Lisp -*- + +(def-test-system test-defsystem-depends-on-1 + :defsystem-depends-on (test-asdf/l-file) + :default-component-class "l-file:cl-source-file.l" + :components + ((:cl-source-file.l "file1" :type "lisp") + (:cl-source-file "file2" :depends-on ("file1")) + (:file "test-extension"))) + +(load-system :test-defsystem-depends-on-1) + +(def-test-system test-defsystem-depends-on-2 + :defsystem-depends-on (test-asdf/l-operation) + :build-operation "l-operation:op" + :components + ((:file "file3"))) + +(assert-equal 0 l-operation:*x*) + +(make :test-defsystem-depends-on-2) + +(assert-equal 2 l-operation:*x*) ;; perform called twice, on file and on system. + +(def-test-system test-defsystem-depends-on-3 + :defsystem-depends-on (test-asdf/l-operation) + :build-operation "does-not-exist" + :components ((:file "file3"))) + +(signals asdf::formatted-system-definition-error (make :test-defsystem-depends-on-3)) diff --git a/test/test-encodings.script b/test/test-encodings.script index 0d9aa54d31b023536d042a1ba39ed7d221e6fa13..5bbbb852da14fb6d258df0a9d822d3936b824f18 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -45,6 +45,10 @@ (when (version< version-nums "1.1.2") (leave-test "Your old ABCL is known to fail this test script, so skipping it." 0))) +#+mkcl +(when (version<= (lisp-implementation-version) "1.1.8") + (leave-test "Your old MKCL is known to fail this test script, so skipping it." 0)) + (with-encoding-test (:utf-8) (def-test-system :test-encoding-explicit-u8 :components ((:file "lambda" :encoding :utf-8)))) diff --git a/test/test-extension.l b/test/test-extension.l new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index 897877aeffb1afc9fc80d17af4b414414c6abf7a..b7e54e076d6d59373e4a49bfacdac39941b1b53c 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -15,7 +15,9 @@ (DBG :logical (logical-pathname-translations "ASDF") (translate-logical-pathname "ASDF:test;test-logical-pathname.asd") - (truename "ASDF:test;test-logical-pathname.asd")) + (truename "ASDF:test;test-logical-pathname.asd") + (translate-logical-pathname "ASDF:test;test-logical-pathname.lisp") + (translate-logical-pathname "ASDF:test;test-logical-pathname.fasl")) #+(or gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0) diff --git a/test/test-program.script b/test/test-program.script index 8756d78d9beb9d7a5f25b299da8b7654579e105e..8a027229229e7011ae2345352b330ec1e4a4beba 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -1,6 +1,9 @@ ;;; -*- Lisp -*- (DBG :foo (current-lisp-file-pathname)) +#+mkcl (trace perform create-image component-depends-on) ;; compiler::build-shared-library compiler::build-static-library compiler::build-bundle compiler::build-program +#+ecl (trace perform create-image c::builder component-depends-on) + (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t) (DBG "Creating images is not supported on your CL implementation") (leave-test "Skipping test" 0)) diff --git a/test/test-utilities.script b/test/test-utilities.script index b67336f9e65945f75c111c8f478b9b7ab0eaaa78..dae08789b5ec27aa65b9d9f759ec6e57d5e55c0e 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -144,7 +144,6 @@ #+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 uiop/os:parse-file-location-info uiop/os:parse-windows-shortcut diff --git a/uiop/image.lisp b/uiop/image.lisp index 39a7066ef0362acf1273b36140b2d36041bdab04..6c328ae8b08ed4dc6e5d8793a1902a90a4c1ec4e 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -416,18 +416,19 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) - (defun create-image (destination object-files - &key kind output-name prologue-code epilogue-code + (defun create-image (destination lisp-object-files + &key kind output-name prologue-code epilogue-code extra-object-files (prelude () preludep) (postlude () postludep) (entry-point () entry-point-p) build-args) - (declare (ignorable destination object-files kind output-name prologue-code epilogue-code - prelude preludep postlude postludep entry-point entry-point-p build-args)) + (declare (ignorable destination lisp-object-files extra-object-files kind output-name + prologue-code epilogue-code prelude preludep postlude postludep + entry-point entry-point-p build-args)) "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" ;; 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. - #-ecl (error "~S not implemented for your implementation (yet)" 'create-image) - #+ecl + #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image) + #+(or ecl mkcl) (let ((epilogue-forms (append (when epilogue-code `(,epilogue-code)) @@ -438,19 +439,26 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ((:image) (setf kind :program) ;; to ECL, it's just another program. `((setf *image-dumped-p* t) - (si::top-level t) (quit))) + (si::top-level #+ecl t) (quit))) ((:program) `((setf *image-dumped-p* :executable) (shell-boolean-exit (restore-image)))))))) - (check-type kind (member :dll :lib :static-library :program :object :fasl :program)) - (apply 'c::builder - kind (pathname destination) - :lisp-files object-files - :init-name (c::compute-init-name (or output-name destination) :kind kind) - :prologue-code prologue-code - :epilogue-code (when epilogue-forms `(progn ,@epilogue-forms)) - build-args)))) + #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl)) + (apply #+ecl 'c::builder #+ecl kind + #+mkcl (ecase kind + ((:dll) 'compiler::build-shared-library) + ((:lib :static-library) 'compiler::build-static-library) + ((:fasl) 'compiler::build-bundle) + ((:program) 'compiler::build-program)) + (pathname destination) + #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files) + #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind) + (append + (when prologue-code `(:prologue-code ,prologue-code)) + (when epilogue-forms `(:epilogue-code (progn ,@epilogue-forms))) + #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) + build-args))))) ;;; Some universal image restore hooks diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 5b2406164e90d4d5ecf845e545d816b2d1c9429e..aac6a3a62cc0602203baf43f514c1ac491719c1e 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -24,7 +24,7 @@ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p - #:find-class* ;; CLOS + #:coerce-class ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:earlier-stamp #:stamps-earliest #:earliest-stamp #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f @@ -331,14 +331,6 @@ the two results passed to STRCAT always reconstitute the original string" (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) -;;; CLOS -(with-upgradability () - (defun find-class* (x &optional (errorp t) environment) - (etypecase x - ((or standard-class built-in-class) x) - (symbol (find-class x errorp environment))))) - - ;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype stamp () '(or real boolean))) @@ -437,6 +429,36 @@ When CALL-NOW-P is true, also call the function immediately." (when call-now-p (call-function hook)))) +;;; CLOS +(with-upgradability () + (defun coerce-class (class &key (package :cl) (super t) (error 'error)) + "Coerce CLASS to a class that is subclass of SUPER if specified, +or invoke ERROR handler as per CALL-FUNCTION. + +A keyword designates the name a symbol, which when found in either PACKAGE, designates a class. +-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. +A string is read as a symbol while in PACKAGE, the symbol designates a class. + +A class object designates itself. +NIL designates itself (no class). +A symbol otherwise designates a class by name." + (let* ((normalized + (typecase class + (keyword (or (find-symbol* class package nil) + (find-symbol* class *package* nil))) + (string (symbol-call :uiop :safe-read-from-string class :package package)) + (t class))) + (found + (etypecase normalized + ((or standard-class built-in-class) normalized) + ((or null keyword) nil) + (symbol (find-class normalized nil nil))))) + (or (and found + (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super)) + found) + (call-function error "Can't coerce ~S to a ~@[class~;subclass of ~:*~S]" class super))))) + + ;;; Hash-tables (with-upgradability () (defun ensure-gethash (key table default)