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

Diff of /gcl/lsp/packlib.lsp

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

revision 1.5 by camm, Thu Oct 24 22:10:45 2002 UTC revision 1.6 by camm, Mon Oct 28 16:54:04 2002 UTC
# Line 171  Line 171 
171    list)    list)
172    
173  (defmacro with-package-iterator ((name plist &rest symbol-types) . body)  (defmacro with-package-iterator ((name plist &rest symbol-types) . body)
174    (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym))    (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) (dum (gensym))
175          (x (gensym))(y (gensym)) (access (gensym)) declaration)          (x (gensym))(y (gensym)) (access (gensym)) declaration)
176      (multiple-value-setq (declaration body) (si::find-declarations body))      (multiple-value-setq (declaration body) (si::find-declarations body))
177      (if (null symbol-types)      (if (null symbol-types)
178          (specific-error :too-few-arguments "Symbol type specifiers must be supplied"))          (specific-error :too-few-arguments "Symbol type specifiers must be supplied"))
179      `(let ((,p nil) (,q nil) (,l nil)      `(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil)
180             (,i -1) (,x 0) (,y 0))             (,i -1) (,x 0) (,y 0))
181         (macrolet ((,name ()         (macrolet ((,name ()
182                           '(block ,name                       '(block ,name
183                              (setq ,l (cdr ,l))                              (when (null (setq ,l (cdr ,l)))
184                              (if (null ,l)                                (when (eql (incf ,i) (+ ,x ,y))
185                                  (progn                                  (when (null (setq ,q (cdr ,q)))
186                                    (setq ,i (1+ ,i))                                    (when (null (setq ,p (cdr ,p)))
187                                    (if (eql ,i (+ ,x ,y))                                      (return-from ,name nil))
188                                        (progn                                    (rplaca ,p (coerce-to-package (car ,p)))
189                                          (setq ,q (cdr ,q))                                    (setq ,q (list
190                                          (if (null ,q)                                              (si::coerce-to-package (car ,p))))
191                                              (progn                                    (when (member :inherited (list ,@symbol-types))
192                                                (if (null ,p)                                      (rplacd ,q (package-use-list (car ,q)))))
193                                                    (setq ,p (if (atom ,plist)                                  (multiple-value-setq (,y ,x) (si::package-size (car ,q)))
194                                                                 (list ,plist)                                  (when (or (not (member :internal (list ,@symbol-types)))
195                                                               ,plist))                                            (not (eq (car ,p) (car ,q))))
196                                                  (setq ,p (cdr ,p)))                                    (setq ,x 0))
197                                                (if (null ,p)                                  (when (and (not (member :external (list ,@symbol-types)))
198                                                    (return-from ,name nil))                                             (eq (car ,p) (car ,q)))
199                                                (rplaca ,p (coerce-to-package (car ,p)))                                    (setq ,y 0))
200                                                (setq ,q (list                                  (when (zerop (+ ,x ,y))
201                                                          (si::coerce-to-package (car ,p))))                                    (setq ,i -1)
202                                                (if (member :inherited (list ,@symbol-types))                                    (return-from ,name (,name)))
203                                                    (rplacd ,q (package-use-list (car ,q))))))                                  (setq ,i 0))
204                                          (setq ,x (multiple-value-list                                (setq ,l (if (< ,i ,x)
205                                                    (si::package-size (car ,q))))                                             (si::package-internal (car ,q) ,i)
206                                          (setq ,y (first ,x))                                           (si::package-external (car ,q) (- ,i ,x)))))
207                                          (setq ,x (second ,x))                              (when (null ,l)
208                                          (if (or (not (member :internal (list ,@symbol-types)))                                (return-from ,name (,name)))
209                                                  (not (eq (car ,p) (car ,q))))                              (multiple-value-setq (,dum ,access)
210                                              (setq ,x 0))                                                   (find-symbol
211                                          (if (and (not (member :external (list ,@symbol-types)))                                                    (symbol-name (car ,l)) (car ,p)))
212                                                   (eq (car ,p) (car ,q)))                              (when (and (not (eq ,access :inherited))
213                                              (setq ,y 0))                                         (not (eq (car ,p) (car ,q))))
214                                          (if (zerop (+ ,x ,y))                                (return-from ,name (,name)))
                                             (progn (setq ,i -1)  
                                                    (return-from ,name (,name)))  
                                           (setq ,i 0))))  
                                   (setq ,l (if (< ,i ,x)  
                                                (si::package-internal (car ,q) ,i)  
                                              (si::package-external (car ,q) (- ,i ,x))))))  
                             (if (null ,l) (return-from ,name (,name)))  
                             (setq ,access (second  
                                            (multiple-value-list  
                                             (find-symbol  
                                              (symbol-name (car ,l)) (car ,p)))))  
                             (if (and (not (eq ,access :inherited))  
                                      (not (eq (car ,p) (car ,q))))  
                                 (return-from ,name (,name)))  
215                              (values 't (car ,l) ,access (car ,p)))))                              (values 't (car ,l) ,access (car ,p)))))
216                   (declare (fixnum ,x ,y))                   (declare (fixnum ,x ,y))
217                   ,@declaration                   ,@declaration

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

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