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

4
(uiop/package:define-package :asdf/system
5
  (:recycle :asdf :asdf/system)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component)
7
  (:export
8
   #:system #:proto-system
9
   #:system-source-file #:system-source-directory #:system-relative-pathname
10
   #:reset-system
11
12
   #:system-description #:system-long-description
   #:system-author #:system-maintainer #:system-licence #:system-license
13
   #:system-defsystem-depends-on
14
   #:component-build-pathname #:build-pathname
15
   #:component-entry-point #:entry-point
16
17
18
   #:homepage #:system-homepage
   #:bug-tracker #:system-bug-tracker
   #:mailto #:system-mailto
19
20
   #:long-name #:system-long-name
   #:source-control #:system-source-control
21
   #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
22
23
(in-package :asdf/system)

24
25
(with-upgradability ()
  (defgeneric* (find-system) (system &optional error-p))
26
  (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system)
27
28
    (:documentation "Return the source file in which system is defined."))
  (defgeneric component-build-pathname (component))
29

30
31
32
  (defgeneric component-entry-point (component))
  (defmethod component-entry-point ((c component))
    nil))
33
34


35
;;;; The system class
36

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
(with-upgradability ()
  (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.
    ((name) (source-file) #|(children) (children-by-names)|#))

  (defclass system (module proto-system)
    ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
    (;; {,long-}description is now inherited from component, but we add the legacy accessors
     (description :accessor system-description)
     (long-description :accessor system-long-description)
     (author :accessor system-author :initarg :author :initform nil)
     (maintainer :accessor system-maintainer :initarg :maintainer :initform nil)
     (licence :accessor system-licence :initarg :licence
              :accessor system-license :initarg :license :initform nil)
     (homepage :accessor system-homepage :initarg :homepage :initform nil)
     (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil)
     (mailto :accessor system-mailto :initarg :mailto :initform nil)
     (long-name :accessor system-long-name :initarg :long-name :initform nil)
     ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
     ;; I'm introducing the slot before the conventions are set for maximum compatibility.
     (source-control :accessor system-source-control :initarg :source-control :initform nil)
     (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
     (build-pathname
      :initform nil :initarg :build-pathname :accessor component-build-pathname)
     (entry-point
      :initform nil :initarg :entry-point :accessor component-entry-point)
     (source-file :initform nil :initarg :source-file :accessor system-source-file)
     (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)))
70
71
72
73


;;;; Pathnames

74
75
76
77
78
(with-upgradability ()
  (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)))
79

80
81
  (defun system-source-directory (system-designator)
    "Return a pathname object corresponding to the directory
82
in which the system specification (.asd file) is located."
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
    (pathname-directory-pathname (system-source-file system-designator)))

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

  (defmethod component-pathname ((system system))
    (let ((pathname (or (call-next-method) (system-source-directory system))))
      (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
                   (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
        (setf (slot-value system 'relative-pathname) pathname))
      pathname))

  (defmethod component-relative-pathname ((system system))
    (parse-unix-namestring
     (and (slot-boundp system 'relative-pathname)
          (slot-value system 'relative-pathname))
     :want-relative t
     :type :directory
     :ensure-absolute t
     :defaults (system-source-directory system)))

  (defmethod component-parent-pathname ((system system))
    (system-source-directory system))

  (defmethod component-build-pathname ((c component))
    nil))