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