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