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