proposed asdf improvements/changes
Rahul Jain <[email protected]>
| Newsgroups | gmane.lisp.cclan.general |
|---|---|
| Message-ID | <[email protected]> |
I'll comment on them next to the places in the diff below where they
occur:
>
> Index: asdf.lisp
> ===================================================================
> RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
> retrieving revision 1.30
> diff -u -r1.30 asdf.lisp
> --- asdf.lisp 4 Jul 2002 02:25:41 -0000 1.30
> +++ asdf.lisp 5 Aug 2002 00:41:37 -0000
> @@ -39,7 +39,7 @@
> (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
> #:system-definition-pathname #:find-component ; miscellaneous
>
> - #:compile-op #:load-op #:test-system-version
> + #:compile-op #:load-op #:clean-op #:test-system-version
> #:operation ; operations
> #:feature ; sort-of operation
> #:version ; metaphorically sort-of an operation
> @@ -57,7 +57,8 @@
> #:module ; components
> #:unix-dso
>
> - #:module-components ; component accessors
> + #:module-components ; component accessors
> + #:module-core-deps
> #:component-pathname
> #:component-relative-pathname
> #:component-name
Added exports for the features I addded.
> @@ -108,7 +109,7 @@
> (apply #'format s (format-control c) (format-arguments c)))))
>
> (define-condition circular-dependency (system-definition-error)
> - ((components :initarg :components)))
> + ((components :initarg :components :reader circular-components)))
cmucl was complaining that there was no reader (and since you can't
portably use slot-value to access condition slots, that means that
they're inaccessible), so I added one. Feel free to choose a better
name.
>
> (define-condition missing-component (system-definition-error)
> ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
> @@ -184,7 +185,8 @@
> :accessor module-if-component-dep-fails
> :initarg :if-component-dep-fails)
> (default-component-class :accessor module-default-component-class
> - :initform 'cl-source-file :initarg :default-component-class)))
> + :initform 'cl-source-file :initarg :default-component-class)
> + (core-deps :accessor module-core-deps :initform nil)))
>
> (defgeneric component-pathname (component)
> (:documentation "Extracts the pathname applicable for a particular component."))
Added a slot to hold the info needed later...
> @@ -230,6 +232,10 @@
> (maintainer :accessor system-maintainer :initarg :maintainer)
> (licence :accessor system-licence :initarg :licence)))
>
> +;;; getting the core deps for a system's parent should return nil
> +(defmethod module-core-deps ((c null))
> + nil)
> +
> ;;; version-satisfies
>
> ;;; with apologies to christophe rhodes ...
The comment more-or-less explains it all. The global parent (NIL)
doesn't have any core-deps.
> @@ -635,7 +641,39 @@
> (component-property c 'last-loaded)))
> nil t))
>
> +;;; clean-op
>
> +(defclass clean-op (operation)
> + ((op-to-clean :initarg :op-to-clean :accessor op-to-clean
> + :initform (make-instance 'compile-op))))
> +
> +(defmethod shared-initialize :after ((o clean-op) slots &rest initargs)
> + (declare (ignore slots initargs))
> + (with-accessors ((op-to-clean op-to-clean)) o
> + (when (not (typep op-to-clean 'operation))
> + (if (listp op-to-clean)
> + (setf op-to-clean (apply #'make-instance op-to-clean))
> + (setf op-to-clean (make-instance op-to-clean))))))
> +
> +(defmethod (setf op-to-clean) :around ((new-value list) (o clean-op))
> + (setf (op-to-clean o) (apply #'make-instance new-value)))
> +
> +(defmethod (setf op-to-clean) :around ((new-value symbol) (o clean-op))
> + (setf (op-to-clean o) (make-instance new-value)))
> +
> +(defmethod perform ((o clean-op) (c component))
> + (let ((output-files (output-files (op-to-clean o) c)))
> + (mapcar #'delete-file output-files)))
> +
> +(defmethod output-files ((o clean-op) (c component))
> + nil)
> +
> +(defmethod operation-done-p ((o clean-op) (c component))
> + (notevery #'probe-file (output-files (op-to-clean o) c)))
> +
> +(defmethod operation-done-p ((o clean-op) (c module))
> + (every (lambda (c) (operation-done-p o c))
> + (module-components c)))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;;; invoking operations
Added an operation to clean the output-files of an operation (defaults
to compile-op).
To clean some other op's output-files, do
(asdf:oos (make-instance 'asdf:clean-op :op-to-clean 'some-op) :some-system)
> @@ -676,25 +714,24 @@
> (t
> (register-system (quote ,name)
> (make-instance ',class :name ',name)))))
> - (parse-component-form nil (apply
> - #'list
> - :module (coerce-name ',name)
> - :pathname
> - (or ,pathname
> - (pathname-sans-name+type *load-truename*)
> - *default-pathname-defaults*)
> - ',component-options))))))
> + (parse-component-form nil (list* ',class (coerce-name ',name)
> + :pathname
> + (or ,pathname
> + (pathname-sans-name+type *load-truename*)
> + *default-pathname-defaults*)
> + ',component-options))))))
>
(apply #'list) is just LIST*, and the class should be whatever was
specified, not module. I think I changed something in
PARSE-COMPONENT-FORM to deal with this, too.
>
> (defun class-for-type (parent type)
> - (let ((class (find-class
> - (or (find-symbol (symbol-name type) *package*)
> - (find-symbol (symbol-name type) #.*package*)) nil)))
> - (or class
> - (and (eq type :file)
> - (or (module-default-component-class parent)
> - (find-class 'cl-source-file)))
> - (sysdef-error "Don't recognize component type ~A" type))))
> + (or (find-class type nil)
> + (when (keywordp type)
> + (find-class (find-symbol (symbol-name type) #.*package*) nil))
> + (find-class (find-symbol (symbol-name type) *package*) nil)
> + (find-class (find-symbol (symbol-name type) #.*package*) nil)
> + (and (eq type :file)
> + (or (module-default-component-class parent)
> + (find-class 'cl-source-file)))
> + (sysdef-error "Don't recognize component type ~A" type)))
>
> (defun maybe-add-tree (tree op1 op2 c)
> "Add the node C at /OP1/OP2 in TREE, unless it's there already.
The previous way seemed a bit prone to accidental name collisions. My
modification seems a bit hairy, tho...
> @@ -728,59 +765,61 @@
> :key #'symbol-name :test 'equal)
> append (list name val)))
>
> +(eval-when (:compile-toplevel :load-toplevel :execute)
> + (defparameter *component-form-keyword-args*
> + '(components pathname default-component-class perform explain output-files
> + operation-done-p depends-on serialize in-order-to core-dep)))
> +
Just to help maintainence, I think it's a good idea to automate
keeping the arg lists in sync.
Sorry about the indentation changes below, I hit M-q before I realized
that the indentation was not what I use by default.
> (defun parse-component-form (parent options)
> - (destructuring-bind
> - (type name &rest rest &key
> - ;; the following list of keywords is reproduced below in the
> - ;; remove-keys form. important to keep them in sync
> - components pathname default-component-class
> - perform explain output-files operation-done-p
> - depends-on serialize in-order-to
> - ;; list ends
> - &allow-other-keys) options
> + (destructuring-bind #.`(type name &rest rest
> + &key ,@*component-form-keyword-args*
> + &allow-other-keys) options
Insert the keyword arg list at read time.
> (declare (ignore serialize))
> - ;; XXX add dependencies for serialized subcomponents
> - (let* ((other-args (remove-keys
> - '(components pathname default-component-class
> - perform explain output-files operation-done-p
> - depends-on serialize in-order-to)
> - rest))
> - (ret
> - (or (find-component parent name)
> - (make-instance (class-for-type parent type)))))
> - (apply #'reinitialize-instance
> - ret
> - :name (coerce-name name)
> - :pathname pathname
> - :parent parent
> - :in-order-to (union-of-dependencies
> - in-order-to
> - `((compile-op (load-op ,@depends-on))))
> - other-args)
> - (when (typep ret 'module)
> - (setf (module-default-component-class ret)
> - (or default-component-class
> - (and (typep parent 'module)
> - (module-default-component-class parent)))))
> - (when components
> - (setf (module-components ret)
> - (mapcar (lambda (x) (parse-component-form ret x)) components)))
> - (loop for (n v) in `((perform ,perform) (explain ,explain)
> - (output-files ,output-files)
> - (operation-done-p ,operation-done-p))
> - do (map 'nil
> - ;; this is inefficient as most of the stored
> - ;; methods will not be for this particular gf n
> - ;; But this is hardly performance-critical
> - (lambda (m) (remove-method (symbol-function n) m))
> - (component-inline-methods ret))
> - when v
> - do (destructuring-bind (op qual (o c) &body body) v
> - (pushnew
> - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
> - ,@body))
> - (component-inline-methods ret))))
> - ret)))
> + ;; XXX add dependencies for serialized subcomponents
> + (let* ((name (coerce-name name))
> + (other-args (remove-keys *component-form-keyword-args* rest))
> + (ret (or (let ((c (find-component parent name)))
> + (when (eq (class-of c) (class-for-type parent type))
> + c))
> + (make-instance (class-for-type parent type)))))
If the class of the component in the defsystem form has changed, we
should honor that. CHANGE-CLASS might also be useful here:
(when (eq (class-of c) (class-for-type parent type))
c
#+clisp nil
#-clisp (change-class c (class-for-type parent type)))
> + (apply #'reinitialize-instance
> + ret
> + :name name
> + :pathname pathname
> + :parent parent
> + :in-order-to (union-of-dependencies
> + in-order-to
> + `((compile-op (load-op ,@depends-on
> + ,@(module-core-deps parent)))))
Add in the core-deps, too.
> + other-args)
> + (when core-dep
> + (push name (module-core-deps parent)))
To record the core-dep for later components of this one's parent.
> + (when (typep ret 'module)
> + ;; clear core-deps list so that children are reinitialized with correct deps
> + (setf (module-core-deps ret) nil)
This is a bit annoying, but otherwise, a core-dep will get applied to
all previous components, too, but not on the first loading of the
defsystem form... Maybe this other behavior is really what we want?
But then multiple core-deps would cause circular-dependencies...
> + (setf (module-default-component-class ret)
> + (or default-component-class
> + (and (typep parent 'module)
> + (module-default-component-class parent)))))
> + (when components
> + (setf (module-components ret)
> + (mapcar (lambda (x) (parse-component-form ret x)) components)))
> + (loop for (n v) in `((perform ,perform) (explain ,explain)
> + (output-files ,output-files)
> + (operation-done-p ,operation-done-p))
> + do (map 'nil
> + ;; this is inefficient as most of the stored
> + ;; methods will not be for this particular gf n
> + ;; But this is hardly performance-critical
> + (lambda (m) (remove-method (symbol-function n) m))
> + (component-inline-methods ret))
> + when v
> + do (destructuring-bind (op qual (o c) &body body) v
> + (pushnew
> + (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
> + ,@body))
> + (component-inline-methods ret))))
> + ret)))
>
>
> ;;; optional extras
> @@ -814,5 +853,16 @@
> "/bin/sh"
> (list "-c" command)
> :input nil :output *trace-output*))))
> +
> +#+lispworks
> +(defun run-shell-command (control-string &rest args)
> + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
> +synchronously execute the result using a Bourne-compatible shell, with
> +output to *trace-output*. Returns the shell's exit code."
> + (let ((command (apply #'format nil control-string args)))
> + (format *trace-output* "; $ ~A~%" command)
> + (system:call-system-showing-output command
> + :shell-type "/bin/sh"
> + :output-stream *trace-output*)))
>
> (pushnew :asdf *features*)
>
Since I'm using LW to help me develop DefDoc, both as a probably
delivery mechanism for any commercial derivatives (CLIM-based editor)
and because it has an inspector that can deal with CLOS instances, I
decided to add this while I was poking through LW documentation, not
that I use it.
--
-> -/ - Rahul Jain - \- <-
-> -\ http://linux.rice.edu/~rahul -=- mailto:[email protected] /- <-
-> -X "Structure is nothing if it is all you got. Skeletons spook X- <-
-> -/ people if [they] try to walk around on their own. I really \- <-
-> -\ wonder why XML does not." -- Erik Naggum, comp.lang.lisp /- <-
|--|--------|--------------|----|-------------|------|---------|-----|-|
(c)1996-2002, All rights reserved. Disclaimer available upon request.
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf