/[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.7 by camm, Tue Oct 29 01:33:39 2002 UTC revision 1.8 by camm, Sun Nov 3 18:06:49 2002 UTC
# Line 178  Line 178 
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 (cons t (if (atom ,plist) (list ,plist) ,plist))) (,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         (labels ((,name ()         (flet ((,name ()
182                         (when (null (setq ,l (cdr ,l)))                       (tagbody ,name
183                           (when (eql (incf ,i) (+ ,x ,y))                                (when (null (setq ,l (cdr ,l)))
184                             (when (null (setq ,q (cdr ,q)))                                  (when (eql (incf ,i) (+ ,x ,y))
185                               (when (null (setq ,p (cdr ,p)))                                    (when (null (setq ,q (cdr ,q)))
186                                 (return-from ,name nil))                                      (when (null (setq ,p (cdr ,p)))
187                               (rplaca ,p (coerce-to-package (car ,p)))                                        (return-from ,name nil))
188                               (setq ,q (list                                      (rplaca ,p (coerce-to-package (car ,p)))
189                                         (si::coerce-to-package (car ,p))))                                      (setq ,q (list
190                               (when (member :inherited (list ,@symbol-types))                                                (si::coerce-to-package (car ,p))))
191                                 (rplacd ,q (package-use-list (car ,q)))))                                      (when (member :inherited (list ,@symbol-types))
192                             (multiple-value-setq (,y ,x) (si::package-size (car ,q)))                                        (rplacd ,q (package-use-list (car ,q)))))
193                             (when (or (not (member :internal (list ,@symbol-types)))                                    (multiple-value-setq (,y ,x) (si::package-size (car ,q)))
194                                       (not (eq (car ,p) (car ,q))))                                    (when (or (not (member :internal (list ,@symbol-types)))
195                               (setq ,x 0))                                              (not (eq (car ,p) (car ,q))))
196                             (when (and (not (member :external (list ,@symbol-types)))                                      (setq ,x 0))
197                                        (eq (car ,p) (car ,q)))                                    (when (and (not (member :external (list ,@symbol-types)))
198                               (setq ,y 0))                                               (eq (car ,p) (car ,q)))
199                             (when (zerop (+ ,x ,y))                                      (setq ,y 0))
200                               (setq ,i -1)                                    (when (zerop (+ ,x ,y))
201                               (return-from ,name (,name)))                                      (setq ,i -1)
202                             (setq ,i 0))                                      (go ,name))
203                           (setq ,l (if (< ,i ,x)                                    (setq ,i 0))
204                                        (si::package-internal (car ,q) ,i)                                  (setq ,l (if (< ,i ,x)
205                                      (si::package-external (car ,q) (- ,i ,x)))))                                               (si::package-internal (car ,q) ,i)
206                         (when (null ,l)                                             (si::package-external (car ,q) (- ,i ,x)))))
207                           (return-from ,name (,name)))                                (when (null ,l)
208                         (multiple-value-setq (,dum ,access)                                  (go ,name))
209                                              (find-symbol                                (multiple-value-setq (,dum ,access)
210                                               (symbol-name (car ,l)) (car ,p)))                                                     (find-symbol
211                         (when (and (not (eq ,access :inherited))                                                      (symbol-name (car ,l)) (car ,p)))
212                                    (not (eq (car ,p) (car ,q))))                                (when (and (not (eq ,access :inherited))
213                           (return-from ,name (,name)))                                           (not (eq (car ,p) (car ,q))))
214                         (values 't (car ,l) ,access (car ,p))))                                  (go ,name)))
215                 (declare (fixnum ,x ,y))                       (values 't (car ,l) ,access (car ,p))))
216                 ,@declaration               (declare (fixnum ,x ,y))
217                 ,@body))))               ,@declaration
218                 ,@body))))
219    

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

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