;; Record-case.

;; Copyright (c) 2007 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.

(module record-case mzscheme
  (provide record-case record-case*)
  (require-for-syntax "private/check-syntax.ss")
  
  (define-syntax record-case
    (lambda (stx)
      (with-syntax (((_ . args) stx))
        (syntax-case stx (else)
          ((_ exp 
              (symbol0 formals0 exp00 exp01 ...) 
              (symbol1 formals1 exp10 exp11 ...) 
              ... 
              (else exp0 exp1 ...))
           (and (check-symbols (syntax (symbol0 symbol1 ...)))
                (check-formals (syntax (formals0 formals1 ...))))
           (syntax (record-case* . args)))
          
          ((_ exp 
              (symbol0 formals0 exp00 exp01 ...) 
              (symbol1 formals1 exp10 exp11 ...) ...)
           (and (check-symbols (syntax (symbol0 symbol1 ...)))
                (check-formals (syntax (formals0 formals1 ...))))
           (syntax (record-case* . args)))))))
          
            
  ;; Like record-case but assumes expression is well-formed.
  (define-syntax record-case*
    (syntax-rules ()
      ((record-case* e clause ...)
       (let ((x e))
         (letrec-syntax 
             ((record-case/accum
               (syntax-rules (else)
                 ((record-case/accum accum)
                  (case (car x) . accum))
                 ((record-case/accum (accum (... ...)) (else . body))
                  (record-case/accum (accum (... ...) (else . body))))
                 ((record-case/accum accum (symbol formals . body) . clauses)
                  (record-case/accum (((symbol) 
                                       (list-bind formals (cdr x) (let () . body)))
                                      . accum) . clauses))))
              (list-bind
               (syntax-rules ()
                 ((list-bind () list body) body)
                 ((list-bind (x . rest) list body)
                  (let ((x (car list))
                        (y (cdr list)))
                    (list-bind rest y body)))
                 ((list-bind x list body)
                  (let ((x list))
                    body)))))
           
           (record-case/accum () clause ...))))))
  
  ) ; end of module record-case