From 3fdca5b3a2639b8ae7ce060007dbef78f7a07486 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Fri, 1 May 1998 10:37:12 +0000 Subject: [PATCH] Error handling in DEFPACKAGE is now in more conformance with ANSI spec. Some bitrot in previous error checking logic removed. DO-SYMBOLS fixed so that external symbols interned from other packages are operated on (needed STRING= :test in MEMBER). --- code/package.lisp | 43 ++++++++++++++++++++++++------------------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/code/package.lisp b/code/package.lisp index 1ffdd556c..0fa21f331 100644 --- a/code/package.lisp +++ b/code/package.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.42 1998/04/20 11:32:52 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.43 1998/05/01 10:37:12 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -403,7 +403,7 @@ (when (>= (aref hash-vec i) 2) (let ((sym (aref sym-vec i))) (declare (inline member)) - (unless (member sym ignore :test #'eq) + (unless (member sym ignore :test #'string=) (,flet-name sym)))))))) (iterate-over-hash-table (package-internal-symbols package) nil) (iterate-over-hash-table (package-external-symbols package) nil) @@ -627,8 +627,6 @@ (imports nil) (interns nil) (exports nil) - (incomming nil) - (outgoing nil) (doc nil)) (dolist (option options) (unless (consp option) @@ -653,12 +651,10 @@ :format-arguments (list (second option)))))) (:shadow (let ((new (stringify-names (cdr option) "symbol"))) - (setf incomming (append-unique new incomming :shadow)) (setf shadows (append shadows new)))) (:shadowing-import-from (let ((package-name (stringify-name (second option) "package")) (names (stringify-names (cddr option) "symbol"))) - (setf incomming (append-unique names incomming :shadowing-import)) (let ((assoc (assoc package-name shadowing-imports :test #'string=))) (if assoc @@ -672,7 +668,6 @@ (:import-from (let ((package-name (stringify-name (second option) "package")) (names (stringify-names (cddr option) "symbol"))) - (setf incomming (append-unique names incomming :import-from)) (let ((assoc (assoc package-name imports :test #'string=))) (if assoc @@ -680,12 +675,9 @@ (setf imports (acons package-name names imports)))))) (:intern (let ((new (stringify-names (cdr option) "symbol"))) - (setf incomming (append-unique new incomming :intern)) - (setf outgoing (append-unique new outgoing :intern)) (setf interns (append interns new)))) (:export (let ((new (stringify-names (cdr option) "symbol"))) - (setf outgoing (append-unique new outgoing :export)) (setf exports (append exports new)))) (:documentation (when doc @@ -696,16 +688,37 @@ (error 'program-error :format-control "Bogus DEFPACKAGE option: ~S" :format-arguments (list option))))) + (check-disjoint `(:intern ,@interns) `(:export ,@exports)) + (check-disjoint `(:intern ,@interns) + `(:import-from + ,@(apply #'append (mapcar #'rest imports))) + `(:shadow ,@shadows) + `(:shadowing-import-from + ,@(apply #'append (mapcar #'rest shadowing-imports)))) `(eval-when (compile load eval) (%defpackage ,(stringify-name package "package") ',nicknames ',size ',shadows ',shadowing-imports ',(if use-p use :default) ',imports ',interns ',exports ',doc)))) +(defun check-disjoint(&rest args) + ;; 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 'program-error + :format-control "Parameters ~S and ~S must be disjoint ~ + but have common elements ~% ~S" + :format-arguments (list (car x)(car y) z))))) + (defun stringify-name (name kind) (typecase name (simple-string name) (string (coerce name 'simple-string)) (symbol (symbol-name name)) + (base-char (string name)) (t (error "Bogus ~A name: ~S" kind name)))) @@ -714,14 +727,6 @@ (stringify-name name kind)) names)) -(defun append-unique (new old list) - (dolist (name new) - (if (member name old) - (cerror "Ignore it." - "Duplicate name in the ~S list: ~A" list name) - (push name old))) - old) - (defun %defpackage (name nicknames size shadows shadowing-imports use imports interns exports doc-string) (declare (type simple-base-string name) @@ -797,7 +802,7 @@ (find-symbol name package) (cond (how symbol) - (t + (t ; @@@ This should be a correctable PACKAGE-ERROR (cerror "INTERN it." "~A does not contain a symbol ~A" (package-name package) -- GitLab