package.lisp 8.49 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 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 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 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
;;;; ---------------------------------------------------------------------------
;;;; 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
   #:find-symbol* #:define-package))

(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)
    (let ((sym (find-symbol* symbol package)))
      (when sym
        #-cormanlisp (unexport sym package)
        (unintern sym package)
        sym)))
  (defun present-symbol-p (symbol package)
    (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
  (defun present-symbols (package)
    ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
    (let (l)
      (do-symbols (s package)
        (when (present-symbol-p s package) (push s l)))
      (reverse l)))
  (defun ensure-package-use (package use)
    (dolist (used (package-use-list package))
      (unless (member (package-name used) use :test 'string=)
        (unuse-package used)
        (do-external-symbols (sym used)
          (when (eq sym (find-symbol* sym package))
            (remove-symbol sym package)))))
    (dolist (used (reverse use))
      (do-external-symbols (sym used)
        (unless (eq sym (find-symbol* sym package))
          (remove-symbol sym package)))
      (use-package used package)))
  (defun ensure-package-unintern (package symbols)
    (loop :with packages = (list-all-packages)
          :for sym :in symbols
          :for removed = (remove-symbol sym package)
          :when removed :do
            (loop :for p :in packages :do
              (when (eq removed (find-symbol* sym p))
                (unintern removed p)))))
  (defun unlink-package (package)
    (let ((u (find-package package)))
      (when u
        (ensure-package-unintern u (present-symbols u))
        (loop :for p :in (package-used-by-list u) :do
          (unuse-package u p))
        (delete-package u))))
  (defun ensure-package-exists (name nicknames use)
    (let ((previous
            (remove-duplicates
             (mapcar #'find-package (cons name nicknames))
             :from-end t)))
      ;; do away with packages with conflicting (nick)names
      (map () #'unlink-package (cdr previous))
      ;; reuse previous package with same name
      (let ((p (car previous)))
        (cond
          (p
           (rename-package p name nicknames)
           (ensure-package-use p use)
           p)
          (t
           (make-package name :nicknames nicknames :use use))))))
  (defun ensure-package-shadow (package symbols)
    (shadow symbols package))
  (defun ensure-package-fmakunbound (package symbols)
    (loop :for name :in symbols
          :for sym = (find-symbol* name package)
          :when sym :do (fmakunbound sym)))
  (defun ensure-package-fmakunbound-setf (package symbols)
    (loop :for name :in symbols
          :for sym = (find-symbol* name package)
          :when sym :do #-gcl (fmakunbound `(setf ,sym))))
  (defun ensure-package-export (package export)
    (let ((formerly-exported-symbols nil)
          (bothly-exported-symbols nil)
          (newly-exported-symbols nil))
      (do-external-symbols (sym package)
        (if (member sym export :test 'string-equal)
            (push sym bothly-exported-symbols)
            (push sym formerly-exported-symbols)))
      (loop :for sym :in export :do
        (unless (member sym bothly-exported-symbols :test 'equal)
          (push sym newly-exported-symbols)))
      (loop :for user :in (package-used-by-list package)
            :for shadowing = (package-shadowing-symbols user) :do
              (loop :for new :in newly-exported-symbols
                    :for old = (find-symbol* new user)
                    :when (and old (not (member old shadowing)))
                      :do (unintern old user)))
      (loop :for x :in newly-exported-symbols :do
        (export (intern* x package)))))
  (defun ensure-package (name &key
127 128 129 130
                                nicknames use intern unintern shadow export
                                import-from shadowing-import-from
                                recycle mix fmakunbound fmakunbound-setf)
    recycle mix intern import-from shadowing-import-from
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
    (let* ((p (ensure-package-exists name nicknames use)))
      #-ecl (ensure-package-fmakunbound p fmakunbound) #+ecl fmakunbound ;; do it later on ECL
      #-ecl (ensure-package-fmakunbound-setf p fmakunbound-setf) #+ecl fmakunbound-setf
      (ensure-package-unintern p unintern)
      (ensure-package-shadow p shadow)
               (ensure-package-export p export)
               p))
#|
  (let ((h (make-hash-table :test 'equal)))
    (labels ((ensure-imported (n)
               (let* ((s (string n))
                      (x (gethash s h)))
                 (unless x (setf (gethash s h) t))
                 x))
             (import-from (package)
               (loop :for s :being :each :external-symbol :in package
                 :for n = (symbol-name s)
                 :unless (ensure-imported n)
                 :collect n)))
      ;; First, mark the symbols explicitly imported by the user
      (loop :for (kw . ()) :in clauses
            :when (member kw '(:import-from :shadowing-import-from)) :do
              (map () #'ensure-imported (cddr clauses)))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         (ensure-package
          ',name :nicknames ',nicknames :use ',use :export ',export
                 :shadow ',shadow :unintern ',unintern
                 :fmakunbound ',fmakunbound :fmakunbound-setf ',fmakunbound-setf)))
      `(defpackage ,package (:use)
         ,@(loop :for p :in mixed-packages
             :collect `(:import-from ,p ,@(import-from p)))
         ,@clauses
         (:export ,@(loop :for s :being :the :hash-keys :of h :collect s)))))))
|#
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
  (defun parse-define-package-clauses (clauses)
    (loop :for (kw . args) :in clauses
      :when (eq kw :nicknames) :append args :into nicknames :else
      :when (eq kw :use) :append args :into use :else
      :when (eq kw :shadow) :append args :into shadow :else
      :when (eq kw :export) :append args :into export :else
      :when (eq kw :intern) :append args :into intern :else
      :when (eq kw :import-from) :collect args :into import-from :else
      :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
      :when (eq kw :recycle) :append args :into recycle :else
      :when (eq kw :mix) :append args :into mix :else
      :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
        :do (error "unrecognized define-package keyword ~S" kw)
      :finally (return `(:nicknames ,nicknames :use ,use
                         :shadow ,shadow :export ,export :intern ,intern
                         :import-from ,import-from :shadowing-import-from ,shadowing-import-from
                         :recycle ,recycle :mix ,mix :unintern ,unintern
                         :fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf))))
);eval-when
186 187 188

(defmacro define-package (package &rest clauses)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
189
     (apply 'ensure-package ',package ',(parse-define-package-clauses clauses))))