src/code/defpackage.lisp

   1 ;;;; the DEFPACKAGE macro
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-IMPL")
  13
  14 ;;; FIXME: figure out why a full call to FORMAT this early in warm load
  15 ;;; says that CLASS is not a known type. (Obviously it needs to parse
  16 ;;; a type spec, but then why it is only a style-warning and not an error?)
  17 ;;; Weirder still, why does it depend on the target architecture?
  18
  19 (defmacro defpackage (package &rest options)
  20   #.(locally (declare (notinline format))
  21      (format nil
  22   "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
  23    following: ~{~&~4T~A~}
  24    All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
  25    times."
  26   '((:use "{package-name}*")
  27     (:export "{symbol-name}*")
  28     (:import-from "<package-name> {symbol-name}*")
  29     (:shadow "{symbol-name}*")
  30     (:shadowing-import-from "<package-name> {symbol-name}*")
  31     (:local-nicknames "{local-nickname actual-package-name}*")
  32     #+sb-package-locks (:lock "boolean")
  33     #+sb-package-locks (:implement "{package-name}*")
  34     (:documentation "doc-string")
  35     (:intern "{symbol-name}*")
  36     (:size "<integer>")
  37     (:nicknames "{package-name}*"))
  38   '(:size #+sb-package-locks :lock)))
  39   (let ((nicknames nil)
  40         (local-nicknames nil)
  41         (size nil)
  42         (shadows nil)
  43         (shadowing-imports nil)
  44         (use nil)
  45         (use-p nil)
  46         (imports nil)
  47         (interns nil)
  48         (exports nil)
  49         (package (stringify-string-designator package))
  50         (implement nil)
  51         (implement-p nil)
  52         (lock nil)
  53         (doc nil)
  54         (optname nil)
  55         (optval nil)
  56         (seen nil))
  57     (dolist (option options)
  58       (unless (consp option)
  59         (error 'simple-program-error
  60                :format-control "bogus DEFPACKAGE option: ~S"
  61                :format-arguments (list option)))
  62       (setq optname (car option) optval (cdr option))
  63       (case optname
  64         ((:documentation :size #+sb-package-locks :lock)
  65          (when (memq optname seen)
  66            (error 'simple-program-error
  67                   :format-control "can't specify ~S more than once."
  68                   :format-arguments (list optname)))
  69          (unless (typep optval '(cons t null))
  70            (error 'simple-program-error
  71                   :format-control "~S expects a single argument. Got ~S"
  72                   :format-arguments (list (cdr option))))
  73          (push optname seen)
  74          (setq optval (car optval))))
  75       (case optname
  76         (:nicknames
  77          (setf nicknames
  78                (append nicknames (stringify-string-designators optval))))
  79         (:local-nicknames
  80          (setf local-nicknames
  81                (append local-nicknames
  82                        (mapcar (lambda (spec)
  83                                  (destructuring-bind (nick name) spec
  84                                    (cons (stringify-package-designator nick)
  85                                          (stringify-package-designator name))))
  86                                optval))))
  87         (:size
  88          (if (typep optval 'unsigned-byte)
  89              (setf size optval)
  90              (error 'simple-program-error
  91                     :format-control ":SIZE is not a positive integer: ~S"
  92                     :format-arguments (cdr option))))
  93         (:shadow
  94          (setf shadows (append shadows (stringify-string-designators optval))))
  95         (:shadowing-import-from
  96          (let ((package-name (stringify-package-designator (car optval)))
  97                (names (stringify-string-designators (cdr optval))))
  98            (let ((assoc (assoc package-name shadowing-imports :test #'string=)))
  99              (if assoc
 100                  (setf (cdr assoc) (append (cdr assoc) names))
 101                  (setf shadowing-imports
 102                        (acons package-name names shadowing-imports))))))
 103         (:use
 104          (setf use (append use (stringify-package-designators optval))
 105                use-p t))
 106         (:import-from
 107          (let ((package-name (stringify-package-designator (car optval)))
 108                (names (stringify-string-designators (cdr optval))))
 109            (let ((assoc (assoc package-name imports :test #'string=)))
 110              (if assoc
 111                  (setf (cdr assoc) (append (cdr assoc) names))
 112                  (setf imports (acons package-name names imports))))))
 113         (:intern
 114          (setf interns (append interns (stringify-string-designators optval))))
 115         (:export
 116          (setf exports (append exports (stringify-string-designators optval))))
 117         #+sb-package-locks
 118         (:implement
 119          (setf implement (append implement (stringify-package-designators optval))
 120                implement-p t))
 121         #+sb-package-locks
 122         (:lock
 123          (setf lock (coerce optval 'boolean)))
 124         (:documentation
 125          (setf doc (possibly-base-stringize optval)))
 126         (t
 127          (error 'simple-program-error
 128                 :format-control "bogus DEFPACKAGE option: ~S"
 129                 :format-arguments (list option)))))
 130     (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
 131     (check-disjoint `(:intern ,@interns)
 132                     `(:import-from
 133                       ,@(apply #'append (mapcar #'rest imports)))
 134                     `(:shadow ,@shadows)
 135                     `(:shadowing-import-from
 136                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
 137     `(eval-when (:compile-toplevel :load-toplevel :execute)
 138        (%defpackage ,package ',nicknames ',size
 139                     ',shadows ',shadowing-imports ',(if use-p use :default)
 140                     ',imports ',interns ',exports
 141                     ;; FIXME: the default singleton list seems unnecessary.
 142                     ;; PACKAGE-LOCK-VIOLATION-P considers every package to implement
 143                     ;; itself. Additionally there's an obvious inconsistency:
 144                     ;; * (package-implements-list (defpackage "A")) => (#<PACKAGE "A">)
 145                     ;; * (package-implements-list (make-package "B")) => NIL
 146                     ',(if implement-p implement (list package))
 147                     ',local-nicknames
 148                     ',lock (sb-c:source-location)
 149                     ,@(and doc
 150                            `(,doc))))))
 151
 152 (defun check-disjoint (&rest args)
 153   ;; An arg is (:key . set)
 154   (do ((list args (cdr list)))
 155       ((endp list))
 156     (loop
 157       with x = (car list)
 158       for y in (rest list)
 159       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
 160       when z do (error 'simple-program-error
 161                        :format-control "Parameters ~S and ~S must be disjoint ~
 162                                         but have common elements ~%   ~S"
 163                        :format-arguments (list (car x)(car y) z)))))
 164
 165 (flet ((designator-to-string (kind designator)
 166          (cond ((and (eq kind 'package) (packagep designator))
 167                 (package-name designator)) ; already simple and basic if possible
 168                (t
 169                 (possibly-base-stringize
 170                  (cond ((stringp designator) designator)
 171                        ((symbolp designator) (symbol-name designator))
 172                        ((characterp designator) (string designator))
 173                        (t (error 'simple-type-error
 174                                  :datum designator
 175                                  :expected-type
 176                                  (if (eq kind 'package) 'package-designator 'string-designator)
 177                                  :format-control "~S does not designate a ~(~A~)"
 178                                  :format-arguments (list designator kind)))))))))
 179   (defun stringify-string-designator (string-designator)
 180     (designator-to-string 'string string-designator))
 181   (defun stringify-package-designator (package-designator)
 182     (designator-to-string 'package package-designator)))
 183
 184 (defun stringify-string-designators (string-designators)
 185   (mapcar #'stringify-string-designator string-designators))
 186
 187 (defun stringify-package-designators (package-designators)
 188   (mapcar #'stringify-package-designator package-designators))
 189
 190 (defun import-list-symbols (import-list)
 191   (let ((symbols nil))
 192     (dolist (import import-list symbols)
 193       (destructuring-bind (package-name &rest symbol-names)
 194           import
 195         (let ((package (find-undeleted-package-or-lose package-name)))
 196           (mapcar (lambda (name)
 197                     (push (find-or-make-symbol name package) symbols))
 198                   symbol-names))))))
 199
 200 (defun use-list-packages (package package-designators)
 201   (cond ((listp package-designators)
 202          (mapcar #'find-undeleted-package-or-lose package-designators))
 203         (package
 204          ;; :default for an existing package means preserve the
 205          ;; existing use list
 206          (package-use-list package))
 207         (t
 208          ;; :default for a new package is the *!default-package-use-list*
 209          '#.*!default-package-use-list*)))
 210
 211 (defun update-package (package nicknames source-location
 212                        shadows shadowing-imports
 213                        use
 214                        imports interns
 215                        exports implement local-nicknames
 216                        lock doc-string)
 217   (declare #-sb-package-locks (ignore implement lock))
 218   (%enter-new-nicknames package nicknames)
 219   ;; 1. :shadow and :shadowing-import-from
 220   ;;
 221   ;; shadows is a list of strings, shadowing-imports is a list of symbols.
 222   (shadow shadows package)
 223   (shadowing-import shadowing-imports package)
 224   ;; 2. :use
 225   ;;
 226   ;; use is a list of package objects.
 227   (use-package use package)
 228   ;; 3. :import-from and :intern
 229   ;;
 230   ;; imports is a list of symbols. interns is a list of strings.
 231   (import imports package)
 232   (dolist (intern interns)
 233     (intern intern package))
 234   ;; 4. :export
 235   ;;
 236   ;; exports is a list of strings
 237   (export (mapcar (lambda (symbol-name) (intern symbol-name package))
 238                   exports)
 239           package)
 240   ;; 5. :local-nicknames
 241   (setf (package-%local-nicknames package) nil) ; throw out the old ones.
 242   (loop :for (nickname . nickname-package) :in local-nicknames :do
 243      (add-package-local-nickname nickname nickname-package package))
 244   ;; Everything was created: update metadata
 245   (when source-location
 246     (setf (package-source-location package) source-location))
 247   (setf (package-doc-string package) doc-string)
 248   #+sb-package-locks
 249   (progn
 250     ;; Handle packages this is an implementation package of
 251     (dolist (p implement)
 252       (add-implementation-package package p))
 253     ;; Handle lock
 254     (setf (package-lock package) lock))
 255   package)
 256
 257 (declaim (type list *on-package-variance*))
 258 (defvar *on-package-variance* '(:warn t)
 259   "Specifies behavior when redefining a package using DEFPACKAGE and the
 260 definition is in variance with the current state of the package.
 261
 262 The value should be of the form:
 263
 264   (:WARN [T | packages-names] :ERROR [T | package-names])
 265
 266 specifying which packages get which behaviour -- with T signifying the default unless
 267 otherwise specified. If default is not specified, :WARN is used.
 268
 269 :WARN keeps as much state as possible and causes SBCL to signal a full warning.
 270
 271 :ERROR causes SBCL to signal an error when the variant DEFPACKAGE form is executed,
 272 with restarts provided for user to specify what action should be taken.
 273
 274 Example:
 275
 276   (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t))
 277
 278 specifies to signal a warning if SWANK package is in variance, and an error otherwise.")
 279
 280 (defun note-package-variance (&rest args &key package &allow-other-keys)
 281   (let ((pname (package-name package)))
 282     (destructuring-bind (&key warn error) *on-package-variance*
 283       (let ((what (cond ((and (listp error) (member pname error :test #'string=))
 284                          :error)
 285                         ((and (listp warn) (member pname warn :test #'string=))
 286                          :warn)
 287                         ((eq t error)
 288                          :error)
 289                         (t
 290                          :warn))))
 291         (ecase what
 292           (:error
 293            (apply #'error 'package-at-variance-error args))
 294           (:warn
 295            (apply #'warn 'package-at-variance args)))))))
 296
 297 (defun update-package-with-variance (package name nicknames source-location
 298                                      shadows shadowing-imports
 299                                      use
 300                                      imports interns
 301                                      exports
 302                                      implement local-nicknames
 303                                      lock doc-string)
 304   (unless (string= (the string (package-name package)) name)
 305     (error 'simple-package-error
 306            :package name
 307            :format-control "~A is a nickname for the package ~A"
 308            :format-arguments (list name (package-name name))))
 309   (let ((no-longer-shadowed
 310           (set-difference (package-%shadowing-symbols package)
 311                           (append shadows shadowing-imports)
 312                           :test #'string=)))
 313     (when no-longer-shadowed
 314       (restart-case
 315           (let ((*package* (find-package :keyword)))
 316             (note-package-variance
 317              :format-control "~A also shadows the following symbols:~%  ~S"
 318              :format-arguments (list name no-longer-shadowed)
 319              :package package))
 320         (drop-them ()
 321           :report "Stop shadowing them by uninterning them."
 322           (dolist (sym no-longer-shadowed)
 323             (unintern sym package)))
 324         (keep-them ()
 325           :report "Keep shadowing them."))))
 326   (let ((no-longer-used (set-difference (package-use-list package) use)))
 327     (when no-longer-used
 328       (restart-case
 329           (note-package-variance
 330            :format-control "~A also uses the following packages:~%  ~A"
 331            :format-arguments (list name (mapcar #'package-name no-longer-used))
 332            :package package)
 333         (drop-them ()
 334           :report "Stop using them."
 335           (unuse-package no-longer-used package))
 336         (keep-them ()
 337           :report "Keep using them."))))
 338   (let (old-exports)
 339     (do-external-symbols (s package)
 340       (push s old-exports))
 341     (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
 342      (when no-longer-exported
 343        (restart-case
 344            (note-package-variance
 345             :format-control "~A also exports the following symbols:~%  ~S"
 346             :format-arguments (list name no-longer-exported)
 347             :package package)
 348          (drop-them ()
 349            :report "Unexport them."
 350            (unexport no-longer-exported package))
 351          (keep-them ()
 352            :report "Keep exporting them.")))))
 353   #+sb-package-locks
 354   (let ((old-implements
 355           (set-difference (package-implements-list package)
 356                           (mapcar #'find-undeleted-package-or-lose implement))))
 357     (when old-implements
 358       (restart-case
 359           (note-package-variance
 360            :format-control "~A is also an implementation package for:~% ~{~S~^~%  ~}"
 361            :format-arguments (list name old-implements)
 362            :package package)
 363         (drop-them ()
 364           :report "Stop being an implementation package for them."
 365           (dolist (p old-implements)
 366             (remove-implementation-package package p)))
 367         (keep-them ()
 368           :report "Keep exporting them."))))
 369   (update-package package nicknames source-location
 370                   shadows shadowing-imports
 371                   use imports interns exports
 372                   implement local-nicknames
 373                   lock doc-string))
 374
 375 (defun %defpackage (name nicknames size shadows shadowing-imports
 376                     use imports interns exports implement local-nicknames
 377                     lock source-location &optional doc)
 378   (declare (type simple-string name)
 379            (type list nicknames shadows shadowing-imports
 380                  imports interns exports)
 381            (type (or list (member :default)) use)
 382            (type (or simple-string null) doc))
 383   (with-package-graph ()
 384     (let* ((existing-package (find-package name))
 385            (use (use-list-packages existing-package use))
 386            (shadowing-imports (import-list-symbols shadowing-imports))
 387            (imports (import-list-symbols imports)))
 388       (if existing-package
 389           (update-package-with-variance existing-package name
 390                                         nicknames source-location
 391                                         shadows shadowing-imports
 392                                         use imports interns exports
 393                                         implement local-nicknames
 394                                         lock doc)
 395           (let ((package (make-package name
 396                                        :use nil
 397                                        :internal-symbols (or size 10)
 398                                        :external-symbols (length exports))))
 399             (update-package package
 400                             nicknames
 401                             source-location
 402                             shadows shadowing-imports
 403                             use imports interns exports
 404                             implement local-nicknames
 405                             lock doc))))))
 406
 407 (defun find-or-make-symbol (name package)
 408   (multiple-value-bind (symbol how) (find-symbol name package)
 409     (cond (how
 410            symbol)
 411           (t
 412            (with-simple-restart (continue "INTERN it.")
 413              (error 'simple-package-error
 414                     :package package
 415                     :format-control "no symbol named ~S in ~S"
 416                     :format-arguments (list name (package-name package))))
 417            (intern name package)))))
 418
 419 ;;;; package hacking
 420
 421 ;;; FIXME: This nickname is a deprecated hack for backwards
 422 ;;; compatibility with code which assumed the CMU-CL-style
 423 ;;; SB-ALIEN/SB-C-CALL split. That split went away and was deprecated
 424 ;;; in 0.7.0, so we should get rid of this nickname after a while.
 425 (let ((package (find-package "SB-ALIEN")))
 426   (rename-package package package
 427                   (cons "SB-C-CALL" (package-nicknames package))))
 428
 429 (let ((package (find-package "SB-SEQUENCE")))
 430   (rename-package package package (list "SEQUENCE")))