system.lisp 3.34 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Systems

4
(asdf/package:define-package :asdf/system
5
  (:recycle :asdf :asdf/system)
6
  (:use :common-lisp :asdf/driver :asdf/upgrade :asdf/component)
7 8
  (:intern #:children #:children-by-name #:default-component-class
           #:author #:maintainer #:licence #:source-file #:defsystem-depends-on)
9
  (:export
10
   #:system #:proto-system
11 12 13 14
   #:system-source-file #:system-source-directory #:system-relative-pathname
   #:reset-system #:builtin-system-p
   #:system-description #:system-long-description
   #:system-author #:system-maintainer #:system-licence #:system-license
15
   #:find-system ;; forward-reference, defined in find-system
16 17 18 19
   #:system-defsystem-depends-on))
(in-package :asdf/system)

(defgeneric* find-system (system &optional error-p))
20 21
(defgeneric* system-source-file (system)
  (:documentation "Return the source file in which system is defined."))
22

23
;;;; The system class
24 25 26 27

(defclass proto-system () ; slots to keep when resetting a system
  ;; To preserve identity for all objects, we'd need keep the components slots
  ;; but also to modify parse-component-form to reset the recycled objects.
28
  ((name) (source-file) #|(children) (children-by-names)|#))
29 30 31 32

(defclass system (module proto-system)
  ;; Backward-compatibility: inherit from module. ASDF3: only inherit from parent-component.
  (;; {,long-}description is now inherited from component, but we add the legacy accessors
33 34
   (description :accessor system-description)
   (long-description :accessor system-long-description)
35 36 37 38
   (author :accessor system-author :initarg :author)
   (maintainer :accessor system-maintainer :initarg :maintainer)
   (licence :accessor system-licence :initarg :licence
            :accessor system-license :initarg :license)
39
   (source-file :initform nil :initarg :source-file :accessor system-source-file)
40 41 42 43 44 45 46 47 48 49
   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))

(defun* reset-system (system &rest keys &key &allow-other-keys)
  (change-class (change-class system 'proto-system) 'system)
  (apply 'reinitialize-instance system keys))


;;;; Pathnames

(defmethod component-pathname ((system system))
50 51 52 53
  (and (or (slot-boundp system 'relative-pathname)
           (slot-boundp system 'absolute-pathname)
           (slot-value system 'source-file))
    (call-next-method)))
54 55 56 57 58 59 60

(defmethod system-source-file ((system-name string))
  (system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
  (system-source-file (find-system system-name)))

(defun* system-source-directory (system-designator)
61 62
  "Return a pathname object corresponding to the directory
in which the system specification (.asd file) is located."
63 64 65 66 67 68 69 70 71 72
  (pathname-directory-pathname (system-source-file system-designator)))

(defun* system-relative-pathname (system name &key type)
  (subpathname (system-source-directory system) name :type type))

;;;; Beware of builtin systems
(defgeneric* builtin-system-p (system))
(defmethod builtin-system-p ((s system))
  (let* ((system (find-system s nil))
         (sysdir (and system (component-pathname system)))
73 74 75 76 77 78
         (truesysdir (truename* sysdir))
         (impdir (lisp-implementation-directory))
         (trueimpdir (truename* impdir)))
    (and sysdir impdir
         (or (subpathp sysdir impdir)
             (subpathp truesysdir trueimpdir)))))