package.lisp 16.1 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
;;
;; See https://bugs.launchpad.net/asdf/+bug/485687
;;
;; CAUTION: we must handle the first few packages specially for hot-upgrade.
;; asdf/package will be frozen as of 2.27
;; to forever export the same exact symbols.
;; Any other symbol must be import-from'ed
;; and reexported in a different package
;; (alternatively the package may be dropped & replaced by one with a new name).

(defpackage :asdf/package
  (:use :common-lisp)
  (:export
16 17
   #:find-package* #:package-name* #:find-symbol* #:intern* #:unintern*
   #:unlink-package #:ensure-package #:define-package #:package-data))
18 19 20

(in-package :asdf/package)

21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
(declaim (optimize (speed 0) (safety 3) (debug 3)))

(defmacro DBG (tag &rest exprs)
  "simple debug statement macro:
outputs a tag plus a list of variable and their values, returns the last value"
  ;"if not in debugging mode, just compute and return last value"
  #-DBGXXX (declare (ignore tag)) #-DBGXXX (car (last exprs)) #+DBGXXX
  (let ((res (gensym))(f (gensym)))
  `(let (,res (*print-readably* nil))
    (flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args)))
      (fresh-line *standard-output*) (fresh-line *trace-output*) (fresh-line *error-output*)
      (,f "~&~A~%" ,tag)
      ,@(mapcan
         #'(lambda (x)
            `((,f "~&  ~S => " ',x)
              (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x)))))
         exprs)
      (apply 'values ,res)))))

40 41 42
;;;; General purpose package utilities

(eval-when (:load-toplevel :compile-toplevel :execute)
43 44 45 46 47 48 49 50 51 52
  (defun find-package* (package-designator &optional (error t))
    (let ((package (find-package package-designator)))
      (cond
        (package package)
        (error (error "No package named ~S" (string package-designator)))
        (t nil))))
  (defun package-name* (package-designator &optional (error t))
    (let ((package (find-package* package-designator error)))
      (when package (package-name package))))
  (defun find-symbol* (name package-designator &optional (error t))
53 54 55 56 57 58
    "Find a symbol in a package of given string'ified NAME;
unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
by letting you supply a symbol or keyword for the name;
also works well when the package is not present.
If optional ERROR argument is NIL, return NIL instead of an error
when the symbol is not found."
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
    (block nil
      (let ((package (find-package* package-designator error)))
        (when package
          (multiple-value-bind (symbol status) (find-symbol (string name) package)
            (cond
              (status (return (values symbol status)))
              (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
        (values nil nil))))
  (defun intern* (name package-designator &optional (error t))
    (intern (string name) (package-name* package-designator error)))
  (defun unintern* (name package-designator &optional (error t))
    (block nil
      (let ((package (find-package* package-designator error)))
        (when package
          (multiple-value-bind (symbol status) (find-symbol* name package error)
            (cond
              (status (unintern symbol package)
                      (return (values symbol status)))
              (error (error "symbol ~A not present in package ~A"
                            (string symbol) (package-name package))))))
        (values nil nil))))
  (defun package-data (package-designator &optional (error t))
    (let ((package (find-package* package-designator error)))
      (when package
        (labels ((string-sort (strings)
                   (sort strings #'string<))
                 (sort-packages (packages)
                   (string-sort (mapcar #'package-name packages))))
          (loop :with internal :with external :with inherited
                :for sym :being :the :symbols :in package
                :for status = (nth-value 1 (find-symbol* sym package)) :do
                  (ecase status
                    (:internal (push sym internal))
                    (:external (push sym external))
                    (:inherited (push sym inherited)))
                :finally
                   (return
                     `(:name ,(package-name package)
                       :nicknames ,(package-nicknames package)
                       :internal ,(string-sort internal)
                       :external ,(string-sort external)
                       :inherited ,(string-sort inherited)
                       :shadowing ,(string-sort (package-shadowing-symbols package))
                       :use ,(sort-packages (package-use-list package))
                       :used-by ,(sort-packages (package-used-by-list package))))))))))
104 105 106 107 108 109 110 111 112 113 114 115

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun soft-upgrade-p (upgrade)
    (ecase upgrade ((:soft nil) t) (:hard nil)))
  (defun ensure-package-unused (package)
    (loop :for p :in (package-used-by-list package) :do
      (unuse-package package p)))
  (defun ensure-package-deleted (package) ;; &key upgrade
    (let ((p (find-package package)))
      (when p
        (ensure-package-unused p)
        (delete-package package))))
116 117
  (defun ensure-package-fmakunbound (package symbols)
    (loop :for name :in symbols
118
          :for sym = (find-symbol* name package nil)
119 120 121
          :when sym :do (fmakunbound sym)))
  (defun ensure-package-fmakunbound-setf (package symbols)
    (loop :for name :in symbols
122
          :for sym = (find-symbol* name package nil)
123
          :when sym :do #-gcl (fmakunbound `(setf ,sym))))
124 125 126
  (defun recycle-symbol (name recycle)
    (loop :for r :in recycle
          :for s = (find-symbol* name r nil)
127
          :when s :do (return (values s r))))
128
  (defun ensure-package (name &key
129 130 131 132 133 134 135 136 137 138 139 140 141 142
                                upgrade
                                nicknames documentation use
                                shadow shadowing-import-from
                                import-from export intern
                                recycle mix reexport
                                unintern fmakunbound fmakunbound-setf)
    (let* ((nicknames (mapcar #'string nicknames))
           (shadow (mapcar #'string shadow))
           (shadowing-import-from (loop :for sif :in shadowing-import-from
                                        :collect (mapcar #'string sif)))
           (import-from (loop :for if :in import-from
                              :collect (mapcar #'string if)))
           (export (mapcar #'string export))
           (recycle (remove nil (mapcar #'find-package recycle)))
143 144 145 146
           (shadowed (make-hash-table :test 'equal)) ; string to bool
           (imported (make-hash-table :test 'equal)) ; string to bool
           (exported (make-hash-table :test 'equal)) ; string to bool
           (inherited (make-hash-table :test 'equal)) ; string to package name
147 148 149 150 151 152
           (previous (remove-duplicates
                      (mapcar #'find-package (cons name nicknames))
                      :from-end t))
           (discarded (cdr previous))
           (package (or (first previous) (make-package name :nicknames nicknames))))
      (setf (documentation package t) documentation)
153 154 155 156 157 158 159
      (DBG :ensure-package name upgrade
                                nicknames documentation use
                                shadow shadowing-import-from
                                import-from export intern
                                recycle mix reexport
                                unintern fmakunbound fmakunbound-setf)
      ;;#+DBG (untrace)(trace find-symbol make-package delete-package use-package unuse-package import export intern shadow shadowing-import unintern unexport)
160 161 162 163
      (assert (soft-upgrade-p upgrade))
      (ensure-package-unused package)
      (map () #'ensure-package-deleted discarded)
      (rename-package package name nicknames)
164
      (dolist (name unintern) (unintern* name package))
165 166
      ;;; Compute the desired state of the package
      (loop :for sym :in shadow :for name = (string sym) :do
167
        (DBG :sha name)
168 169 170 171 172 173 174 175
        (setf (gethash name shadowed) t)
        (multiple-value-bind (recycled previous) (recycle-symbol name recycle)
          (cond
            ((or (not previous) (not (member (symbol-package recycle) recycle)))
             (ecase (nth-value 1 (find-symbol* name package nil))
               ((nil :inherited) (shadow name package))
               ((:internal :external) (shadowing-import (make-symbol name) package))))
            ((eq previous package) (shadow recycled package))
176
            (t (unintern* recycled previous) (shadowing-import recycled package)))))
177 178 179 180 181 182
      (labels
          ((ensure-shadowing-import (sym p)
             (let* ((name (string sym))
                    (i (find-symbol* name p)))
               (cond
                 ((gethash name shadowed)
183
                  (unless (eq i (find-symbol* name package))
184 185 186
                    (error "Conflicting shadowings for ~A" name)))
                 (t
                    (setf (gethash name shadowed) t)
187
                    (setf (gethash name imported) t)
188 189 190 191
                    (shadowing-import package)))))
           (ensure-import (sym p)
             (let* ((name (string sym))
                    (i (find-symbol* name p)))
192
               (multiple-value-bind (x xp) (find-symbol name package)
193
                 (cond
194 195
                   ((gethash name imported)
                    (unless (eq i x)
196
                      (error "Can't import ~S from both ~S and ~S"
197
                             name (package-name (symbol-package x)) (package-name p))))
198 199 200
                   ((gethash name shadowed)
                    (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
                   (t
201 202 203 204
                    (when (and xp (not (eq i x)))
                      (unintern* x package))
                    (setf (gethash name imported) t)
                    (import i package))))))
205 206
           (ensure-mix (sym p)
             (let* ((name (string sym))
207 208 209
                    (sp (string p)))
               (unless (or (gethash name shadowed) (gethash name imported))
                 (let ((ip (gethash name inherited)))
210
                   (cond
211 212
                     ((eq sp ip))
                     (ip
213
                      (remhash name inherited)
214
                      (ensure-shadowing-import name ip))
215
                     (t
216
                      (ensure-inherited sym sp)))))))
217 218
           (ensure-inherited (sym p)
             (let* ((name (string sym))
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
                    (sp (string p))
                    (s (find-symbol* name sp))
                    (ip (gethash name inherited)))
               (multiple-value-bind (x xp) (find-symbol name package)
                 (cond
                   (ip
                    (unless (eq ip sp)
                      (error "Can't inherit ~S from ~S, it is inherited from ~S"
                             name sp ip)))
                   ((gethash name imported)
                    (unless (eq s x)
                      (error "Can't inherit ~S from ~S, it is imported from ~S"
                             name sp (package-name (symbol-package x)))))
                   ((gethash name shadowed)
                    (error "Can't inherit ~S from ~S, it is shadowed" name sp))
                   (t
                    (when xp
                      (unintern* x package)))))))
           (ensure-registered (sym)
238 239
             (let ((name (string sym)))
               (unless (or (gethash name shadowed)
240 241
                           (gethash name imported)
                           (gethash name inherited))
242 243
                 (multiple-value-bind (recycled previous) (recycle-symbol name recycle)
                   (cond
244 245
                       ((or (not previous) (not (member (symbol-package recycled) recycle)))
                        (unintern* sym package))
246
                       ((eq previous package))
247
                       (t (unintern* recycled previous) (import recycled package))))))))
248
        (loop :for (p . syms) :in shadowing-import-from :do
249
          (DBG :shaif p syms)
250 251
          (dolist (sym syms) (ensure-shadowing-import sym p)))
        (loop :for p :in mix :do
252
          (DBG :mix p)
253 254
          (do-external-symbols (sym p) (ensure-mix sym p)))
        (loop :for (p . syms) :in import-from :do
255
          (DBG :if p syms)
256
          (dolist (sym syms) (ensure-import sym p)))
257 258 259 260 261
        (loop :for p :in use :for sp = (string p) :for pp = (find-package sp) :do
          (DBG :use p sp pp)
          (do-external-symbols (sym pp) (ensure-inherited sym sp))
          (use-package pp package))
        (DBG :intern intern)
262 263
        (dolist (sym intern) (intern* sym package))
        (do-symbols (sym package)
264 265
          (DBG :ers sym)
          (ensure-registered sym))
266
        (loop :for p :in reexport :do
267 268 269 270 271 272 273 274 275
          (DBG :reex p)
          (do-external-symbols (sym p)
            (let ((name (string sym)))
              (export (find-symbol* name package) package) (setf (gethash name exported) t))))
        (DBG :export export)
        (loop :for sym :in export :for name = (string sym) :for symbol = (intern* name package) :do
          (export symbol package) (setf (gethash name exported) t))
        (DBG :unexport)
        (do-external-symbols (sym package) (unless (gethash (symbol-name sym) exported) (unexport sym package)))
276 277 278 279
        ;; do away with packages with conflicting (nick)names
        ;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed)
        (ensure-package-fmakunbound package fmakunbound)
        (ensure-package-fmakunbound-setf package fmakunbound-setf)
280
        ;;#+DBG (untrace)
281 282 283
        package))))

(eval-when (:load-toplevel :compile-toplevel :execute)
284
  (defun parse-define-package-form (package clauses)
285 286 287 288
    (loop
      :with use-p = nil :with recycle-p = nil
      :with documentation = nil :with upgrade = nil
      :for (kw . args) :in clauses
289
      :when (eq kw :nicknames) :append args :into nicknames :else
290 291 292 293 294 295
      :when (eq kw :documentation)
        :do (cond
              (documentation (error "define-package: can't define documentation twice"))
              ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
              (t (setf documentation (car args)))) :else
      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
296
      :when (eq kw :shadow) :append args :into shadow :else
297 298
      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
      :when (eq kw :import-from) :collect args :into import-from :else
299 300
      :when (eq kw :export) :append args :into export :else
      :when (eq kw :intern) :append args :into intern :else
301
      :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
302
      :when (eq kw :mix) :append args :into mix :else
303
      :when (eq kw :reexport) :append args :into reexport :else
304 305 306
      :when (eq kw :unintern) :append args :into unintern :else
      :when (eq kw :fmakunbound) :append args :into fmakunbound :else
      :when (eq kw :fmakunbound-setf) :append args :into fmakunbound-setf :else
307 308 309 310 311
      :when (eq kw :upgrade)
        :do (unless (and (consp args) (null (cdr args)) (member (car args) '(:soft :hard)) (null upgrade))
              (error "define-package: bad :upgrade directive"))
            (setf upgrade (car args)) :else
      :do (error "unrecognized define-package keyword ~S" kw)
312 313
      :finally (return `(,package
                         :nicknames ,nicknames :documentation ,documentation
314 315 316 317 318 319 320
                         :use ,(if use-p use '(:common-lisp))
                         :shadow ,shadow :shadowing-import-from ,shadowing-import-from
                         :import-from ,import-from :export ,export :intern ,intern
                         :recycle ,(if recycle-p recycle (cons package nicknames))
                         :mix ,mix :reexport ,reexport :unintern ,unintern
                         ,@(when upgrade `(:upgrade ,upgrade))
                         :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf)))))
321 322 323

(defmacro define-package (package &rest clauses)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
324
     #+gcl (defpackage ,package (:use))
325
     (apply 'ensure-package ',(parse-define-package-form package clauses))))