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

Diff of /gcl/lsp/sloop.lsp

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

revision 1.1.1.1 by wfs, Mon Dec 6 22:44:08 1999 UTC revision 1.2 by camm, Sun Dec 8 03:28:51 2002 UTC
# Line 163  a symbol for the purposes of being a key Line 163  a symbol for the purposes of being a key
163                ((eql (car v) :no-body)                ((eql (car v) :no-body)
164                 `((parse-no-body  .item.) ,@ (cdr v)))                 `((parse-no-body  .item.) ,@ (cdr v)))
165                ((setq tem                ((setq tem
166                       (member (car v) '(:sloop-macro :sloop-for :sloop-map)))                       (member (car v) '(sloop-macro sloop-for sloop-map)))
167                 `((and (symbolp .item.)(get .item. ,(car tem))) ,@ (cdr v)))                 `((and (symbolp .item.)(get .item. ',(car tem))) ,@ (cdr v)))
168                (t                (t
169                 `((l-equal .item. ',(car v)) ,@ (cdr v))))                 `((l-equal .item. ',(car v)) ,@ (cdr v))))
170          bod))          bod))
171      (or last-case (push `(t (error "lcase fell off end ~a  " .item.)) bod))       (or last-case (push `(t (error "lcase fell off end ~a  " .item.)) bod))
172      `(let ((.item. (translate-name ,item)))      `(let ((.item. (translate-name ,item)))
173         (cond ,@ (nreverse bod)))))         (cond ,@ (nreverse bod)))))
174    
# Line 389  otherwise nil" Line 389  otherwise nil"
389               (end-test  (setq *loop-end-test*               (end-test  (setq *loop-end-test*
390                                (append (parse-loop-do) *loop-end-test*)))                                (append (parse-loop-do) *loop-end-test*)))
391               (with-unique (parse-loop-with nil t))               (with-unique (parse-loop-with nil t))
392               (:sloop-macro (parse-loop-macro v :sloop-macro))               (sloop-macro (parse-loop-macro v 'sloop-macro))
393               (t               (t
394                 (cond (first                 (cond (first
395                         (setf found nil))                         (setf found nil))
# Line 569  otherwise nil" Line 569  otherwise nil"
569    (declare (special *loop-prologue* *last-val*    (declare (special *loop-prologue* *last-val*
570                      *loop-collect-var* *loop-epilogue* ))                      *loop-collect-var* *loop-epilogue* ))
571    (let* ((com  (find command *additional-collections* :test 'l-equal))    (let* ((com  (find command *additional-collections* :test 'l-equal))
572           (helper (get com :sloop-collect)))           (helper (get com 'sloop-collect)))
573      (let ((form (funcall helper collect-var name-val)))      (let ((form (funcall helper collect-var name-val)))
574        (let ((*loop-form* form) *last-val*)        (let ((*loop-form* form) *last-val*)
575          (declare (special  *loop-form* *last-val*))          (declare (special  *loop-form* *last-val*))
# Line 784  recompile.")) Line 784  recompile."))
784                 (to                 (to
785                   (setq from-data (add-from-data from-data                   (setq from-data (add-from-data from-data
786                                                  var nil (loop-pop) nil nil t)))                                                  var nil (loop-pop) nil nil t)))
787                 (:sloop-for (parse-loop-macro (translate-name v)                 (sloop-for (parse-loop-macro (translate-name v)
788                                               :sloop-for var )                                               'sloop-for var )
789                             (return 'done))                             (return 'done))
790                 (:sloop-map (parse-loop-map (translate-name v) var )                 (sloop-map (parse-loop-map (translate-name v) var )
791                             (return nil))                             (return nil))
792                 (t(or                                     (t(or                    
793                     (loop-un-pop))                     (loop-un-pop))
# Line 848  recompile.")) Line 848  recompile."))
848    (let ((helper (get v type)) args)    (let ((helper (get v type)) args)
849      (setq args      (setq args
850            (ecase type            (ecase type
851              (:sloop-for              (sloop-for
852               (let ((tem (get v :sloop-for-args)))               (let ((tem (get v 'sloop-for-args)))
853                 (or (cdr tem) (error "sloop-for macro needs at least one arg"))                 (or (cdr tem) (error "sloop-for macro needs at least one arg"))
854                 (cdr tem)))                 (cdr tem)))
855              (:sloop-macro(get v :sloop-macro-args))))              (sloop-macro(get v 'sloop-macro-args))))
856      (let ((last-helper-apply-arg      (let ((last-helper-apply-arg
857              (cond ((member '&rest args)              (cond ((member '&rest args)
858                     (prog1 *loop-form* (setf *loop-form* nil)))                     (prog1 *loop-form* (setf *loop-form* nil)))
# Line 862  recompile.")) Line 862  recompile."))
862        (setq *loop-form*        (setq *loop-form*
863              (append              (append
864                (case type                (case type
865                      (:sloop-for (apply helper initial last-helper-apply-arg))                      (sloop-for (apply helper initial last-helper-apply-arg))
866                      (:sloop-macro(apply helper  last-helper-apply-arg)))                      (sloop-macro(apply helper  last-helper-apply-arg)))
867                *loop-form*)))))                *loop-form*)))))
868    
869  (defun parse-loop-map (v var)  (defun parse-loop-map (v var)
870    (declare (special *loop-map* *loop-map-declares* *loop-form*))    (declare (special *loop-map* *loop-map-declares* *loop-form*))
871    (and *loop-map* (error "Sorry only one allowed loop-map per sloop"))    (and *loop-map* (error "Sorry only one allowed loop-map per sloop"))
872    (let ((helper (get v :sloop-map))    (let ((helper (get v 'sloop-map))
873          (args  (get v :sloop-map-args)))          (args  (get v 'sloop-map-args)))
874      (or args (error "map needs one arg before the key word"))      (or args (error "map needs one arg before the key word"))
875      (cond ((member '&rest args)      (cond ((member '&rest args)
876             (error "Build this in two steps if you want &rest")))             (error "Build this in two steps if you want &rest")))
# Line 912  recompile.")) Line 912  recompile."))
912                (defun ,helper ,args                (defun ,helper ,args
913                  ,@ body)                  ,@ body)
914                ,@ (and list `((pushnew ',name ,list)))                ,@ (and list `((pushnew ',name ,list)))
915                (setf (get ',name ,(intern (format nil "SLOOP-~a" type)                (setf (get ',name ',(intern (format nil "SLOOP-~a" type)
916                                           (find-package 'keyword))) ',helper)                                           (find-package 'sloop))) ',helper)
917                (setf (get ',name ,(intern (format nil "SLOOP-~a-ARGS" type)                (setf (get ',name ',(intern (format nil "SLOOP-~a-ARGS" type)
918                                           (find-package 'keyword))) ',args)))                                           (find-package 'sloop))) ',args)))
919  )  )
920                                    
921    

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.2

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