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