From e745241cb470412442f3a6d8330e35e7d27d683b Mon Sep 17 00:00:00 2001 From: Daniel Barlow <> Date: Wed, 6 Mar 2002 00:39:55 +0000 Subject: [PATCH] component gains a slot: + (parent :initarg :parent :initform nil :reader component-parent) relevant other changes to accomodate and take advantage of this lose the *known-extensions* completely; we don't need a reversable mapping any more (we were only using the reverse half. replaced with a nice sensible gf +(defgeneric source-file-type (component system)) new static-file component that does nothing oos rewnamed to operate component name -> pathname case conversion issues finally specified (defun system-definition-pathname (system) break out the appropriate bit from find-system defsystem gets a new 'class' option so that systems can be subclassed. presently this is only specialised on in component-file-type, but more gfs will appear later I expect --- asdf.lisp | 149 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 94 insertions(+), 55 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index 2c3b5546..0bbd5be2 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -2,8 +2,8 @@ ;;; we can't use defsystem to compile it. Hence, all in one file (defpackage #:asdf - (:export #:defsystem #:oos #:find-system #:run-shell-command - #:find-component ; miscellaneous + (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous #:compile-op #:load-op #:test-system-version #:operation ; operations @@ -23,11 +23,12 @@ #:component-relative-pathname #:component-name #:component-version - + #:component-parent + #:component-depends-on - #:*component-parent-pathname* ; variables - #:*central-registry* + ;#:*component-parent-pathname* + #:*central-registry* ; variables #:operation-error #:compile-failed #:compile-warned #:system-definition-error @@ -110,17 +111,28 @@ and NIL NAME and TYPE components" ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated (inline-methods :accessor component-inline-methods :initform nil) + (parent :initarg :parent :initform nil :reader component-parent) ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname))) +(defmethod component-system ((component component)) + "Find the top-level system containing COMPONENT" + (aif (component-parent component) + (component-system it) + component)) + (defgeneric component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) -(defmethod component-pathname ((component component)) - (let ((*default-pathname-defaults* *component-parent-pathname*)) - (merge-pathnames (component-relative-pathname component)))) +(defun component-parent-pathname (component) + (aif (component-parent component) + (component-pathname it) + *default-pathname-defaults*)) +(defmethod component-pathname ((component component)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) + (merge-pathnames (component-relative-pathname component)))) (defmethod print-object ((c component) (stream stream)) (print-unreadable-object (c stream :type t :identity t) @@ -138,9 +150,11 @@ and NIL NAME and TYPE components" :initform 'cl-source-file :initarg :default-component-class))) (defmethod component-relative-pathname ((component module)) - (let ((*default-pathname-defaults* *component-parent-pathname*)) - (or (slot-value component 'relative-pathname) - (make-pathname :directory `(:relative ,(component-name component)))))) + (or (slot-value component 'relative-pathname) + (make-pathname + :directory `(:relative ,(component-name component)) + :host (pathname-host (component-parent-pathname component))))) + (defgeneric find-component (module name &optional version) (:documentation "Finds the component with name NAME present in the @@ -162,27 +176,25 @@ system.")) (defclass source-file (component) ()) (defclass cl-source-file (source-file) ()) +(defclass c-source-file (source-file) ()) +(defclass java-source-file (source-file) ()) -;;; a reversible registry that lets us query class <-> extension - -(defvar *known-extensions* - '(("lisp" . cl-source-file) - ("c" . c-source-file) - ("java" . java-source-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") + (defmethod component-relative-pathname ((component source-file)) - (let ((*default-pathname-defaults* *component-parent-pathname*)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) (or (slot-value component 'relative-pathname) (make-pathname :name (component-name component) - :type (car (rassoc (class-name (class-of component)) - *known-extensions*)))))) + :type + (source-file-type component + (component-system component)))))) -(defclass c-source-file (source-file) ()) -(defclass java-source-file (source-file) ()) +(defclass static-file (source-file) ()) +(defmethod source-file-type ((c static-file) (s module)) nil) -;;; XXX we don't need the first of these if we have the second, probably -(defvar *component-parent-pathname*) -(defvar *component-parent*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -279,13 +291,12 @@ system.")) ;;; (eql 'perform) and (eql 'explain) for :before and :after (defmethod traverse ((operation operation) (c component) (function symbol)) - (declare (optimize (debug 3))) (labels ((do-one-dep (required-op required-c required-v) (let ((op (if (subtypep (type-of operation) required-op) operation (make-sub-operation operation required-op))) (dep-c (or (find-component - *component-parent* required-c required-v) + (component-parent c) required-c required-v) (error 'missing-dependency :required-by c :version required-v :requires required-c)))) @@ -326,9 +337,7 @@ system.")) do (do-dep required-op deps)) ;; constituent bits (when (typep c 'module) - (let ((*component-parent-pathname* (component-pathname c)) - (*component-parent* c) - (at-least-one nil) + (let ((at-least-one nil) (error nil)) (loop for kid in (module-components c) do (handler-case @@ -368,8 +377,9 @@ system.")) operation component)) (defmethod output-files ((operation operation) (c component)) - (sysdef-error "Required method OUTPUT-FILES not implemented for operation ~A" - (class-of operation))) + (sysdef-error + "Required method OUTPUT-FILES not implemented for operation ~A, component ~A" + (class-of operation) (class-of c))) ;;; compile-op @@ -395,6 +405,12 @@ system.")) (defmethod output-files ((operation compile-op) (c cl-source-file)) (list (compile-file-pathname (component-pathname c)))) +(defmethod perform ((operation compile-op) (c static-file)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + nil) + ;;; load-op (defclass load-op (operation) ()) @@ -403,6 +419,9 @@ system.")) (let ((co (make-sub-operation o 'compile-op))) (map nil #'load (output-files co c)))) +(defmethod perform ((operation load-op) (c static-file)) + nil) + (defmethod output-files ((operation load-op) (c component)) nil) @@ -451,35 +470,48 @@ system.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations -(defun oos (operation-class system &rest args) +(defun operate (operation-class system &rest args) (let ((op (apply #'make-instance operation-class :original-initargs args args)) - (*component-parent-pathname* *default-pathname-defaults*) - (*component-parent* nil) (system (if (typep system 'component) system (find-system system)))) (traverse op system 'perform))) +(defun oos (&rest args) + "Alias of OPERATE function" + (apply #'operate args)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems (defvar *defined-systems* (make-hash-table :test 'equal)) -(defparameter *central-registry* +(defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "Invalid component designator ~A" name)))) + +(defvar *central-registry* '(*default-pathname-defaults* "/home/dan/src/sourceforge/cclan/asdf/systems/" #+nil "telent:asdf;systems;")) +(defun system-definition-pathname (system) + (let ((name (coerce-name system))) + (dolist (dir *central-registry*) + (let* ((defaults (eval dir)) + (file (make-pathname + :name name :case :local :type "asd" + :defaults defaults + :version :newest))) + (if (probe-file file) (return-from system-definition-pathname file)))) + nil)) + (defun internal-find-system (name) - (let* ((name (if (symbolp name) (symbol-name name) name)) + (let* ((name (coerce-name name)) (in-memory (gethash name *defined-systems*)) - (on-disk - (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (make-pathname - :case :common :name name :type "ASD" - :defaults defaults - :version :newest))) - (if (probe-file file) (return file)))) )) + (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) @@ -499,29 +531,35 @@ system.")) (defun register-system (name system) (format t "Registering ~A as ~A ~%" system name) - (setf (gethash (if (symbolp name) (symbol-name name) name) *defined-systems*) + (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) (defun system-registered-p (name) - (gethash (if (symbolp name) (symbol-name name) name) *defined-systems*)) + (gethash (coerce-name name) *defined-systems*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax (defmacro defsystem (name &body options) - (destructuring-bind (&key pathname &allow-other-keys) options + (destructuring-bind (&key pathname (class 'module) &allow-other-keys) options `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from (let ((s (system-registered-p ',name))) - (if s - (setf (car s) (get-universal-time)) - (register-system (quote ,name) - (make-instance 'module :name ',name)))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) (parse-component-form nil (apply #'list - :module ',name + :module (coerce-name ',name) :pathname (or ,pathname (pathname-sans-name+type *load-truename*) @@ -593,8 +631,9 @@ Returns the new tree (which probably shares structure with the old one)" (make-instance (class-for-type parent type))))) (apply #'reinitialize-instance ret - :name name + :name (coerce-name name) :pathname pathname + :parent parent :in-order-to (union-of-dependencies in-order-to `((compile-op (load-op ,@depends-on)))) -- GitLab