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 (defun update-package-with-variance (package name nicknames source-location
 266                                      shadows shadowing-imports
 267                                      use
 268                                      imports interns
 269                                      exports
 270                                      implement local-nicknames
 271                                      lock doc-string)
 272   (unless (string= (the string (package-name package)) name)
 273     (error 'simple-package-error
 274            :package name
 275            :format-control "~A is a nickname for the package ~A"
 276            :format-arguments (list name (package-name name))))
 277   (let ((no-longer-shadowed
 278           (set-difference (package-%shadowing-symbols package)
 279                           (append shadows shadowing-imports)
 280                           :test #'string=)))
 281     (when no-longer-shadowed
 282       (restart-case
 283           (let ((*package* (find-package :keyword)))
 284             (error 'sb!kernel::package-at-variance-error
 285                    :format-control "~A also shadows the following symbols:~%  ~S"
 286                    :format-arguments (list name no-longer-shadowed)
 287                    :package package))
 288         (drop-them ()
 289           :report "Stop shadowing them by uninterning them."
 290           (dolist (sym no-longer-shadowed)
 291             (unintern sym package)))
 292         (keep-them ()
 293           :report "Keep shadowing them."))))
 294   (let ((no-longer-used (set-difference (package-use-list package) use)))
 295     (when no-longer-used
 296       (restart-case
 297           (error 'sb!kernel::package-at-variance-error
 298                  :format-control "~A also uses the following packages:~%  ~A"
 299                  :format-arguments (list name (mapcar #'package-name no-longer-used))
 300                  :package package)
 301         (drop-them ()
 302           :report "Stop using them."
 303           (unuse-package no-longer-used package))
 304         (keep-them ()
 305           :report "Keep using them."))))
 306   (let (old-exports)
 307     (do-external-symbols (s package)
 308       (push s old-exports))
 309     (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
 310      (when no-longer-exported
 311        (restart-case
 312            (error 'sb!kernel::package-at-variance-error
 313                   :format-control "~A also exports the following symbols:~%  ~S"
 314                   :format-arguments (list name no-longer-exported)
 315                   :package package)
 316          (drop-them ()
 317            :report "Unexport them."
 318            (unexport no-longer-exported package))
 319          (keep-them ()
 320            :report "Keep exporting them.")))))
 321   (let ((old-implements
 322           (set-difference (package-implements-list package)
 323                           (mapcar #'find-undeleted-package-or-lose implement))))
 324     (when old-implements
 325       (restart-case
 326           (error 'sb!kernel::package-at-variance-error
 327                  :format-control "~A is also an implementation package for:~% ~{~S~^~%  ~}"
 328                  :format-arguments (list name old-implements)
 329                  :package package)
 330         (drop-them ()
 331           :report "Stop being an implementation package for them."
 332           (dolist (p old-implements)
 333             (remove-implementation-package package p)))
 334         (keep-them ()
 335           :report "Keep exporting them."))))
 336   (update-package package nicknames source-location
 337                   shadows shadowing-imports
 338                   use imports interns exports
 339                   implement local-nicknames
 340                   lock doc-string))
 341
 342 (defun %defpackage (name nicknames size shadows shadowing-imports
 343                     use imports interns exports implement local-nicknames
 344                     lock doc-string
 345                     source-location)
 346   (declare (type simple-string name)
 347            (type list nicknames shadows shadowing-imports
 348                  imports interns exports)
 349            (type (or list (member :default)) use)
 350            (type (or simple-string null) doc-string)
 351            #!-sb-package-locks
 352            (ignore implement lock))
 353   (with-package-graph ()
 354     (let* ((existing-package (find-package name))
 355            (use (use-list-packages existing-package use))
 356            (shadowing-imports (import-list-symbols shadowing-imports))
 357            (imports (import-list-symbols imports)))
 358       (if existing-package
 359           (update-package-with-variance existing-package name
 360                                         nicknames source-location
 361                                         shadows shadowing-imports
 362                                         use imports interns exports
 363                                         implement local-nicknames
 364                                         lock doc-string)
 365           (let ((package (make-package name
 366                                        :use nil
 367                                        :internal-symbols (or size 10)
 368                                        :external-symbols (length exports))))
 369             (update-package package
 370                             nicknames
 371                             source-location
 372                             shadows shadowing-imports
 373                             use imports interns exports
 374                             implement local-nicknames
 375                             lock doc-string))))))
 376
 377 (defun find-or-make-symbol (name package)
 378   (multiple-value-bind (symbol how) (find-symbol name package)
 379     (cond (how
 380            symbol)
 381           (t
 382            (with-simple-restart (continue "INTERN it.")
 383              (error 'simple-package-error
 384                     :package package
 385                     :format-control "no symbol named ~S in ~S"
 386                     :format-arguments (list name (package-name package))))
 387            (intern name package)))))