add error form

This commit is contained in:
Sam Caldwell 2019-05-20 14:28:38 -04:00
parent 4420f6cd74
commit ed695c66d6
1 changed files with 10 additions and 2 deletions

View File

@ -12,10 +12,11 @@
match match
tuple tuple
select select
error
(for-syntax (all-defined-out))) (for-syntax (all-defined-out)))
(require "core-types.rkt") (require "core-types.rkt")
(require (only-in "prim.rkt" Bool #%datum)) (require (only-in "prim.rkt" Bool String #%datum))
(require (postfix-in - racket/match)) (require (postfix-in - racket/match))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -147,7 +148,7 @@
#'((x ...) ...)) #'((x ...) ...))
-------------------------------------------------------------- --------------------------------------------------------------
[ (match- e- [p- s-] ... [ (match- e- [p- s-] ...
[_ (#%app- error "incomplete pattern match")]) [_ (#%app- error- "incomplete pattern match")])
( : (U τ-s ...)) ( : (U τ-s ...))
( ν-ep (eps ... ...)) ( ν-ep (eps ... ...))
( ν-f #,(make-Branch #'((fs ...) ...))) ( ν-f #,(make-Branch #'((fs ...) ...)))
@ -171,6 +172,13 @@
(define- (tuple-select n t) (define- (tuple-select n t)
(#%app- list-ref- t (#%app- add1- n))) (#%app- list-ref- t (#%app- add1- n)))
(define-typed-syntax (error msg args ...)
[ msg msg- ( : String)]
[ args args- ( : τ)] ...
#:fail-unless (all-pure? #'(msg- args- ...)) "expressions must be pure"
----------------------------------------
[ (#%app- error- msg- args- ...) ( : )])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpers ;; Helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;