[Gcl-devel] Lisp programming style advice

[Camm Maguire]

Greetings!  In the course of addressing some of the ansi issues
revealed by Paul's tests, I'm finding myself writing ever more
sophisticated (for me) lisp code for GCL with a still partial
understanding of the language. I'd like to take a moment to solicit
the opinions of the list on the with-package-iterator macro I
committed recently.  This works (apparently), and was designed to
emulate the behavior of do-symbols (packlib.lsp).  But its not
particularly elegant, and I worry about the non-tail recursive calls
from a performance point of view.  In general, I'm concerning myself
with correctness first and deferring performance considerations to a
much later stage, but if I can learn some tricks along the way, we'll
save work down the road, I'd imagine.

Take care,


(defmacro with-package-iterator ((name plist &rest symbol-types) . body)
  (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym))
        (x (gensym))(y (gensym)) (access (gensym)) declaration)
    (multiple-value-setq (declaration body) (si::find-declarations body))
    (if (null symbol-types)
        (specific-error :too-few-arguments "Symbol type specifiers must be 
supplied"))
    `(let ((,p nil) (,q nil) (,l nil)
           (,i -1) (,x 0) (,y 0))
       (macrolet ((,name () 
                         '(block ,name
                            (setq ,l (cdr ,l))
                            (if (null ,l) 
                                (progn
                                  (setq ,i (1+ ,i))
                                  (if (eql ,i (+ ,x ,y))
                                      (progn 
                                        (setq ,q (cdr ,q))
                                        (if (null ,q) 
                                            (progn 
                                              (if (null ,p) 
                                                  (setq ,p (if (atom ,plist) 
                                                               (list ,plist) 
                                                             ,plist))
                                                (setq ,p (cdr ,p)))
                                              (if (null ,p)
                                                  (return-from ,name nil))
                                              (rplaca ,p (coerce-to-package 
(car ,p)))
                                              (setq ,q (list 
                                                        (si::coerce-to-package 
(car ,p))))
                                              (if (member :inherited (list 
,@symbol-types))
                                                  (rplacd ,q (package-use-list 
(car ,q))))))
                                        (setq ,x (multiple-value-list 
                                                  (si::package-size (car ,q))))
                                        (setq ,y (first ,x))
                                        (setq ,x (second ,x))
                                        (if (or (not (member :internal (list 
,@symbol-types)))
                                                (not (eq (car ,p) (car ,q))))
                                            (setq ,x 0))
                                        (if (and (not (member :external (list 
,@symbol-types)))
                                                 (eq (car ,p) (car ,q)))
                                            (setq ,y 0))
                                        (if (zerop (+ ,x ,y)) 
                                            (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)))
                            (values 't (car ,l) ,access (car ,p)))))
                 (declare (fixnum ,x ,y))
                 ,@declaration
                 ,@body))))


-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah