From f171838f3036e2c52d6bf2f51e85fd41425e1b99 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 30 Nov 1993 17:46:32 +0000
Subject: [PATCH] Picked up Miles' changes to apropos and apropos-list that
 allows one to supply NIL for the package, meaning all packages.

---
 code/package.lisp | 73 ++++++++++++++++++++++++++---------------------
 1 file changed, 40 insertions(+), 33 deletions(-)

diff --git a/code/package.lisp b/code/package.lisp
index 2ffe975e4..5eb4afccc 100644
--- a/code/package.lisp
+++ b/code/package.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.33 1993/08/15 16:41:26 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.34 1993/11/30 17:46:32 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -28,7 +28,8 @@
 	  do-external-symbols do-all-symbols apropos apropos-list defpackage))
 
 (in-package "EXTENSIONS")
-(export '(*keyword-package* *lisp-package* *default-package-use-list*))
+(export '(*keyword-package* *lisp-package* *default-package-use-list*
+			    map-apropos))
 
 (in-package "KERNEL")
 (export '(%in-package old-in-package))
@@ -1400,46 +1401,52 @@
 	      (return nil))))
 	(return t))))
 
+;;; MAP-APROPOS -- public (extension).
+;;;
+(defun map-apropos (fun string &optional package external-only)
+  "Call FUN with each symbol that contains STRING.
+  If PACKAGE is supplied then only use symbols present in
+  that package.  If EXTERNAL-ONLY is true then only use
+  symbols exported from the specified package."
+  (let ((string (string-upcase string)))
+    (declare (simple-string string))
+    (flet ((apropos-in-package (package)
+             (if external-only
+                 (do-external-symbols (symbol package)
+                   (if (and (eq (symbol-package symbol) package)
+                            (apropos-search symbol string))
+                       (funcall fun symbol)))
+                 (do-symbols (symbol package)
+                   (if (and (eq (symbol-package symbol) package)
+                            (apropos-search symbol string))
+                       (funcall fun symbol))))))
+      (if (null package)
+          (mapc #'apropos-in-package (list-all-packages))
+          (apropos-in-package (package-or-lose package))))
+    nil))
+
+;;; APROPOS -- public.
+;;; 
 (defun apropos (string &optional package external-only)
   "Briefly describe all symbols which contain the specified String.
   If Package is supplied then only describe symbols present in
   that package.  If External-Only is true then only describe
   external symbols in the specified package."
-  (let ((string (string-upcase string)))
-    (declare (simple-string string))
-    (if (null package)
-	(do-all-symbols (symbol)
-	   (if (apropos-search symbol string)
-	       (briefly-describe-symbol symbol)))
-	(let ((package (package-or-lose package)))
-	  (if external-only
-	      (do-external-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (briefly-describe-symbol symbol)))
-	      (do-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (briefly-describe-symbol symbol))))))
-    (values)))
+  (map-apropos #'briefly-describe-symbol string package external-only)
+  (values))
 
+;;; APROPOS-LIST -- public.
+;;; 
 (defun apropos-list (string &optional package external-only)
   "Identical to Apropos, except that it returns a list of the symbols
   found instead of describing them."
-  (let ((string (string-upcase string))
-	(list '()))
-    (declare (simple-string string))
-    (if (null package)
-	(do-all-symbols (symbol)
-	   (if (apropos-search symbol string)
-	       (push symbol list)))
-	(let ((package (package-or-lose package)))
-	  (if external-only
-	      (do-external-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (push symbol list)))
-	      (do-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (push symbol list))))))
-    list))
+  (collect ((result))
+    (map-apropos #'(lambda (symbol)
+		     (result symbol))
+		 string package external-only)
+    (result)))
+
+
 
 ;;; Initialization.
 
-- 
GitLab