diff --git a/remix/stx0.rkt b/remix/stx0.rkt index 6fbcfe8..001391e 100644 --- a/remix/stx0.rkt +++ b/remix/stx0.rkt @@ -5,6 +5,7 @@ racket/generic racket/syntax syntax/parse) + syntax/quote syntax/parse/define remix/stx/singleton-struct0 racket/stxparam) @@ -63,7 +64,7 @@ [(_ (((~and (~not #%brackets) x) . args:expr) . def-body:expr) bind-body:expr) (syntax/loc stx (def*-internal (x (remix-λ args . def-body)) bind-body))])) - + (define-syntax (remix-block stx) (syntax-parse stx #:literals (def*) @@ -79,7 +80,7 @@ (define-syntax #%brackets (make-rename-transformer #'remix-block)) - + (provide def* #%brackets (for-syntax def*-transformer? @@ -286,9 +287,28 @@ (syntax-parameterize ([remix-cut-$ (make-rename-transformer #'x)]) body)))])) +(define-syntax (impossible! stx) + (syntax-parse stx + [(_ fun msg loc) + (quasisyntax/loc stx + (raise-syntax-error fun msg + (quote-syntax/keep-srcloc #,#'loc)))] + [_ + (quasisyntax/loc stx + (raise-syntax-error '☠ "Unreachable code has been reached" + (quote-syntax/keep-srcloc #,stx)))])) + (define-syntax (remix-cond stx) (syntax-parse stx #:literals (#%brackets) + [(_ . (~and (cond-arg ...) + (_ ... (#%brackets (~not #:else) . _)))) + (quasisyntax/loc stx + (remix-cond cond-arg ... + (#%brackets + #:else (impossible! 'cond + "non-existent default case reached" + #,stx))))] [(_ (~and before:expr (~not (#%brackets . any:expr))) ... (#%brackets #:else . answer-body:expr)) (syntax/loc stx @@ -296,23 +316,25 @@ [(_ (~and before:expr (~not (#%brackets . any:expr))) ... (#%brackets question:expr . answer-body:expr) . more:expr) - (syntax/loc stx + (quasisyntax/loc stx (remix-block before ... (if question (remix-block . answer-body) - (remix-cond . more))))])) + #,(syntax/loc #'more (remix-cond . more)))))])) (provide def def* (for-syntax gen:def-transformer gen:def*-transformer) - (rename-out [def ≙] + (rename-out [def ≙] ;; \defs [def :=] [def* ≙*] [def* :=*] [def* nest]) - (rename-out [remix-λ λ] + (rename-out [remix-λ λ] ;; \lambda [remix-cond cond] [remix-cut-$ $]) + impossible! + (rename-out [impossible! ☠]) #%rest (rename-out [remix-block block]) #%brackets @@ -324,7 +346,7 @@ (for-syntax gen:dot-transformer) (rename-out [remix-#%app #%app]) (for-syntax gen:app-dot-transformer) - (rename-out [... …]) + (rename-out [... …]) ;; \ldots #%datum quote unquote diff --git a/remix/tests/simple.rkt b/remix/tests/simple.rkt index 134fac9..d2744b1 100644 --- a/remix/tests/simple.rkt +++ b/remix/tests/simple.rkt @@ -45,13 +45,7 @@ ;; cond requires []s for the question-answer pairs. It uses this to ;; make any code in between clauses go in between the `if`s that pop -;; out of the cond macro. finally, cond REQUIRES a #:else clause. -;; -;; XXX Robby does not like requiring else, but does want a default -;; error. -;; -;; XXX make an (impossible!) macro that is a useful -;; default #:else +;; out of the cond macro. (def (g x) (cond [(< x 100) "100"] @@ -63,6 +57,25 @@ {(g 199) ≡ "div 100"} {(g 200) ≡ 100}) +;; If cond reaches the end without an else, then a runtime error is +;; generated +(def (g2 x) + (cond + [(< x 100) "100"] + (def z (/ x 2)) + [(< z 100) "div 100"])) +(module+ test + {(g2 50) ≡ "100"} + {(g2 199) ≡ "div 100"} + ;; This is the error test: + #;(g2 200)) + +;; This functionality is provided by ☠ (aka impossible!) +(def (g3) + ☠) +(module+ test + #;(g3)) + ;; the @ reader is always on. One fun thing about this is that you can ;; make non-() macros. I wrote a little helper function to turn the ;; string arguments that @{} produces into a string port that has