1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; packlib.lsp |
21 |
|
;;;; |
22 |
|
;;;; package routines |
23 |
|
|
24 |
|
|
25 |
|
(in-package 'lisp) |
26 |
|
|
27 |
|
|
28 |
|
(export '(find-all-symbols do-symbols do-external-symbols do-all-symbols with-package-iterator)) |
29 |
|
(export '(apropos apropos-list)) |
30 |
|
|
31 |
|
|
32 |
|
(in-package 'system) |
33 |
|
|
34 |
|
|
35 |
|
(proclaim '(optimize (safety 2) (space 3))) |
36 |
|
|
37 |
|
|
38 |
|
(defmacro coerce-to-package (p) |
39 |
|
(if (eq p '*package*) |
40 |
|
p |
41 |
|
(let ((g (gensym))) |
42 |
|
`(let ((,g ,p)) |
43 |
|
(if (packagep ,g) |
44 |
|
,g |
45 |
|
(find-package (string ,g))))))) |
46 |
|
|
47 |
|
(defun find-all-symbols (string-or-symbol) |
48 |
|
(when (symbolp string-or-symbol) |
49 |
|
(setq string-or-symbol (symbol-name string-or-symbol))) |
50 |
|
(mapcan #'(lambda (p) |
51 |
|
(multiple-value-bind (s i) |
52 |
|
(find-symbol string-or-symbol p) |
53 |
|
(if (or (eq i :internal) (eq i :external)) |
54 |
|
(list s) |
55 |
|
nil))) |
56 |
|
(list-all-packages))) |
57 |
|
|
58 |
|
|
59 |
|
(defmacro do-symbols ((var &optional (package '*package*) (result-form nil)) |
60 |
|
. body) |
61 |
|
(let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) |
62 |
|
(loop (gensym)) (x (gensym))(y (gensym)) (break (gensym)) declaration) |
63 |
|
(multiple-value-setq (declaration body) (find-declarations body)) |
64 |
|
`(let ((,p (coerce-to-package ,package)) ,var ,l ) |
65 |
|
,@declaration |
66 |
|
(dolist (,q (cons ,p (package-use-list ,p)) (progn (setq ,var nil) ,result-form)) |
67 |
|
(multiple-value-bind |
68 |
|
(,y ,x) (package-size ,q) |
69 |
|
(declare (fixnum ,x ,y)) |
70 |
|
(if (not (eq ,p ,q)) (setq ,x 0)) |
71 |
|
(dotimes (,i (+ ,x ,y)) |
72 |
|
(setq ,l (if (< ,i ,x) |
73 |
|
(si:package-internal ,q ,i) |
74 |
|
(si:package-external ,q (- ,i ,x)))) |
75 |
|
,loop |
76 |
|
(when (null ,l) (go ,break)) |
77 |
|
(setq ,var (car ,l)) |
78 |
|
(if (or (eq ,q ,p) |
79 |
|
(eq :inherited (car (last (multiple-value-list |
80 |
|
(find-symbol (symbol-name ,var) ,p)))))) |
81 |
|
(tagbody ,@body)) |
82 |
|
(setq ,l (cdr ,l)) |
83 |
|
(go ,loop) |
84 |
|
,break)))))) |
85 |
|
|
86 |
|
|
87 |
|
(defmacro do-external-symbols |
88 |
|
((var &optional (package '*package*) (result-form nil)) . body) |
89 |
|
(let ((p (gensym)) (i (gensym)) (l (gensym)) |
90 |
|
(loop (gensym)) (break (gensym)) declaration) |
91 |
|
(multiple-value-setq (declaration body) |
92 |
|
(find-declarations body)) |
93 |
|
`(let ((,p (coerce-to-package ,package)) ,var ,l) |
94 |
|
|
95 |
|
,@declaration |
96 |
|
(dotimes (,i (package-size ,p) (progn (setq ,var nil) ,result-form)) |
97 |
|
(setq ,l (si:package-external ,p ,i)) |
98 |
|
,loop |
99 |
|
(when (null ,l) (go ,break)) |
100 |
|
(setq ,var (car ,l)) |
101 |
|
,@body |
102 |
|
(setq ,l (cdr ,l)) |
103 |
|
(go ,loop) |
104 |
|
,break)))) |
105 |
|
|
106 |
|
(defmacro do-all-symbols((var &optional (result-form nil)) . body) |
107 |
|
`(dolist (.v (list-all-packages) ,result-form) |
108 |
|
(do-symbols (,var .v) |
109 |
|
(tagbody ,@ body)))) |
110 |
|
|
111 |
|
|
112 |
|
(defun substringp (sub str) |
113 |
|
(do ((i (- (length str) (length sub))) |
114 |
|
(l (length sub)) |
115 |
|
(j 0 (1+ j))) |
116 |
|
((> j i) nil) |
117 |
|
(when (string-equal sub str :start2 j :end2 (+ j l)) |
118 |
|
(return t)))) |
119 |
|
|
120 |
|
|
121 |
|
(defun print-symbol-apropos (symbol) |
122 |
|
(prin1 symbol) |
123 |
|
(when (fboundp symbol) |
124 |
|
(if (special-form-p symbol) |
125 |
|
(princ " Special form") |
126 |
|
(if (macro-function symbol) |
127 |
|
(princ " Macro") |
128 |
|
(princ " Function")))) |
129 |
|
(when (boundp symbol) |
130 |
|
(if (constantp symbol) |
131 |
|
(princ " Constant: ") |
132 |
|
(princ " has value: ")) |
133 |
|
(prin1 (symbol-value symbol))) |
134 |
|
(terpri)) |
135 |
|
|
136 |
|
|
137 |
|
;(defun apropos (string &optional package) |
138 |
|
; (setq string (string string)) |
139 |
|
; (cond (package |
140 |
|
; (do-symbols (symbol package) |
141 |
|
; (when (substringp string (string symbol)) |
142 |
|
; (print-symbol-apropos symbol))) |
143 |
|
; (do ((p (package-use-list package) (cdr p))) |
144 |
|
; ((null p)) |
145 |
|
; (do-external-symbols (symbol (car p)) |
146 |
|
; (when (substringp string (string symbol)) |
147 |
|
; (print-symbol-apropos symbol))))) |
148 |
|
; (t |
149 |
|
; (do-all-symbols (symbol) |
150 |
|
; (when (substringp string (string symbol)) |
151 |
|
; (print-symbol-apropos symbol))))) |
152 |
|
; (values)) |
153 |
|
|
154 |
|
|
155 |
|
(defun apropos-list (string &optional package &aux list) |
156 |
|
(setq list nil) |
157 |
|
(setq string (string string)) |
158 |
|
(cond (package |
159 |
|
(do-symbols (symbol package) |
160 |
|
(when (substringp string (string symbol)) |
161 |
|
(setq list (cons symbol list)))) |
162 |
|
(do ((p (package-use-list package) (cdr p))) |
163 |
|
((null p)) |
164 |
|
(do-external-symbols (symbol (car p)) |
165 |
|
(when (substringp string (string symbol)) |
166 |
|
(setq list (cons symbol list)))))) |
167 |
|
(t |
168 |
|
(do-all-symbols (symbol) |
169 |
|
(when (substringp string (string symbol)) |
170 |
|
(setq list (cons symbol list)))))) |
171 |
|
(stable-sort (delete-duplicates list :test #'eq) |
172 |
|
#'string< :key #'symbol-name)) |
173 |
|
|
174 |
|
(defun apropos (string &optional package) |
175 |
|
(dolist (symbol (apropos-list string package)) |
176 |
|
(print-symbol-apropos symbol)) |
177 |
|
(values)) |
178 |
|
|
179 |
|
(defmacro with-package-iterator ((name plist &rest symbol-types) . body) |
180 |
|
(let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) (dum (gensym)) |
181 |
|
(x (gensym))(y (gensym)) (access (gensym)) declaration) |
182 |
|
(multiple-value-setq (declaration body) (si::find-declarations body)) |
183 |
|
(if (null symbol-types) |
184 |
|
(specific-error :too-few-arguments "Symbol type specifiers must be supplied")) |
185 |
|
`(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil) |
186 |
|
(,i -1) (,x 0) (,y 0) (,dum nil) (,access nil)) |
187 |
|
(declare (fixnum ,x ,y)) |
188 |
|
(flet ((,name () |
189 |
|
(tagbody ,name |
190 |
|
(when (null (setq ,l (cdr ,l))) |
191 |
|
(when (eql (incf ,i) (+ ,x ,y)) |
192 |
|
(when (null (setq ,q (cdr ,q))) |
193 |
|
(when (null (setq ,p (cdr ,p))) |
194 |
|
(return-from ,name nil)) |
195 |
|
(rplaca ,p (coerce-to-package (car ,p))) |
196 |
|
(setq ,q (list |
197 |
|
(si::coerce-to-package (car ,p)))) |
198 |
|
(when (member :inherited (list ,@symbol-types)) |
199 |
|
(rplacd ,q (package-use-list (car ,q))))) |
200 |
|
(multiple-value-setq (,y ,x) (si::package-size (car ,q))) |
201 |
|
(when (or (not (member :internal (list ,@symbol-types))) |
202 |
|
(not (eq (car ,p) (car ,q)))) |
203 |
|
(setq ,x 0)) |
204 |
|
(when (and (not (member :external (list ,@symbol-types))) |
205 |
|
(eq (car ,p) (car ,q))) |
206 |
|
(setq ,y 0)) |
207 |
|
(when (zerop (+ ,x ,y)) |
208 |
|
(setq ,i -1) |
209 |
|
(go ,name)) |
210 |
|
(setq ,i 0)) |
211 |
|
(setq ,l (if (< ,i ,x) |
212 |
|
(si::package-internal (car ,q) ,i) |
213 |
|
(si::package-external (car ,q) (- ,i ,x))))) |
214 |
|
(when (null ,l) |
215 |
|
(go ,name)) |
216 |
|
(multiple-value-setq (,dum ,access) |
217 |
|
(find-symbol |
218 |
|
(symbol-name (car ,l)) (car ,p))) |
219 |
|
(when (and (not (eq ,access :inherited)) |
220 |
|
(not (eq (car ,p) (car ,q)))) |
221 |
|
(go ,name))) |
222 |
|
(values 't (car ,l) ,access (car ,p)))) |
223 |
|
,@declaration |
224 |
|
,@body)))) |
225 |
|
|