From 449a6f4a09566d493ccb5045ad4412e614a9564e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 6 Nov 2015 15:32:40 +0100 Subject: [PATCH] Added let-abort and let*-abort --- graph/graph/_examples_cond-abort.rkt | 13 +++++++++++++ graph/graph/cond-abort.rkt | 21 ++++++++++++++++++++- 2 files changed, 33 insertions(+), 1 deletion(-) create mode 100644 graph/graph/_examples_cond-abort.rkt diff --git a/graph/graph/_examples_cond-abort.rkt b/graph/graph/_examples_cond-abort.rkt new file mode 100644 index 0000000..893932e --- /dev/null +++ b/graph/graph/_examples_cond-abort.rkt @@ -0,0 +1,13 @@ +#lang typed/racket + +(require "cond-abort.rkt") + +(match-abort '(1 (a b) 3) + [(list x y z) + (let-abort ([new-x x] + [new-y (match-abort y + [(list n p) (list 'A n p)] + [(list q r s) (list 'B q r s)])] + [new-z z]) + (list new-x new-y new-z))]) + diff --git a/graph/graph/cond-abort.rkt b/graph/graph/cond-abort.rkt index 3aa0907..5f1ad52 100644 --- a/graph/graph/cond-abort.rkt +++ b/graph/graph/cond-abort.rkt @@ -1,7 +1,9 @@ #lang typed/racket (provide cond-abort - match-abort) + match-abort + let-abort + let*-abort) (define-syntax (cond-abort orig-stx) (let rec ([stx orig-stx]) @@ -37,6 +39,23 @@ [_ 'continue])] ...))) +(define-syntax-rule (let-abort ([binding value] ...) . body) + (let ([binding value] ...) + (cond + [(or (eq? 'continue binding) (eq? 'break binding)) binding] + ... + [else (begin . body)]))) + +(define-syntax (let*-abort stx) + (syntax-case stx () + [(_ () . body) + #'(begin . body)] + [(_ ([binding0 value0] . rest) . body) + #'(let ([binding0 value0]) + (if (or (eq? 'continue binding) (eq? 'break binding)) + binding + (let*-abort rest . body)))])) + (module* test typed/racket (require typed/rackunit) (require (submod ".."))