;; `rcv`: A limited "alternative" for SRFI-8 `receive`.
;;
;; This avoids to use call-with-values - which incurs some overhead on
;; chicken.  However, it works *only*, if `values` is used in tail
;; call position within the `expr` itself.  Havoc if `values` is
;; referenced as a value inside the expression.
;;
;; At least it nests.
;;
;; Another advantage over the buildin receive: wrong number of return
;; values is caught at compile-time.
;;
;; There's magic to support calling procedures which produce multiple
;; values in `expr`.

;; # Petrofsky Extraction
;;
;; How to write dirty R5RS macros
;; http://groups.google.com/groups?selm=87oflzcdwt.fsf%40radish.petrofsky.org
;; How to write seemingly unhygienic macros using syntax-rules
;; Date: 2001-11-19 01:23:33 PST
;;
;; Extract several colored identifiers from a form
;;    extract* SYMB-L BODY CONT
;; where SYMB-L is the list of symbols to extract, and BODY and CONT
;; has the same meaning as in extract, see below.
;; 
;; The extract* macro expands into
;;   (K-HEAD (extr-id-l . K-IDL) . K-ARGS)
;; where extr-id-l is the list of extracted colored identifiers. The
;; extraction itself is performed by the macro extract.

(define-syntax extract*
  (syntax-rules ()
    ;; Extract a colored identifier from a form
    ;;    extract SYMB BODY CONT
    ;; BODY is a form that may contain an occurence of an identifier
    ;; that refers to the same binding occurrence as SYMB, perhaps
    ;; with a different color.
    ;; CONT is a form of the shape (K-HEAD K-IDL . K-ARGS)
    ;; where K-IDL are K-ARGS are S-expressions representing lists or
    ;; the empty list.
    ;; The extract macro expands into
    ;;   (K-HEAD (extr-id . K-IDL) . K-ARGS)
    ;; where extr-id is the extracted colored identifier. If symbol
    ;; SYMB does not occur in BODY at all, extr-id is identical to
    ;; SYMB.
    ((_ "extract" symb body _cont)
      (letrec-syntax
	((tr
           (syntax-rules (symb)
	      ((_ x symb tail (cont-head symb-l . cont-args))
	       (cont-head (x . symb-l) . cont-args)) ; symb has occurred
	      ((_ d (x . y) tail cont)   ; if body is a composite form,
	       (tr x x (y . tail) cont)) ; look inside
	      ((_ d1 d2 () (cont-head  symb-l . cont-args))
	       (cont-head (symb . symb-l) . cont-args)) ; symb does not occur
	      ((_ d1 d2 (x . y) cont)
	       (tr x x y cont)))))
	(tr body body () _cont)))
    ((_ (symb) body cont)      ; only one symbol: use extract to do the job
     (extract* "extract" symb body cont))
    ((_ _symbs _body _cont)
     (letrec-syntax
	 ((ex-aux		; extract symbol-by-symbol
	   (syntax-rules ()
	     ((_ found-symbs () body cont)
	      (reverse () found-symbs cont))
	     ((_ found-symbs (symb . symb-others) body cont)
	      (extract* "extract" symb body
		       (ex-aux found-symbs symb-others body cont)))
	     ))
	  (reverse		; reverse the list of extracted symbols
	   (syntax-rules ()     ; to match the order of SYMB-L
	     ((_ res () (cont-head () . cont-args))
	      (cont-head res . cont-args))
	     ((_ res (x . tail) cont)
	      (reverse (x . res) tail cont)))))
       (ex-aux () _symbs _body _cont)))))

(define-syntax rcv
  (syntax-rules ()
    ((_ (id ...) expr body ...)
     (let ((receiver (lambda (id ...) body ...)))
       (call-with-current-continuation
	(lambda (return)
	  (call-with-values
	      (lambda ()
		(let-syntax
		    ((rewrite (syntax-rules ()
				((_ (*values) *expr)
				 (let-syntax
				     ((*values (syntax-rules <...> ()
							     ((_ rv <...>)
							      (return (receiver rv <...>))))))
				   *expr)))))
		  (extract* (values) expr (rewrite () expr))) )
	    ;; Note that this works in chicken if we write just
	    ;;   receiver
	    ;; instead of the (lambda ...) here (and in the second
	    ;; case too).  But R5RS says only continuations captured by call-with-values
	    ;; are safe to be called with multiple values
	    (lambda (id ...) (receiver id ...)))))))
    ((_ id expr body ...)
     (let ((receiver (lambda id body ...)))
       (call-with-current-continuation
	(lambda (return)
	  (call-with-values
	      (lambda ()
		(let-syntax
		    ((rewrite (syntax-rules ()
				((_ (*values) *expr)
				 (let-syntax
				     ((*values (syntax-rules <...> ()
							     ((_ rv <...>)
							      (return (receiver rv <...>))))))
				   *expr)))))
		  (extract* (values) expr (rewrite () expr))) )
	    ;; Let's show that we don't have to have the lambda here; see above.
	    ;;
	    ;; (lambda id (receiver id))
	    receiver)))))))

;; Examples:

;; Compile time error:
;(rcv (a b c) (values 1 2) (display (cons a b)))

(rcv (a b) (let ((x 1) (a 2)) (values x a)) (cons a b))

(rcv x (values 1 2 3) x)

(define (foo) (values 1 2))

(rcv (a b) (foo) (cons a b))

(define (bar a v) (values a v 1))

;; Runtime error only:
(rcv (a b) (bar 2 3) (cons a b))

(rcv (a b) (rcv (a b c) (values 1 2 3) (values c (cons a b))) (vector b a))

(rcv (a b) (rcv (a b c)
		(bar 5 6)
		(values c (cons a b)))
     (vector b a))