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