diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 7dcb6f646b..f9d2415d14 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -89,9 +89,6 @@ This file defines two sorts of primitives. All of them are provided into any mod [typed-racket/private/type-contract (type->contract type->contract-fail)] [typed-racket/env/type-name-env (register-type-name)])) -(define-for-syntax (ignore stx) (ignore-property stx #t)) -(define-for-syntax (ignore-some stx) (ignore-some-property stx #t)) - (begin-for-syntax (define-syntax-class opt-parent #:attributes (nm parent) @@ -281,7 +278,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #`(#%expression (ann #,(ignore-some - #`(let-values (((val) #,(with-type-property #'(ann v Any) #t))) + #`(let-values (((val) #,(with-type #'(ann v Any)))) (contract #,ctc-expr val @@ -506,12 +503,12 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ ([pred? action] ...) . body) (with-syntax ([(pred?* ...) (for/list ([s (in-syntax #'(pred? ...))]) - (with-type-property #`(ann #,s : (Any -> Any)) #t))] + (with-type #`(ann #,s : (Any -> Any))))] [(action* ...) (for/list ([s (in-syntax #'(action ...))]) - (exn-handler-property s #t))] - [body* (exn-body-property #'(let-values () . body) #t)]) - (with-handlers-property #'(with-handlers ([pred?* action*] ...) body*) #t))])) + (exn-handler s))] + [body* (exn-body #'(let-values () . body))]) + (exn-handlers #'(with-handlers ([pred?* action*] ...) body*)))])) (begin-for-syntax (define-syntax-class dtsi-struct-name @@ -527,7 +524,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) (with-syntax* - ([proc* (with-type-property #'(ann proc : proc-ty) #t)] + ([proc* (with-type #'(ann proc : proc-ty))] [d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...) #:property prop:procedure proc*)))] [dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt index 7bb9f51de6..bcc17556ec 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt @@ -18,7 +18,7 @@ #:literal-sets (kernel-literals) #:attributes (opt) ;; Can't optimize this code because it isn't typechecked - (pattern (~or opt:ignore^ opt:ignore-some^ opt:with-handlers^)) + (pattern (~or opt:ignore^ opt:ignore-some^ opt:exn-handlers^)) ;; Can't optimize the body of this code because it isn't typechecked (pattern (~and _:kw-lambda^ diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt index 39202450cf..05813765e9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt @@ -3,53 +3,67 @@ syntax/parse (for-syntax racket/base syntax/parse racket/syntax)) +(define-syntax define-matcher + (syntax-parser + [(_ name:id prop:id) + #'(define-syntax-class name + #:attributes (value) + (pattern e + #:attr value (prop #'e) + #:when (attribute value)))])) + (define-syntax (define-properties stx) (define-syntax-class clause + (pattern (name:id sym:id #:mark) + #:with syntax-class-name (format-id #'name "~a^" #'name) + #:with symbol (generate-temporary #'sym) + #:with function + #'(λ (stx) (syntax-property stx symbol #t))) (pattern (root:id sym:id) #:with name (format-id #'root "~a-property" #'root) #:with syntax-class-name (format-id #'root "~a^" #'root) - #:with symbol (generate-temporary #'sym))) + #:with symbol (generate-temporary #'sym) + #:with function + #'(case-lambda + ((stx) (syntax-property stx symbol)) + ((stx value) (syntax-property stx symbol value))))) (syntax-parse stx - ((_ :clause ...) + [(_ :clause ...) #`(begin (begin - ;; TODO: make this an uninterned symbol once the phasing issue of the unit - ;; tests is fixed - (define symbol 'sym) - (provide name syntax-class-name) - (define name - (case-lambda - ((stx) (syntax-property stx symbol)) - ((stx value) (syntax-property stx symbol value)))) + ;; TODO: make this an uninterned symbol once the phasing issue of the unit + ;; tests is fixed + (define symbol 'sym) + (provide name syntax-class-name) + (define name function) (define-syntax-class syntax-class-name #:attributes (value) (pattern e - #:attr value (name #'e) - #:when (attribute value)))) ...)))) + #:attr value (syntax-property #'e symbol) + #:when (attribute value)))) ...)])) ;;TODO add contracts on the properties -;;TODO make better interface for properties with values of only #t (define-properties (plambda typechecker:plambda) - (ignore typechecker:ignore) - (ignore-some typechecker:ignore-some) + (ignore typechecker:ignore #:mark) + (ignore-some typechecker:ignore-some #:mark) (contract-def/maker typechecker:contract-def/maker) (contract-def typechecker:contract-def) (flat-contract-def typechecker:flat-contract-def) (external-check typechecker:external-check) - (with-type typechecker:with-type) + (with-type typechecker:with-type #:mark) (type-ascription type-ascription) (type-inst type-inst) (type-label type-label) (type-dotted type-dotted) - (exn-handler typechecker:exn-handler) - (exn-body typechecker:exn-body) - (with-handlers typechecker:with-handlers) + (exn-handler typechecker:exn-handler #:mark) + (exn-body typechecker:exn-body #:mark) + (exn-handlers typechecker:exn-handlers #:mark) (struct-info struct-info) (opt-lambda opt-lambda) (kw-lambda kw-lambda) - (tail-position typechecker:called-in-tail-position) + (tail-position typechecker:called-in-tail-position #:mark) ) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index 4a6ccf8aed..5f482630e6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -81,14 +81,13 @@ #:typed-side #f #:kind kind (type->contract-fail typ prop))]) - (ignore-property ; should be ignored by the optimizer + (ignore ; should be ignored by the optimizer (quasisyntax/loc stx (define-values (n) (recursive-contract cnt - #,(contract-kind->keyword kind)))) - #t)))] + #,(contract-kind->keyword kind)))))))] [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 9ede4af765..54c64c0126 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -180,7 +180,7 @@ (syntax-parse form #:literal-sets (kernel-literals) #:literals (find-method/who) - [stx:with-handlers^ + [stx:exn-handlers^ (check-subforms/with-handlers/check form expected)] [stx:ignore-some^ (check-subforms/ignore form) @@ -317,11 +317,8 @@ #:literal-sets (kernel-literals) #:literals (#%app lambda find-method/who) ;; - [stx:with-handlers^ - (let ([ty (check-subforms/with-handlers form)]) - (unless ty - (int-err "internal error: with-handlers")) - ty)] + [stx:exn-handlers^ + (check-subforms/with-handlers form) ] [stx:ignore-some^ (check-subforms/ignore form) (ret Univ)]