Skip to content
Snippets Groups Projects
Commit a3240393 authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

Made process-option-list run at macroexpand time (the current component is

anaphorically captured as asdf:component).
Implemented :perform and :explain defsystem arguments as in (slightly
adjusted) README
Also added :initially-do and :finally-do mk-compatibility options
parent 39511286
No related branches found
No related tags found
No related merge requests found
asdf: another system definition facility -*- Text -*- asdf: another system definition facility -*- Text -*-
$Id: README,v 1.6 2001/08/06 12:51:02 dan_b Exp $ $Id: README,v 1.7 2001/08/20 12:36:13 crhodes Exp $
This system definition utility talks in terms of 'components' and This system definition utility talks in terms of 'components' and
'operations'. 'operations'.
...@@ -275,10 +275,10 @@ mk-defsystem syntax ...@@ -275,10 +275,10 @@ mk-defsystem syntax
We extend the defsystem syntax to allow for eql-specialised methods on We extend the defsystem syntax to allow for eql-specialised methods on
components - components -
(:module "foo" (:components "bar" "baz" "quux") :module "foo" :components ("bar" "baz" "quux")
(:perform compile-system :after (op c) :perform (compile-system :after (op c)
(do-something c)) (do-something c))
(:explain compile-system :after (op c) :explain (compile-system :after (op c)
(explain-something c)) (explain-something c))
has the effect of has the effect of
...@@ -288,7 +288,13 @@ has the effect of ...@@ -288,7 +288,13 @@ has the effect of
(defmethod explain :after ((op compile-system) (c (eql ...))) (defmethod explain :after ((op compile-system) (c (eql ...)))
(explain-something c)) (explain-something c))
where ... is the component in question where ... is the component in question; note that while :before
methods are also supported by this, they may not do what you want them
do (a :before method on perform ((op compile-system) (c (eql ...)))
will run after all the dependencies and sub-components have been
processed, but before the component in question has been
compiled). The mk-alike :initially-do and :finally-do may be what you
are looking for.
** shorthand for source-file components ** shorthand for source-file components
......
...@@ -214,8 +214,10 @@ ...@@ -214,8 +214,10 @@
;;; for our purposes. And CLISP doesn't have non-standard method ;;; for our purposes. And CLISP doesn't have non-standard method
;;; combinations, so let's keep it simple and aspire to portability ;;; combinations, so let's keep it simple and aspire to portability
(defmethod traverse ((operation operation) (c component) function) ;;; we enforce that function is a symbol to allow us to specialize on
; dependencies ;;; (eql 'perform) and (eql 'explain) for :before and :after
(defmethod traverse ((operation operation) (c component) (function symbol))
;; dependencies
(if (component-visiting-p operation c) (if (component-visiting-p operation c)
(error 'circular-dependency :components (list c))) (error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t) (setf (visiting-component operation c) t)
...@@ -283,10 +285,7 @@ ...@@ -283,10 +285,7 @@
(when (and warnings-p (operation-fail-on-warning-p operation)) (when (and warnings-p (operation-fail-on-warning-p operation))
(error 'compile-warned :component c :operation operation)) (error 'compile-warned :component c :operation operation))
(when (and failure-p (operation-fail-on-error-p operation)) (when (and failure-p (operation-fail-on-error-p operation))
(error 'compile-failed :component c :operation operation)) (error 'compile-failed :component c :operation operation)))))
;; now load the file. this is a hack which will go away when we
;; work out dependencies properly
(load output))))
(defmethod output-files ((operation compile-system) (c cl-source-file)) (defmethod output-files ((operation compile-system) (c cl-source-file))
(list (compile-file-pathname (component-pathname c)))) (list (compile-file-pathname (component-pathname c))))
...@@ -393,20 +392,27 @@ ...@@ -393,20 +392,27 @@
;;; syntax ;;; syntax
(defmacro defsystem (name &body options) (defmacro defsystem (name &body options)
(let* ((name (if (symbolp name) (symbol-name name) name)) (let ((name (if (symbolp name) (symbol-name name) name)))
(args `(:name ,name (process-option-list m (quote ,options))))) (multiple-value-bind (initargs bindings)
;; this macro is called (sic) during executing of find-system, so (process-option-list options)
;; we had better not call find-system recursively ;; this macro is called (sic) during executing of find-system, so
`(let ((m (or (cdr (gethash ,name *defined-systems*)) ;; we had better not call find-system recursively
(make-instance 'module :name ,name )))) ;;
(setf (gethash ,name *defined-systems*) (cons 0 m)) ;; asdf:component is explicitly here to be shadowed later on.
(apply #'reinitialize-instance m ,@args)))) `(let ((component (or (cdr (gethash ,name *defined-systems*))
(make-instance 'module :name ,name ))))
(defmethod process-option-list ((c component) options) (setf (gethash ,name *defined-systems*) (cons 0 component))
(let (,@bindings) ; yes, I know this is the same as let ,bindings
(reinitialize-instance component :name ,name ,@initargs))))))
(defmethod process-option-list (options)
(loop for (name value) on options by #'cddr (loop for (name value) on options by #'cddr
append (process-option c name value))) for (i b) = (multiple-value-list (process-option name value))
append i into initargs
if b append b into bindings
finally (return (values initargs bindings))))
(defmethod process-option ((c component) option value) (defmethod process-option (option value)
(list option value)) (list option value))
...@@ -418,34 +424,43 @@ created. If a type is not provided, it will default to the parent's ...@@ -418,34 +424,43 @@ created. If a type is not provided, it will default to the parent's
default constituent type. default constituent type.
|# |#
(defun create-instance-for-component (parent-component keyword name args) (defun create-instance-for-component (keyword name args)
(let* ((name-bits (split name 2 '(#\.))) (multiple-value-bind (initargs bindings)
(name (car name-bits)) (process-option-list args)
(extension (second name-bits)) `(let* ((name-bits (split ,name 2 '(#\.)))
(class (name (car name-bits))
(cond ((eq keyword :file) (extension (second name-bits))
(if extension (class
(cdr (assoc extension *known-extensions* :test 'equal)) (cond ((eq ,keyword :file)
(module-default-component-class parent-component))) (if extension
((eq keyword :module) 'module) (cdr (assoc extension *known-extensions* :test 'equal))
(t (intern (symbol-name keyword) *package*))))) (module-default-component-class m)))
(let ((instance (or (find-component parent-component name) ((eq ,keyword :module) 'module)
(make-instance class :name name)))) (t (intern (symbol-name ,keyword) *package*)))))
(mapc (lambda (x) (remove-method (car x) (cdr x))) ;; here's where we use asdf:component. This is probably a
(slot-value instance 'inline-methods)) ;; documentable feature of the implementation (`option
(apply #'reinitialize-instance ;; processing may use asdf:component to refer to the parent
instance ;; thingy; and MUST bind asdf:component to the current thingy
:name name (process-option-list instance args)) ;; before doing recursive processing').
instance))) (let ((component (or (find-component component name)
(make-instance class :name name))))
(defmethod process-option ((c component) (option (eql :components)) value) (let (,@bindings)
(list :components (reinitialize-instance component :name name ,@initargs)
(mapcar component)))))
(lambda (i)
(if (consp i) (defmethod process-option ((option (eql :components)) value)
(create-instance-for-component c (first i) (second i) (cddr i)) ;; we don't want to shadow asdf::cs
(create-instance-for-component c :file i nil))) (let ((cs (gensym "CS")))
value))) (values
(list :components cs)
(list (list cs
(list* 'list
(mapcar
(lambda (i)
(if (consp i)
(create-instance-for-component (first i) (second i) (cddr i))
(create-instance-for-component :file i nil)))
value)))))))
;;; optional extras ;;; optional extras
...@@ -464,9 +479,53 @@ default constituent type. ...@@ -464,9 +479,53 @@ default constituent type.
(list "-c" command) (list "-c" command)
:input nil :output *trace-output*)))) :input nil :output *trace-output*))))
(defmethod process-option ((option (eql :perform)) value)
(destructuring-bind
(op-specializer combination (op c) &body body)
value
(values
nil
`((#:ignore
(defmethod perform ,combination ((,op ,op-specializer) (,c (eql component)))
,@body))))))
(defmethod process-option ((option (eql :explain)) value)
(destructuring-bind
(op-specializer combination (op c) &body body)
value
(values
nil
`((#:ignore
(defmethod explain ,combination ((,op ,op-specializer) (,c (eql component)))
,@body))))))
;;; mk-compatibility ;;; mk-compatibility
(defmethod process-option ((c component) (option (eql :source-pathname)) value) (defmethod process-option ((option (eql :source-pathname)) value)
(list :pathname value)) (list :pathname value))
(defmethod process-option ((c component) (option (eql :depends-on)) value) (defmethod process-option ((option (eql :depends-on)) value)
(list :in-order-to `((compile-system (load-system ,@value))))) (list :in-order-to `((compile-system (load-system ,@value)))))
;;; initially-do (and finally-do) may need to be moved out of
;;; mk-compatibility (or maybe renamed first...)
(defmethod process-option ((option (eql :initially-do)) value)
(let ((op (gensym "OPERATION"))
(c (gensym "COMPONENT"))
(f (gensym "FUNCTION")))
(values
nil ; no initargs needed -- functionality is in the method.
`((#:ignore
;; look, ma! No explicit coercion or compilation needed! Also
;; note that we are using the asdf:component thing.
(defmethod traverse :before ((,op compile-system) (,c (eql component)) (,f (eql 'perform)))
,value))))))
(defmethod process-option ((option (eql :finally-do)) value)
(let ((op (gensym "OPERATION"))
(c (gensym "COMPONENT"))
(f (gensym "FUNCTION")))
(values
nil ; no initargs needed
`((#:ignore
(defmethod traverse :after ((,op load-system) (,c (eql component)) (,f (eql 'perform)))
,value))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment