suzanne.soy/remix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adding ☠ and changing cond behavior

Browse Source
This commit is contained in:
Jay McCarthy 2015-11-28 13:59:53 -05:00
parent 1457d23fe2
commit 124e97acf2
2 changed files with 49 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
remix/stx0.rkt
View File

@ -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

27
remix/tests/simple.rkt
View File

@ -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