;; Record-case.

;; Copyright (c) 2007, 2008 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; <dvanhorn@cs.brandeis.edu>

;; Record-case, a simple list deconstruction syntax used in the
;; Compiling Scheme Workshop (1996) expository Scheme compiler.

;; PLTv4
;; #lang scheme
;; (require (for-syntax (file private/check-syntax)))
;; PLTv3
(module record-case mzscheme
  (require (lib "plt-match.ss"))
  (require-for-syntax (file "private/check-syntax.ss"))

(provide record-case record-case*)

(define-syntax (record-case stx)
  (<record-case> stx)                  ;; Syntax checking.
  (with-syntax ([(record-case . d) stx])
    (syntax (record-case* . d))))

;; Translate IU `record-case' into `match'.
(define-syntax (record-case* stx)
  
  ;; Convert a `record-case' clause into an equivalent `match' clause.
  (let ((record-case-clause->match-clause
         (lambda (stx) 
           (syntax-case stx (else)
             [(n (x ...) a)     #'[(list-rest 'n vals)  ;; [*]
                                   (match vals
                                     [(list-rest x ... _) a]
                                     [_ (rc-error 'n '(x ...) vals)])]]
             [(n (x ... . y) a) #'[(list-rest 'n x ... y) a]]
             [(else a)          #'[_ a]]))))
    
    (syntax-case stx ()
      [(record-case e c ...)
       (with-syntax ([(c* ...) (map record-case-clause->match-clause
                                    (syntax->list #'(c ...)))])
         #'(match e c* ...))])))
  
;; [*] Why the silliness here?  Because record-case is specified to silently
;;     accept more arguments than there are binders.


;; Signal an error when not given enough arguments.
(define (rc-error symbol formals vals)
  (error 'record-case "Clause ~a expects ~a values, given ~a, ~a"
         (list symbol formals '...)
         (length formals)
         (length vals)
         vals))
  
) ; end of module record-case