package-system.lisp 5.23 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
;;;; -------------------------------------------------------------------------
;;;; Package systems in the style of quick-build or faslpath

(uiop:define-package :asdf/package-system
  (:recycle :asdf/package-system :asdf)
  (:use :uiop/common-lisp :uiop
        :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
        :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
  (:export
   #:package-system #:register-system-packages #:sysdef-package-system-search
11
   #:*defpackage-forms* #:*package-systems* #:package-system-missing-package-error))
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
(in-package :asdf/package-system)

(with-upgradability ()
  (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))

  (defun initial-package-systems-table ()
    (let ((h (make-hash-table :test 'equal)))
      (dolist (p (list-all-packages))
        (dolist (n (package-names p))
          (setf (gethash n h) t)))
      h))

  (defvar *package-systems* (initial-package-systems-table))

  (defclass package-system (system)
    ())

  (defun defpackage-form-p (form)
    (and (consp form)
         (member (car form) *defpackage-forms*)))

  (defun stream-defpackage-form (stream)
34
35
    (loop :for form = (read stream nil nil) :while form
          :when (defpackage-form-p form) :return form))
36
37
38
39
40

  (defun file-defpackage-form (file)
    (with-input-file (f file)
      (stream-defpackage-form f)))

41
42
43
44
45
46
47
48
  (define-condition package-system-missing-package-error (system-definition-error)
    ((system :initarg :system :reader error-system)
     (pathname :initarg :pathname :reader error-pathname))
    (:report (lambda (c s)
               (format s (compatfmt "~@<No package form found while ~
                                     trying to define package-system ~A from file ~A~>")
                       (error-system c) (error-pathname c)))))

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
  (defun package-dependencies (defpackage-form)
    (assert (defpackage-form-p defpackage-form))
    (remove-duplicates
     (while-collecting (dep)
       (loop* :for (option . arguments) :in (cddr defpackage-form) :do
              (ecase option
                ((:use :mix :reexport :use-reexport :mix-reexport)
                 (dolist (p arguments) (dep (string p))))
                ((:import-from :shadowing-import-from)
                 (dep (string (first arguments))))
                ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
     :from-end t :test 'equal))

  (defun package-designator-name (package)
    (etypecase package
      (package (package-name package))
      (string package)
      (symbol (string package))))

  (defun register-system-packages (system packages)
    (let ((name (or (eq system t) (coerce-name system))))
      (dolist (p (ensure-list packages))
        (setf (gethash (package-designator-name p) *package-systems*) name))))

  (defun package-name-system (package-name)
    (check-type package-name string)
    (if-let ((system-name (gethash package-name *package-systems*)))
      system-name
      (string-downcase package-name)))

79
80
81
82
  (defun package-system-file-dependencies (file &optional system)
    (if-let (defpackage-form (file-defpackage-form file))
      (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
      (error 'package-system-missing-package-error :system system :pathname file)))
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

  (defun same-package-system-p (system name directory subpath dependencies)
    (and (eq (type-of system) 'package-system)
         (equal (component-name system) name)
         (pathname-equal directory (component-pathname system))
         (equal dependencies (component-sideway-dependencies system))
         (let ((children (component-children system)))
           (and (length=n-p children 1)
                (let ((child (first children)))
                  (and (eq (type-of child) 'cl-source-file)
                       (equal (component-name child) "lisp")
                       (and (slot-boundp child 'relative-pathname)
                            (equal (slot-value child 'relative-pathname) subpath))))))))

  (defun sysdef-package-system-search (system)
    (let ((primary (primary-system-name system)))
      (unless (equal primary system)
        (let ((top (find-system primary nil)))
          (when (typep top 'package-system)
            (if-let (dir (system-source-directory top))
              (let* ((sub (subseq system (1+ (length primary))))
                     (f (probe-file* (subpathname dir sub :type "lisp")
                                     :truename *resolve-symlinks*)))
                (when (file-pathname-p f)
107
                  (let ((dependencies (package-system-file-dependencies f system))
108
109
110
111
112
113
114
115
116
117
118
119
                        (previous (cdr (system-registered-p system))))
                    (if (same-package-system-p previous system dir sub dependencies)
                        previous
                        (eval `(defsystem ,system
                                 :class package-system
                                 :source-file nil
                                 :pathname ,dir
                                 :depends-on ,dependencies
                                 :components ((cl-source-file "lisp" :pathname ,sub)))))))))))))))

(with-upgradability ()
  (pushnew 'sysdef-package-system-search *system-definition-search-functions*))