;;;-*- Mode: Lisp; Package: XLE -*-

(in-package :xle)

;; extension of a macro by Bruno Haible
(defmacro collecting (&body forms)
  (let ((a (gensym))
        (b (gensym))
        (c (gensym))
        (f (gensym)))
    `(let ((,a nil) (,b nil))
       (macrolet ((collect (form)
                    `((lambda (,',c)
                        (if ,',a
                          (setf (cdr ,',b) (setf ,',b ,',c))
                          (setf ,',a (setf ,',b ,',c))))
                      (list ,form)))
                  (collect-append (form)
                    `(mapc (lambda (,',c)
                             (let ((,',f (list ,',c)))
                               (if ,',a
                                   (setf (cdr ,',b) (setf ,',b ,',f))
                                 (setf ,',a (setf ,',b ,',f)))))
                       ,form)))
         (progn ,@forms)
         ,a))))

#+test
(collecting
 (loop for x on '(1 2 3 4)
       do (collect-append (list x))))

(defmacro collect (form)
  (declare (ignore form))
  (error "collect used outside of collecting"))

(defmacro collect-append (form)
  (declare (ignore form))
  (error "collect-append used outside of collecting"))

;; add collect-new!

(defmacro collecting-into (vars &body forms)
  (let ((b (gensym "B-"))
        (c (gensym "C-"))
	(f (gensym "F-")))
    `(let ((,b nil)
	   ,@(mapcar (lambda (var)
		       `(,var nil))
		     vars))
       (macrolet ((collect-into (var form)
		    `((lambda (,',c)
			(if ,var
			    (setf (cdr (getf ,',b ',var)) (setf (getf ,',b ',var) ,',c))
			  (setf ,var (setf (getf ,',b ',var) ,',c))))
		      (list ,form)))
		  (collect-append-to (var form)
                    `(mapc (lambda (,',c)
                             (let ((,',f (list ,',c)))
                               (if ,var
                                   (setf (cdr (getf ,',b ',var)) (setf (getf ,',b ',var) ,',f))
				   (setf ,var (setf (getf ,',b ',var) ,',f)))))
                       ,form)))
         (progn ,@forms)))))

(defmacro collect-into (var form)
  (declare (ignore var form))
  (error "collect used outside of collecting"))

(defmacro collect-append-to (var form)
  (declare (ignore var form))
  (error "collect-append used outside of collecting"))

#+test
(collecting-into
 (a b)
 (loop for x in '(1 2 3 4)
     do (collect-into a x)
	(collect-into b (- x)))
 (print (list a b)))

;;----- other macros

(defmacro with-gensyms ((&rest vars) &body body)
  (let ((bindings (mapcar (lambda (var)
			    `(,var (gensym)))
			  vars)))
    `(let ,bindings ,@body)))

#-lispworks
(defmacro when-let ((value form) &body body)
  `(let ((,value ,form))
     (when ,value ,@body)))  

(defmacro if-let ((value form) &body body)
  `(let ((,value ,form))
     (if ,value ,@body)))

(defmacro concat (&rest strings)
  `(concatenate 'string ,@strings))

(defmacro with-stream-lines ((stream line) &body body)
  `(let (,line)
     (loop do (setf ,line (read-line ,stream nil :eof))
           until (eq ,line :eof)
           do
           ,@body)))

(defmacro with-file-lines ((line path &key
				 #+allegro(external-format excl::*default-external-format*)
				 #+sbcl(external-format sb-impl::*default-external-format*)
				 ) &body body)
  (let ((stream (gensym)))
    `(with-open-file (,stream ,path :external-format ,external-format)
         (with-stream-lines (,stream ,line)
           ,@body))))

:eof