← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to lsp/gcl_packlib.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
lsp/gcl_packlib.lsp
 
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
           (unless (or
 
44
                    (packagep ,g)
 
45
                    (setq ,g (find-package (string ,g))))
 
46
            (specific-error :package-error "Cannot coerce ~S to a package~%" ,p))
 
47
          ,g))))
 
48
 
 
49
(defun find-all-symbols (string-or-symbol)
 
50
  (when (symbolp string-or-symbol)
 
51
        (setq string-or-symbol (symbol-name string-or-symbol)))
 
52
  (mapcan #'(lambda (p)
 
53
              (multiple-value-bind (s i)
 
54
                  (find-symbol string-or-symbol p)
 
55
                (if (or (eq i :internal) (eq i :external))
 
56
                    (list s)
 
57
                    nil)))
 
58
          (list-all-packages)))
 
59
 
 
60
 
 
61
(defmacro do-symbols ((var &optional (package '*package*) (result-form nil))
 
62
                      . body)
 
63
  (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym))
 
64
        (loop (gensym)) (x (gensym))(y (gensym)) (break (gensym)) declaration)
 
65
    (multiple-value-setq (declaration body) (find-declarations body))
 
66
    `(let ((,p (coerce-to-package ,package)) ,var ,l )
 
67
       ,@declaration
 
68
       (dolist (,q (cons ,p (package-use-list ,p)) (progn (setq ,var nil) ,result-form))
 
69
               (multiple-value-bind 
 
70
                (,y ,x) (package-size ,q)
 
71
                (declare (fixnum ,x ,y))
 
72
                (if (not (eq ,p ,q)) (setq ,x 0))
 
73
                (dotimes (,i (+ ,x ,y))
 
74
                         (setq ,l (if (< ,i ,x)
 
75
                                      (si:package-internal ,q ,i)
 
76
                                    (si:package-external ,q (- ,i ,x))))
 
77
                         ,loop
 
78
                         (when (null ,l) (go ,break))
 
79
                         (setq ,var (car ,l))
 
80
                         (if (or (eq ,q ,p) 
 
81
                                 (eq :inherited (car (last (multiple-value-list 
 
82
                                                            (find-symbol (symbol-name ,var) ,p))))))
 
83
                             (tagbody ,@body))
 
84
                         (setq ,l (cdr ,l))
 
85
                         (go ,loop)
 
86
                         ,break))))))
 
87
       
 
88
 
 
89
(defmacro do-external-symbols
 
90
          ((var &optional (package '*package*) (result-form nil)) . body)
 
91
  (let ((p (gensym)) (i (gensym)) (l (gensym))
 
92
        (loop (gensym)) (break (gensym)) declaration)
 
93
    (multiple-value-setq (declaration body)
 
94
                         (find-declarations body))
 
95
    `(let ((,p (coerce-to-package ,package)) ,var ,l)
 
96
       
 
97
       ,@declaration
 
98
       (dotimes (,i (package-size ,p) (progn (setq ,var nil) ,result-form))
 
99
         (setq ,l (si:package-external ,p ,i))
 
100
       ,loop
 
101
         (when (null ,l) (go ,break))
 
102
         (setq ,var (car ,l))
 
103
         ,@body
 
104
         (setq ,l (cdr ,l))
 
105
         (go ,loop)
 
106
       ,break))))
 
107
 
 
108
(defmacro do-all-symbols((var &optional (result-form nil)) . body)
 
109
  `(dolist (.v (list-all-packages) ,result-form)
 
110
           (do-symbols (,var .v)
 
111
                       (tagbody ,@ body))))
 
112
           
 
113
 
 
114
(defun substringp (sub str)
 
115
  (do ((i (- (length str) (length sub)))
 
116
       (l (length sub))
 
117
       (j 0 (1+ j)))
 
118
      ((> j i) nil)
 
119
    (when (string-equal sub str :start2 j :end2 (+ j l))
 
120
          (return t))))
 
121
 
 
122
 
 
123
(defun print-symbol-apropos (symbol)
 
124
  (prin1 symbol)
 
125
  (when (fboundp symbol)
 
126
        (if (special-form-p symbol)
 
127
            (princ "  Special form")
 
128
            (if (macro-function symbol)
 
129
                (princ "  Macro")
 
130
                (princ "  Function"))))
 
131
  (when (boundp symbol)
 
132
        (if (constantp symbol)
 
133
            (princ "  Constant: ")
 
134
            (princ "  has value: "))
 
135
        (prin1 (symbol-value symbol)))
 
136
  (terpri))
 
137
 
 
138
 
 
139
;(defun apropos (string &optional package)
 
140
;  (setq string (string string))
 
141
;  (cond (package
 
142
;         (do-symbols (symbol package)
 
143
;           (when (substringp string (string symbol))
 
144
;                 (print-symbol-apropos symbol)))
 
145
;         (do ((p (package-use-list package) (cdr p)))
 
146
;             ((null p))
 
147
;           (do-external-symbols (symbol (car p))
 
148
;             (when (substringp string (string symbol))
 
149
;                   (print-symbol-apropos symbol)))))
 
150
;        (t
 
151
;         (do-all-symbols (symbol)
 
152
;           (when (substringp string (string symbol))
 
153
;                 (print-symbol-apropos symbol)))))
 
154
;  (values))
 
155
 
 
156
 
 
157
(defun apropos-list (string &optional package &aux list)
 
158
  (setq list nil)
 
159
  (setq string (string string))
 
160
  (cond (package
 
161
         (do-symbols (symbol package)
 
162
                     (when (substringp string (string symbol))
 
163
                       (setq list (cons symbol list))))
 
164
         (do ((p (package-use-list package) (cdr p)))
 
165
             ((null p))
 
166
             (do-external-symbols (symbol (car p))
 
167
                                  (when (substringp string (string symbol))
 
168
                                    (setq list (cons symbol list))))))
 
169
        (t
 
170
         (do-all-symbols (symbol)
 
171
                         (when (substringp string (string symbol))
 
172
                           (setq list (cons symbol list))))))
 
173
  (stable-sort (delete-duplicates list :test #'eq)
 
174
               #'string< :key #'symbol-name))
 
175
 
 
176
(defun apropos (string &optional package)
 
177
  (dolist (symbol (apropos-list string package))
 
178
    (print-symbol-apropos symbol))
 
179
  (values))
 
180
 
 
181
(defmacro with-package-iterator ((name plist &rest symbol-types) . body)
 
182
  (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) (dum (gensym))
 
183
        (x (gensym))(y (gensym)) (access (gensym)) declaration)
 
184
    (multiple-value-setq (declaration body) (si::find-declarations body))
 
185
    (if (null symbol-types)
 
186
        (specific-error :too-few-arguments "Symbol type specifiers must be supplied"))
 
187
    `(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil)
 
188
           (,i -1) (,x 0) (,y 0) (,dum nil) (,access nil))
 
189
       (declare (fixnum ,x ,y))
 
190
       (flet ((,name () 
 
191
                     (tagbody ,name
 
192
                              (when (null (setq ,l (cdr ,l)))
 
193
                                (when (eql (incf ,i) (+ ,x ,y))
 
194
                                  (when (null (setq ,q (cdr ,q))) 
 
195
                                    (when (null (setq ,p (cdr ,p)))
 
196
                                      (return-from ,name nil))
 
197
                                    (rplaca ,p (coerce-to-package (car ,p)))
 
198
                                    (setq ,q (list 
 
199
                                              (si::coerce-to-package (car ,p))))
 
200
                                    (when (member :inherited (list ,@symbol-types))
 
201
                                      (rplacd ,q (package-use-list (car ,q)))))
 
202
                                  (multiple-value-setq (,y ,x) (si::package-size (car ,q)))
 
203
                                  (when (or (not (member :internal (list ,@symbol-types)))
 
204
                                            (not (eq (car ,p) (car ,q))))
 
205
                                    (setq ,x 0))
 
206
                                  (when (and (not (member :external (list ,@symbol-types)))
 
207
                                             (eq (car ,p) (car ,q)))
 
208
                                    (setq ,y 0))
 
209
                                  (when (zerop (+ ,x ,y)) 
 
210
                                    (setq ,i -1)
 
211
                                    (go ,name))
 
212
                                  (setq ,i 0))
 
213
                                (setq ,l (if (< ,i ,x)
 
214
                                             (si::package-internal (car ,q) ,i)
 
215
                                           (si::package-external (car ,q) (- ,i ,x)))))
 
216
                              (when (null ,l)
 
217
                                (go ,name))
 
218
                              (multiple-value-setq (,dum ,access) 
 
219
                                                   (find-symbol 
 
220
                                                    (symbol-name (car ,l)) (car ,p)))
 
221
                              (when (and (not (eq ,access :inherited)) 
 
222
                                         (not (eq (car ,p) (car ,q))))
 
223
                                (go ,name)))
 
224
                     (values 't (car ,l) ,access (car ,p))))
 
225
             ,@declaration
 
226
             ,@body))))
 
227