package.lisp 13.6 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 18
   #:find-symbol* #:present-symbol-p #:present-symbols
   #:intern* #:remove-symbol #:unlink-package #:ensure-package
   #:define-package))
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42

(in-package :asdf/package)

;;;; General purpose package utilities

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun find-symbol* (name package-name &optional (error t))
    "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."
    (let ((package (find-package package-name)))
      (if package
          (let ((symbol (find-symbol (string name) package)))
            (or symbol
                (when error
                  (error "There is no symbol ~A in package ~A" name package-name))))
          (when error
            (error "There is no package ~A" package-name)))))
  (defun intern* (name package)
    (intern (string name) package))
  (defun remove-symbol (symbol package)
43
    (let ((sym (find-symbol* symbol package nil)))
44 45 46 47 48
      (when sym
        #-cormanlisp (unexport sym package)
        (unintern sym package)
        sym)))
  (defun present-symbol-p (symbol package)
49
    (member (nth-value 1 (find-symbol* symbol package nil)) '(:internal :external)))
50 51
  (defun present-symbols (package)
    ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
    (let (l) (do-symbols (s package) (when (present-symbol-p s package) (push s l))) (reverse l))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun soft-upgrade-p (upgrade)
    (ecase upgrade ((:soft nil) t) (:hard nil)))
  (defun check-packages-exist (package-names)
    (remove-duplicates
     (loop :for n :in package-names
           :for p = (find-package n)
           :when p :collect p :else :do (error "Package ~A does not exist" n))
     :from-end t))
  (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
        ;;(unless (soft-upgrade-p upgrade) (ensure-package-unintern p (present-symbols u)))
        (ensure-package-unused p)
        (delete-package package))))
72 73
  (defun ensure-package-fmakunbound (package symbols)
    (loop :for name :in symbols
74
          :for sym = (find-symbol* name package nil)
75 76 77
          :when sym :do (fmakunbound sym)))
  (defun ensure-package-fmakunbound-setf (package symbols)
    (loop :for name :in symbols
78
          :for sym = (find-symbol* name package nil)
79
          :when sym :do #-gcl (fmakunbound `(setf ,sym))))
80 81 82 83 84 85 86 87 88 89 90 91 92 93
  (defun ensure-package-unintern (package unintern &key table (users (list-all-packages)))
    (loop :for u :in unintern
          :for name = (string u)
          :for removed = (remove-symbol name package) :do
          (when removed
            (loop :for p :in users :do
              (when (eq removed (find-symbol name p))
                (unintern removed p)))))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun recycle-symbol (name recycle)
    (loop :for r :in recycle
          :for s = (find-symbol* name r nil)
          :when s :do (values s r)))
94
  (defun ensure-package (name &key
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
                                upgrade
                                nicknames documentation use
                                shadow shadowing-import-from
                                import-from export intern
                                recycle mix reexport
                                unintern fmakunbound fmakunbound-setf)
    (let* ((nicknames (mapcar #'string nicknames))
           (use (check-packages-exist use))
           (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)))
           (mix (check-packages-exist mix))
           (shadowed (make-hash-table :test 'equal))
           (inherited (make-hash-table :test 'equal))
           (imported (make-hash-table :test 'equal))
           (exported (make-hash-table :test 'equal))
           (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)
      (assert (soft-upgrade-p upgrade))
      (ensure-package-unused package)
      (map () #'ensure-package-deleted discarded)
      (rename-package package name nicknames)
      (dolist (name unintern) (remove-symbol name package))
      ;;; Compute the desired state of the package
      (loop :for sym :in shadow :for name = (string sym) :do
        (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))
            (t (unintern recycled previous) (shadowing-import recycled package)))))
      (labels
          ((ensure-shadowing-import (sym p)
             (let* ((name (string sym))
                    (i (find-symbol* name p)))
               (cond
                 ((gethash name shadowed)
                  (unless (eq i (gethash name imported))
                    (error "Conflicting shadowings for ~A" name)))
                 (t
                    (setf (gethash name shadowed) t)
                    (setf (gethash name imported) i)
                    (shadowing-import package)))))
           (ensure-import (sym p)
             (let* ((name (string sym))
                    (i (find-symbol* name p)))
               (multiple-value-bind (ii ip) (gethash name imported)
                 (cond
                   (ip
                    (unless (eq i ii)
                      (error "Can't import ~S from both ~S and ~S"
                             name (package-name (symbol-package ii)) (package-name p))))
                   ((gethash name shadowed)
                    (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
                   (t
                    (multiple-value-bind (x xp) (find-symbol name package)
                      (when (and xp (not (eq i x)))
                        (unintern x package))
                      (import i package)))))))
           (ensure-mix (sym p)
             (let* ((name (string sym))
                    (i (find-symbol* name p)))
               (unless (or (gethash name shadowed) (nth-value 1 (gethash name imported)))
                 (multiple-value-bind (in inp) (gethash name inherited)
                   (cond
                     ((eq i in))
                     (inp
                      (remhash name inherited)
                      (ensure-shadowing-import name (symbol-package in)))
                     (t
                      (ensure-inherited sym p)))))))
           (ensure-inherited (sym p)
             (let* ((name (string sym))
                    (i (find-symbol* name p)))
               (multiple-value-bind (in inp) (gethash name inherited)
                 (multiple-value-bind (im imp) (gethash name imported)
                   (cond
                     (inp
                      (unless (eq i in)
                        (error "Can't inherit ~S from ~S, it is inherited from ~S"
                               name (package-name p) (package-name (symbol-package in)))))
                     (imp
                      (unless (eq i im)
                        (error "Can't inherit ~S from ~S, it is imported from ~S"
                               name (package-name p) (package-name (symbol-package im)))))
                     ((gethash name shadowed)
                      (error "Can't inherit ~S from ~S, it is shadowed" name (package-name p)))
                     (t
                      (multiple-value-bind (x xp) (find-symbol name package)
                        (when xp
                          (unintern x package)))))))))
           (ensure-registered-symbol (sym)
             (let ((name (string sym)))
               (unless (or (gethash name shadowed)
                           (nth-value 1 (gethash name imported))
                           (nth-value 1 (gethash name inherited)))
                 (multiple-value-bind (recycled previous) (recycle-symbol name recycle)
                   (cond
                       ((or (not previous) (not (member (symbol-package recycle) recycle)))
                        (unintern sym package))
                       ((eq previous package))
                       (t (unintern recycled previous) (import recycled package))))))))
        (loop :for (p . syms) :in shadowing-import-from :do
          (dolist (sym syms) (ensure-shadowing-import sym p)))
        (loop :for p :in mix :do
          (do-external-symbols (sym p) (ensure-mix sym p)))
        (loop :for (p . syms) :in import-from :do
          (dolist (sym syms) (ensure-import sym p)))
        (loop :for p :in use :do
          (do-external-symbols (sym p) (ensure-inherited sym p)))
        (loop :for p :in use :do (use-package p package))
        (dolist (sym intern) (intern* sym package))
        (do-symbols (sym package)
          (ensure-registered-symbol sym))
        (loop :for p :in reexport :do
        (do-external-symbols (sym p)
          (let ((name (string sym)))
            (export (find-symbol* name package) package) (setf (gethash name exported) t))))
        (dolist (sym export) (export sym package) (setf (gethash sym exported) t))
        (do-external-symbols (sym package) (unless (gethash sym exported) (unexport sym)))
        ;; 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)
        package))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun parse-define-package-clauses (package clauses)
    (loop
      :with use-p = nil :with recycle-p = nil
      :with documentation = nil :with upgrade = nil
      :for (kw . args) :in clauses
238
      :when (eq kw :nicknames) :append args :into nicknames :else
239 240 241 242 243 244
      :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
245
      :when (eq kw :shadow) :append args :into shadow :else
246 247
      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
      :when (eq kw :import-from) :collect args :into import-from :else
248 249
      :when (eq kw :export) :append args :into export :else
      :when (eq kw :intern) :append args :into intern :else
250
      :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
251
      :when (eq kw :mix) :append args :into mix :else
252
      :when (eq kw :reexport) :append args :into reexport :else
253 254 255
      :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
256 257 258 259 260 261 262 263 264 265 266 267 268
      :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)
      :finally (return `(:nicknames ,nicknames :documentation ,documentation
                         :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)))))
269 270 271

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