#lang racket
(provide cas-cad-e break)
(require (for-syntax unstable/syntax)
         (for-syntax syntax/stx)
         racket/stxparam)

;;; SYNTAX
;;    (cas-cad-e <val-expr> <case-clause> ...+)
;; where
;;     <case-clause> :==  [(<datum> ...) <then-expr> ...+]

(define-for-syntax (illegal-case-clause clause-stx)
  ; Returns #f if the clause is legal, otherwise the offending clause syntax is returned.
  (syntax-case clause-stx ()
    [[(d ...) t1 t2 ...] #f]
    [_ clause-stx]))

(define-for-syntax (check-for-illegal-clauses clauses-stx)
  ; Raise syntax error, if there are any illegal clauses.
  (cond
    [(ormap illegal-case-clause (syntax->list clauses-stx))
     => (λ (offending-stx)
          (syntax-case offending-stx ()
            [[(d ...)] 
             (raise-syntax-error
              'cas-cad-e 
              "Syntax error: Expected at least one then-expresion in the cas-cad-clause."
              clauses-stx offending-stx)]
            [_
             (raise-syntax-error
              'cas-cad-e 
              "Syntax error: Expected a cas-cad-clause of the form [(<datum> ...) <then-expr> ...+]"
              clauses-stx offending-stx)]))]
    [else #f]))

(define-syntax-parameter break
  (λ (stx) (raise-syntax-error 'break "The keywork break was used of context." stx)))

(define-syntax (cas-cad-e stx)
  (syntax-case stx ()
    [(cas ve c1 ... c-last)
     (begin 
       (check-for-illegal-clauses #'(c1 ... c-last))
       (with-syntax* ([(l1 ...)                    (generate-temporaries #'(c1 ...))]
                      [last                        (generate-temporary)]
                      [(g1 ...)                    (stx-cdr #'(l1 ... last))]
                      [([(d ...) te ... ] ...)     #'(c1 ...)]
                      [[(last-d ...) last-te ... ] #'c-last])
         #'(let/ec break1
             (syntax-parameterize ([break (make-rename-transformer #'break1)])
              (letrec ([l1 (λ () te ... (g1))]
                       ...
                       [last (λ () last-te ...)])
                (case ve
                   [(d ...) (l1)]
                   ...
                  [(last-d ...) (last)]
                   [else (void)]))))))]
    ;; Check for syntax errors    
    [_
     (syntax-case stx ()
       [(_ ve)
        (raise-syntax-error
         'cas-cad-e 
         "Syntax error: Expected one or more case-clauses after the value expression.\n"
         stx)]
       [_ 
        (raise-syntax-error 
         'cas-cad-e 
         (string-append
          "Syntax error: Expected a value epression and one or more case-clauses.\n"
          " The syntax of cas-cad-e is (cas-cad-e <val-expr> <case-clause> ...+) "
          "where <case-clause> :==  [(<datum> ...) <then-expr> ...+]\n")
         stx)])]))