1;;; defpackage.lisp 2;;; 3;;; Copyright (C) 2003-2007 Peter Graves 4;;; $Id$ 5;;; 6;;; This program is free software; you can redistribute it and/or 7;;; modify it under the terms of the GNU General Public License 8;;; as published by the Free Software Foundation; either version 2 9;;; of the License, or (at your option) any later version. 10;;; 11;;; This program is distributed in the hope that it will be useful, 12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;; GNU General Public License for more details. 15;;; 16;;; You should have received a copy of the GNU General Public License 17;;; along with this program; if not, write to the Free Software 18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 19;;; 20;;; As a special exception, the copyright holders of this library give you 21;;; permission to link this library with independent modules to produce an 22;;; executable, regardless of the license terms of these independent 23;;; modules, and to copy and distribute the resulting executable under 24;;; terms of your choice, provided that you also meet, for each linked 25;;; independent module, the terms and conditions of the license of that 26;;; module. An independent module is a module which is not derived from 27;;; or based on this library. If you modify this library, you may extend 28;;; this exception to your version of the library, but you are not 29;;; obligated to do so. If you do not wish to do so, delete this 30;;; exception statement from your version. 31 32(in-package "SYSTEM") 33 34;;; Adapted from CMUCL. 35 36(defun designated-package-name (designator) 37 (cond ((packagep designator) 38 (package-name designator)) 39 (t 40 (string designator)))) 41 42(defun stringify-names (names) 43 (mapcar #'string names)) 44 45(defun check-disjoint (&rest args) 46 (let ((rest-args args)) 47 (dolist (arg1 args) 48 (let ((key1 (car arg1)) 49 (set1 (cdr arg1))) 50 (setq rest-args (cdr rest-args)) 51 (dolist (arg2 rest-args) 52 (let* ((key2 (car arg2)) 53 (set2 (cdr arg2)) 54 (common (remove-duplicates (intersection set1 set2 :test #'string=)))) 55 (when common 56 (error 'program-error 57 :format-control 58 "Parameters ~S and ~S must be disjoint, but have common elements: ~S" 59 :format-arguments 60 (list key1 key2 common))))))))) 61 62(defun ensure-available-symbols (symbols) 63 symbols) 64 65(defmacro defpackage (package &rest options) 66 (let ((nicknames nil) 67 (size nil) 68 (shadows nil) 69 (shadowing-imports nil) 70 (use nil) 71 (use-p nil) 72 (imports nil) 73 (interns nil) 74 (exports nil) 75 (local-nicknames nil) 76 (doc nil)) 77 (dolist (option options) 78 (unless (consp option) 79 (error 'program-error "bad DEFPACKAGE option: ~S" option)) 80 (case (car option) 81 (:nicknames 82 (setq nicknames (stringify-names (cdr option)))) 83 (:size 84 (cond (size 85 (error 'program-error "can't specify :SIZE twice")) 86 ((and (consp (cdr option)) 87 (typep (second option) 'unsigned-byte)) 88 (setq size (second option))) 89 (t 90 (error 'program-error 91 "bad :SIZE, must be a positive integer: ~S" 92 (second option))))) 93 (:shadow 94 (let ((new (stringify-names (cdr option)))) 95 (setq shadows (append shadows new)))) 96 (:shadowing-import-from 97 (let ((package-name (designated-package-name (cadr option))) 98 (symbol-names (stringify-names (cddr option)))) 99 (let ((assoc (assoc package-name shadowing-imports 100 :test #'string=))) 101 (if assoc 102 (setf (cdr assoc) (append (cdr assoc) symbol-names)) 103 (setq shadowing-imports 104 (acons package-name symbol-names shadowing-imports)))))) 105 (:use 106 (let ((new (mapcar #'designated-package-name (cdr option)))) 107 (setq use (delete-duplicates (nconc use new) :test #'string=)) 108 (setq use-p t))) 109 (:import-from 110 (let ((package-name (designated-package-name (cadr option))) 111 (symbol-names (stringify-names (cddr option)))) 112 (let ((assoc (assoc package-name imports 113 :test #'string=))) 114 (if assoc 115 (setf (cdr assoc) (append (cdr assoc) symbol-names)) 116 (setq imports (acons package-name symbol-names imports)))))) 117 (:intern 118 (let ((new (stringify-names (cdr option)))) 119 (setq interns (append interns new)))) 120 (:export 121 (let ((new (stringify-names (cdr option)))) 122 (setq exports (append exports new)))) 123 (:documentation 124 (when doc 125 (error 'program-error "can't specify :DOCUMENTATION twice")) 126 (setq doc (coerce (cadr option) 'simple-string))) 127 (:local-nicknames 128 (dolist (nickdecl (cdr option)) 129 (unless (= (length nickdecl) 2) 130 (error 'program-error "Malformed local nickname declaration ~A" 131 nickdecl)) 132 (let ((local-nickname (string (first nickdecl))) 133 (package-name (designated-package-name (second nickdecl)))) 134 (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD") 135 :test #'string=) 136 (cerror "Continue anyway" 137 (format nil "Trying to define a local nickname for package ~A" 138 local-nickname))) 139 (when (member local-nickname (list* package nicknames) 140 :test #'string=) 141 (cerror "Continue anyway" 142 "Trying to override the name or a nickname (~A) ~ 143 with a local nickname for another package ~A" 144 local-nickname package-name)) 145 (push (list local-nickname package-name) local-nicknames)))) 146 (t 147 (error 'program-error "bad DEFPACKAGE option: ~S" option)))) 148 (check-disjoint `(:intern ,@interns) `(:export ,@exports)) 149 (check-disjoint `(:intern ,@interns) 150 `(:import-from 151 ,@(apply #'append (mapcar #'rest imports))) 152 `(:shadow ,@shadows) 153 `(:shadowing-import-from 154 ,@(apply #'append (mapcar #'rest shadowing-imports)))) 155 `(prog1 156 (%defpackage ,(string package) ',nicknames ',size 157 ',shadows (ensure-available-symbols ',shadowing-imports) 158 ',(if use-p use nil) 159 (ensure-available-symbols ',imports) ',interns ',exports 160 ',local-nicknames ',doc) 161 ,(when (and (symbolp package) (not (keywordp package))) 162 `(record-source-information-for-type ',package :package)) 163 (record-source-information-for-type ,(intern (string package) :keyword) :package) 164 ))) 165