diff options
| -rw-r--r-- | csc/match.csc | 60 |
1 files changed, 43 insertions, 17 deletions
diff --git a/csc/match.csc b/csc/match.csc index 3e02937..86efab7 100644 --- a/csc/match.csc +++ b/csc/match.csc @@ -39,22 +39,48 @@ result result* ...)))) + (define-record-type <no-match> + (make-no-match) + no-match?) + + + (define-syntax match-pattern + (syntax-rules (_ ! when) + ((match-pattern x pattern (when condition) result result* ...) + (match-pattern x pattern + (if condition + (begin result result* ...) + (raise (make-no-match))))) + ((match-pattern x _ result result* ...) + (begin result result* ...)) + ((match-pattern x '() result result* ...) + (if (null? x) + (begin result result* ...) + (raise (make-no-match)))) + ((match-pattern x (! constant) result result* ...) + (if (equal? x constant) + (begin result result* ...) + (raise (make-no-match)))) + ((match-pattern x (pattern) result result* ...) + (if (= 1 (length x)) + (match-pattern (car x) pattern result result* ...) + (raise (make-no-match)))) + ((match-pattern x (pattern . rest) result result* ...) + (if (pair? x) + (match-pattern (car x) pattern + (match-pattern (cdr x) rest result result* ...)) + (raise (make-no-match)))) + ((match-pattern x identifier result result* ...) + (let ((identifier x)) + result result* ...)))) + + (define-syntax match (syntax-rules (when) - ((match x (pattern (when condition) result result* ...)) - (if (matches? x pattern) - (bind-pattern x pattern - (if condition - (begin result result* ...))))) - ((match x (pattern result1 result2 ...)) - (if (matches? x pattern) - (bind-pattern x pattern result1 result2 ...))) - ((match x (pattern (when condition) result result* ...) clause clause* ...) - (if (and (matches? x pattern) - (bind-pattern x pattern condition)) - (bind-pattern x pattern result result* ...) - (match x clause clause* ...))) - ((match x (pattern result1 result2 ...) clause1 clause2 ...) - (if (matches? x pattern) - (bind-pattern x pattern result1 result2 ...) - (match x clause1 clause2 ...))))))) + ((match x (pattern result result* ...)) + (guard (e ((no-match? e) (if #f #f))) + (match-pattern x pattern result result* ...))) + ((match x (pattern result result* ...) clause clause* ...) + (guard (e ((no-match? e) + (match x clause clause* ...))) + (match-pattern x pattern result result* ...))))))) |