permissive-receive.scm

#!r6rs
;; a permissive version of receive, that allows extra values without
;; error, and supplies a default for missing ones
;;
;; tested on guile and racket
(library (permissive-receive)
(export receive*)
(import (rnrs)
        (for (only (srfi :1 lists) iota) expand))
(define-syntax receive*
  (lambda (stx)
    (syntax-case stx ()
      [(receive (args ...) expr body rest ...)
       (let* ((args #'(args ...))
              (num-args (length args)))
         #`(call-with-values (lambda () expr)
             (lambda multiple-values
               (let ((vec (make-vector #,num-args #f)))
                 (let loop ((lst multiple-values) (idx 0))
                   (unless (or (null? lst) (>= idx #,num-args))
                     (vector-set! vec idx (car lst))
                     (loop (cdr lst) (+ idx 1))))
                 (let #,(map (lambda (arg index)
                               #`(#,arg (vector-ref vec #,index)))
                             args
                             (iota num-args))
                   body rest ...)))))]
      [(receive id expr body rest ...)
       (identifier? #'id)
       #'(call-with-values
             (lambda () expr)
           (lambda id body rest ...))])))
)


;; (receive* a (values 1 2 3) a) ; (1 2 3)
;; (receive* (a b c) (values 1 2 3) (list a b c)) ; (1 2 3)
;; (receive* (a b) (values 1 2 3) (list a b)) ; (1 2)
;; (receive* (a b c d) (values 1 2 3) (list a b c d)) ; (1 2 3 #f)

;; extending this to allow rest lists e.g.
;; (receive* (a b c . d) ...)
;; is left as an exercise