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