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 |