From 07251643bfad4517cfb022b9bc02489b8bfd6d64 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 4 Dec 1990 12:31:26 +0000
Subject: [PATCH] Added Blaine's with-package-iterator.

---
 code/package.lisp | 135 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 133 insertions(+), 2 deletions(-)

diff --git a/code/package.lisp b/code/package.lisp
index 2d9b5a248..25aa789df 100644
--- a/code/package.lisp
+++ b/code/package.lisp
@@ -18,10 +18,9 @@
 	  package-use-list package-used-by-list package-shadowing-symbols
 	  list-all-packages intern find-symbol unintern export
 	  unexport import shadowing-import shadow use-package
-	  unuse-package find-all-symbols do-symbols
+	  unuse-package find-all-symbols do-symbols with-package-iterator
 	  do-external-symbols do-all-symbols apropos apropos-list))
 
-
 (in-package "EXTENSIONS")
 (export '(*keyword-package* *lisp-package*))
 (in-package 'lisp)
@@ -421,6 +420,138 @@
       ,TAG
        ,@external-code)))
 
+;;;; WITH-PACKAGE-ITERATOR
+
+(defmacro with-package-iterator ((mname package-list &rest symbol-types)
+				 &body body)
+  (let* ((packages (gensym))
+	 (these-packages (gensym))
+	 (ordered-types (let ((res nil))
+			  (dolist (kind '(:inherited :external :internal)
+					res)
+			    (when (member kind symbol-types)
+			      (push kind res)))))  ; Order symbol-types.
+	 (counter (gensym))
+	 (kind (gensym))
+	 (hash-vector (gensym))
+	 (vector (gensym))
+	 (package-use-list (gensym))
+	 (init-macro (gensym))
+	 (end-test-macro (gensym))
+	 (real-symbol-p (gensym))
+	 (BLOCK (gensym)))
+    `(let* ((,these-packages ,package-list)
+	    (,packages `,(mapcar #'(lambda (package)
+				     (if (packagep package)
+					 package
+					 (find-package package)))
+				 (if (consp ,these-packages)
+				     ,these-packages
+				     (list ,these-packages))))
+	    (,counter nil)
+	    (,kind (car ,packages))
+	    (,hash-vector nil)
+	    (,vector nil)
+	    (,package-use-list nil))
+       ,(if (member :inherited ordered-types)
+	    `(setf ,package-use-list (package-use-list (car ,packages)))
+	    `(declare (ignore ,package-use-list)))
+       (macrolet ((,init-macro (next-kind)
+ 	 (let ((symbols (gensym)))
+	   `(progn
+	      (setf ,',kind ,next-kind)
+	      (setf ,',counter nil)
+	      ,(case next-kind
+		 (:internal
+		  `(let ((,symbols (package-internal-symbols
+				    (car ,',packages))))
+		     (setf ,',vector (package-hashtable-table ,symbols))
+		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))
+		 (:external
+		  `(let ((,symbols (package-external-symbols
+				    (car ,',packages))))
+		     (setf ,',vector (package-hashtable-table ,symbols))
+		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))
+		 (:inherited
+		  `(let ((,symbols (package-external-symbols
+				    (car ,',package-use-list))))
+		     (setf ,',vector (package-hashtable-table ,symbols))
+		     (setf ,',hash-vector (package-hashtable-hash ,symbols))))))))
+		  (,end-test-macro (this-kind)
+		     `,(let ((next-kind (cadr (member this-kind
+						      ',ordered-types))))
+			 (if next-kind
+			     `(,',init-macro ,next-kind)
+			     `(if (endp (setf ,',packages (cdr ,',packages)))
+				  (return-from ,',BLOCK)
+				  (,',init-macro ,(car ',ordered-types)))))))
+	 (when ,packages
+	   ,(when (null symbol-types)
+	      (error "Must supply at least one of :internal, :external, or ~
+	      :inherited."))
+	   ,(dolist (symbol symbol-types)
+	      (unless (member symbol '(:internal :external :inherited))
+		(error "~S is not one of :internal, :external, or :inherited."
+		       symbol)))
+	   (,init-macro ,(car ordered-types))
+	   (flet ((,real-symbol-p (number)
+		    (> number 1)))
+	     (macrolet ((,mname ()
+	      `(block ,',BLOCK
+		 (loop
+		   (case ,',kind
+		     ,@(when (member :internal ',ordered-types)
+			 `((:internal
+			    (setf ,',counter
+				  (position-if #',',real-symbol-p ,',hash-vector
+					       :start (if ,',counter
+							  (1+ ,',counter)
+							  0)))
+			    (if ,',counter
+				(return-from ,',BLOCK
+				 (values t (svref ,',vector ,',counter)
+					 ,',kind (car ,',packages)))
+				(,',end-test-macro :internal)))))
+		     ,@(when (member :external ',ordered-types)
+			 `((:external
+			    (setf ,',counter
+				  (position-if #',',real-symbol-p ,',hash-vector
+					       :start (if ,',counter
+							  (1+ ,',counter)
+							  0)))
+			    (if ,',counter
+				(return-from ,',BLOCK
+				 (values t (svref ,',vector ,',counter)
+					 ,',kind (car ,',packages)))
+				(,',end-test-macro :external)))))
+		     ,@(when (member :inherited ',ordered-types)
+			 `((:inherited
+			    (setf ,',counter
+				  (position-if #',',real-symbol-p ,',hash-vector
+					       :start (if ,',counter
+							  (1+ ,',counter)
+							  0)))
+			    (cond (,',counter
+				   (return-from
+				    ,',BLOCK
+				    (values t (svref ,',vector ,',counter)
+					    ,',kind (car ,',packages))))
+				  (t
+				   (setf ,',package-use-list
+					 (cdr ,',package-use-list))
+				   (cond ((endp ,',package-use-list)
+					  (setf ,',packages (cdr ,',packages))
+					  (when (endp ,',packages)
+					    (return-from ,',BLOCK))
+					  (setf ,',package-use-list
+						(package-use-list
+						 (car ,',packages)))
+					  (,',init-macro ,(car ',ordered-types)))
+					 (t (,',init-macro :inherited)
+					    (setf ,',counter nil)))))))))))))
+	       ,@body)))))))
+
+
 ;;; Enter-New-Nicknames  --  Internal
 ;;;
 ;;;    Enter any new Nicknames for Package into *package-names*.
-- 
GitLab