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