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 (defmacro defpackage (package &rest options)
  15   #!+sb-doc
  16   "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
  17    following:
  18      (:NICKNAMES {package-name}*)
  19      (:SIZE <integer>)
  20      (:SHADOW {symbol-name}*)
  21      (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
  22      (:USE {package-name}*)
  23      (:IMPORT-FROM <package-name> {symbol-name}*)
  24      (:INTERN {symbol-name}*)
  25      (:EXPORT {symbol-name}*)
  26      (:DOCUMENTATION doc-string)
  27    All options except :SIZE and :DOCUMENTATION can be used multiple times."
  28   (let ((nicknames nil)
  29         (size nil)
  30         (shadows nil)
  31         (shadowing-imports nil)
  32         (use nil)
  33         (use-p nil)
  34         (imports nil)
  35         (interns nil)
  36         (exports nil)
  37         (doc nil))
  38     (dolist (option options)
  39       (unless (consp option)
  40         (error 'simple-program-error
  41                :format-control "bogus DEFPACKAGE option: ~S"
  42                :format-arguments (list option)))
  43       (case (car option)
  44         (:nicknames
  45          (setf nicknames (stringify-names (cdr option) "package")))
  46         (:size
  47          (cond (size
  48                 (error 'simple-program-error
  49                        :format-control "can't specify :SIZE twice."))
  50                ((and (consp (cdr option))
  51                      (typep (second option) 'unsigned-byte))
  52                 (setf size (second option)))
  53                (t
  54                 (error
  55                  'simple-program-error
  56                  :format-control ":SIZE is not a positive integer: ~S"
  57                  :format-arguments (list (second option))))))
  58         (:shadow
  59          (let ((new (stringify-names (cdr option) "symbol")))
  60            (setf shadows (append shadows new))))
  61         (:shadowing-import-from
  62          (let ((package-name (stringify-name (second option) "package"))
  63                (names (stringify-names (cddr option) "symbol")))
  64            (let ((assoc (assoc package-name shadowing-imports
  65                                :test #'string=)))
  66              (if assoc
  67                  (setf (cdr assoc) (append (cdr assoc) names))
  68                  (setf shadowing-imports
  69                        (acons package-name names shadowing-imports))))))
  70         (:use
  71          (setf use (append use (stringify-names (cdr option) "package") )
  72                use-p t))
  73         (:import-from
  74          (let ((package-name (stringify-name (second option) "package"))
  75                (names (stringify-names (cddr option) "symbol")))
  76            (let ((assoc (assoc package-name imports
  77                                :test #'string=)))
  78              (if assoc
  79                  (setf (cdr assoc) (append (cdr assoc) names))
  80                  (setf imports (acons package-name names imports))))))
  81         (:intern
  82          (let ((new (stringify-names (cdr option) "symbol")))
  83            (setf interns (append interns new))))
  84         (:export
  85          (let ((new (stringify-names (cdr option) "symbol")))
  86            (setf exports (append exports new))))
  87         (:documentation
  88          (when doc
  89            (error 'simple-program-error
  90                   :format-control "multiple :DOCUMENTATION options"))
  91          (setf doc (coerce (second option) 'simple-string)))
  92         (t
  93          (error 'simple-program-error
  94                 :format-control "bogus DEFPACKAGE option: ~S"
  95                 :format-arguments (list option)))))
  96     (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
  97     (check-disjoint `(:intern ,@interns)
  98                     `(:import-from
  99                       ,@(apply #'append (mapcar #'rest imports)))
 100                     `(:shadow ,@shadows)
 101                     `(:shadowing-import-from
 102                       ,@(apply #'append (mapcar #'rest shadowing-imports))))
 103     `(eval-when (:compile-toplevel :load-toplevel :execute)
 104        (%defpackage ,(stringify-name package "package") ',nicknames ',size
 105                     ',shadows ',shadowing-imports ',(if use-p use :default)
 106                     ',imports ',interns ',exports ',doc))))
 107
 108 (defun check-disjoint (&rest args)
 109   ;; An arg is (:key . set)
 110   (do ((list args (cdr list)))
 111       ((endp list))
 112     (loop
 113       with x = (car list)
 114       for y in (rest list)
 115       for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
 116       when z do (error 'simple-program-error
 117                        :format-control "Parameters ~S and ~S must be disjoint ~
 118                                         but have common elements ~%   ~S"
 119                        :format-arguments (list (car x)(car y) z)))))
 120
 121 (defun stringify-name (name kind)
 122   (typecase name
 123     (simple-string name)
 124     (string (coerce name 'simple-string))
 125     (symbol (symbol-name name))
 126     (base-char (string name))
 127     (t
 128      (error "bogus ~A name: ~S" kind name))))
 129
 130 (defun stringify-names (names kind)
 131   (mapcar (lambda (name)
 132             (stringify-name name kind))
 133           names))
 134
 135 (defun %defpackage (name nicknames size shadows shadowing-imports
 136                          use imports interns exports doc-string)
 137   (declare (type simple-base-string name)
 138            (type list nicknames shadows shadowing-imports
 139                  imports interns exports)
 140            (type (or list (member :default)) use)
 141            (type (or simple-base-string null) doc-string))
 142   (let ((package (or (find-package name)
 143                      (progn
 144                        (when (eq use :default)
 145                          (setf use *default-package-use-list*))
 146                        (make-package name
 147                                      :use nil
 148                                      :internal-symbols (or size 10)
 149                                      :external-symbols (length exports))))))
 150     (unless (string= (the string (package-name package)) name)
 151       (error 'simple-package-error
 152              :package name
 153              :format-control "~A is a nickname for the package ~A"
 154              :format-arguments (list name (package-name name))))
 155     (enter-new-nicknames package nicknames)
 156     ;; Handle shadows and shadowing-imports.
 157     (let ((old-shadows (package-%shadowing-symbols package)))
 158       (shadow shadows package)
 159       (dolist (sym-name shadows)
 160         (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
 161       (dolist (simports-from shadowing-imports)
 162         (let ((other-package (find-undeleted-package-or-lose
 163                               (car simports-from))))
 164           (dolist (sym-name (cdr simports-from))
 165             (let ((sym (find-or-make-symbol sym-name other-package)))
 166               (shadowing-import sym package)
 167               (setf old-shadows (remove sym old-shadows))))))
 168       (when old-shadows
 169         (warn "~A also shadows the following symbols:~%  ~S"
 170               name old-shadows)))
 171     ;; Handle USE.
 172     (unless (eq use :default)
 173       (let ((old-use-list (package-use-list package))
 174             (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
 175         (use-package (set-difference new-use-list old-use-list) package)
 176         (let ((laterize (set-difference old-use-list new-use-list)))
 177           (when laterize
 178             (unuse-package laterize package)
 179             (warn "~A used to use the following packages:~%  ~S"
 180                   name
 181                   laterize)))))
 182     ;; Handle IMPORT and INTERN.
 183     (dolist (sym-name interns)
 184       (intern sym-name package))
 185     (dolist (imports-from imports)
 186       (let ((other-package (find-undeleted-package-or-lose (car
 187                                                             imports-from))))
 188         (dolist (sym-name (cdr imports-from))
 189           (import (list (find-or-make-symbol sym-name other-package))
 190                   package))))
 191     ;; Handle exports.
 192     (let ((old-exports nil)
 193           (exports (mapcar (lambda (sym-name) (intern sym-name package))
 194                            exports)))
 195       (do-external-symbols (sym package)
 196         (push sym old-exports))
 197       (export exports package)
 198       (let ((diff (set-difference old-exports exports)))
 199         (when diff
 200           (warn "~A also exports the following symbols:~%  ~S" name diff))))
 201     ;; Handle documentation.
 202     (setf (package-doc-string package) doc-string)
 203     package))
 204
 205 (defun find-or-make-symbol (name package)
 206   (multiple-value-bind (symbol how) (find-symbol name package)
 207     (cond (how
 208            symbol)
 209           (t
 210            (with-simple-restart (continue "INTERN it.")
 211              (error 'simple-package-error
 212                     :package package
 213                     :format-control "no symbol named ~S in ~S"
 214                     :format-arguments (list name (package-name package))))
 215            (intern name package)))))