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   '((:nicknames "{package-name}*")
  38     (:size "<integer>")
  39     (:shadow "{symbol-name}*")
  40     (:shadowing-import-from "<package-name> {symbol-name}*")
  41     (:use "{package-name}*")
  42     (:import-from "<package-name> {symbol-name}*")
  43     (:intern "{symbol-name}*")
  44     (:export "{symbol-name}*")
  45     #!+sb-package-locks (:implement "{package-name}*")
  46     #!+sb-package-locks (:lock "boolean")
  47     (:documentation "doc-string"))
  48   '(:size #!+sb-package-locks :lock))
  49   (let ((nicknames nil)
  50         (size nil)
  51         (shadows nil)
  52         (shadowing-imports nil)
  53         (use nil)
  54         (use-p nil)
  55         (imports nil)
  56         (interns nil)
  57         (exports nil)
  58         (implement (stringify-package-designators (list package)))
  59         (implement-p nil)
  60         (lock nil)
  61         (doc nil))
  62     #!-sb-package-locks
  63     (declare (ignore implement-p))
  64     (dolist (option options)
  65       (unless (consp option)
  66         (error 'simple-program-error
  67                :format-control "bogus DEFPACKAGE option: ~S"
  68                :format-arguments (list option)))
  69       (case (car option)
  70         (:nicknames
  71          (setf nicknames (stringify-package-designators (cdr option))))
  72         (:size
  73          (cond (size
  74                 (error 'simple-program-error
  75                        :format-control "can't specify :SIZE twice."))
  76                ((and (consp (cdr option))
  77                      (typep (second option) 'unsigned-byte))
  78                 (setf size (second option)))
  79                (t
  80                 (error
  81                  'simple-program-error
  82                  :format-control ":SIZE is not a positive integer: ~S"
  83                  :format-arguments (list (second option))))))
  84         (:shadow
  85          (let ((new (stringify-string-designators (cdr option))))
  86            (setf shadows (append shadows new))))
  87         (:shadowing-import-from
  88          (let ((package-name (stringify-package-designator (second option)))
  89                (names (stringify-string-designators (cddr option))))
  90            (let ((assoc (assoc package-name shadowing-imports
  91                                :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 (cdr option)) )
  98                use-p t))
  99         (:import-from
 100          (let ((package-name (stringify-package-designator (second option)))
 101                (names (stringify-string-designators (cddr option))))
 102            (let ((assoc (assoc package-name imports
 103                                :test #'string=)))
 104              (if assoc
 105                  (setf (cdr assoc) (append (cdr assoc) names))
 106                  (setf imports (acons package-name names imports))))))
 107         (:intern
 108          (let ((new (stringify-string-designators (cdr option))))
 109            (setf interns (append interns new))))
 110         (:export
 111          (let ((new (stringify-string-designators (cdr option))))
 112            (setf exports (append exports new))))
 113         #!+sb-package-locks
 114         (:implement
 115          (unless implement-p
 116            (setf implement nil))
 117          (let ((new (stringify-package-designators (cdr option))))
 118            (setf implement (append implement new)
 119                  implement-p t)))
 120         #!+sb-package-locks
 121         (:lock
 122          (when lock
 123            (error 'simple-program-error
 124                   :format-control "multiple :LOCK options"))
 125          (setf lock (coerce (second option) 'boolean)))
 126         (:documentation
 127          (when doc
 128            (error 'simple-program-error
 129                   :format-control "multiple :DOCUMENTATION options"))
 130          (setf doc (coerce (second option) 'simple-string)))
 131         (t
 132          (error 'simple-program-error
 133                 :format-control "bogus DEFPACKAGE option: ~S"
 134                 :format-arguments (list option)))))
 135     (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
 136     (check-disjoint `(:intern ,@interns)
 137                     `(:import-from
 138                       ,@(apply #'append (mapcar #'rest imports)))
 139                     `(:shadow ,@shadows)
 140                     `(:shadowing-import-from
 141                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
 142     `(eval-when (:compile-toplevel :load-toplevel :execute)
 143        (%defpackage ,(stringify-string-designator package) ',nicknames ',size
 144                     ',shadows ',shadowing-imports ',(if use-p use :default)
 145                     ',imports ',interns ',exports ',implement ',lock ',doc
 146                     (sb!c:source-location)))))
 147
 148 (defun check-disjoint (&rest args)
 149   ;; An arg is (:key . set)
 150   (do ((list args (cdr list)))
 151       ((endp list))
 152     (loop
 153       with x = (car list)
 154       for y in (rest list)
 155       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
 156       when z do (error 'simple-program-error
 157                        :format-control "Parameters ~S and ~S must be disjoint ~
 158                                         but have common elements ~%   ~S"
 159                        :format-arguments (list (car x)(car y) z)))))
 160
 161 (defun stringify-string-designator (string-designator)
 162   (typecase string-designator
 163     (simple-string string-designator)
 164     (string (coerce string-designator 'simple-string))
 165     (symbol (symbol-name string-designator))
 166     (character (string string-designator))
 167     (t
 168      (error "~S does not designate a string" string-designator))))
 169
 170 (defun stringify-string-designators (string-designators)
 171   (mapcar #'stringify-string-designator string-designators))
 172
 173 (defun stringify-package-designator (package-designator)
 174   (typecase package-designator
 175     (simple-string package-designator)
 176     (string (coerce package-designator 'simple-string))
 177     (symbol (symbol-name package-designator))
 178     (character (string package-designator))
 179     (package (package-name package-designator))
 180     (t
 181      (error "~S does not designate a package" package-designator))))
 182
 183 (defun stringify-package-designators (package-designators)
 184   (mapcar #'stringify-package-designator package-designators))
 185
 186 (defun import-list-symbols (import-list)
 187   (let ((symbols nil))
 188     (dolist (import import-list symbols)
 189       (destructuring-bind (package-name &rest symbol-names)
 190           import
 191         (let ((package (find-undeleted-package-or-lose package-name)))
 192           (mapcar (lambda (name)
 193                     (push (find-or-make-symbol name package) symbols))
 194                   symbol-names))))))
 195
 196 (defun use-list-packages (package package-designators)
 197   (cond ((listp package-designators)
 198          (mapcar #'find-undeleted-package-or-lose package-designators))
 199         (package
 200          ;; :default for an existing package means preserve the
 201          ;; existing use list
 202          (package-use-list package))
 203         (t
 204          ;; :default for a new package is the *default-package-use-list*
 205          '#.*default-package-use-list*)))
 206
 207 (defun update-package (package nicknames source-location
 208                        shadows shadowing-imports
 209                        use
 210                        imports interns
 211                        exports
 212                        implement lock doc-string)
 213   (declare #!-sb-package-locks
 214            (ignore implement lock))
 215   (%enter-new-nicknames package nicknames)
 216   ;; 1. :shadow and :shadowing-import-from
 217   ;;
 218   ;; shadows is a list of strings, shadowing-imports is a list of symbols.
 219   (shadow shadows package)
 220   (shadowing-import shadowing-imports package)
 221   ;; 2. :use
 222   ;;
 223   ;; use is a list of package objects.
 224   (use-package use package)
 225   ;; 3. :import-from and :intern
 226   ;;
 227   ;; imports is a list of symbols. interns is a list of strings.
 228   (import imports package)
 229   (dolist (intern interns)
 230     (intern intern package))
 231   ;; 4. :export
 232   ;;
 233   ;; exports is a list of strings
 234   (export (mapcar (lambda (symbol-name) (intern symbol-name package))
 235                   exports)
 236           package)
 237   ;; Everything was created: update metadata
 238   (sb!c:with-source-location (source-location)
 239     (setf (package-source-location package) source-location))
 240   (setf (package-doc-string package) doc-string)
 241   #!+sb-package-locks
 242   (progn
 243     ;; Handle packages this is an implementation package of
 244     (dolist (p implement)
 245       (add-implementation-package package p))
 246     ;; Handle lock
 247     (setf (package-lock package) lock))
 248   package)
 249
 250 (defun update-package-with-variance (package name nicknames source-location
 251                                      shadows shadowing-imports
 252                                      use
 253                                      imports interns
 254                                      exports
 255                                      implement lock doc-string)
 256   (unless (string= (the string (package-name package)) name)
 257     (error 'simple-package-error
 258            :package name
 259            :format-control "~A is a nickname for the package ~A"
 260            :format-arguments (list name (package-name name))))
 261   (let ((no-longer-shadowed
 262           (set-difference (package-%shadowing-symbols package)
 263                           (append shadows shadowing-imports)
 264                           :test #'string=)))
 265     (when no-longer-shadowed
 266       (restart-case
 267           (let ((*package* (find-package :keyword)))
 268             (error 'sb!kernel::package-at-variance-error
 269                    :format-control "~A also shadows the following symbols:~%  ~S"
 270                    :format-arguments (list name no-longer-shadowed)
 271                    :package package))
 272         (drop-them ()
 273           :report "Stop shadowing them by uninterning them."
 274           (dolist (sym no-longer-shadowed)
 275             (unintern sym package)))
 276         (keep-them ()
 277           :report "Keep shadowing them."))))
 278   (let ((no-longer-used (set-difference (package-use-list package) use)))
 279     (when no-longer-used
 280       (restart-case
 281           (error 'sb!kernel::package-at-variance-error
 282                  :format-control "~A also uses the following packages:~%  ~A"
 283                  :format-arguments (list name (mapcar #'package-name no-longer-used))
 284                  :package package)
 285         (drop-them ()
 286           :report "Stop using them."
 287           (unuse-package no-longer-used package))
 288         (keep-them ()
 289           :report "Keep using them."))))
 290   (let (old-exports)
 291     (do-external-symbols (s package)
 292       (push s old-exports))
 293     (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
 294      (when no-longer-exported
 295        (restart-case
 296            (error 'sb!kernel::package-at-variance-error
 297                   :format-control "~A also exports the following symbols:~%  ~S"
 298                   :format-arguments (list name no-longer-exported)
 299                   :package package)
 300          (drop-them ()
 301            :report "Unexport them."
 302            (unexport no-longer-exported package))
 303          (keep-them ()
 304            :report "Keep exporting them.")))))
 305   (let ((old-implements
 306           (set-difference (package-implements-list package)
 307                           (mapcar #'find-undeleted-package-or-lose implement))))
 308     (when old-implements
 309       (restart-case
 310           (error 'sb!kernel::package-at-variance-error
 311                  :format-control "~A is also an implementation package for:~% ~{~S~^~%  ~}"
 312                  :format-arguments (list name old-implements)
 313                  :package package)
 314         (drop-them ()
 315           :report "Stop being an implementation package for them."
 316           (dolist (p old-implements)
 317             (remove-implementation-package package p)))
 318         (keep-them ()
 319           :report "Keep exporting them."))))
 320   (update-package package nicknames source-location
 321                   shadows shadowing-imports
 322                   use imports interns exports
 323                   implement lock doc-string))
 324
 325 (defun %defpackage (name nicknames size shadows shadowing-imports
 326                     use imports interns exports implement lock doc-string
 327                     source-location)
 328   (declare (type simple-string name)
 329            (type list nicknames shadows shadowing-imports
 330                  imports interns exports)
 331            (type (or list (member :default)) use)
 332            (type (or simple-string null) doc-string)
 333            #!-sb-package-locks
 334            (ignore implement lock))
 335   (with-package-graph ()
 336     (let* ((existing-package (find-package name))
 337            (use (use-list-packages existing-package use))
 338            (shadowing-imports (import-list-symbols shadowing-imports))
 339            (imports (import-list-symbols imports)))
 340       (if existing-package
 341           (update-package-with-variance existing-package name
 342                                         nicknames source-location
 343                                         shadows shadowing-imports
 344                                         use imports interns exports
 345                                         implement lock doc-string)
 346           (let ((package (make-package name
 347                                        :use nil
 348                                        :internal-symbols (or size 10)
 349                                        :external-symbols (length exports))))
 350             (update-package package
 351                             nicknames source-location
 352                             shadows shadowing-imports
 353                             use imports interns exports
 354                             implement lock doc-string))))))
 355
 356 (defun find-or-make-symbol (name package)
 357   (multiple-value-bind (symbol how) (find-symbol name package)
 358     (cond (how
 359            symbol)
 360           (t
 361            (with-simple-restart (continue "INTERN it.")
 362              (error 'simple-package-error
 363                     :package package
 364                     :format-control "no symbol named ~S in ~S"
 365                     :format-arguments (list name (package-name package))))
 366            (intern name package)))))