/[gcl]/gcl/lsp/gcl_packlib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_packlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26