;; `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 some limited (and questionable) magic to support calling
;; procedures which produce multiple values in `expr` by wraping the
;; call into `values-from`.

;; # 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 ()
    ((_ bindings expr body ...)
     (let ((receiver (lambda bindings body ...)))
       (let-syntax
	   ((rewrite (syntax-rules ()
		       ((_ (*values *vals) *expr)
			(let-syntax
			    ((*values (syntax-rules <...> ()
						    ((_ rv <...>) (receiver rv <...>))))
			     (*vals (syntax-rules <...> ()
						  ((_ (proc))
						   (call-with-values proc
						     (lambda bindings (receiver . bindings))))
						  ((_ (proc a <...>))
						   (call-with-values (lambda () (proc a <...>))
						     (lambda bindings (receiver . bindings)))))))
			  *expr)))))
	 (extract* (values values-from) expr (rewrite () expr)))))))

;; 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)

; Havoc example:
;(let ((return values)) (rcv x (return 1 2 3) x))

(define (foo) (values 1 2))

(rcv (a b) (foo) (cons a b)) ;; => fails to exec body because no "values" was found

(rcv (a b) (values-from (foo)) (cons a b))

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

;; Runtime error only:
; (rcv (a b) (values-from (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)
		(values-from (bar 5 6))
		(values c (cons a b)))
     (vector b a))