Skip to content
Snippets Groups Projects
Commit 90abd538 authored by Gary King's avatar Gary King
Browse files

Patch for system-source-file from Greg Pfeil 

 * system-source-file now works for systems without their own .asd

 * moved defgenerics to their own section because I like it that way.
parent cd468d51
Branches
Tags 1.358
No related merge requests found
Show whitespace changes
Inline Side-by-side
Showing
with 104 additions and 106 deletions
asdf.lisp
+ 104
− 106
View file @ 90abd538
......@@ -165,6 +165,104 @@
(defparameter +asdf-methods+
'(perform explain output-files operation-done-p))
(define-method-combination standard-asdf-method-combination ()
((around-asdf (around))
(around (:around))
(before (:before))
(primary () :required t)
(after (:after)))
(flet ((call-methods (methods)
(mapcar #'(lambda (method)
`(call-method ,method))
methods)))
(let* ((form (if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(call-methods before)
(call-method ,(first primary)
,(rest primary)))
,@(call-methods (reverse after)))
`(call-method ,(first primary))))
(standard-form (if around
`(call-method ,(first around)
(,@(rest around)
(make-method ,form)))
form)))
(if around-asdf
`(call-method ,(first around-asdf)
(,@(rest around-asdf) (make-method ,standard-form)))
standard-form))))
(defgeneric perform (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric explain (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric output-files (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric input-files (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
(defgeneric component-system (component)
(:documentation "Find the top-level system containing COMPONENT"))
(defgeneric component-pathname (component)
(:documentation "Extracts the pathname applicable for a particular component."))
(defgeneric component-relative-pathname (component)
(:documentation "Extracts the relative pathname applicable for a particular component."))
(defgeneric component-property (component property))
(defgeneric (setf component-property) (new-value component property))
(defgeneric version-satisfies (component version))
(defgeneric find-component (module name &optional version)
(:documentation "Finds the component with name NAME present in the
MODULE module; if MODULE is nil, then the component is assumed to be a
system."))
(defgeneric source-file-type (component system))
(defgeneric operation-ancestor (operation)
(:documentation
"Recursively chase the operation's parent pointer until we get to
the head of the tree"))
(defgeneric component-visited-p (operation component))
(defgeneric visit-component (operation component data))
(defgeneric (setf visiting-component) (new-value operation component))
(defgeneric component-visiting-p (operation component))
(defgeneric component-depends-on (operation component)
(:documentation
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
(<operation> <component>*), where <operation> is a class
designator and each <component> is a component
designator, which means that the component depends on
<operation> having been performed on each <component>; or
(FEATURE <feature>), which means that the component depends
on <feature>'s presence in *FEATURES*.
Methods specialized on subclasses of existing component types
should usually append the results of CALL-NEXT-METHOD to the
list."))
(defgeneric component-self-dependencies (operation component))
(defgeneric traverse (operation component))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff
......@@ -280,9 +378,6 @@ and NIL NAME and TYPE components"
(when (missing-parent c)
(component-name (missing-parent c)))))
(defgeneric component-system (component)
(:documentation "Find the top-level system containing COMPONENT"))
(defmethod component-system ((component component))
(aif (component-parent component)
(component-system it)
......@@ -303,17 +398,11 @@ and NIL NAME and TYPE components"
(default-component-class :accessor module-default-component-class
:initform 'cl-source-file :initarg :default-component-class)))
(defgeneric component-pathname (component)
(:documentation "Extracts the pathname applicable for a particular component."))
(defun component-parent-pathname (component)
(aif (component-parent component)
(component-pathname it)
*default-pathname-defaults*))
(defgeneric component-relative-pathname (component)
(:documentation "Extracts the relative pathname applicable for a particular component."))
(defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname)
(make-pathname
......@@ -324,13 +413,9 @@ and NIL NAME and TYPE components"
(let ((*default-pathname-defaults* (component-parent-pathname component)))
(merge-pathnames (component-relative-pathname component))))
(defgeneric component-property (component property))
(defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal)))
(defgeneric (setf component-property) (new-value component property))
(defmethod (setf component-property) (new-value (c component) property)
(let ((a (assoc property (slot-value c 'properties) :test #'equal)))
(if a
......@@ -345,7 +430,9 @@ and NIL NAME and TYPE components"
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
:accessor system-license :initarg :license)))
:accessor system-license :initarg :license)
(source-file :reader system-source-file :initarg :source-file
:writer %set-system-source-file)))
;;; version-satisfies
......@@ -363,8 +450,6 @@ and NIL NAME and TYPE components"
(unless end (return list))
(setf start (1+ end)))))))
(defgeneric version-satisfies (component version))
(defmethod version-satisfies ((c component) version)
(unless (and version (slot-boundp c 'version))
(return-from version-satisfies t))
......@@ -565,11 +650,6 @@ to `~a` which is not a directory.~@:>"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding components
(defgeneric find-component (module name &optional version)
(:documentation "Finds the component with name NAME present in the
MODULE module; if MODULE is nil, then the component is assumed to be a
system."))
(defmethod find-component ((module module) name &optional version)
(if (slot-boundp module 'components)
(let ((m (find name (module-components module)
......@@ -593,7 +673,6 @@ system."))
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
(defgeneric source-file-type (component system))
(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
(defmethod source-file-type ((c c-source-file) (s module)) "c")
(defmethod source-file-type ((c java-source-file) (s module)) "java")
......@@ -641,52 +720,9 @@ system."))
;; empty method to disable initarg validity checking
)
(define-method-combination standard-asdf-method-combination ()
((around-asdf (around))
(around (:around))
(before (:before))
(primary () :required t)
(after (:after)))
(flet ((call-methods (methods)
(mapcar #'(lambda (method)
`(call-method ,method))
methods)))
(let* ((form (if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(call-methods before)
(call-method ,(first primary)
,(rest primary)))
,@(call-methods (reverse after)))
`(call-method ,(first primary))))
(standard-form (if around
`(call-method ,(first around)
(,@(rest around)
(make-method ,form)))
form)))
(if around-asdf
`(call-method ,(first around-asdf)
(,@(rest around-asdf) (make-method ,standard-form)))
standard-form))))
(defgeneric perform (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric explain (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric output-files (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric input-files (operation component)
(:method-combination standard-asdf-method-combination))
(defun node-for (o c)
(cons (class-name (class-of o)) c))
(defgeneric operation-ancestor (operation)
(:documentation
"Recursively chase the operation's parent pointer until we get to
the head of the tree"))
(defmethod operation-ancestor ((operation operation))
(aif (operation-parent operation)
(operation-ancestor it)
......@@ -713,10 +749,6 @@ the head of the tree"))
:parent o :original-initargs args args)))))
(defgeneric component-visited-p (operation component))
(defgeneric visit-component (operation component data))
(defmethod visit-component ((o operation) (c component) data)
(unless (component-visited-p o c)
(push (cons (node-for o c) data)
......@@ -727,8 +759,6 @@ the head of the tree"))
(operation-visited-nodes (operation-ancestor o))
:test 'equal))
(defgeneric (setf visiting-component) (new-value operation component))
(defmethod (setf visiting-component) (new-value operation component)
;; MCL complains about unused lexical variables
(declare (ignorable new-value operation component)))
......@@ -741,30 +771,11 @@ the head of the tree"))
(setf (operation-visiting-nodes a)
(remove node (operation-visiting-nodes a) :test 'equal)))))
(defgeneric component-visiting-p (operation component))
(defmethod component-visiting-p ((o operation) (c component))
(let ((node (node-for o c)))
(member node (operation-visiting-nodes (operation-ancestor o))
:test 'equal)))
(defgeneric component-depends-on (operation component)
(:documentation
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
(<operation> <component>*), where <operation> is a class
designator and each <component> is a component
designator, which means that the component depends on
<operation> having been performed on each <component>; or
(FEATURE <feature>), which means that the component depends
on <feature>'s presence in *FEATURES*.
Methods specialized on subclasses of existing component types
should usually append the results of CALL-NEXT-METHOD to the
list."))
(defmethod component-depends-on ((op-spec symbol) (c component))
(component-depends-on (make-instance op-spec) c))
......@@ -772,8 +783,6 @@ the head of the tree"))
(cdr (assoc (class-name (class-of o))
(slot-value c 'in-order-to))))
(defgeneric component-self-dependencies (operation component))
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
(remove-if-not (lambda (x)
......@@ -836,7 +845,6 @@ the head of the tree"))
;;; runs :before methods most->least-specific, which is back to front
;;; for our purposes.
(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
(let ((forced nil))
(labels ((%do-one-dep (required-op required-c required-v)
......@@ -1245,7 +1253,9 @@ created with the same initargs as the original one.
(change-class (cdr s) ',class))
(t
(register-system (quote ,name)
(make-instance ',class :name ',name)))))
(make-instance ',class :name ',name))))
(%set-system-source-file *load-truename*
(cdr (system-registered-p ',name))))
(parse-component-form nil (apply
#'list
:module (coerce-name ',name)
......@@ -1509,21 +1519,9 @@ output to `*verbose-out*`. Returns the shell's exit code."
(error "RUN-SHELL-PROGRAM not implemented for this Lisp")
))
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
(defmethod system-source-file ((system-name t))
(system-source-file (find-system system-name)))
(defmethod system-source-file ((system system))
(let ((pn (and (slot-boundp system 'relative-pathname)
(make-pathname
:type "asd"
:name (asdf:component-name system)
:defaults (asdf:component-relative-pathname system)))))
(when pn
(probe-file pn))))
(defun system-source-directory (system-name)
(make-pathname :name nil
:type nil
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment