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