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 |
|
|
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)) |
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*)) |
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)) |
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))) |
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"))) |
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 |
|
|