Skip to content
Snippets Groups Projects
Commit e506e91a authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Move the inline-method support to parse-defsystem

from backward-internals, where it doesn't belong (anymore),
since there is no longer any desire to deprecate the feature.
parent 15c022dc
No related branches found
No related tags found
No related merge requests found
...@@ -69,7 +69,7 @@ XCL ?= xcl ...@@ -69,7 +69,7 @@ XCL ?= xcl
header_lisp := header.lisp header_lisp := header.lisp
driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/run-program.lisp uiop/lisp-build.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/run-program.lisp uiop/lisp-build.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp
defsystem_lisp := upgrade.lisp component.lisp system.lisp cache.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 parse-defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp package-inferred-system.lisp interface.lisp user.lisp footer.lisp defsystem_lisp := upgrade.lisp component.lisp system.lisp cache.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp
all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
# Making ASDF itself should be our first, default, target: # Making ASDF itself should be our first, default, target:
......
...@@ -56,16 +56,16 @@ ...@@ -56,16 +56,16 @@
(:file "operate" :depends-on ("plan")) (:file "operate" :depends-on ("plan"))
(:file "output-translations" :depends-on ("operate")) (:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system")) (:file "source-registry" :depends-on ("find-system"))
(:file "backward-internals" :depends-on ("lisp-action" "operate")) (:file "parse-defsystem" :depends-on ("cache" "system" "lisp-action" "operate"))
(:file "parse-defsystem" :depends-on ("backward-internals" "cache" "system"))
(:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem")) (:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem"))
(:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle")) (:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
(:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem")) (:file "package-inferred-system" :depends-on ("system" "find-system" "parse-defsystem"))
(:file "backward-internals" :depends-on ("find-system" "parse-defsystem"))
(:file "backward-interface" :depends-on ("operate" "output-translations"))
(:file "interface" :depends-on (:file "interface" :depends-on
("parse-defsystem" "concatenate-source" ("parse-defsystem" "concatenate-source"
"backward-interface" "backward-internals" "output-translations" "source-registry" "package-inferred-system"
"output-translations" "source-registry" "package-inferred-system")) "backward-interface" "backward-internals"))
(:file "user" :depends-on ("interface")) (:file "user" :depends-on ("interface"))
(:file "footer" :depends-on ("user")))) (:file "footer" :depends-on ("user"))))
...@@ -78,7 +78,7 @@ ...@@ -78,7 +78,7 @@
:version "3.1.4.6" ;; to be automatically updated by make bump-version :version "3.1.4.6" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
:class #.(if (find-class 'package-inferred-system nil) 'package-inferred-system 'system) :class #+asdf3.1 package-inferred-system #-asdf3.1 system
;; For most purposes, asdf itself specially counts as a builtin system. ;; For most purposes, asdf itself specially counts as a builtin system.
;; If you want to link it or do something forbidden to builtin systems, ;; If you want to link it or do something forbidden to builtin systems,
;; specify separate dependencies on uiop (aka asdf-driver) and asdf/defsystem. ;; specify separate dependencies on uiop (aka asdf-driver) and asdf/defsystem.
......
...@@ -3,56 +3,16 @@ ...@@ -3,56 +3,16 @@
(uiop/package:define-package :asdf/backward-internals (uiop/package:define-package :asdf/backward-internals
(:recycle :asdf/backward-internals :asdf) (:recycle :asdf/backward-internals :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
:asdf/system :asdf/component :asdf/operation
:asdf/find-system :asdf/action :asdf/lisp-action)
(:export ;; for internal use (:export ;; for internal use
#:load-sysdef #:make-temporary-package
#:%refresh-component-inline-methods
#:make-sub-operation #:make-sub-operation
#:load-sysdef #:make-temporary-package)) #:load-sysdef #:make-temporary-package))
(in-package :asdf/backward-internals) (in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
(with-upgradability ()
(defparameter* +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(defun %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
#'(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
(component-inline-methods component) nil)
(defun %define-component-inline-methods (ret rest)
(loop* :for (key value) :on rest :by #'cddr
:for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
:when name :do
(destructuring-bind (op &rest body) value
(loop :for arg = (pop body)
:while (atom arg)
:collect arg :into qualifiers
:finally
(destructuring-bind (o c) arg
(pushnew
(eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
(component-inline-methods ret)))))))
(defun %refresh-component-inline-methods (component rest)
;; clear methods, then add the new ones
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest)))
(when-upgrading (:when (fboundp 'make-sub-operation)) (when-upgrading (:when (fboundp 'make-sub-operation))
(defun make-sub-operation (c o dep-c dep-o) (defun make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
;;;; load-sysdef ;;;; load-sysdef
(with-upgradability () (with-upgradability ()
(defun load-sysdef (name pathname) (defun load-sysdef (name pathname)
...@@ -65,4 +25,3 @@ ...@@ -65,4 +25,3 @@
;; this would be a bad idea, so preserve the old behavior. ;; this would be a bad idea, so preserve the old behavior.
(make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
...@@ -6,8 +6,7 @@ ...@@ -6,8 +6,7 @@
(:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
(:use :uiop/common-lisp :asdf/driver :asdf/upgrade (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
:asdf/cache :asdf/component :asdf/system :asdf/cache :asdf/component :asdf/system
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
:asdf/backward-internals)
(:import-from :asdf/system #:depends-on #:weakly-depends-on) (:import-from :asdf/system #:depends-on #:weakly-depends-on)
(:export (:export
#:defsystem #:register-system-definition #:defsystem #:register-system-definition
...@@ -123,6 +122,42 @@ ...@@ -123,6 +122,42 @@
(invalid)))))) (invalid))))))
;;; "inline methods"
(with-upgradability ()
(defparameter* +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
(defun %remove-component-inline-methods (component)
(dolist (name +asdf-methods+)
(map ()
;; this is inefficient as most of the stored
;; methods will not be for this particular gf
;; But this is hardly performance-critical
#'(lambda (m)
(remove-method (symbol-function name) m))
(component-inline-methods component)))
(component-inline-methods component) nil)
(defun %define-component-inline-methods (ret rest)
(loop* :for (key value) :on rest :by #'cddr
:for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
:when name :do
(destructuring-bind (op &rest body) value
(loop :for arg = (pop body)
:while (atom arg)
:collect arg :into qualifiers
:finally
(destructuring-bind (o c) arg
(pushnew
(eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
(component-inline-methods ret)))))))
(defun %refresh-component-inline-methods (component rest)
;; clear methods, then add the new ones
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest)))
;;; Main parsing function ;;; Main parsing function
(with-upgradability () (with-upgradability ()
(defun* parse-dependency-def (dd) (defun* parse-dependency-def (dd)
......
...@@ -14,8 +14,9 @@ ...@@ -14,8 +14,9 @@
(format t "Method run for ~A - *a* = ~S~%" (action-description o c) *a*) (format t "Method run for ~A - *a* = ~S~%" (action-description o c) *a*)
(call-next-method))))) (call-next-method)))))
;;; Note: not calling load-system, because on ECL that would be a load-fasl-op, ;;; Note: not calling load-system, because on ECL that could end up being a load-fasl-op,
;;; and at most the file load-op happen, whereas the second .o is linked and never loaded. ;;; and at most the file1 load-op happen, whereas the file2 .o is linked and never loaded
;;; (the linked fasl, on the other hand, will be loaded, but won't trigger the inline method).
(operate 'load-op :foo) (operate 'load-op :foo)
(assert-equal *a* 2) (assert-equal *a* 2)
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