defpackage.lsp 10.7 KB
Newer Older
1 2 3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

4
;;;;
jjgarcia's avatar
jjgarcia committed
5
;;;
Daniel Kochmański's avatar
Daniel Kochmański committed
6 7 8 9 10 11
;;;                              THE BOEING COMPANY
;;;                           BOEING COMPUTER SERVICES
;;;                            RESEARCH AND TECHNOLOGY
;;;                               COMPUTER SCIENCE
;;;                           P.O. BOX 24346, MS 7L-64
;;;                            SEATTLE, WA 98124-0346
jjgarcia's avatar
jjgarcia committed
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
;;;
;;;
;;; Copyright (c) 1990, 1991 The Boeing Company, All Rights Reserved.
;;;
;;; Permission is granted to any individual or institution to use,
;;; copy, modify, and distribute this software, provided that this
;;; complete copyright and permission notice is maintained, intact, in
;;; all copies and supporting documentation and that modifications are
;;; appropriately documented with date, author and description of the
;;; change.
;;;
;;; Stephen L. Nicoud (snicoud@boeing.com) provides this software "as
;;; is" without express or implied warranty by him or The Boeing
;;; Company.
;;;
;;; This software is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY.  No author or distributor accepts
;;; responsibility to anyone for the consequences of using it or for
;;; whether it serves any particular purpose or works at all.
;;;
Daniel Kochmański's avatar
Daniel Kochmański committed
32
;;;     Author: Stephen L. Nicoud
jjgarcia's avatar
jjgarcia committed
33 34 35
;;;
;;; -----------------------------------------------------------------
;;;
36
;;;     Adapted for X3J13 by Stephen L Nicoud, 91/5/23
Daniel Kochmański's avatar
Daniel Kochmański committed
37
;;;     Adapted for ECL by Giuseppe Attardi, 6/6/1994.
38
;;;     Partially rewritten by Daniel Kochmański, 2017-05-01
39
;;;
jjgarcia's avatar
jjgarcia committed
40 41 42 43 44
;;; -----------------------------------------------------------------

(in-package "SYSTEM")

(defmacro DEFPACKAGE (name &rest options)
45
  (declare (type (or symbol string character) name))
Daniel Kochmański's avatar
Daniel Kochmański committed
46
  "DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}*                  [Macro]
jjgarcia's avatar
jjgarcia committed
47 48

   This creates a new package, or modifies an existing one, whose name is
49
   DEFINED-PACKAGE-NAME.  The DEFINED-PACKAGE-NAME may be a string or a
jjgarcia's avatar
jjgarcia committed
50
   symbol; if it is a symbol, only its print name matters, and not what
51
   package, if any, the symbol happens to be in.  The newly created or
jjgarcia's avatar
jjgarcia committed
52 53 54
   modified package is returned as the value of the DEFPACKAGE form.

   Each standard OPTION is a list of keyword (the name of the option)
55 56 57 58
   and associated arguments.  No part of a DEFPACKAGE form is
   evaluated.  Except for the :LOCK and :DOCUMENTATION options, more
   than one option of the same kind may occur within the same
   DEFPACKAGE form.
jjgarcia's avatar
jjgarcia committed
59 60

  Valid Options:
Daniel Kochmański's avatar
Daniel Kochmański committed
61
        (:documentation         string)
62
        (:lock                  boolean)
Daniel Kochmański's avatar
Daniel Kochmański committed
63 64 65 66
        (:nicknames             {package-name}*)
        (:shadow                {symbol-name}*)
        (:shadowing-import-from package-name {symbol-name}*)
        (:use                   {package-name}*)
67
        (:local-nicknames       (local-nickname actual-package-name)*)
Daniel Kochmański's avatar
Daniel Kochmański committed
68 69 70 71
        (:import-from           package-name {symbol-name}*)
        (:intern                {symbol-name}*)
        (:export                {symbol-name}*)
        (:export-from           {package-name}*)
jjgarcia's avatar
jjgarcia committed
72

73 74
  [Note: :EXPORT-FROM, :DOCUMENTATION, :LOCK and :LOCAL-NICKNAMES are
         extensions to DEFPACKAGE.
jjgarcia's avatar
jjgarcia committed
75

76 77 78 79
         If a symbol is interned in the package being created and if a
         symbol with the same print name appears as an external symbol
         of one of the packages in the :EXPORT-FROM option, then the
         symbol is exported from the package being created.]"
jjgarcia's avatar
jjgarcia committed
80

81
  (flet ((designators (values)
82
           (mapcar #'string values)))
83
    (let ((nicknames nil)
84 85 86 87 88 89 90 91 92 93 94 95
          (documentation nil)
          (size nil)
          (shadowed-symbol-names nil)
          (interned-symbol-names nil)
          (exported-symbol-names nil)
          (shadowing-imported-from-symbol-names-list nil)
          (imported-from-symbol-names-list nil)
          (exported-from-package-names nil)
          (use nil)
          (use-p nil)
          (lock nil)
          (local-nicknames nil))
96
      (dolist (option options)
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
        (case (car option)
          (:nicknames
           (setf nicknames (append nicknames (designators (rest option)))))
          (:documentation
           (when documentation
             (si:simple-program-error
              "DEFPACKAGE option :DOCUMENTATION specified more than once."))
           (setf documentation (second option)))
          (:use
           (setf use (append use (designators (rest option)))
                 use-p t))
          (:shadow
           (setf shadowed-symbol-names
                 (append shadowed-symbol-names (designators (rest option)))))
          (:intern
           (setf interned-symbol-names
                 (append interned-symbol-names (designators (rest option)))))
          (:export
           (setf exported-symbol-names
                 (append exported-symbol-names (designators (rest option)))))
          (:shadowing-import-from
           (destructuring-bind (package-name . names)
               (designators (rest option))
             (let ((assoc (assoc package-name shadowing-imported-from-symbol-names-list
                                 :test #'string=)))
               (if assoc
                   (setf (cdr assoc) (append (cdr assoc) names))
                   (setf shadowing-imported-from-symbol-names-list
                         (acons package-name names shadowing-imported-from-symbol-names-list))))))
          (:import-from
           (destructuring-bind (package-name . names)
               (designators (rest option))
             (let ((assoc (assoc package-name imported-from-symbol-names-list
                                 :test #'string=)))
               (if assoc
                   (setf (cdr assoc) (append (cdr assoc) names))
                   (setf imported-from-symbol-names-list
                         (acons package-name names imported-from-symbol-names-list))))))
          (:size
           ;; Size is ignored for all we care, but standard mandates signalling
           ;; error if size is passed twice in DEFPACKAGE.
           (when size
             (si:simple-program-error
              "DEFPACKAGE option :SIZE specified more than once."))
           (setf size (second option)))
          ;; extensions
          (:export-from
           (setf exported-from-package-names
                 (append exported-from-package-names (designators (rest option)))))
          (:lock
           (when lock
             (si:simple-program-error
              "DEFPACKAGE option :LOCK specified more than once.")
             (setf lock (second option))))
          (:local-nicknames
           (setf local-nicknames
                 (append local-nicknames
                         (mapcar (lambda (spec)
                                   (destructuring-bind (nick name) spec
                                     (cons nick name)))
                                 (rest option)))))
          ;; unknown
          (otherwise
           (cerror "Proceed, ignoring this option."
                   "~s is not a valid DEFPACKAGE option." option))))
162
      (check-disjoint `(:intern ,@interned-symbol-names)
163
                      `(:export ,@exported-symbol-names))
164
      (check-disjoint `(:intern ,@interned-symbol-names)
165 166 167 168 169
                      `(:import-from
                        ,@(apply #'append (mapcar #'rest imported-from-symbol-names-list)))
                      `(:shadow ,@shadowed-symbol-names)
                      `(:shadowing-import-from
                        ,@(apply #'append (mapcar #'rest shadowing-imported-from-symbol-names-list))))
jjgarcia's avatar
jjgarcia committed
170
      `(eval-when (eval compile load)
171 172 173 174 175 176 177 178 179 180 181 182 183
         (si::dodefpackage
          ,(string name)
          ',nicknames
          ,documentation
          ,(cadr (assoc ':lock options))
          ',(if use-p use "CL")
          ',local-nicknames
          ',shadowed-symbol-names
          ',interned-symbol-names
          ',exported-symbol-names
          ',shadowing-imported-from-symbol-names-list
          ',imported-from-symbol-names-list
          ',exported-from-package-names)))))
jjgarcia's avatar
jjgarcia committed
184

185
(defun check-disjoint (&rest args)
186
  (declare (si::c-local))
187 188 189 190 191 192 193 194 195 196 197
  ;; An arg is (:key . set)
  (do ((list args (cdr list)))
      ((endp list))
    (loop
      with x = (car list)
      for y in (rest list)
      for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
      when z do (error 'simple-program-error
                       :format-control "Parameters ~S and ~S must be disjoint ~
                                        but have common elements ~%   ~S"
                       :format-arguments (list (car x)(car y) z)))))
jjgarcia's avatar
jjgarcia committed
198

199 200 201 202 203 204
(defun dodefpackage
    (name
     nicknames
     documentation
     lock
     use
205
     local-nicknames
206 207 208 209 210 211
     shadowed-symbol-names
     interned-symbol-names
     exported-symbol-names
     shadowing-imported-from-symbol-names-list
     imported-from-symbol-names-list
     exported-from-package-names)
jjgarcia's avatar
jjgarcia committed
212
  (if (find-package name)
213 214 215 216 217
      (progn ; (rename-package name name)
        (when nicknames
          (rename-package name name nicknames))
        (when use
          (unuse-package (package-use-list (find-package name)) name)))
218
      (make-package name :use nil :nicknames nicknames :local-nicknames local-nicknames))
jjgarcia's avatar
jjgarcia committed
219
  (let ((*package* (find-package name)))
220 221
    (when documentation
      (setf (documentation *package* t) documentation))
222 223 224
    (shadow shadowed-symbol-names)
    (dolist (item shadowing-imported-from-symbol-names-list)
      (let ((package (find-package (first item))))
Daniel Kochmański's avatar
Daniel Kochmański committed
225 226
        (dolist (name (rest item))
          (shadowing-import (find-or-make-symbol name package)))))
227 228 229
    (use-package use)
    (dolist (item imported-from-symbol-names-list)
      (let ((package (find-package (first item))))
Daniel Kochmański's avatar
Daniel Kochmański committed
230 231 232 233
        (dolist (name (rest item))
          ;; IMPORT can accept a list as argument, hence if we want to
          ;; import symbol NIL, we have to enclose it in a list.
          (import (or (find-or-make-symbol name package) (list NIL))))))
234 235 236 237
    (mapc #'intern interned-symbol-names)
    (export (mapcar #'intern exported-symbol-names))
    (dolist (package exported-from-package-names)
      (do-external-symbols (symbol (find-package package))
Daniel Kochmański's avatar
Daniel Kochmański committed
238 239 240
        (when (nth 1 (multiple-value-list
                      (find-symbol (string symbol))))
          (export (list (intern (string symbol))))))))
241
  (when lock (lock-package name))
jjgarcia's avatar
jjgarcia committed
242 243
  (find-package name))

244 245 246 247 248
(defun find-or-make-symbol (name package)
  (declare (si::c-local))
  (multiple-value-bind (symbol found)
      (find-symbol name package)
    (unless found
249
      (signal-simple-error 'package-error "INTERN it."
Daniel Kochmański's avatar
Daniel Kochmański committed
250 251 252
                           "Cannot find symbol ~S in package ~S"
                           (list name package)
                           :package package)
253 254 255
      (setq symbol (intern name package)))
    symbol))

jjgarcia's avatar
jjgarcia committed
256
;;;; ------------------------------------------------------------
Daniel Kochmański's avatar
Daniel Kochmański committed
257
;;;;    End of File
jjgarcia's avatar
jjgarcia committed
258
;;;; ------------------------------------------------------------